Language 84

File

language84-0.4/c.84

{
: elaborate
: emit
}

Where

Define (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
                {
                : functions
                : init
                })
    In
    {
    : packages
    : constants program.constants
    : label_names program.label_names
    : record_indexes program.record_indexes
    : nil_label program.nil_label
    : cons_label program.cons_label
    }

Define (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")
        Match program.constants
        | 'nil {}
        | 'cons._
            Begin
                (write "static X ")
                (LIST.reduce (LIST.iota (LIST.length program.constants)) ""
                    Func {prefix i}
                        Begin
                            (write prefix)
                            (write "c")
                            (write (Z.show i))
                            ","
                        End)
                (write ";\n")
            End
        ;
        (write "static X ")
        (LIST.reduce (LIST.iota (LIST.length program.packages)) ""
            Func {prefix i}
                Begin
                    (write prefix)
                    (write "p")
                    (write (Z.show i))
                    ","
                End)
        (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[256*1024*1024];")
        (write "s36(sizeof(heap_bytes),heap_bytes,1024*1024,sizeof(record_layouts)/sizeof(record_layouts[0]),record_layouts,argc,argv);\n")
        (LIST.for_each_numbered program.constants
            Func {i s}
                Begin
                    (emit 'c.i)
                    (write "=({const char s[]=")
                    (write s)
                    (write ";s86(sizeof(s),s);});")
                End)
        (LIST.for_each_numbered program.packages
            Func {i package}
                Begin
                    (write "\n")
                    (emit 'p.i)
                    (write "=")
                    (emit package.init)
                    (write ";")
                End)
        (write "\nreturn 0;}\n")
    End

Where

Define (make_emit write)
    Func {tree}
        Define (emit rec tree)
            (rec rec tree)
        In
        Define (emit_list rec exprs)
            Match exprs
            | 'nil {}
            | 'cons.{expr exprs}
                Begin
                    (emit rec expr)
                    (LIST.for_each exprs
                        Func {expr} Begin (write ",") (emit rec expr) End)
                End
            ;
        Define (emit_stmt rec stmt)
            Match stmt
            | 'expr.expr
                Begin
                    (write "({X t=s52(),x=")
                    (emit rec expr)
                    (write ";s15(t);x;});")
                End
            | 'assign.{var expr}
                Begin
                    (emit rec var)
                    (write "=")
                    (emit rec expr)
                    (write ";")
                End
            | 'env_access.{closure_var pairs}
                Begin
                    (write "const X*env=s62(")
                    (emit rec closure_var)
                    (write "),")
                    Match pairs
                    | 'nil (die "Malformed environment access.")
                    | 'cons.{pair pairs}
                        Define (write_pair {xm j})
                            Begin
                                (emit rec 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
                    (LIST.reduce pairs "X "
                        Func {intro {var maybe_init}}
                            Begin
                                (write intro)
                                (emit rec var)
                                Match maybe_init
                                | 'nothing {}
                                | 'just.expr
                                    Begin
                                        (write "=")
                                        (emit rec expr)
                                    End
                                ;
                                ","
                            End)
                    (write ";")
                End
            ;
        In
        Define (emit rec tree)
            Match tree
            | 'true (write "15")
            | 'false (write "271")
            | 'num.i (write (Z.show i))
            | '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 rec expr)
                    (write ")")
                End
            | 'remove_label.expr
                Begin
                    (write "s06(")
                    (emit rec expr)
                    (write ")")
                End
            | 'alloc_tuple.exprs
                Let n (LIST.length exprs)
                In
                Match exprs
                | 'nil (emit rec 'empty_tuple)
                | 'cons.{expr exprs}
                    Begin
                        (write "s78(")
                        (write (Z.show n))
                        (write ",(X[]){")
                        (emit rec expr)
                        (LIST.for_each exprs
                            Func {expr} Begin (write ",") (emit rec 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 rec expr)
                            (LIST.for_each exprs
                                Func {expr} Begin (write ",") (emit rec expr) End)
                        End
                    ;
                    (write "},")
                    (write (Z.show layout))
                    (write ")")
                End
            | 'tuple_fetch.{code i}
                Begin
                    (write "s68(")
                    (emit rec code)
                    (write ",")
                    (write (Z.show i))
                    (write ")")
                End
            | 'record_fetch.{code i}
                Begin
                    (write "s31(")
                    (emit rec code)
                    (write ",")
                    (write (Z.show i))
                    (write ")")
                End
            | 'iterate.{inits expr}
                Begin
                    (write "({__label__ l;")
                    Match inits
                    | 'nil (write "U4 t=s52();")
                    | 'cons._ (emit_stmt rec 'decls.inits)
                    ;
                    (write "l:")
                    (emit rec expr)
                    (write ";})")
                End
            | 'continue.stmts
                Begin
                    (write "({")
                    Match stmts
                    | 'nil (write "s15(t);")
                    | 'cons._
                        (LIST.for_each stmts
                            Func {stmt} (emit_stmt rec stmt))
                    ;
                    (write "goto l;31;})")
                End
            | 'stmt_expr.{stmts expr}
                Begin
                    (write "({")
                    (LIST.for_each stmts
                        Func {stmt} (emit_stmt rec stmt))
                    (emit rec expr)
                    (write ";})")
                End
            | 'func.{i args stmts expr}
                Begin
                    (write "static X f")
                    (write (Z.show i))
                    (write "(")
                    (LIST.reduce args ""
                        Func {prefix arg}
                            Begin
                                (write prefix)
                                (write "X ")
                                (emit rec arg)
                                ","
                            End)
                    (write "){return ")
                    (emit rec
                        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 rec args)
                    (write ")")
                End
            | 'closure_app_known.{i func args}
                Begin
                    (write "f")
                    (write (Z.show i))
                    (write "(")
                    (emit_list rec [func & args])
                    (write ")")
                End
            | 'closure_app.{func args}
                Let n (LIST.length args)
                In
                Begin
                    (write "({X c=")
                    (emit rec func)
                    (write ";((X(*)(X")
                    (LIST.for_each args
                        Func {_} (write ",X"))
                    (write "))s35(c,")
                    (write (Z.show n))
                    (write "))(c")
                    (LIST.for_each args
                        Func {arg} Begin (write ",") (emit rec arg) End)
                    (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 rec free) (write "}") End
                    ;
                    (write ")")
                End
            | 'labeled.{label expr}
                Begin
                    (write "({__label__ ")
                    (emit rec label)
                    (write ";")
                    (emit rec label)
                    (write ":")
                    (emit rec expr)
                    (write ";})")
                End
            | 'stuck_cond
                (write "s89()")
            | 'halt
                (write "s87()")
            | 'match.{expr_var pat_var expr clauses}
                Begin
                    (write "({X r,")
                    (emit rec expr_var)
                    (write "=")
                    (emit rec expr)
                    (write ",")
                    (emit rec pat_var)
                    (write "=")
                    (emit rec 'remove_label.expr_var)
                    (write ";switch(s09(")
                    (emit rec expr_var)
                    (write ")){")
                    (LIST.for_each clauses
                        Func {clause}
                            Match clause
                            | 'default.body
                                Begin
                                    (write "default:")
                                    Match body
                                    | 'expr.expr
                                        Begin
                                            (write "r=")
                                            (emit rec expr)
                                            (write ";break;")
                                        End
                                    | 'stuck (write "s53();")
                                    ;
                                End
                            | 'labeled.{label expr}
                                Begin
                                    (write "case ")
                                    (write (Z.show label))
                                    (write ":r=")
                                    (emit rec expr)
                                    (write ";break;")
                                End
                            ;)
                    (write "}r;})")
                End
            | 'if.{test then else}
                Begin
                    (write "(")
                    (emit rec test)
                    (write "==15?")
                    (emit rec then)
                    (write ":")
                    (emit rec 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
            ;
        In
        (emit emit tree)

Define (elaborate m env loop expr)
    Define (rec rec m env loop expr)
        Match expr
        | 'true 'true
        | 'false 'false
        | 'num.n 'num.(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 (rec rec 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} (rec rec m env 'nothing expr)])
            ;
        | 'record.{layout inits}
            For 'alloc_record.{layout inits}
                Let inits
                    (LIST.map inits
                        Func {init} (rec rec m env 'nothing init))
        | 'block.{binders expr}
            Let m0 m
            Let {m env stmts}
                Let env_outer env
                In
                (LIST.fold binders {m env_outer QUEUE.empty}
                    Func {binder {m env_inner stmts}}
                        Match binder
                        | 'do.expr
                            {m env_inner
                                (QUEUE.push stmts
                                    'expr.(rec rec m env_outer 'nothing expr))}
                        | 'let.{pat expr}
                            Match pat
                            | 'var.name
                                Cond
                                | (STRING.equal name "_")
                                    {m env_inner
                                        (QUEUE.push stmts
                                            'expr.(rec rec m env_outer 'nothing expr))}
                                | True
                                    Let {m xm} (fresh_var m)
                                    In
                                    {m (VAR_MAP.insert env_inner {name xm})
                                        (QUEUE.push stmts
                                            'assign.{xm
                                                (rec rec m env_outer 'nothing expr)})}
                                ;
                            | 'tuple.names
                                Let {m tuple_var} (fresh_var m)
                                In
                                Let stmts
                                    (QUEUE.push stmts
                                        'assign.{tuple_var
                                            (rec rec m env_outer 'nothing expr)})
                                In
                                Let {_ m env_inner stmts}
                                    (LIST.reduce names {0 m env_inner stmts}
                                        Func {{i m env_inner stmts} name}
                                            Cond
                                            | (STRING.equal name "_")
                                                {[i + 1] m env_inner stmts}
                                            | True
                                                Let {m xm} (fresh_var m)
                                                In
                                                Let env_inner
                                                    (VAR_MAP.insert env_inner {name xm})
                                                Let stmts
                                                    (QUEUE.push stmts
                                                        'assign.{xm
                                                            'tuple_fetch.{tuple_var i}})
                                                In
                                                {[i + 1] m env_inner stmts}
                                            ;)
                                In
                                {m env_inner stmts}
                            ;
                        ;)
            In
            Cond
            | (QUEUE.is_empty stmts)
                (rec rec 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 (rec rec m env loop expr)}
            ;
        | 'func.{i 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
                {m (QUEUE.push args xm) env}
            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 (rec rec m env 'nothing expr)
            Let stmts
                Let stmts
                    Match maybe_env_access
                    | 'nothing 'nil
                    | 'just.stmt [stmt & 'nil]
                    ;
                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)}
                Define (transform arg)
                    (rec rec m env 'nothing arg)
        | 'closure_app_known.{i func args}
            For 'closure_app_known.{i (transform func) (LIST.map args transform)}
                Define (transform expr)
                    (rec rec m env 'nothing expr)
        | 'closure_app.{func args}
            For 'closure_app.{(transform func) (LIST.map args transform)}
                Define (transform expr)
                    (rec rec 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 inits
                (LIST.map inits
                    Func {init} 'just.(rec rec m env 'nothing init))
            Let {vars expr}
                Let {m vars env}
                    (LIST.fold vars {m 'nil 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
                {vars (rec rec m env 'just.vars expr)}
            In
            'iterate.{(LIST.zip vars inits) expr}
        | 'continue.exprs
            Match loop
            | 'nothing (die "Unexpected loop scoping error.")
            | 'just.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 (rec rec 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) & 'nil])
                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
                'continue.(QUEUE.pop_all stmts)
            ;
        | 'cond.clauses
            (LIST.fold clauses 'stuck_cond
                Func {{test body} expr}
                    Match test
                    | 'true (rec rec m env loop body)
                    | 'false expr
                    | _
                        'if.{(rec rec m env 'nothing test)
                            (rec rec m env loop body) expr}
                    ;)
        | 'if.{test_expr then_expr else_expr}
            'if.{(rec rec m env 'nothing test_expr)
                (rec rec m env loop then_expr)
                (rec rec m env loop else_expr)}
        | 'not.expr
            'if.{(rec rec m env 'nothing expr) 'false 'true}
        | 'and.{test_expr then_expr}
            'if.{(rec rec m env 'nothing test_expr)
                (rec rec m env loop then_expr)
                'false}
        | 'or.{test_expr else_expr}
            'if.{(rec rec m env 'nothing test_expr)
                'true
                (rec rec 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 (rec rec 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.(rec rec m env loop body)
                        | 'labeled._ clause
                        ;)
            Define (labeled_clause label vars body)
                Match vars
                | 'ignore
                    'labeled.{label (rec rec m env loop body)}
                | 'var.name
                    Let env (VAR_MAP.insert env {name pat_var})
                    In
                    'labeled.{label (rec rec m env loop body)}
                | 'tuple.names
                    Let n (LIST.length names)
                    In
                    Cond
                    | [n = 0]
                        'labeled.{label (rec rec m env loop body)}
                    | True
                        Let {_ m env inits}
                            (LIST.fold names {[n - 1] m env 'nil}
                                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 (rec rec m env loop body)
                        In
                        Match inits
                        | 'nil 'labeled.{label expr}
                        | 'cons._ 'labeled.{label 'stmt_expr.{['decls.inits & 'nil] expr}}
                        ;
                    ;
                ;
            In 
            Let clauses
                (LIST.reduce clauses [default_clause & 'nil]
                    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 (rec rec m env 'nothing expr) clauses}
        | _ (die "Unexpected expression class.")
        ;
    In
    (rec rec m env loop expr)

Where

Define (encode_empty_variant label)
    [[label * 256] + 47]

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

Define (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"