{
: 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 expr
Unfold input From 'expr.expr
Match input
| 'list.exprs
Match exprs
| 'nil {}
| 'cons.{expr exprs}
Begin
(Fold 'expr.expr)
(Fold 'list_tail.exprs)
End
;
| 'list_tail.exprs
Match exprs
| 'nil {}
| 'cons.{expr exprs}
Begin
(write ",")
(Fold 'expr.expr)
(Fold 'list_tail.exprs)
End
;
| 'stmt.stmt
Match stmt
| 'expr.expr
Begin
(write "({X t=s52(),x=")
(Fold 'expr.expr)
(write ";s15(t);x;});")
End
| 'assign.{var expr}
Begin
(Fold 'expr.var)
(write "=")
(Fold 'expr.expr)
(write ";")
End
| 'env_access.{closure_var pairs}
Begin
(write "const X*env=s62(")
(Fold 'expr.closure_var)
(write "),")
Match pairs
| 'nil (die "Malformed environment access.")
| 'cons.{pair pairs}
Define (write_pair {xm j})
Begin
(Fold 'expr.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)
(Fold 'expr.var)
Match maybe_init
| 'nothing {}
| 'just.expr
Begin
(write "=")
(Fold 'expr.expr)
End
;
","
End)
(write ";")
End
;
| 'expr.expr
Match expr
| '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 ",")
(Fold 'expr.expr)
(write ")")
End
| 'remove_label.expr
Begin
(write "s06(")
(Fold 'expr.expr)
(write ")")
End
| 'alloc_tuple.exprs
Let n (LIST.length exprs)
In
Match exprs
| 'nil (Fold 'expr.'empty_tuple)
| 'cons.{expr exprs}
Begin
(write "s78(")
(write (Z.show n))
(write ",(X[]){")
(Fold 'expr.expr)
(LIST.for_each exprs
Func expr Begin (write ",") (Fold 'expr.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
(Fold 'expr.expr)
(LIST.for_each exprs
Func expr Begin (write ",") (Fold 'expr.expr) End)
End
;
(write "},")
(write (Z.show layout))
(write ")")
End
| 'tuple_fetch.{code i}
Begin
(write "s68(")
(Fold 'expr.code)
(write ",")
(write (Z.show i))
(write ")")
End
| 'record_fetch.{code i}
Begin
(write "s31(")
(Fold 'expr.code)
(write ",")
(write (Z.show i))
(write ")")
End
| 'iterate.{inits expr}
Begin
(write "({__label__ l;")
Match inits
| 'nil (write "U4 t=s52();")
| 'cons._ (Fold 'stmt.'decls.inits)
;
(write "l:")
(Fold 'expr.expr)
(write ";})")
End
| 'continue.stmts
Begin
(write "({")
Match stmts
| 'nil (write "s15(t);")
| 'cons._
(LIST.for_each stmts
Func stmt (Fold 'stmt.stmt))
;
(write "goto l;31;})")
End
| 'stmt_expr.{stmts expr}
Begin
(write "({")
(LIST.for_each stmts
Func stmt (Fold 'stmt.stmt))
(Fold 'expr.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 ")
(Fold 'expr.arg)
","
End)
(write "){return ")
Block
Let expr
Match stmts
| 'nil expr
| 'cons._ 'stmt_expr.{stmts expr}
;
In
(Fold 'expr.expr)
(write ";}\n")
End
| 'prim_app.{name args}
Begin
(write (RUNTIME.prim_short_name name))
(write "(")
(Fold 'list.args)
(write ")")
End
| 'closure_app_known.{i func args}
Begin
(write "f")
(write (Z.show i))
(write "(")
(Fold 'list.[func & args])
(write ")")
End
| 'closure_app.{func args}
Let n (LIST.length args)
In
Begin
(write "({X c=")
(Fold 'expr.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 ",") (Fold 'expr.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[]){") (Fold 'list.free) (write "}") End
;
(write ")")
End
| 'labeled.{label expr}
Begin
(write "({__label__ ")
(Fold 'expr.label)
(write ";")
(Fold 'expr.label)
(write ":")
(Fold 'expr.expr)
(write ";})")
End
| 'stuck_cond
(write "s89()")
| 'halt
(write "s87()")
| 'match.{expr_var pat_var expr clauses}
Begin
(write "({X r,")
(Fold 'expr.expr_var)
(write "=")
(Fold 'expr.expr)
(write ",")
(Fold 'expr.pat_var)
(write "=")
(Fold 'expr.'remove_label.expr_var)
(write ";switch(s09(")
(Fold 'expr.expr_var)
(write ")){")
(LIST.for_each clauses
Func clause
Match clause
| 'default.body
Begin
(write "default:")
Match body
| 'expr.expr
Begin
(write "r=")
(Fold 'expr.expr)
(write ";break;")
End
| 'stuck (write "s53();")
;
End
| 'labeled.{label expr}
Begin
(write "case ")
(write (Z.show label))
(write ":r=")
(Fold 'expr.expr)
(write ";break;")
End
;)
(write "}r;})")
End
| 'if.{test then else}
Begin
(write "(")
(Fold 'expr.test)
(write "==15?")
(Fold 'expr.then)
(write ":")
(Fold 'expr.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
;
;
Define (elaborate m env loop expr)
Unfold {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 (Fold 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 (Fold m env 'nothing expr)])
;
| 'record.{layout inits}
For 'alloc_record.{layout inits}
Let inits
(LIST.map inits
Func init (Fold 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.(Fold m env_outer 'nothing expr))}
| 'let.{pat expr}
Match pat
| 'var.name
Cond
| (STRING.equal name "_")
{m env_inner
(QUEUE.push stmts
'expr.(Fold 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
(Fold m env_outer 'nothing expr)})}
;
| 'tuple.names
Let {m tuple_var} (fresh_var m)
In
Let stmts
(QUEUE.push stmts
'assign.{tuple_var
(Fold 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)
(Fold 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 (Fold 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 (Fold 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)
(Fold m env 'nothing arg)
| 'closure_app_known.{i func args}
For 'closure_app_known.{i (transform func) (LIST.map args transform)}
Define (transform expr)
(Fold m env 'nothing expr)
| 'closure_app.{func args}
For 'closure_app.{(transform func) (LIST.map args transform)}
Define (transform expr)
(Fold 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.(Fold 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 (Fold 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 (Fold 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 (Fold m env loop body)
| 'false expr
| _
'if.{(Fold m env 'nothing test)
(Fold m env loop body) expr}
;)
| 'if.{test_expr then_expr else_expr}
'if.{(Fold m env 'nothing test_expr)
(Fold m env loop then_expr)
(Fold m env loop else_expr)}
| 'not.expr
'if.{(Fold m env 'nothing expr) 'false 'true}
| 'and.{test_expr then_expr}
'if.{(Fold m env 'nothing test_expr)
(Fold m env loop then_expr)
'false}
| 'or.{test_expr else_expr}
'if.{(Fold m env 'nothing test_expr)
'true
(Fold 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 (Fold 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.(Fold m env loop body)
| 'labeled._ clause
;)
Define (labeled_clause label vars body)
Match vars
| 'ignore
'labeled.{label (Fold m env loop body)}
| 'var.name
Let env (VAR_MAP.insert env {name pat_var})
In
'labeled.{label (Fold m env loop body)}
| 'tuple.names
Let n (LIST.length names)
In
Cond
| [n = 0]
'labeled.{label (Fold 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 (Fold 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 (Fold m env 'nothing expr) clauses}
| _ (die "Unexpected expression class.")
;
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"