Merge pull request #211 from andrew-johnson-4/inline-constructors-1

Inline constructors 1

Author: andrew-johnson-4

BOOTSTRAP/cli.s

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

Cargo.toml

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

Makefile

@@ -479,8 +479,8 @@ strict-bind-accessors := λ ctx base-type src-type field-offset field-number . (
          (App( (App( (Literal ':) (Variable 'src) )) (Literal LocalVariable) ))
          (App(
             (App( (Variable '.program) (
-               \t 'movq \s ('+( ('.expression 'src) field-offset )) \s \[ '%rbp \] ,
-               \s '%r15 \n
+               \t 'mov \s ('+( ('.expression 'src) field-offset )) \s \[ '%rbp \] ,
+               \s '% register-name \n
             )))
             (App( (Variable '.expression) (
                register-name

PRODUCTION/codegen-strict.lm

@@ -89,6 +89,26 @@ fragment-substitute-context := λ ctx fragment-rhs . (match fragment-rhs (
       ))
       result
    )))
+   ( (App(
+        (App(
+           (App(
+              (Variable 'if-eq)
+              l
+           ))
+           r
+        ))
+        body
+     )) (tail(
+      (set l (fragment-substitute-context( ctx l )))
+      (set r (fragment-substitute-context( ctx r )))
+      (local result)
+      (if (eq( l r )) (
+         (set result (
+            (fragment-substitute-context( ctx body ))
+         ))
+      ) ())
+      result
+   )))
    ( ('.expression v ) (tail(
       (if (is-atom v) (
          (while ctx (

PRODUCTION/fragment.lm

@@ -17,57 +17,34 @@ stack-call := λ ctx function-name function-args offset . (tail(
          (local src-offset)
          (local copy-offset)
          (set src-offset (s2i 8)) # stack pointer is 64 bits
-         (match (expr::get-expr e-args) (
-            ()
-            ( 1 (tail(
-               (set copy-offset (add( (s2i '-1) copy-offset )))
-               (set copy-bytes ( copy-bytes
-                  \t 'mov \s (i2s( src-offset )) \[ '%rbp \] , \s '%al \n
-                  \t 'mov \s '%al , \s (i2s( copy-offset )) \[ '%rbp \] \n
-               ))
-               (set src-offset (add( src-offset (s2i 1) )))
-            )))
-            ( 2 (tail(
-               (set copy-offset (add( (s2i '-2) copy-offset )))
-               (set copy-bytes ( copy-bytes
-                  \t 'mov \s (i2s( src-offset )) \[ '%rbp \] , \s '%ax \n
-                  \t 'mov \s '%ax , \s (i2s( copy-offset )) \[ '%rbp \] \n
-               ))
-               (set src-offset (add( src-offset (s2i 2) )))
-            )))
-            ( 4 (tail(
-               (set copy-offset (add( (s2i '-4) copy-offset )))
-               (set copy-bytes ( copy-bytes
-                  \t 'mov \s (i2s( src-offset )) \[ '%rbp \] , \s '%eax \n
-                  \t 'mov \s '%eax , \s (i2s( copy-offset )) \[ '%rbp \] \n
-               ))
-               (set src-offset (add( src-offset (s2i 4) )))
-            )))
-            ( copy-size (tail(
-               (set copy-size (s2i copy-size))
-               (set copy-offset (inv( copy-size )))
-               (while copy-size (
-                  (set copy-bytes ( copy-bytes
-                     \t 'mov \s (i2s( src-offset )) \[ '%rbp \] , \s '%rax \n
-                     \t 'mov \s '%rax , \s (i2s( copy-offset )) \[ '%rbp \] \n
-                  ))
-                  (set copy-offset (add( (s2i '8) copy-offset )))
-                  (set src-offset (add( (s2i '8) src-offset )))
-                  (set copy-size (add( (s2i '-8) copy-size )))
-               ))
-            )))
+         (local copy-size)
+         (set copy-size (s2i (expr::get-expr e-args)))
+         (set copy-offset (inv( copy-size )))
+         (while copy-size (
+            (set copy-bytes ( copy-bytes
+               \t 'mov \s (i2s( src-offset )) \[ '%rbp \] , \s '%rax \n
+               \t 'mov \s '%rax , \s (i2s( copy-offset )) \[ '%rbp \] \n
+            ))
+            (set copy-offset (add( (s2i '8) copy-offset )))
+            (set src-offset (add( (s2i '8) src-offset )))
+            (set copy-size (add( (s2i '-8) copy-size )))
+         ))
+         (local args-size)
+         (set args-size (expr::get-expr e-args))
+         (if (eq( args-size 0 )) () (
+            (set args-size (max( '8 args-size )))
          ))
          (set e-call (expr::set-prog( e-call (
             (expr::get-frame e-args)
             (expr::get-prog e-args)
             (enter-function())
-            (if (eq( (expr::get-expr e-args) 0 )) () (
-               ( \t 'sub \s '$ (expr::get-expr e-args) , \s '%rsp \n )
+            (if (eq( args-size 0 )) () (
+               ( \t 'sub \s '$ args-size , \s '%rsp \n )
             ))
             copy-bytes
             (\t 'call \s (mangle-identifier( function-name (typecheck-lookup body) )) \n)
-            (if (eq( (expr::get-expr e-args) 0 )) () (
-               ( \t 'add \s '$ (expr::get-expr e-args) , \s '%rsp \n )
+            (if (eq( args-size 0 )) () (
+               ( \t 'add \s '$ args-size , \s '%rsp \n )
             ))
             (\t 'mov \s '%rbp, \s '%rsp              \n
              \t 'pop \s '%rbp                        \n)
@@ -136,39 +113,32 @@ stack-call-push-arg := λ ctx e-arg offset args-size . (tail(
    (assert-typeof( 'stack-call-push-arg::args-size args-size Atom ))
    (local e1)
    (local e2)
-   (local e3)
    (local et)
    (set et (typecheck-lookup e-arg))
    (local e-sz)
    (set e-sz (typecheck-sizeof et))
+   (set e-sz (max( 8 e-sz )))
    (set args-size (i2s(add( (s2i args-size) (s2i e-sz) ))) )
    (local new-offset)
    (set new-offset(  (i2s(add( (s2i offset) (inv(s2i( e-sz ))) ))) ))
-
-   (local frame)
+   
    (local unframe)
    (if (eq( e-sz '0 )) () (
-      (set frame ( \t 'sub \s '$ e-sz , \s '%rsp \n ))
-      (set unframe ( \t 'add \s '$ e-sz , \s '%rsp \n ))
+      (set unframe ( \t 'add \s '$ (max( '8 e-sz )) , \s '%rsp \n ))
    ))
 
    (set e1 (compile-expr-strict( ctx e-arg new-offset Used )))
    (set e1 (expr::set-type( e1 (typecheck-lookup e-arg))))
-   (set e2 (expr::new()))
-   (set e2 (expr::set-expr( e2 new-offset )))
-   (set e2 (expr::set-context( e2 ctx )))
-   (set e2 (expr::set-offset( e2 new-offset )))
-   (set e2 (expr::set-type( e2 (And( LocalVariable (Sized e-sz) )) )))
 
-   (set e3 (fragment-apply(
-      ctx 'mov (Cons( (typecheck-lookup e-arg) (And( LocalVariable (Sized e-sz) )) ))
-      ((() e1) e2) e2
+   (set e2 (fragment-apply(
+      ctx 'push (typecheck-lookup e-arg)
+      (() e1) e1
    )))
 
-   (set e3 (expr::set-frame( e3 ((expr::get-frame e3) frame) )))
-   (set e3 (expr::set-unframe( e3 ((expr::get-unframe e3) unframe) )))
-   (set e3 (expr::set-expr( e3 args-size )))
-   e3
+   (set e2 (expr::set-unframe( e2 ((expr::get-unframe e2) unframe) )))
+   (set e2 (expr::set-expr( e2 args-size )))
+   (set e2 (expr::set-offset( e2 new-offset )))
+   e2
 ));
 
 stack-destructure-args := λ ctx function-args offset arg-mode . (tail(
@@ -227,6 +197,7 @@ stack-define-destructure := λ ctx lhs offset . (match lhs (
       (set ltype (typecheck-infer-type-compound ltype) )
       (local size)
       (set size (typecheck-sizeof ltype))
+      (set size (max( '8 size )))
       (local new_offset)
       (set new_offset (add( offset (inv(s2i size)) )) )
       (local return)
@@ -242,6 +213,7 @@ stack-define-destructure := λ ctx lhs offset . (match lhs (
       (set ltype (typecheck-infer-type-compound ltype) )
       (local size)
       (set size (typecheck-sizeof ltype))
+      (set size (max( '8 size )))
       (local new_offset)
       (set new_offset (add( offset (inv(s2i size)) )) )
       (local more-e)

PRODUCTION/stack.lm

@@ -736,7 +736,7 @@ typecheck-infer-expr := λctx e used . (tail(
          (local ctype)
          (set ctype (typecheck-infer-constructor-type lit))
          (if ctype (
-            (typecheck-ascript( e (And( Constant (And( lit ctype )) )) ))
+            (typecheck-ascript( e (And( (And( lit ctype )) Constant )) ))
          ) (
             (typecheck-ascript( e Atom ))
          ))
@@ -873,6 +873,33 @@ typecheck-sizeof-impl := λtt . (match tt (
    )))
 ));
 
+typecheck-assign-representation := λtt . (tail(
+   (print-s (AssignRepr tt))(print-s \n)
+   (if (not(typecheck-has-representation tt)) (
+      (set tt (And( LocalVariable tt )))
+      (print-s (Repr tt))(print-s \n)
+   ) ())
+   tt
+));
+
+typecheck-has-representation := λtt . (match tt (
+   ()
+   ( (lt rt) (
+      if (typecheck-has-representation lt) True
+         (typecheck-has-representation rt)
+   ))
+   ( () () )
+   ( Constant True )
+   ( Reg8 True )
+   ( Reg16 True )
+   ( Reg32 True )
+   ( Reg64 True )
+   ( LocalVariable True )
+   ( StackVariable True )
+   ( GlobalVariable True )
+   ( _ () )
+));
+
 typecheck-not-representation := λtt . (match tt (
    ()
    ( (And( Constant rt )) (typecheck-not-representation rt) )

PRODUCTION/typecheck.lm

@@ -6,9 +6,6 @@ fragment type Reg64 RAX | RBX | RCX | RDX | RSI | RDI | RBP | RSP | R8  | R9  |
 
 fragment syscall := λ. (: (.program( \t 'syscall \n )) Nil);
 
-fragment push := λ(: l Constant+U64). (: ( (.program( \t 'pushq \s '$ (.expression l) \n)) ) Nil);
-fragment push := λ(: l Constant+I64). (: ( (.program( \t 'pushq \s '$ (.expression l) \n)) ) Nil);
-
 fragment cdecl::return := λ(: l Nil). (: () Nil);
 fragment cdecl::return := λ(: l Reg8). (: (  (.program( \t 'mov \t '% (.expression l) , '%al \n))  (.expression 'al)  ) Nil);
 fragment cdecl::return := λ(: l Reg16). (: (  (.program( \t 'mov \t '% (.expression l) , '%ax \n))  (.expression 'ax)  ) Nil);
@@ -42,11 +39,29 @@ fragment push := λ(: src GlobalVariable+Sized<size>). (: (
          \t 'pushq \s '0 \[ '%r15 \] \n
          \t 'add \s '$8 , \s '%r15 \n
       ))
+      (if-eq size 4 (
+         \t 'mov \s '0 \[ '%r15 \] , \s '%r15d \n
+         \t 'push \s '%r15 \n
+      ))
+      (if-eq size 2 (
+         \t 'mov \s '0 \[ '%r15 \] , \s '%r15w \n
+         \t 'push \s '%r15 \n
+      ))
+      (if-eq size 2 (
+         \t 'mov \s '0 \[ '%r15 \] , \s '%r15b \n
+         \t 'push \s '%r15 \n
+      ))
    ))
 ) Nil);
 fragment push := λ(: src LocalVariable+Sized<size>). (: (
    (.program ( for word-offset in (range( 0 (/( size 8 )) )) (
-      \t 'pushq \s (+( (.expression src) (*( word-offset 8 )) )) \[ '%rbp \] \n
+      \t 'pushq \s (+(
+         (.expression src)
+         (+(
+            (+( size '-8 ))
+            (inv(*( word-offset 8 )))
+         ))
+      )) \[ '%rbp \] \n
    )))
 ) Nil);
 fragment pop := λ(: src LocalVariable+Sized<size>). (: (
@@ -150,6 +165,11 @@ fragment mov := λ(: src LocalVariable)(: dst Reg16). (: (.program( \t 'mov \s (
 fragment mov := λ(: src LocalVariable)(: dst Reg32). (: (.program( \t 'mov \s (.expression src) \[ '%rbp \] , \s '% (.expression dst) \n )) Nil);
 fragment mov := λ(: src LocalVariable)(: dst Reg64). (: (.program( \t 'mov \s (.expression src) \[ '%rbp \] , \s '% (.expression dst) \n )) Nil);
 
+fragment push := λ(: dst Reg8). (: (.program( \t 'mov \s '% (.expression dst) , '%r15b \n \t 'push \s '%r15 \n )) Nil);
+fragment push := λ(: dst Reg16). (: (.program( \t 'mov \s '% (.expression dst) , '%r15w \n \t 'push \s '%r15 \n )) Nil);
+fragment push := λ(: dst Reg32). (: (.program( \t 'mov \s '% (.expression dst) , '%r15d \n \t 'push \s '%r15 \n )) Nil);
+fragment push := λ(: dst Reg64). (: (.program( \t 'push \s '% (.expression dst) \n )) Nil);
+
 fragment mov := λ(: offset Constant)(: src Reg64)(: dst Reg8). (: (.program( \t 'mov \s (.expression offset) \[ '% (.expression src) \] , \s '% (.expression dst) \n )) Nil);
 
 fragment cmp := λ(: imm Constant+Literal+Sized<8>)(: r Constant+Reg64). (: (.program( \t 'cmp \s '$ (.expression imm) , '% (.expression r) \n )) Nil);

STDLIB/default-instruction-set.lm

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