assemble-text-section := (: SNil S);
assemble-init-section := (: SNil S);
assemble-data-section := (: SNil S);
assemble-final := '_s;
assemble-argv-referenced := False_u8;
compile := λ(). (: (tail(
(let global-ctx (maybe-deref(fragment-context::new())))
(let preview-program ast-parsed-program)
(while (non-zero preview-program) (match preview-program (
()
( (Seq( rst (Frg( k rhs _ )) )) (tail(
(let is-template False_u8)
(match k (
()
( 'template::push_s (set is-template True_u8) )
( 'template::mov_s (set is-template True_u8) )
( _ () )
))
(if (==( is-template True_u8 )) (tail(
(let fragment (maybe-deref(fragment::new())))
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))
(let fragment-3 (maybe-deref(fragment::set( fragment-2 'fragment_s (maybe-deref(to-s rhs)) ))))
(let fragment-4 (maybe-deref(fragment::set-type( fragment-3 (maybe-deref(typeof rhs)) ))))
(let global-ctx-2 (maybe-deref(fragment-context::bind(
global-ctx
k
(maybe-deref(typeof rhs))
fragment-4
))))
(match preview-program (
()
( (Seq( _ frg )) (ascript( (fragment::get( fragment-4 'fragment_s )) (typeof frg) )) )
))
(set global-ctx global-ctx-2)
)) ())
(set preview-program rst)
)))
( (Seq( rst _ )) (
(set preview-program rst)
))
)))
(let preview-program ast-parsed-program)
(while (non-zero preview-program) (match preview-program (
()
( (Seq( rst (Glb( k rhs )) )) (tail(
(if (==( k 'main_s )) (set assemble-argv-referenced True_u8) ())
(let open False_u8)
(match preview-program (
()
( (Seq( _ term )) (
(if (is-open(typeof term)) (set open True_u8) ())
))
))
(if (==( open True_u8 )) () (tail(
(let fragment (maybe-deref(fragment::new())))
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Global_s) ))))
(let rhs-tt (maybe-deref(typeof rhs)))
(match (slot( rhs-tt '->_s )) (
()
( (TGround( '->_s _ )) (tail(
(let fragment-3 (maybe-deref(fragment::set-type( fragment-2 rhs-tt ))))
(let global-ctx-2 (maybe-deref(fragment-context::bind(
global-ctx k rhs-tt fragment-3
))))
(set global-ctx global-ctx-2)
)))
( _ (tail(
(let clean-tt (maybe-deref(without-representation rhs-tt)))
(let repr-tt (TAnd( (close clean-tt) (close(t1 'GlobalVariable_s)) )))
(let fragment-3 (maybe-deref(fragment::set-type( fragment-2 repr-tt ))))
(let mid (mangle-identifier( k clean-tt )))
(let fragment-4 (maybe-deref(fragment::set( fragment-3 'expression_s (SAtom mid) ))))
(let global-ctx-2 (maybe-deref(fragment-context::bind(
global-ctx k repr-tt fragment-4
))))
(set global-ctx global-ctx-2)
)))
))
)))
(set preview-program rst)
)))
( (Seq( rst (Frg( k rhs _ )) )) (tail(
(let fragment (maybe-deref(fragment::new())))
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))
(let fragment-3 (maybe-deref(fragment::set( fragment-2 'fragment_s (maybe-deref(to-s rhs)) ))))
(let fragment-4 (maybe-deref(fragment::set-type( fragment-3 (maybe-deref(typeof rhs)) ))))
(let global-ctx-2 (maybe-deref(fragment-context::bind(
global-ctx
k
(maybe-deref(typeof rhs))
fragment-4
))))
(set global-ctx global-ctx-2)
(set preview-program rst)
)))
( (Seq( rst (ASTType( lhs rhs )) )) (tail(
(let global-ctx-2 (maybe-deref(compile-type( global-ctx lhs rhs ))))
(set global-ctx global-ctx-2)
(set preview-program rst)
)))
( (Seq( rst _ )) (
(set preview-program rst)
))
)))
(compile-program-ordered( global-ctx ast-parsed-program ))
(compile-finish())
(compile-write())
)) Nil);
compile-program-ordered := λ(: global-ctx FContext)(: program AST). (: (tail(
(let open False_u8)
(match program (
()
( (Seq( _ e )) (
(if (is-open(typeof e)) (set open True_u8) ())
))
( _ () )
))
(match program (
()
( (Seq( rst (Glb( k rhs )) )) (tail(
(compile-program-ordered( global-ctx rst ))
(if (==( open True_u8 )) () (
(compile-global( global-ctx k rhs ))
))
)))
( (Seq( rst e )) (tail(
(compile-program-ordered( global-ctx rst ))
(compile-global( global-ctx e ))
)))
( ASTEOF () )
))
)) Nil);
compile-type := λ(: ctx FContext)(: lhs AST)(: rhs AST). (: (tail(
(let def rhs)
(let base-type (maybe-deref(type-of-s( lhs ))))
(let case-number 0_u64)
(if (is-fragment base-type) () (
(while (non-zero def) (match def (
()
( (App( (App( tds (Var '|_s) )) body )) (tail(
(let ctx-2 (maybe-deref(compile-type-case( ctx base-type body case-number ))))(set ctx ctx-2)
(set case-number (+( case-number 1_u64 )))
(set def tds)
)))
( body (tail(
(let ctx-2 (maybe-deref(compile-type-case( ctx base-type body case-number ))))(set ctx ctx-2)
(set case-number (+( case-number 1_u64 )))
(set def ASTEOF)
)))
)))
))
(close ctx)
)) FContext[]);
compile-type-case := λ(: ctx FContext)(: base-type Type)(: rhs AST)(: case-number U64). (: (tail(
(match rhs (
()
( (Lit tag) (tail(
(let rtype (TAnd( (close base-type) (close(parse-type tag)) )) )
(let ctx-3 (maybe-deref(compile-define-tag-constructor( ctx tag TAny base-type rtype case-number ))))(set ctx ctx-3)
)))
( (App( (Lit tag) args )) (tail(
(let atype (maybe-deref(type-of-s args)))
(let rtype (TAnd( (close base-type) (close(parse-type tag)) )))
(let ctx-3 (maybe-deref(compile-define-tag-constructor( ctx tag atype base-type rtype case-number ))))(set ctx ctx-3)
)))
( _ () )
))
(close ctx)
)) FContext[]);
compile-define-tag-constructor := λ(: ctx FContext)(: tag String)(: arg-types Type)(: base-type Type)(: rtype Type)(: case-number U64). (: (tail(
(if (is-open base-type) (tail(
(let ctx-2 (maybe-deref(compile-define-tag-constructor-parametric( ctx tag arg-types base-type rtype case-number ))))
(set ctx ctx-2)
)) (tail(
(let ctx-2 (maybe-deref(compile-define-tag-constructor-simple( ctx tag arg-types base-type rtype case-number ))))
(set ctx ctx-2)
)))
(close ctx)
)) FContext[]);
compile-define-tag-constructor-parametric := λ(: ctx FContext)(: tag String)(: arg-types Type)(: base-type Type)(: rtype Type)(: case-number U64). (: (tail(
(let tg (maybe-deref(tand( (t1 tag) (tsized '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 tctx (SSLSeq(
(close SSLEOF)
'case-number_s
(SAtom(to-string case-number))
)))
(let arrow-tt (t3( 'Arrow_s (maybe-deref(t1 tag)) (maybe-deref(tand( rtype (maybe-deref(t1 'StackVariable_s)) ))) )))
(let arrow-dc (TAnd( (close arrow-tt) (close(t1 'DontChain_s)) )))(set arrow-tt arrow-dc)
(let fragment push-template)
(let fragment-1 (maybe-deref(fragment::set-type( fragment arrow-dc ))))(set fragment fragment-1)
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))(set fragment fragment-2)
(let spt (specialize-term( tctx (fragment::get( fragment 'fragment_s )) )))
(ascript( spt (typeof( (fragment::get( fragment 'fragment_s )) )) ))
(let fragment-3 (maybe-deref(fragment::set( fragment 'fragment_s spt ))))(set fragment fragment-3)
(let ctx-2 (maybe-deref(fragment-context::bind(
ctx 'push_s arrow-tt fragment
))))(set ctx ctx-2)
(let arrow-tt (t3( 'Arrow_s (t3( 'Cons_s (maybe-deref(t1 tag)) (t1 'LocalVariable_s) )) (t1 'Nil_s) )))
(let arrow-dc (TAnd( (close arrow-tt) (close(t1 'DontChain_s)) )))(set arrow-tt arrow-dc)
(let fragment movl-template)
(let fragment-1 (maybe-deref(fragment::set-type( fragment arrow-dc ))))(set fragment fragment-1)
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))(set fragment fragment-2)
(let spt (specialize-term( tctx (fragment::get( fragment 'fragment_s )) )))
(ascript( spt (typeof( (fragment::get( fragment 'fragment_s )) )) ))
(let fragment-3 (maybe-deref(fragment::set( fragment 'fragment_s spt ))))(set fragment fragment-3)
(let ctx-2 (maybe-deref(fragment-context::bind(
ctx 'push_s arrow-tt fragment
))))(set ctx ctx-2)
(let arrow-tt (t3( 'Arrow_s (t3( 'Cons_s (maybe-deref(t1 tag)) (t1 'GlobalVariable_s) )) (t1 'Nil_s) )))
(let arrow-dc (TAnd( (close arrow-tt) (close(t1 'DontChain_s)) )))(set arrow-tt arrow-dc)
(let fragment movg-template)
(let fragment-1 (maybe-deref(fragment::set-type( fragment arrow-dc ))))(set fragment fragment-1)
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))(set fragment fragment-2)
(let spt (specialize-term( tctx (fragment::get( fragment 'fragment_s )) )))
(ascript( spt (typeof( (fragment::get( fragment 'fragment_s )) )) ))
(let fragment-3 (maybe-deref(fragment::set( fragment 'fragment_s spt ))))(set fragment fragment-3)
(let ctx-2 (maybe-deref(fragment-context::bind(
ctx 'push_s arrow-tt fragment
))))(set ctx ctx-2)
(close ctx)
)) FContext[]);
compile-define-tag-constructor-simple := λ(: ctx FContext)(: tag String)(: arg-types Type)(: base-type Type)(: rtype Type)(: case-number U64). (: (tail(
(if (non-zero arg-types) (tail(
(let base-type-sz (typecheck-aligned-sizeof base-type))
(let args-sz (typecheck-aligned-sizeof arg-types))
(let whitespace-sz (-( (-( base-type-sz 8_u64 )) args-sz )))
(let arrow-tt (t3( 'Arrow_s (maybe-deref(t1 tag)) (maybe-deref(tand( rtype (maybe-deref(t1 'StackVariable_s)) ))) )))
(let arrow-dc (TAnd( (close arrow-tt) (close(t1 'DontChain_s)) )))(set arrow-tt arrow-dc)
(let fragment (maybe-deref(fragment::new())))
(let fragment-1 (maybe-deref(fragment::set-type( fragment arrow-tt ))))(set fragment fragment-1)
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))(set fragment fragment-2)
(let fragment-3 (maybe-deref(fragment::set( fragment 'fragment_s
(maybe-deref(s-abs(
(s-var 'src_s)
(s-app(
(s-var '.program_s)
(s-app(
(s-app(
(s-app(
(s-lit '\tsubq\s$_s)
(s-lit(to-string whitespace-sz))
))
(s-lit ',\s%rsp\n_s)
))
(s-app(
(s-app(
(s-var '.program_s)
(s-var 'src_s)
))
(s-app(
(s-lit '\tpushq\s$_s)
(s-app(
(s-lit(to-string case-number))
(s-lit '\n_s)
))
))
))
))
))
)))
))))(set fragment fragment-3)
(let ctx-2 (maybe-deref(fragment-context::bind(
ctx 'push_s arrow-tt fragment
))))(set ctx ctx-2)
(let arrow-tt (t3( 'Arrow_s
(t3( 'Cons_s (maybe-deref(t1 tag)) (maybe-deref(t1 'LocalVariable_s)) ))
(maybe-deref(t1 'Nil_s))
)))
(let arrow-dc (TAnd( (close arrow-tt) (close(t1 'DontChain_s)) )))(set arrow-tt arrow-dc)
(let fragment (maybe-deref(fragment::new())))
(let fragment-1 (maybe-deref(fragment::set-type( fragment arrow-tt ))))(set fragment fragment-1)
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))(set fragment fragment-2)
(let pop SNil)
(let popped-sz 0_u64)
(while (<( popped-sz base-type-sz )) (tail(
(let pop-2 (maybe-deref(s-app(
(close pop)
(s-app(
(s-lit '\tpop\s_s)
(s-app(
(s-app( (s-var '+_s) (s-app(
(s-app( (s-var '.expression_s) (s-var 'dst_s) ))
(s-lit(to-string popped-sz))
))))
(s-lit '\[%rbp\]\n_s)
))
))
))))
(set pop pop-2)
(set popped-sz (+( popped-sz 8_u64 )))
)))
(let fragment-3 (maybe-deref(fragment::set( fragment 'fragment_s
(maybe-deref(s-abs(
(s-app(
(s-var 'src_s)
(s-var 'dst_s)
))
(s-app(
(s-var '.program_s)
(s-app(
(s-app(
(s-var '.program_s)
(s-var 'src_s)
))
(close pop)
))
))
)))
))))(set fragment fragment-3)
(let ctx-2 (maybe-deref(fragment-context::bind(
ctx 'mov_s arrow-tt fragment
))))(set ctx ctx-2)
(let arrow-tt (t3( 'Arrow_s
(t3( 'Cons_s (maybe-deref(t1 tag)) (maybe-deref(t1 'GlobalVariable_s)) ))
(maybe-deref(t1 'Nil_s))
)))
(let arrow-dc (TAnd( (close arrow-tt) (close(t1 'DontChain_s)) )))(set arrow-tt arrow-dc)
(let fragment (maybe-deref(fragment::new())))
(let fragment-1 (maybe-deref(fragment::set-type( fragment arrow-tt ))))(set fragment fragment-1)
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))(set fragment fragment-2)
(let pop SNil)
(let popped-sz 0_u64)
(while (<( popped-sz base-type-sz )) (tail(
(let pop-2 (maybe-deref(s-app(
(close pop)
(s-app(
(s-lit '\tpop\s_s)
(s-app(
(s-lit(to-string popped-sz))
(s-lit '\[%r15\]\n_s)
))
))
))))
(set pop pop-2)
(set popped-sz (+( popped-sz 8_u64 )))
)))
(let fragment-3 (maybe-deref(fragment::set( fragment 'fragment_s
(maybe-deref(s-abs(
(s-app(
(s-var 'src_s)
(s-var 'dst_s)
))
(s-app(
(s-var '.program_s)
(s-app(
(s-app(
(s-var '.program_s)
(s-var 'src_s)
))
(s-app(
(s-app(
(s-lit '\tmov\s$_s)
(s-app(
(s-app( (s-var '.expression_s) (s-var 'dst_s) ))
(s-lit ',\s%r15\n_s)
))
))
(close pop)
))
))
))
)))
))))(set fragment fragment-3)
(let ctx-2 (maybe-deref(fragment-context::bind(
ctx 'mov_s arrow-tt fragment
))))(set ctx ctx-2)
)) (tail(
(let base-type-sz (typecheck-aligned-sizeof base-type))
(let whitespace-sz (-( base-type-sz 8_u64 )))
#push constructor
(let arrow-tt (t3( 'Arrow_s (maybe-deref(t1 tag)) rtype )))
(let arrow-dc (TAnd( (close arrow-tt) (close(t1 'DontChain_s)) )))(set arrow-tt arrow-dc)
(let fragment (maybe-deref(fragment::new())))
(let fragment-1 (maybe-deref(fragment::set-type( fragment arrow-tt ))))(set fragment fragment-1)
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))(set fragment fragment-2)
(let fragment-3 (maybe-deref(fragment::set( fragment 'fragment_s
(maybe-deref(s-abs(
(s-var 'tag_s)
(s-app(
(s-var '.program_s)
(s-app(
(s-app(
(s-app(
(s-lit '\tsubq\s$_s)
(s-lit(to-string whitespace-sz))
))
(s-lit ',\s%rsp\n_s)
))
(s-app(
(s-lit '\tpushq\s$_s)
(s-app(
(s-lit(to-string case-number))
(s-lit '\n_s)
))
))
))
))
)))
))))(set fragment fragment-3)
(let ctx-2 (maybe-deref(fragment-context::bind(
ctx 'push_s arrow-tt fragment
))))(set ctx ctx-2)
#mov local constructor
(let arrow-tt (t3( 'Arrow_s
(t3( 'Cons_s (maybe-deref(t1 tag)) (TAnd( (close base-type) (close(t1 'LocalVariable_s)) )) ))
(maybe-deref(t1 'Nil_s))
)))
(let arrow-dc (TAnd( (close arrow-tt) (close(t1 'DontChain_s)) )))(set arrow-tt arrow-dc)
(let fragment (maybe-deref(fragment::new())))
(let fragment-1 (maybe-deref(fragment::set-type( fragment arrow-tt ))))(set fragment fragment-1)
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))(set fragment fragment-2)
(let fragment-3 (maybe-deref(fragment::set( fragment 'fragment_s
(maybe-deref(s-abs(
(s-app(
(s-var 'src_s)
(s-var 'dst_s)
))
(s-app(
(s-var '.program_s)
(s-app(
(s-lit '\tmovq\s$_s)
(s-app(
(s-lit(to-string case-number))
(s-app(
(s-lit ',\s_s)
(s-app(
(s-app(
(s-var '.expression_s)
(s-var 'dst_s)
))
(s-lit '\[%rbp\]\n_s)
))
))
))
))
))
)))
))))(set fragment fragment-3)
(let ctx-2 (maybe-deref(fragment-context::bind(
ctx 'mov_s arrow-tt fragment
))))(set ctx ctx-2)
#mov global constructor
(let arrow-tt (t3( 'Arrow_s
(t3( 'Cons_s (maybe-deref(t1 tag)) (TAnd( (close base-type) (close(t1 'GlobalVariable_s)) )) ))
(maybe-deref(t1 'Nil_s))
)))
(let arrow-dc (TAnd( (close arrow-tt) (close(t1 'DontChain_s)) )))(set arrow-tt arrow-dc)
(let fragment (maybe-deref(fragment::new())))
(let fragment-1 (maybe-deref(fragment::set-type( fragment arrow-tt ))))(set fragment fragment-1)
(let fragment-2 (maybe-deref(fragment::set( fragment 'fragment-type_s (SAtom 'Fragment_s) ))))(set fragment fragment-2)
(let fragment-3 (maybe-deref(fragment::set( fragment 'fragment_s
(maybe-deref(s-abs(
(s-app(
(s-var 'src_s)
(s-var 'dst_s)
))
(s-app(
(s-var '.program_s)
(s-app(
(s-lit '\tmovq\s$_s)
(s-app(
(s-app(
(s-var '.expression_s)
(s-var 'dst_s)
))
(s-app(
(s-lit ',\s%r15\n\tmovq\s$_s)
(s-app(
(s-lit(to-string case-number))
(s-lit ',\s0\[%r15\]\n_s)
))
))
))
))
))
)))
))))(set fragment fragment-3)
(let ctx-2 (maybe-deref(fragment-context::bind(
ctx 'mov_s arrow-tt fragment
))))(set ctx ctx-2)
)))
(close ctx)
)) FContext[]);
compile-finish := λ. (: (tail(
(let output SNil)
(set output (SCons( (close output) (close(compile-text-header())) )))
(set output (SCons( (close output) (close(compile-exit-cleanup())) )))
(set output (SCons( (close output) (close assemble-text-section) )))
(set output (SCons( (close output) (close(compile-data-header())) )))
(set output (SCons( (close output) (close assemble-data-section) )))
(set assemble-final (clone-rope(maybe-deref(escape-string output))))
)) Nil);
compile-write := λ. (: (tail(
()
(write-file( config-target assemble-final ))
)) Nil);