Merge pull request #212 from andrew-johnson-4/inline-structure-creation

Inline structure creation

Author: andrew-johnson-4

BOOTSTRAP/cli.s

@@ -1,6 +1,6 @@
 [package]
 name = "lambda_mountain"
-version = "1.11.74"
+version = "1.11.75"
 authors = ["Andrew <andrew@subarctic.org>"]
 license = "MIT"
 description = "Lambda Mountain"

Cargo.toml

@@ -1,7 +1,6 @@
 
 nostd: prod
-	./production --nostd -o tmp.s tests/nostd/write_function2.lm
-#	./production --nostd -o tmp.s tests/strict/cc2.lm
+	./production --nostd -o tmp.s tests/strict/cc2.lm
 	as -o tmp.o tmp.s
 	ld -o tmp tmp.o
 	./tmp && echo $?

Makefile

@@ -9,7 +9,7 @@ compile-push-rvalue := λctx e offset . (tail(
             ()
             ( (App( le re )) (tail(
                (set e1 (compile-push-rvalue( ctx le offset )))
-               (set e2 (compile-push-rvalue( ctx re offset )))
+               (set e2 (compile-push-rvalue( ctx re (expr::get-offset e1) )))
                (expr::chain( e1 e2 ))
             )))
             ( u (fail (UnexpectedRvalue e)))
@@ -38,6 +38,7 @@ compile-expr-strict := λctx e offset used . (tail(
    (local e2)
    (local e3)
    (local e4)
+   (local return)
    (match used (
       ()
       (Return (tail(
@@ -52,8 +53,8 @@ compile-expr-strict := λctx e offset used . (tail(
             ))
          ))
       )))
-      (_ (
-         (match e (
+      (_ (tail(
+         (set return (match e (
             ()
             ( (App( (Lambda( (Variable lname) Nil )) rhs )) (tail(
                (local sz)
@@ -243,7 +244,12 @@ compile-expr-strict := λctx e offset used . (tail(
                      ( (Literal tag) (tail(
                         (set e1 (compile-push-rvalue( ctx r offset )))
                         (set e2 (fragment-apply( ctx 'push (And( (typecheck-lookup e) DontChain)) (() e1) e1 )))
+                        (local sz)
+                        (set sz (typecheck-sizeof(typecheck-lookup e)))
+                        (set offset (expr::get-offset e2))
+                        (set offset (i2s(add( (inv(s2i( sz ))) (s2i offset) ))))
                         (set e2 (expr::set-type( e2 StackVariable )))
+                        (set e2 (expr::set-offset( e2 offset )))
                         e2
                      )))
                      ( u (tail(
@@ -268,8 +274,9 @@ compile-expr-strict := λctx e offset used . (tail(
                result
             )))
             ( _ (fail (TODO CompileStrict e)))
-         ))
-      ))
+         )))
+         return
+      )))
    ))
 ));
 
@@ -347,6 +354,7 @@ strict-codegen-type-case := λ ctx base-type type-body case-number . (tail(
                   \t 'sub \s '$ case-padding , \s '%rsp \n
                ))
                (App( (Variable '.program) (Variable 'src) ))
+               DontChain
                \t 'pushq \s '$ case-number \n
             )))
          ))))
@@ -393,6 +401,7 @@ strict-codegen-type-case := λ ctx base-type type-body case-number . (tail(
                (if (eq( case-padding 0 )) () (
                   \t 'sub \s '$ case-padding , \s '%rsp \n
                ))
+               DontChain
                \t 'pushq \s '$ case-number \n
             )))
          ))))

PRODUCTION/codegen-strict.lm

@@ -2,6 +2,8 @@
 fragment-substitute-context := λ ctx fragment-rhs . (match fragment-rhs (
    ()
    ( () () )
+   ( (Variable Dontchain) () )
+   ( DontChain () )
    ( (Variable( v )) (tail(
       (while ctx (
          (if (eq( v (head (tail ctx)) )) (
@@ -208,6 +210,16 @@ fragment-apply-context := λctx fragment-rhs e . (tail(
    return
 ));
 
+fragment-is-dont-chain := λ f . (match f (
+   ()
+   ( DontChain DontChain )
+   ( (l r) (
+      if (fragment-is-dont-chain l) DontChain
+         (fragment-is-dont-chain r)
+   ))
+   ( _ () )
+));
+
 fragment-apply := λ ctx function-name function-type function-args e-proto . (tail(
    (assert-typeof( 'fragment-apply::e-proto e-proto StrictExpr ))
    (assert-typeof( 'fragment-apply::function-name function-name Atom ))
@@ -225,6 +237,9 @@ fragment-apply := λ ctx function-name function-type function-args e-proto . (ta
       ()
       ( DontChain (set dont-chain DontChain))
    ))
+   (if (fragment-is-dont-chain arrow) (
+      (set dont-chain DontChain)
+   ) ())
    (local return)
    (set return (fragment-apply-direct( arrow function-args e-proto dont-chain )))
    (assert-typeof( 'fragment-apply::return return StrictExpr ))

PRODUCTION/fragment.lm

@@ -130,10 +130,14 @@ stack-call-push-arg := λ ctx e-arg offset args-size . (tail(
    (set e1 (compile-expr-strict( ctx e-arg new-offset Used )))
    (set e1 (expr::set-type( e1 (typecheck-lookup e-arg))))
 
-   (set e2 (fragment-apply(
-      ctx 'push (typecheck-lookup e-arg)
-      (() e1) e1
-   )))
+   (if (typecheck-has-representation( typecheck-lookup e-arg )) (
+      (set e2 (fragment-apply(
+         ctx 'push (typecheck-lookup e-arg)
+         (() e1) e1
+      )))
+   ) (
+      (set e2 e1)
+   ))
 
    (set e2 (expr::set-unframe( e2 ((expr::get-unframe e2) unframe) )))
    (set e2 (expr::set-expr( e2 args-size )))

PRODUCTION/stack.lm

@@ -507,6 +507,32 @@ typecheck-infer-type-compound := λcompound . (tail(
    result
 ));
 
+typecheck-is-constructor := λtt . (match tt (
+   ()
+   ( (And( lt rt )) (
+      if (typecheck-is-constructor lt) True
+         (typecheck-is-constructor rt)
+   ))
+   ( () () )
+   ( (_ _) () )
+   ( ta (typecheck-is-constructor-atom ta))
+));
+typecheck-is-constructor-atom := λta . (tail(
+   (local is-constructor)
+   (local constructors)
+   (set constructors typecheck-constructors)
+   (while constructors (tail(
+      (if (eq( (head(tail constructors)) ta )) (
+         (set is-constructor True)
+      ) ())
+      (if (eq( (tail(tail constructors)) ta )) (
+         (set is-constructor True)
+      ) ())
+      (set constructors (head constructors))
+   )))
+   is-constructor
+));
+
 typecheck-infer-type-constructor := λbase-type body . (match body (
    ()
    ( (Literal tag) (tail(
@@ -556,12 +582,12 @@ typecheck-infer-constructor-type := λtag . (tail(
 typecheck-set-size := λ tt sz . (if sz (tail(
    (local sizes)
    (local has-size)
-   (while sizes (
+   (while sizes (tail(
       (if (deep-eq( (head (tail sizes)) tt )) (
          (set has-size True)
       ) ())
       (set sizes (head sizes))
-   ))
+   )))
    (if has-size () (
       (if (eq( sz Unsized )) (
          (set typecheck-size ( typecheck-size ( tt () )))

PRODUCTION/typecheck.lm

@@ -9,14 +9,8 @@ echo := λ(: x U64). (: (
 ) U64);
 
 main := (
-   (let l1 (SAtom( 'an-atom_s )))
-   (let l2 (close(l1)))
-   (let r1 (SNil))
-   (let r2 (close(r1)))
-   (let x (SCons( l2 r2 )))
-   (print x)
-#   (print (SCons(
-#      (close(SAtom( 'an-atom_s )))
-#      (close(SNil))
-#   )))
+   (print(SCons(
+      (close (SAtom( 'an-atom_s )))
+      (close SNil)
+   )))
 );