Merge pull request #203 from andrew-johnson-4/strict-compiler-dev-18

Strict compiler dev 18

Author: andrew-johnson-4

Cargo.toml

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

PRODUCTION/codegen-strict.lm

@@ -21,8 +21,8 @@ compile-push-rvalue := λctx e offset . (tail(
             ()
             ( StackVariable e1 )
             ( _ (tail(
-               (set e2 (fragment-apply( ctx 'push lt (() e1) e1 )))
-               (expr::chain( e1 e2 ))
+               ()
+               (fragment-apply( ctx 'push lt (() e1) e1 ))
             )))
          ))
       )))
@@ -172,19 +172,27 @@ compile-expr-strict := λctx e offset used . (tail(
                (set e1 (expr::set-offset( e1 offset )))
                e1
             )))
+            ( (App( (Variable 'sizeof) (Literal ltype) )) (tail(
+               (set ltype (parse-type ltype))
+               (set e1 (expr::set-expr( (expr::new ()) (typecheck-sizeof ltype) )))
+               (set e1 (expr::set-context( e1 ctx )))
+               (set e1 (expr::set-offset( e1 offset )))
+               (set e1 (expr::set-type( e1 ltype )))
+               e1
+            )))
             ( (Literal lval) (tail(
                (set e1 (expr::set-expr( (expr::new ()) lval )))
                (set e1 (expr::set-context( e1 ctx )))
                (set e1 (expr::set-offset( e1 offset )))
                e1
             )))
             ( (App( (App( (Literal ':) lval )) ltype )) (tail(
-               (set e1 (compile-expr-strict( ctx lval offset Unused )))
+               (set e1 (compile-expr-strict( ctx lval offset Used )))
                (set e1 (expr::set-type( e1 (typecheck-lookup e) )))
                e1
             )))
             ( (App( (App( (Variable 'as) lval )) ltype )) (tail(
-               (set e1 (compile-expr-strict( ctx lval offset Unused )))
+               (set e1 (compile-expr-strict( ctx lval offset Used )))
                (set e1 (expr::set-type( e1 (typecheck-lookup e) )))
                e1
             )))

PRODUCTION/typecheck.lm

@@ -85,6 +85,9 @@ typecheck-assert-expr := λe . (tail(
       ( (App( (App( (Literal ':) (Literal _) )) tt )) (
          (typecheck-assert-one( e ))
       ))
+      ( (App( (Variable 'sizeof) (Literal tt) )) (
+         (typecheck-assert-one( e ))
+      ))
       ( (App( (App( (Literal ':) te )) tt )) (
          (typecheck-assert-expr( te ))
          (typecheck-assert-one( e ))
@@ -742,6 +745,9 @@ typecheck-infer-expr := λctx e used . (tail(
          (typecheck-infer-expr( ctx rhs Used ))
          (typecheck-ascript( e (typecheck-typeof-var( ctx lhs )) ))
       )))
+      ( (App( (Variable 'sizeof) (Literal tt) )) (tail(
+         (typecheck-ascript( e (parse-type( U64+Literal+Constant )) ))
+      )))
       ( (App( (App( (App( (Variable 'if) cond )) t )) f )) (tail(
          (typecheck-infer-expr( ctx cond Used ))
          (typecheck-infer-expr( ctx t Used ))
@@ -808,7 +814,12 @@ typecheck-infer-expr := λctx e used . (tail(
    ctx
 ));
 
-typecheck-sizeof := λtt . (match tt (
+typecheck-sizeof := λtt . (tail(
+   (local sz)
+   (set sz (typecheck-sizeof-impl tt))
+   sz
+));
+typecheck-sizeof-impl := λtt . (match tt (
    ()
    ( Nil 0 )
    ( '? () )
@@ -927,6 +938,7 @@ typecheck-as-return := λrt . (tail(
       (2 (And( Reg16 rt )))
       (4 (And( Reg32 rt )))
       (8 (And( Reg64 rt )))
+      (_ (And( LocalVariable rt )))
    ))
 ));
 

STDLIB/default-instruction-set.lm

@@ -58,8 +58,30 @@ fragment pop := λ(: src LocalVariable+Sized<size>). (: (
    )))
 ) Nil);
 
+fragment mov := λ(: src LocalVariable+Sized<size>)(: index Literal+Constant)(: dst Reg64+x[]). (: (
+   (.program (
+      (\t 'mov \s '% (.expression dst) , \s '%r14 \n)
+      (for word-offset in (range( 0 (/( size 8 )) )) (
+         \t 'movq \s (+( (.expression src) (*( word-offset 8 )) )) \[ '%rbp \] , \s '%r15 \n
+         \t 'movq \s '%r15 , \s (*( word-offset 8 )) \[ '%r14 \] \n
+      ))
+   ))
+) Nil);
+fragment mov := λ(: src Reg64+x[])(: index Literal+Constant)(: dst LocalVariable+Sized<size>). (: (
+   (.program (
+      (\t 'mov \s '% (.expression src) , \s '%r14 \n)
+      (for word-offset in (range( 0 (/( size 8 )) )) (
+         \t 'movq \s (*( word-offset 8 )) \[ '%r14 \] , '%r15 \n
+         \t 'movq \s '%r15 , \s (+( (.expression dst) (*( word-offset 8 )) )) \[ '%rbp \] \n
+      ))
+   ))
+) Nil);
+
 fragment mov := λ(: src LocalVariable)(: dst Constant+Reg64). (: ( (.program( \t 'mov \t (.expression src) \[ '%rbp \] , \s '% (.expression dst) \n)) ) Nil);
-fragment mov := λ(: src LocalVariable)(: dst Constant+Reg64). (: ( (.program( \t 'mov \t (.expression src) \[ '%rbp \] , \s '% (.expression dst) \n)) ) Nil);
+fragment mov := λ(: src GlobalVariable)(: dst Constant+Reg64). (: ( (.program(
+   \t 'mov \t '$ (.expression src) , \s '% (.expression dst) \n
+   \t 'mov \t '0 \[ '% (.expression dst) \] , \s '% (.expression dst) \n
+)) ) Nil);
 fragment mov := λ(: src Constant+Literal+Sized<8>)(: dst Constant+Reg64). (: ( (.program( \t 'mov \t '$ (.expression src) , \s '% (.expression dst) \n)) ) Nil);
 fragment mov := λ(: src Reg64)(: dst Constant+Reg64). (: ( (.program( \t 'mov \t '% (.expression src) , \s '% (.expression dst) \n)) ) Nil);
 
@@ -161,5 +183,7 @@ fragment div := λ(: l Reg64). (: (.program( \t 'div \s '% (.expression l) \n ))
 fragment add := λ(: src Constant+Literal+Sized<1>)(: dst LocalVariable). (: (.program( \t 'addb \s '$ (.expression src) , \s (.expression dst) \[ '%rbp \] \n )) Nil);
 fragment add := λ(: src Constant+Literal+Sized<8>)(: dst Reg64). (: (.program( \t 'addq \s '$ (.expression src) , \s '% (.expression dst) \n )) Nil);
 
+fragment add := λ(: src LocalVariable+Sized<8>)(: dst Reg64). (: (.program( \t 'addq \s (.expression src) \[ '%rbp \] , \s '% (.expression dst) \n )) Nil);
+
 fragment push := λ(: l Reg64). (: (.program( \t 'push \s '% (.expression l) \n )) Nil);
 fragment pop := λ(: l Reg64). (: (.program( \t 'pop \s '% (.expression l) \n )) Nil);

STDLIB/default-stdlib.lm

@@ -5,8 +5,9 @@ type S (SNil)
      | (SPointer( ?[] ));
 
 close := λ(: x S). (: (tail(
-   ()
-   (as 0u64 S[])
+   (mov( (malloc(sizeof S)) R8 ))
+   (mov( x 0u64 (as R8 S[]) ))
+   (as R8 S[])
 )) S[]);
 
 print := λ(: x S). (: (tail(
@@ -17,10 +18,15 @@ print := λ(: x S). (: (tail(
          (print (.1 (as x SAtom)))
       ) (
          (if (==( (.0 x) 1u64 )) (tail(
+            (let c SNil)
             (print '\[_s)
-            (print (as (.1 (as x SCons)) U64))
+            (print( (as (.1 (as x SCons)) U64) ))
+            (mov( (.1 (as x SCons)) 0u64 c ))
+            (print c)
             (print '\s_s)
-            (print (as (.2 (as x SCons)) U64))
+            (print( (as (.2 (as x SCons)) U64) ))
+            (mov( (.2 (as x SCons)) 0u64 c ))
+            (print c)
             (print '\]_s)
          )) (tail(
             (print '[_s)
@@ -189,6 +195,8 @@ malloc := λ (: sz U64) . (: (tail(
       (syscall())
    )) ())
    (let curr cons-page-tail)
-   (set cons-page-tail (+( cons-page-tail sz )))
+   (mov( cons-page-tail R8 ))
+   (add( sz R8 ))
+   (set cons-page-tail (as R8 U64))
    (as curr ?[])
 )) ?[]);

STRICT/cli.lm

@@ -14,17 +14,17 @@ config-mode              := Compile;
 main := λ(: argc U64)(: argv U8[][]).(tail(
 #   (let argi 0u64)
    (let input_l (SAtom( 'an-atom_s )))
-   (let input_r (SPointer( as 'test_s ?[] )))
-   (let input (SCons(
-      (close( input_l ))
-      (close( input_r ))
-   )))
-   (print input)
-   (print (as (malloc 24u64) U64))
-   (print ',_s)
-   (print (as (malloc 24u64) U64))
-   (print ',_s)
-   (print (as (malloc 24u64) U64))
+   (let input_o SNil)
+   (let close_l 0u64)
+   (push (close( input_l )))
+   (pop( close_l ))
+   (mov( close_l R8 ))
+   (mov( (as R8 S[]) 0u64 input_o ))
+   (print input_o)
+#   (push (close( input_r )))
+#   (pop( close_r ))
+#   (let input (SCons( (as close_l S[]) (as close_r S[]) )))
+#   (print input)
 #   (while (<( argi argc )) (
 #      (if (==( ([]( argv argi )) '--tokenize_s )) (
 #         (print '--tokenize_s)