Merge pull request #1449 from andrew-johnson-4/remove-more-fctx-lookup-fpqrrii

Remove more fctx lookup fpqrrii

Author: andrew-johnson-4

BOOTSTRAP/cli.c

@@ -3,22 +3,22 @@ compile-c-function-args := λ(: ctx FContext)(: lhs AST). (: (
    (let r SNil)
    (match lhs (
       ()
-      ( (App( rst (App( (Lit( ':_s _ )) (App( (Var( k _ )) (AType kt) )) )) )) (
+      ( (App( rst (App( (Lit( ':_s _ )) (App( (@( v-t (Var( k _ )) )) (AType kt) )) )) )) (
          (let decl (mangle-c-declaration kt))
          (set r (compile-c-function-args(ctx rst)))
          (set r (+( r (SAtom ',_s) )))
          (set r (+( r (.first decl) )))
          (set r (+( r (SAtom '\s_s) )))
-         (let kf (.lookup( ctx k TAny lhs )))
-         (set r (+( r (.get( kf 'expression_s)) )))
+         (let def-bound (.lookup( std-c-fragment-context v-t (mk-fragment()) )))
+         (set r (+( r (.get( def-bound 'expression_s)) )))
          (set r (+( r (.second decl) )))
       ))
-      ( (App( (Lit( ':_s _ )) (App( (Var( k _ )) (AType kt) )) )) (
+      ( (App( (Lit( ':_s _ )) (App( (@( v-t (Var( k _ )) )) (AType kt) )) )) (
          (let decl (mangle-c-declaration kt))
          (set r (.first decl))
          (set r (+( r (SAtom '\s_s) )))
-         (let kf (.lookup( ctx k TAny lhs )))
-         (set r (+( r (.get( kf 'expression_s)) )))
+         (let def-bound (.lookup( std-c-fragment-context v-t (mk-fragment()) )))
+         (set r (+( r (.get( def-bound 'expression_s)) )))
          (set r (+( r (.second decl) )))
       ))
       ( _ () )

PLUGINS/BACKEND/C/compile-c-function-args.lm

@@ -16,7 +16,7 @@ compile-expr-direct := λ(: ctx FContext)(: term AST)(: stack-offset I64)(: used
          (set e (compile-expr( ctx t stack-offset Tail )))
          (set.context( e (close ctx) ))
       ))
-      ( (App( (Var( 'open_s _ )) t )) (
+      ( (App( (@( o-t (Var( 'open_s _ )) )) t )) (
          (let tt (typeof t))
          (if (.is-t( tt 'Array_s )) (
             (match (.slot( tt 'Array_s )) (
@@ -25,14 +25,16 @@ compile-expr-direct := λ(: ctx FContext)(: term AST)(: stack-offset I64)(: used
                   (set e (compile-expr( ctx t stack-offset Used )))
                ) )
                ( (TGround( 'Array_s (LCons( TAny (LCons( inner-tt LEOF )) )) )) (
-                  (set e (std-c-compile-call( ctx 'open_s (find-global-callable( 'open_s (typeof t) )) t )))
+                  (let fterm (.lookup( var-to-def-index o-t ASTEOF )))
+                  (set e (std-c-compile-call( ctx 'open_s fterm t )))
                ))
                ( (TGround( 'Array_s (LCons( array-length (LCons( inner-tt LEOF )) )) )) (
                   (set e (compile-expr( ctx t stack-offset Used )))
                ))
             ))
          ) (
-            (set e (std-c-compile-call( ctx 'open_s (find-global-callable( 'open_s (typeof t) )) t )))
+            (let fterm (.lookup( var-to-def-index o-t ASTEOF )))
+            (set e (std-c-compile-call( ctx 'open_s fterm t )))
          ))
       ))
       ( (App( (Var( 'sizeof_s _ )) (AType tt) )) (

PLUGINS/BACKEND/C/compile-expr-direct.lm

@@ -1,28 +1,28 @@
 
 let std-c-compile-call(ctx: FContext, fname: CString, fterm: AST, args: AST): Fragment = (
    if typeof(fterm).is-t(c"Blob") {
-      let f = ctx.lookup(fname, typeof(args), args);
       let r = mk-fragment();
-      match f.term {
-         Abs{lhs=lhs, rhs=rhs} => (
+      match fterm {
+         Glb{val:Abs{lhs=lhs, rhs=rhs}} => (
             (let callee-ctx, let caller-ctx) = std-c-compile-args(global-ctx, ctx, lhs, args);
             r = blob-render(callee-ctx, rhs, r, 0);
             r.context = close(caller-ctx);
          );
+         _ => fail("Unexpected fterm in std-c-compile-call: \{fname}\n\{fterm}\n");
       }; r
    } else if typeof(fterm).is-t(c"Prop") { std-c-compile-expr(ctx, args, false)
    } else {
       let push-args = std-c-compile-push-args(ctx, args);
       let ictx = mk-fragment().set(c"function-id", SAtom{mangle-identifier(fname, typeof(fterm))});
       let inner-ctx = mk-fctx().bind(c"ictx", t1(c"ImplicitContext"), ictx)
                                .bind(c"args", typeof(args), push-args);
-      let f = ctx.lookup(c"primitive::call", t3(c"Cons",t1(c"ImplicitContext"),typeof(args)), args);
       let r = mk-fragment();
-      match f.term {
-         Abs{lhs=lhs, rhs=rhs} => (
+      match find-global-callable(c"primitive::call", t3(c"Cons",t1(c"ImplicitContext"),typeof(args))) {
+         Glb{val:Abs{lhs=lhs, rhs=rhs}} => (
             r = blob-render(inner-ctx, rhs, r, 0);
             r.context = close(ctx);
          );
+         _ => fail("Unexpected fterm in std-c-compile-call: \{fname}\n\{fterm}\n");
       }; r
    }
 );

PLUGINS/BACKEND/C/std-c-compile-call.lsts

@@ -129,17 +129,23 @@ infer-expr-one := λ(: tctx Maybe<TContext>)(: term AST)(: scoped IsScoped)(: hi
          (let weak-ctx (infer-expr( tctx r Scoped TAny Tail )))
          (ascript-normal( term (typeof r) ))
       ))
-      ( (App( (Var( 'open_s _ )) r )) (
+      ( (App( (@( o-t (Var( 'open_s _ )) )) r )) (
          (set tctx (infer-expr( tctx r Unscoped TAny Used )))
          (let deref-type (typeof r))
          (match (.slot( deref-type 'Array_s )) (
             ()
             ( (TGround( 'Array_s (LCons( _ (LCons( TAny LEOF )) )) )) () )
             ( (TGround( 'Array_s (LCons( TAny (LCons( array-base LEOF )) )) )) (
+               (let def (defof-var( term tctx 'open_s deref-type )))
+               (set var-to-def-index (.bind( var-to-def-index o-t def )))
                (maybe-specialize( 'open_s (typeof-var-raw( term tctx 'open_s )) deref-type ))
                (set deref-type array-base)
             ))
-            ( _ (do-specialize( 'open_s (typeof-var-raw( term tctx 'open_s )) deref-type term )) )
+            ( _ (
+               (let def (defof-var( term tctx 'open_s deref-type )))
+               (set var-to-def-index (.bind( var-to-def-index o-t def )))
+               (do-specialize( 'open_s (typeof-var-raw( term tctx 'open_s )) deref-type term ))
+            ))
          ))
          (ascript-normal( term deref-type ))
       ))
@@ -267,7 +273,7 @@ infer-expr-one := λ(: tctx Maybe<TContext>)(: term AST)(: scoped IsScoped)(: hi
          (let arg-type (typeof r))
          (if (&&( (non-zero(var-name-if-var l)) (.is-arrow(typeof l)) )) (
             (let def (defof-var( term tctx (var-name-if-var l) arg-type )))
-            (set var-to-def-index (.bind( var-to-def-index term def )))
+            (set var-to-def-index (.bind( var-to-def-index l def )))
          ) ())
       ))
       ( (Abs( lhs rhs tlt )) (

SRC/infer-expr.lm

@@ -55,26 +55,27 @@ defof-var := λ(: sloc AST)(: tctx Maybe<TContext>)(: vname String). (: (
 
 defof-var := λ(: sloc AST)(: tctx Maybe<TContext>)(: vname String)(: tt Type). (: (
    (set vname (find-alias( vname tt )))
-   (let f-type (typeof-var-raw( sloc tctx vname )))
-   (set f-type (.function-type(apply( (var-name-if-var sloc) f-type tt false ))))
    (let found ASTEOF)
+   (let found-type TAny)
    (let continue 1_u64)
    (for-each ( (Tuple( k vt def )) in
                (.get-or( tctx (: LEOF List<Tuple<String,Type,AST>>) )) ) (
       (if (&&( continue (==( k vname )) )) (
-         (if (non-zero found) (
-            (if (==( f-type vt )) (set found def) ())
-         ) (
-            (set found def)
-         ))
-         (if (not(.is-arrow vt)) (
-            (set continue 0_u64)
-         ) ())
+         (set found def)
+         (set continue 0_u64)
       ) ())
    ))
    (for-each ((Tuple( kt t )) in (.lookup( global-type-context vname (: LEOF List<Tuple<Type,AST>>) ))) (
-      (if (non-zero found) (
-         (if (==( f-type kt )) (set found t) ())
+      (if (.is-arrow kt) (
+         (if (can-unify( (.domain kt) tt )) (
+            (if (non-zero found-type) (
+               (set found-type (most-special( found-type kt )))
+               (if (==( found-type kt )) (set found t) ())
+            ) (
+               (set found-type kt)
+               (set found t)
+            ))
+         ) ())
       ) (
          (set found t)
       ))