Merge pull request #522 from andrew-johnson-4/lm-stabilize-deploy-par…

…adata

Lm stabilize deploy paradata

.gitignore

@@ -33,3 +33,5 @@ re-production
 deploy
 deploy.s
 deploy2.s
+dev
+dev.s

Cargo.toml

@@ -1,6 +1,6 @@
 [package]
 name = "lambda_mountain"
-version = "1.13.64"
+version = "1.14.0"
 authors = ["Andrew <[email protected]>"]
 license = "MIT"
 description = "Compiler Backend / Programming Language Scaffolding"

LIB/default-templates.lm

@@ -1,36 +1,36 @@
 
-fragment : DontChain template::push := λ(: src Constructor<tag>). (: (
+fragment : DontChain template::push := λ(: src Constructor<tag>+Sized<struct-size>+FieldsSized<fields-size>). (: (
    (.program(
-      (for wsz in (range( '0 (/( (-( (-( 'struct-size 'fields-size )) '8 )) '8 )) )) (
+      (for wsz in (range( '0 (/( (-( (-( (.expression struct-size) (.expression fields-size) )) '8 )) '8 )) )) (
          \t 'pushq \s '$0 \n
       ))
       (.program src)
       \t 'pushq \s '$ 'case-number \n
    ))
 ) StackVariable);
 
-fragment : DontChain template::mov := λ(: src Constructor<tag>)(: dst LocalVariable). (: (
+fragment : DontChain template::mov := λ(: src Constructor<tag>+Sized<struct-size>+FieldsSized<fields-size>)(: dst LocalVariable). (: (
    (.program(
-      (for wsz in (range( '0 (/( (-( (-( 'struct-size 'fields-size )) '8 )) '8 )) )) (
+      (for wsz in (range( '0 (/( (-( (-( (.expression struct-size) (.expression fields-size) )) '8 )) '8 )) )) (
          \t 'pushq \s '$0 \n
       ))
       (.program src)
       \t 'pushq \s '$ 'case-number \n
-      (for index in (range( 0 (/( 'struct-size '8 )) )) (
+      (for index in (range( 0 (/( (.expression struct-size) '8 )) )) (
          \t 'popq \s (+( (.expression dst) (*( '8 (.expression index) )) )) \[ '%rbp \] \n
       ))
    ))
 ) Nil);
 
-fragment : DontChain template::mov := λ(: src Constructor<tag>)(: dst GlobalVariable). (: (
+fragment : DontChain template::mov := λ(: src Constructor<tag>+Sized<struct-size>+FieldsSized<fields-size>)(: dst GlobalVariable). (: (
    (.program(
-      (for wsz in (range( '0 (/( (-( (-( 'struct-size 'fields-size )) '8 )) '8 )) )) (
+      (for wsz in (range( '0 (/( (-( (-( (.expression struct-size) (.expression fields-size) )) '8 )) '8 )) )) (
          \t 'pushq \s '$0 \n
       ))
       (.program src)
       \t 'pushq \s '$ 'case-number \n
       \t 'movq \s '$ (.expression dst) , \s '%r15 \n
-      (for index in (range( 0 (/( 'struct-size '8 )) )) (
+      (for index in (range( 0 (/( (.expression struct-size) '8 )) )) (
          \t 'popq \s (*( '8 (.expression index) )) \[ '%r15 \] \n
       ))
    ))

Makefile

@@ -1,6 +1,6 @@
 
 develop: compile-production
-	time ./production -o tmp.s tests/regress/paradata.lm
+	time ./production -o tmp.s tests/regress/poly_mov.lm
 	as tmp.s -o tmp.o
 	ld tmp.o -o tmp
 	./tmp
@@ -14,6 +14,12 @@ deploy: compile-production
 	mv deploy.s BOOTSTRAP/cli.s
 	cargo test regression_tests
 
+compile-dev: compile-bootstrap
+	rm -f dev dev.o dev.s
+	./bootstrap -o dev.s DEV/cli.lm
+	as -o dev.o dev.s
+	ld -o dev   dev.o
+
 compile-production: compile-bootstrap
 	rm -f production production.o production.s
 	./bootstrap -o production.s SRC/cli.lm

SRC/assemble.lm

@@ -174,15 +174,13 @@ compile-type-case := λ(: ctx FContext)(: base-type Type)(: rhs AST)(: case-numb
 )) FContext[]);
 
 compile-define-tag-constructor := λ(: ctx FContext)(: tag String)(: arg-types Type)(: base-type Type)(: rtype Type)(: case-number U64). (: (tail(
-   (let tg (maybe-deref(tand( (t2( 'Constructor_s (t1 tag) )) (tsized '0_s) ))))
+   (let tg (maybe-deref(tand( (t2( 'Constructor_s (t1 tag) )) (maybe-deref(tand( (t2( 'Sized_s (t1 '0_s) )) (t2( 'FieldsSized_s (t1 '0_s) )) ))) ))))
    (let push-template (fragment-context::lookup( ctx 'template::push_s tg ASTEOF )))
    (let movl-template (fragment-context::lookup( ctx 'template::mov_s (t3( 'Cons_s tg (t1 'LocalVariable_s) )) ASTEOF )))
    (let movg-template (fragment-context::lookup( ctx 'template::mov_s (t3( 'Cons_s tg (t1 'GlobalVariable_s) )) ASTEOF )))
 
    (let tag-tctx (TCtxBind( (close TCtxEOF) 'tag_s (t1 tag) ASTEOF )))
    (let case-tctx (SSLSeq( (close SSLEOF) 'case-number_s (SAtom(to-string case-number)) )))
-   (set case-tctx (SSLSeq( (close case-tctx) 'fields-size_s (SAtom(to-string(typecheck-aligned-sizeof arg-types))) )))
-   (set case-tctx (SSLSeq( (close case-tctx) 'struct-size_s (SAtom(to-string(typecheck-aligned-sizeof base-type))) )))
 
    (let fragment push-template)
    (let arrow-tt (substitute( tag-tctx (fragment::get-type fragment) )))

SRC/codegen.lm

@@ -187,7 +187,6 @@ compile-expr-direct := λ(: ctx FContext)(: term AST)(: stack-offset I64)(: used
       )))
       ( (App( (Lit ':_s) (App( t (AType tt) )) )) (tail(
          (let e1 (maybe-deref(compile-expr( ctx t stack-offset used ))))
-         (let e1-2 (maybe-deref(fragment::set-type( e1 (maybe-deref(typeof term)) ))))(set e1 e1-2)
          (set e e1)
       )))
       ( (App( (Var 'tail_s) (App( lt rt )) )) (tail(
@@ -746,19 +745,19 @@ compile-fragment-args := λ(: ctx FContext)(: rval AST)(: offset I64). (: (tail(
 )) FragmentList);
 
 compile-constructor := λ(: ctx FContext)(: tag-name String)(: return-type Type)(: args-type Type)(: args AST)(: offset I64). (: (tail(
-   (let whitespace-sz (-( (-( (typecheck-sizeof return-type) (typecheck-sizeof args-type) )) 8_u64 )))
+   (let whitespace-sz (-( (-( (typecheck-aligned-sizeof return-type) (typecheck-aligned-sizeof args-type) )) 8_u64 )))
    (let e1 (maybe-deref(compile-push-rvalue( ctx args (-( offset (as whitespace-sz I64) )) ))))
-   (let e1-2 (maybe-deref(fragment::set-type( e1 (t2( 'Constructor_s (t1 tag-name) )) ))))(set e1 e1-2)
-   (let args-type-sized (maybe-deref(tand(
+   (let constructor-parms (maybe-deref(tand(
       (t2( 'Constructor_s (t1 tag-name) ))
       (maybe-deref(tand(
-         args-type
-         (maybe-deref(tsized(to-string(typecheck-sizeof args-type))))
+         (t2( 'Sized_s (t1(to-string(typecheck-aligned-sizeof return-type))) ))
+         (t2( 'FieldsSized_s (t1(to-string(typecheck-aligned-sizeof args-type))) ))
       )))
    ))))
+   (let e1-2 (maybe-deref(fragment::set-type( e1 constructor-parms ))))(set e1 e1-2)
    (let r (maybe-deref(fragment-apply(
       ctx offset 'push_s
-      (FLSeq( (close FLEOF) e1 )) (t3( 'Arrow_s args-type-sized return-type )) args
+      (FLSeq( (close FLEOF) e1 )) (t3( 'Arrow_s constructor-parms return-type )) args
    ))))
    (let r-1 (maybe-deref(fragment::set-context( r ctx ))))(set r r-1)
    (let r-2 (maybe-deref(fragment::set-type( r return-type ))))(set r r-2)

SRC/stable-fragment.lm

@@ -444,7 +444,7 @@ fragment::render-impl := λ(: ctx FContext)(: s S). (: (tail(
             (let fe (fragment::get( f (tail-string op) )))
             (if (non-zero fe) () (tail(
                (print 'Referenced\sVariable\sIn\sFragment\sWas\sNull\s_s)
-               (print v)(print '\n_s)(exit 1_u64)
+               (print '._s)(print op)(print '\s_s)(print v)(print '\n_s)(exit 1_u64)
             )))
             (set r fe)
          )) (tail(

SRC/stable-types.lm

@@ -355,6 +355,26 @@ without-tag := λ(: tt Type). (: (tail(
    tt
 )) Type);
 
+without-open := λ(: tt Type). (: (tail(
+   (match tt (
+      ()
+      ( (TAnd( lt rt )) (tail(
+         (let lt1 (without-open lt))
+         (let rt1 (without-open rt))
+         (match (TPair( lt1 rt1 )) (
+            ()
+            ( (TPair( TAny rt2 )) (set tt rt2) )
+            ( (TPair( lt2 TAny )) (set tt lt2) )
+            ( (TPair( lt2 rt2 )) (
+               (set tt (TAnd( (close lt2) (close rt2) )))
+            ))
+         ))
+      )))
+      ( _ (if (is-open tt) (set tt TAny) ()))
+   ))
+   tt
+)) Type);
+
 without-tag := λ(: tt TypeList). (: (tail(
    (match tt (
       ()
@@ -498,6 +518,7 @@ without-size := λ(: tt Type). (: (tail(
          ))
       )))
       ( (TGround( 'Sized_s sz )) (set tt TAny) )
+      ( (TGround( 'FieldsSized_s sz )) (set tt TAny) )
       ( (TGround( tag ps )) (
          (set tt (TGround( tag (close(without-size ps)) )))
       ))
@@ -570,6 +591,7 @@ without-size-unless-class-inner := λ(: tt Type). (: (tail(
             ))
          ))
       )))
+      ( (TGround( 'FieldsSized_s _ )) (set tt TAny) )
       ( (TGround( 'Sized_s _ )) (set tt TAny) )
       ( (TGround( tag ps )) (
          (set tt (TGround( tag (close(without-size-unless-class ps)) )))