{Record elaborate emit}

Where

Let (elaborate program)
    Let packages
        (LIST.map program.packages
            Func package.
                Let functions
                    (LIST.map package.functions
                        Func function.
                            (elaborate 0 VAR_MAP.empty `nothing function))
                Let init
                    (elaborate 0 VAR_MAP.empty `nothing package.init)
                In
                {Record functions init})
    In
    {Record
        packages
        constants:program.constants
        label_names:program.label_names
        record_indexes:program.record_indexes
        nil_label:program.nil_label
        cons_label:program.cons_label
        }

Let (emit program write)
    Let emit (make_emit write)
    In
    Begin
        (write "#include <support.h>\n")
        (write "const U2 record_layouts[]={")
        (LIST.for_each program.record_indexes
            Func index.
                Begin
                    (LIST.for_each index
                        Func label.
                            Begin (write (Z.show label)) (write ",") End)
                    (write "Z,")
                    End)
        (write "};\n")
        (write "static X s34(X x1,X x2){return s27(")
        (write (Z.show program.cons_label))
        (write ",s78(2,(X[]){x1,x2}));}\n")
        Match program.constants
        | `nil {}
        | `cons._
            Begin
                (write "static X ")
                (LIST.reduce (LIST.iota (LIST.length program.constants)) ""
                    Func prefix i.
                        Do Begin
                            (write prefix)
                            (write "c")
                            (write (Z.show i))
                            End
                        In
                        ",")
                (write ";\n")
                End
        ;
        (write "static X ")
        (LIST.reduce (LIST.iota (LIST.length program.packages)) ""
            Func prefix i.
                Do Begin
                    (write prefix)
                    (write "p")
                    (write (Z.show i))
                    End
                In
                ",")
        (write ";\n")
        (LIST.for_each program.packages
            Func package. (LIST.for_each (LIST.reverse package.functions) emit))
        (write "int main(int argc,const char*argv[]){\n")
        (write "static _Alignas(16) char heap_bytes[32*1024*1024];")
        (write "s36(sizeof(heap_bytes),heap_bytes,1024*1024,sizeof(record_layouts)/sizeof(record_layouts[0]),record_layouts);\n")
        (write "X args=")
        (write (Z.show (encode_empty_variant program.nil_label)))
        (write ";")
        (write "for(int i=argc-1;i>=0;i--)args=s27(")
        (write (Z.show program.cons_label))
        (write ",s78(2,(X[]){s57(argv[i]),args}));\n")
        (LIST.for_each_numbered program.constants
            Func i s.
                Begin
                    (emit `c.i)
                    (write "=s57(")
                    (write s)
                    (write ");")
                    End)
        (LIST.for_each_numbered program.packages
            Func i package.
                Begin
                    (write "\n")
                    (emit `p.i)
                    (write "=")
                    (emit package.init)
                    (write ";")
                    End)
        Block
            Let main
                (STRING.append "p" (Z.show ((LIST.length program.packages) - 1)))
            In
            Begin
                (write "\n((X(*)(X,X))s35(")
                (write main)
                (write ",1))(")
                (write main)
                (write ",args);\n")
                End
        (write "return 0;}\n")
        End

Where

Let (make_emit write)
    Define (emit tree)
        Let (emit_list exprs)
            Match exprs
            | `nil {}
            | `cons.{expr exprs}
                Do (emit expr)
                In
                (LIST.for_each exprs
                    Func expr. Do (write ",") In (emit expr))
            ;
        Let (emit_decl_pair {var maybe_init})
            Match maybe_init
            | `nothing (emit var)
            | `just.expr
                Begin (emit var) (write "=") (emit expr) End
            ;
        In
        Match tree
        | `true (write "15")
        | `false (write "271")
        | `empty_tuple
            (write "31")
        | `labeled_empty_tuple.label
            (write (Z.show (encode_empty_variant label)))
        | `alloc_labeled_value.{label expr}
            Begin
                (write "s27(")
                (write (Z.show label))
                (write ",")
                (emit expr)
                (write ")")
                End
        | `remove_label.expr
            Begin
                (write "s06(")
                (emit expr)
                (write ")")
                End
        | `alloc_tuple.exprs
            Let n (LIST.length exprs)
            In
            Match exprs
            | `nil (emit `empty_tuple)
            | `cons.{expr exprs}
                Begin
                    (write "s78(")
                    (write (Z.show n))
                    (write ",(X[]){")
                    (emit expr)
                    (LIST.for_each exprs
                        Func expr. Begin (write ",") (emit expr) End)
                    (write "})")
                    End
            ;
        | `alloc_record.{layout exprs}
            Begin
                (write "s30(")
                (write (Z.show (LIST.length exprs)))
                (write ",(X[]){")
                Match exprs
                | `nil
                    (die "Record specified without any fields.")
                | `cons.{expr exprs}
                    Begin
                        (emit expr)
                        (LIST.for_each exprs
                            Func expr. Begin (write ",") (emit expr) End)
                        End
                ;
                (write "},")
                (write (Z.show layout))
                (write ")")
                End
        | `tuple_fetch.{code i}
            Begin
                (write "s68(")
                (emit code)
                (write ",")
                (write (Z.show i))
                (write ")")
                End
        | `record_fetch.{code i}
            Begin
                (write "s31(")
                (emit code)
                (write ",")
                (write (Z.show i))
                (write ")")
                End
        | `stmt_expr.{stmts expr}
            Begin
                (write "({")
                (LIST.for_each stmts
                    Func stmt.
                        Match stmt
                        | `expr.expr
                            Begin
                                (emit expr)
                                (write ";")
                                End
                        | `assign.{var expr}
                            Begin
                                (emit var)
                                (write "=")
                                (emit expr)
                                (write ";")
                                End
                        | `env_access.{closure_var pairs}
                            Begin
                                (write "const X*env=s62(")
                                (emit closure_var)
                                (write "),")
                                Match pairs
                                | `nil (die "Malformed environment access.")
                                | `cons.{pair pairs}
                                    Let (write_pair {xm j})
                                        Begin
                                            (emit xm)
                                            (write "=env[")
                                            (write (Z.show j))
                                            (write "]")
                                            End
                                    In
                                    Begin
                                        (write_pair pair)
                                        (LIST.for_each pairs
                                            Func pair.
                                                Begin
                                                    (write ",")
                                                    (write_pair pair)
                                                    End)
                                        End
                                ;
                                (write ";")
                                End
                        | `decls.pairs
                            Begin
                                (write "X ")
                                Match pairs
                                | `nil (die "Declaration list is empty.")
                                | `cons.{pair pairs}
                                    Begin
                                        (emit_decl_pair pair)
                                        (LIST.for_each pairs
                                            Func pair.
                                                Begin
                                                    (write ",")
                                                    (emit_decl_pair pair)
                                                    End)
                                        End
                                ;
                                (write ";")
                                End
                        | `goto.label
                            Begin
                                (write "goto ")
                                (emit label)
                                (write ";")
                                End
                        ;)
                (emit expr)
                (write ";})")
                End
        | `func.{i args stmts expr}
            Begin
                (write "static X f")
                (write (Z.show i))
                (write "(")
                (LIST.reduce args ""
                    Func prefix arg.
                        Do Begin
                            (write prefix)
                            (write "X ")
                            (emit arg)
                            End
                        In
                        ",")
                (write "){return ")
                (emit
                    Match stmts
                    | `nil expr
                    | `cons._ `stmt_expr.{stmts expr}
                    ;)
                (write ";}\n")
                End
        | `prim_app.{name args}
            Begin
                (write (RUNTIME.prim_short_name name))
                (write "(")
                (emit_list args)
                (write ")")
                End
        | `closure_app_known.{i func args}
            Begin
                (write "f")
                (write (Z.show i))
                (write "(")
                (emit func)
                (write ",")
                (emit_list args)
                (write ")")
                End
        | `closure_app.{func args}
            Let n (LIST.length args)
            In
            Begin
                (write "({X c=")
                (emit func)
                (write ";((X(*)(X")
                (LIST.for_each args
                    Func _. (write ",X"))
                (write "))s35(c,")
                (write (Z.show n))
                (write "))(c,")
                (emit_list args)
                (write ");})")
                End
        | `alloc_closure.{i free num_params}
            Begin
                (write "s75(f")
                (write (Z.show i))
                (write ",")
                (write (Z.show num_params))
                (write ",")
                (write (Z.show (LIST.length free)))
                Match free
                | `nil (write ",0")
                | `cons._
                    Begin (write ",(X[]){") (emit_list free) (write "}") End
                ;
                (write ")")
                End
        | `labeled.{label expr}
            Begin
                (write "({__label__ ")
                (emit label)
                (write ";")
                (emit label)
                (write ":")
                (emit expr)
                (write ";})")
                End
        | `stuck_cond
            (write "s89()")
        | `halt
            (write "s87()")
        | `switch.{xm expr clauses}
            Begin
                (write "({X r,")
                (emit xm)
                (write "=")
                (emit expr)
                (write ";switch(")
                (emit xm)
                (write "){")
                (LIST.for_each clauses
                    Func clause.
                        Match clause
                        | `default.body
                            Begin
                                (write "default:")
                                Match body
                                | `expr.expr
                                    Begin
                                        (write "r=")
                                        (emit expr)
                                        (write ";break;")
                                        End
                                | `stuck (write "s88();")
                                ;
                                End
                        | `case.{n body}
                            Begin
                                (write "case ")
                                (write (Z.show (RUNTIME.encode_small_integer n)))
                                (write ":r=")
                                (emit body)
                                (write ";break;")
                                End
                        ;)
                (write "}r;})")
                End
        | `match.{expr_var pat_var expr clauses}
            Begin
                (write "({X r,")
                (emit expr_var)
                (write "=")
                (emit expr)
                (write ",")
                (emit pat_var)
                (write "=")
                (emit `remove_label.expr_var)
                (write ";switch(s09(")
                (emit expr_var)
                (write ")){")
                (LIST.for_each clauses
                    Func clause.
                        Match clause
                        | `default.body
                            Begin
                                (write "default:")
                                Match body
                                | `expr.expr
                                    Begin
                                        (write "r=")
                                        (emit expr)
                                        (write ";break;")
                                        End
                                | `stuck (write "s53();")
                                ;
                                End
                        | `labeled.{label expr}
                            Begin
                                (write "case ")
                                (write (Z.show label))
                                (write ":r=")
                                (emit expr)
                                (write ";break;")
                                End
                        ;)
                (write "}r;})")
                End
        | `if.{test then else}
            Begin
                (write "(")
                (emit test)
                (write "==15?")
                (emit then)
                (write ":")
                (emit else)
                (write ")")
                End
        | `x.i
            Begin (write "x") (write (Z.show i)) End
        | `c.i
            Begin (write "c") (write (Z.show i)) End
        | `p.i
            Begin (write "p") (write (Z.show i)) End
        | `int.i
            (write (Z.show i))
        ;
    In
    emit

Define (elaborate m env loop expr)
    Match expr
    | `true `true
    | `false `false
    | `num.n `int.(RUNTIME.encode_small_integer n)
    | `const.i `c.i
    | `package.i `p.i
    | `var.name
        Match (VAR_MAP.search env name)
        | `nothing (die "Unexpected scope error.")
        | `just.{_ xm} xm
        ;
    | `chain.{expr chain}
        (LIST.reduce chain (elaborate m env `nothing expr)
            Func code access.
                Match access
                | `tuple_fetch.i `tuple_fetch.{code i}
                | `record_fetch.i `record_fetch.{code i}
                ;)
    | `tuple.exprs
        Match exprs
        | `nil `empty_tuple
        | `cons._
            `alloc_tuple.(LIST.map exprs (Func expr. (elaborate m env `nothing expr)))
        ;
    | `record.{layout inits}
        For `alloc_record.{layout inits}
            Let inits
                (LIST.map inits
                    Func init. (elaborate m env `nothing init))
    | `block.{binders expr}
        Let m0 m
        Let {m env stmts}
            (LIST.fold binders {m env QUEUE.empty}
                Func binder {m env' stmts}.
                    Match binder
                    | `do.expr
                        {m env'
                            (QUEUE.push stmts
                                `expr.(elaborate m env `nothing expr))}
                    | `let.{pat expr}
                        Match pat
                        | `var.name
                            Cond
                            | (STRING.equal name "_")
                                {m env'
                                    (QUEUE.push stmts
                                        `expr.(elaborate m env `nothing expr))}
                            | True
                                Let {m xm} (fresh_var m)
                                In
                                {m (VAR_MAP.insert env' {name xm})
                                    (QUEUE.push stmts
                                        `assign.{xm
                                            (elaborate m env `nothing expr)})}
                            ;
                        | `tuple.names
                            Let {m tuple_var} (fresh_var m)
                            In
                            Let stmts
                                (QUEUE.push stmts
                                    `assign.{tuple_var
                                        (elaborate m env `nothing expr)})
                            In
                            Let {_ m env' stmts}
                                (LIST.reduce names {0 m env' stmts}
                                    Func {i m env' stmts} name.
                                        Cond
                                        | (STRING.equal name "_")
                                            {(i + 1) m env' stmts}
                                        | True
                                            Let {m xm} (fresh_var m)
                                            In
                                            Let env'
                                                (VAR_MAP.insert env' {name xm})
                                            Let stmts
                                                (QUEUE.push stmts
                                                    `assign.{xm
                                                        `tuple_fetch.{tuple_var i}})
                                            In
                                            {(i + 1) m env' stmts}
                                        ;)
                            In
                            {m env' stmts}
                        ;
                    ;)
        In
        Cond
        | (QUEUE.is_empty stmts)
            (elaborate m env loop expr)
        | True
            Let stmts (QUEUE.pop_all stmts)
            In
            Let stmts
                Cond
                | (m = m0) stmts
                | True
                    Let decls
                        (LIST.map (LIST.iota (m - m0))
                            Func i. {`x.(m0 + i) `nothing})
                    In
                    (`decls.decls :: stmts)
                ;
            In
            `stmt_expr.{stmts (elaborate m env loop expr)}
        ;
    | `func.{i self free param_pats expr}
        Let {m args inits env}
            {0 QUEUE.empty QUEUE.empty VAR_MAP.empty}
        In
        Let {m args env}
            Let {m xm} (fresh_var m)
            In
            Let args (QUEUE.push args xm)
            In
            Match self
            | `nothing
                {m args env}
            | `just.name
                {m args (VAR_MAP.insert env {name xm})}
            ;
        In
        Let {m args inits env}
            (LIST.reduce param_pats {m args inits env}
                Func {m args inits env} pat.
                    Let {m arg} (fresh_var m)
                    In
                    Let args (QUEUE.push args arg)
                    In
                    Match pat
                    | `ignore
                        {m args inits env}
                    | `var.name
                        {m args inits
                            (VAR_MAP.insert env {name arg})}
                    | `tuple.names
                        Let {_ m inits env}
                            (LIST.reduce names {0 m inits env}
                                Func {j m inits env} name.
                                    \ TODO Handle name="_" case better.
                                    Let {m xm} (fresh_var m)
                                    In
                                    Let env
                                        (VAR_MAP.insert env {name xm})
                                    Let init
                                        {xm `just.`tuple_fetch.{arg j}}
                                    In
                                    {(j + 1) m
                                        (QUEUE.push inits init)
                                        env})
                        In
                        {m args inits env}
                    ;)
        In
        Let {m maybe_env_access env}
            Match free
            | `nil {m `nothing env}
            | _
                Let {_ m pairs env}
                    (LIST.reduce free {0 m QUEUE.empty env}
                        Func {j m pairs env} name.
                            Let {m xm} (fresh_var m)
                            In
                            {(j + 1) m
                                (QUEUE.push pairs {xm j})
                                (VAR_MAP.insert env {name xm})})
                In
                {m `just.`env_access.{`x.0 (QUEUE.pop_all pairs)} env}
            ;
        In
        Let expr (elaborate m env `nothing expr)
        Let stmts
            Let stmts
                Match maybe_env_access
                | `nothing []
                | `just.stmt [stmt]
                ;
            In
            If (QUEUE.is_empty inits)
                stmts
                (`decls.(QUEUE.pop_all inits) :: stmts)
        In
        `func.{i (QUEUE.pop_all args) stmts expr}
    | `prim_app.{name args}
        For `prim_app.{name (LIST.map args transform)}
            Let (transform arg)
                (elaborate m env `nothing arg)
    | `closure_app_known.{i func args}
        For `closure_app_known.{i (transform func) (LIST.map args transform)}
            Let (transform expr)
                (elaborate m env `nothing expr)
    | `closure_app.{func args}
        For `closure_app.{(transform func) (LIST.map args transform)}
            Let (transform expr)
                (elaborate m env `nothing expr)
    | `closure.{i free num_params}
        For `alloc_closure.{i free num_params}
            Let free
                (LIST.map free
                    Func name.
                        Match (VAR_MAP.search env name)
                        | `nothing (die "Unexpected scope error.")
                        | `just.{_ xm} xm
                        ;)
    | `iterate.{vars inits expr}
        Let {m label} (fresh_var m)
        In
        Let {m' vars env'}
            (LIST.fold vars {m [] env}
                Func name {m' vars env'}.
                    Let {m' var} (fresh_var m')
                    In
                    Let env' (VAR_MAP.insert env' {name var})
                    In
                    {m' (var :: vars) env'})
        In
        Let inits
            (LIST.zip vars
                (LIST.map inits
                    Func init. `just.(elaborate m env `nothing init)))
        Let expr `labeled.{label (elaborate m' env' `just.{label vars} expr)}
        In
        Match inits
        | `nil expr
        | `cons._ `stmt_expr.{[`decls.inits] expr}
        ;
    | `continue.exprs
        Match loop
        | `nothing (die "Unexpected loop scoping error.")
        | `just.{label params}
            Let args exprs
            Let m0 m
            In
            Let {_ evals}
                (LIST.reduce args {m QUEUE.empty}
                    Func {m evals} arg.
                        Let {m xm} (fresh_var m)
                        Let arg_code (elaborate m0 env `nothing arg)
                        In
                        {m (QUEUE.push evals {xm `just.arg_code})})
            In
            Let stmts
                If (QUEUE.is_empty evals)
                    QUEUE.empty
                    (QUEUE.new [`decls.(QUEUE.pop_all evals)])
            In
            Let {_ stmts}
                (LIST.reduce params {m0 stmts}
                    Func {m stmts} param.
                        Let {m xm} (fresh_var m)
                        In
                        {m (QUEUE.push stmts `assign.{param xm})})
            In
            Let stmts (QUEUE.push stmts `goto.label)
            In
            `stmt_expr.{(QUEUE.pop_all stmts) `empty_tuple}
        ;
    | `switch.{expr clauses}
        Let {m xm} (fresh_var m)
        In
        Let default_clause
            (LIST.reduce clauses `default.`stuck
                Func clause {pat body}.
                    Match pat
                    | `default.maybe_var
                        Match maybe_var
                        | `nothing
                            `default.`expr.(elaborate m env loop body)
                        | `just.name
                            Let env (VAR_MAP.insert env {name xm})
                            In
                            `default.`expr.(elaborate m env loop body)
                        ;
                    | _ clause
                    ;)
        In
        Let clauses
            (LIST.reduce clauses [default_clause]
                Func clauses {pat body}.
                    Match pat
                    | `default._ clauses
                    | `value.n
                        (`case.{n (elaborate m env loop body)} :: clauses)
                    ;)
        In
        `switch.{xm (elaborate m env `nothing expr) clauses}
    | `cond.clauses
        (LIST.fold clauses `stuck_cond
            Func {test body} expr.
                Match test
                | `true (elaborate m env loop body)
                | `false expr
                | _
                    `if.{(elaborate m env `nothing test)
                        (elaborate m env loop body) expr}
                ;)
    | `if.{test_expr then_expr else_expr}
        `if.{(elaborate m env `nothing test_expr)
            (elaborate m env loop then_expr)
            (elaborate m env loop else_expr)}
    | `not.expr
        `if.{(elaborate m env `nothing expr) `false `true}
    | `and.{test_expr then_expr}
        `if.{(elaborate m env `nothing test_expr)
            (elaborate m env loop then_expr)
            `false}
    | `or.{test_expr else_expr}
        `if.{(elaborate m env `nothing test_expr)
            `true
            (elaborate m env loop else_expr)}
    | `labeled.{label expr}
        Let expr_is_empty_tuple
            Match expr
            | `tuple.exprs Match exprs | `nil True | _ False ;
            | _ False
            ;
        In
        If expr_is_empty_tuple
            `labeled_empty_tuple.label
            `alloc_labeled_value.{label (elaborate m env `nothing expr)}
    | `match.{expr clauses}
        Let {m expr_var} (fresh_var m)
        In
        Let {m pat_var} (fresh_var m)
        In
        Let default_clause
            (LIST.reduce clauses `default.`stuck
                Func clause {pat body}.
                    Match pat
                    | `default `default.`expr.(elaborate m env loop body)
                    | `labeled._ clause
                    ;)
        Let (labeled_clause label vars body)
            Match vars
            | `ignore
                `labeled.{label (elaborate m env loop body)}
            | `var.name
                Let env (VAR_MAP.insert env {name pat_var})
                In
                `labeled.{label (elaborate m env loop body)}
            | `tuple.names
                Let n (LIST.length names)
                In
                Cond
                | (n = 0)
                    `labeled.{label (elaborate m env loop body)}
                | True
                    Let {_ m env inits}
                        (LIST.fold names {(n - 1) m env []}
                            Func name {i m env inits}.
                                Cond
                                | (STRING.equal name "_")
                                    {(i - 1) m env inits}
                                | True
                                    Let {m xm} (fresh_var m)
                                    In
                                    Let env (VAR_MAP.insert env {name xm})
                                    Let init {xm `just.`tuple_fetch.{pat_var i}}
                                    In
                                    {(i - 1) m env (init :: inits)}
                                ;)
                    In
                    Let expr (elaborate m env loop body)
                    In
                    Match inits
                    | `nil `labeled.{label expr}
                    | `cons._ `labeled.{label `stmt_expr.{[`decls.inits] expr}}
                    ;
                ;
            ;
        In 
        Let clauses
            (LIST.reduce clauses [default_clause]
                Func clauses {pat body}.
                    Match pat
                    | `default clauses
                    | `labeled.{label vars}
                        Let clause (labeled_clause label vars body)
                        In
                        (clause :: clauses)
                    ;)
        In
        `match.{expr_var pat_var (elaborate m env `nothing expr) clauses}
    | _ (die "Unexpected expression class.")
    ;

Where

Let (encode_empty_variant label)
    ((label * 256) + 47)

Let VAR_MAP (SEARCH.MAP STRING.compare (Func {key _}. key))

Let (fresh_var m)
    {(m + 1) `x.m}

Where

Let die OS.die

Where

Let LIST Package "list"
Let OS Package "os"
Let QUEUE Package "queue"
Let RUNTIME Package "runtime"
Let SEARCH Package "search"
Let STDIO Package "stdio"
Let STRING Package "string"
Let Z Package "z"