{ : collect_free_variables : lift_functions : collect_constants } Where Define (collect_free_variables expr) Let SET (SEARCH.SET STRING.compare) Let MAP (SEARCH.MAP STRING.compare Func {var} var.name) In Define (insert_each env depth vars) (LIST.reduce vars env Func {env var} (MAP.insert env {: name var : depth})) Define (maybe_insert env depth free name) Match (MAP.search env name) | 'just.var If [var.depth < depth] (SET.insert free name) free | 'nothing (die (STRING.concat [Right "Variable \"" & name & "\" is not bound." & 'nil])) ; In Define (pure x) Func {_ _ free rec} {x free} Define (lift1 m1 f) Func {env depth free rec} Let {x1 free} (m1 env depth free rec) In {(f x1) free} Define (lift2 m1 m2 f) Func {env depth free rec} Let {x1 free} (m1 env depth free rec) In Let {x2 free} (m2 env depth free rec) In {(f x1 x2) free} Define (lift3 m1 m2 m3 f) Func {env depth free rec} Let {x1 free} (m1 env depth free rec) In Let {x2 free} (m2 env depth free rec) In Let {x3 free} (m3 env depth free rec) In {(f x1 x2 x3) free} Define (in_context vars m) Func {env depth free rec} Let env (insert_each env depth vars) In (m env depth free rec) Define (map list f) Func {env depth free rec} ((rec.map list f) env depth free rec) Define (collect expr) Func {env depth free rec} ((rec.collect expr) env depth free rec) In Define (map list f) Match list | 'nil (pure 'nil) | 'cons.{item list} (lift2 (f item) (map list f) LIST.cons) ; Define (collect expr) Match expr | 'true (pure expr) | 'false (pure expr) | 'num._ (pure expr) | 'str._ (pure expr) | 'package._ (pure expr) | 'prim._ (pure expr) | 'var.name Func {env depth free _} {expr (maybe_insert env depth free name)} | 'chain.{expr chain} (lift1 (collect expr) Func {expr} 'chain.{expr chain}) | 'tuple.exprs (lift1 (map exprs collect) Func {exprs} 'tuple.exprs) | 'record.{labels inits} (lift1 (map inits collect) Func {inits} 'record.{labels inits}) | 'block.{binders expr} Let vars (LIST.concat_map binders binder_variables) Let binder_exprs (LIST.map binders binder_expr) In (lift2 (map binder_exprs collect) (in_context vars (collect expr)) Func {binder_exprs expr} Let binders (LIST.map (LIST.zip binders binder_exprs) Func {{binder expr}} Match binder | 'do._ 'do.expr | 'let.{pat _} 'let.{pat expr} ;) In 'block.{binders expr}) | 'app.{func args} (lift2 (collect func) (map args collect) Func {func args} 'app.{func args}) | 'func.{param_pats expr} Let vars (LIST.concat_map param_pats pattern_variables) In Func {env depth free rec} Let {expr func_free} Let depth [depth + 1] In Let env (insert_each env depth vars) Let m (collect expr) In (m env depth SET.empty rec) In Let func_free_list (SET.list func_free) In Let free (LIST.reduce func_free_list free Func {free name} (maybe_insert env depth free name)) In {'func.{func_free_list param_pats expr} free} | 'iterate.{vars inits expr} (lift2 (map inits collect) (in_context vars (collect expr)) Func {inits expr} 'iterate.{vars inits expr}) | 'continue.exprs (lift1 (map exprs collect) Func {exprs} 'continue.exprs) | 'cond.clauses Define (collect_in_clause {test body}) (lift2 (collect test) (collect body) Func {test body} {test body}) In (lift1 (map clauses collect_in_clause) Func {clauses} 'cond.clauses) | 'if.{test then else} (lift3 (collect test) (collect then) (collect else) Func {test then else} 'if.{test then else}) | 'not.expr (lift1 (collect expr) Func {expr} 'not.expr) | 'and.{test then} (lift2 (collect test) (collect then) Func {test then} 'and.{test then}) | 'or.{test else} (lift2 (collect test) (collect else) Func {test else} 'or.{test else}) | 'list.exprs (lift1 (map exprs collect) Func {exprs} 'list.exprs) | 'labeled.{label expr} (lift1 (collect expr) Func {expr} 'labeled.{label expr}) | 'match.{expr clauses} Define (collect_in_clause {pat body}) Let vars Match pat | 'default 'nil | 'labeled.{_ pat} (pattern_variables pat) ; In (lift1 (in_context vars (collect body)) Func {body} {pat body}) In (lift2 (collect expr) (map clauses collect_in_clause) Func {expr clauses} 'match.{expr clauses}) ; In For expr Let {expr _} ((collect expr) MAP.empty 0 SET.empty {: map : collect}) Define (lift_functions i expr) Let MAP (SEARCH.MAP STRING.compare Func {{key _}} key) In Define (pure x) Func {_ i funcs rec} {x i funcs} Define (lift1 m1 f) Func {env i funcs rec} Let {x1 i funcs} (m1 env i funcs rec) In {(f x1) i funcs} Define (lift2 m1 m2 f) Func {env i funcs rec} Let {x1 i funcs} (m1 env i funcs rec) In Let {x2 i funcs} (m2 env i funcs rec) In {(f x1 x2) i funcs} Define (lift3 m1 m2 m3 f) Func {env i funcs rec} Let {x1 i funcs} (m1 env i funcs rec) In Let {x2 i funcs} (m2 env i funcs rec) In Let {x3 i funcs} (m3 env i funcs rec) In {(f x1 x2 x3) i funcs} Define (bind m1 f) Func {env i funcs rec} Let {x1 i funcs} (m1 env i funcs rec) In Let m2 (f x1) In (m2 env i funcs rec) Define (lookup var) Func {env i funcs _} Match (MAP.search env var) | 'just.{_ expr} {expr i funcs} | 'nothing (die "No var.") ; Define (in_context bindings m) Func {env i funcs rec} Let env (LIST.reduce bindings env MAP.insert) In (m env i funcs rec) Define (map list f) Func {env i funcs rec} ((rec.map list f) env i funcs rec) Define (rewrite expr) Func {env i funcs rec} ((rec.rewrite expr) env i funcs rec) In Define (map list f) Match list | 'nil (pure 'nil) | 'cons.{item items} (lift2 (f item) (map items f) LIST.cons) ; Define (rewrite expr) Match expr | 'true (pure expr) | 'false (pure expr) | 'num._ (pure expr) | 'str._ (pure expr) | 'package._ (pure expr) | 'prim._ (pure expr) | 'var._ (pure expr) | 'chain.{expr chain} (lift1 (rewrite expr) Func {expr} 'chain.{expr chain}) | 'tuple.exprs (lift1 (map exprs rewrite) Func {exprs} 'tuple.exprs) | 'record.{labels inits} (lift1 (map inits rewrite) Func {inits} 'record.{labels inits}) | 'block.{binders expr} Let binder_exprs (LIST.map binders binder_expr) In (bind (map binder_exprs rewrite) Func {binder_exprs} Let binders (LIST.map (LIST.zip binders binder_exprs) Func {{binder expr}} Match binder | 'do._ 'do.expr | 'let.{pat _} 'let.{pat expr} ;) In Let bindings (LIST.concat_map binders Func {binder} Match binder | 'do._ 'nil | 'let.{pat expr} Match pat | 'ignore 'nil | 'var.var Match expr | 'closure.{i _ num_params} [{var 'func.{i num_params}} & 'nil] | _ [{var 'expr} & 'nil] ; | 'tuple.vars (LIST.map vars Func {var} {var 'expr}) ; ;) In (lift1 (in_context bindings (rewrite expr)) Func {expr} 'block.{binders expr})) | 'app.{func args} Match func | 'var.var (bind (lookup var) Func {expr} Match expr | 'func.{i num_params} If [num_params != (LIST.length args)] (die "Protocol mismatch in function application.") (lift2 (rewrite func) (map args rewrite) Func {func args} 'app_known.{i func args}) | 'expr (lift2 (rewrite func) (map args rewrite) Func {func args} 'app.{func args}) ;) | _ (lift2 (rewrite func) (map args rewrite) Func {func args} 'app.{func args}) ; | 'func.{free param_pats expr} Func {env i funcs rec} Let rewriter Let bindings (LIST.map (LIST.concat_map param_pats pattern_variables) Func {var} {var 'expr}) In (in_context bindings (rewrite expr)) In Let {expr i funcs} (rewriter env i funcs rec) In Let closure 'closure.{i free (LIST.length param_pats)} Let func 'func.{i free param_pats expr} In {closure [i + 1] [func & funcs]} | 'iterate.{vars inits expr} Let bindings (LIST.map vars Func {var} {var 'expr}) In (lift2 (map inits rewrite) (in_context bindings (rewrite expr)) Func {inits expr} 'iterate.{vars inits expr}) | 'continue.exprs (lift1 (map exprs rewrite) Func {exprs} 'continue.exprs) | 'cond.clauses Define (rewrite_clause {test body}) (lift2 (rewrite test) (rewrite body) Func {test body} {test body}) In (lift1 (map clauses rewrite_clause) Func {clauses} 'cond.clauses) | 'if.{test then else} (lift3 (rewrite test) (rewrite then) (rewrite else) Func {test then else} 'if.{test then else}) | 'not.expr (lift1 (rewrite expr) Func {expr} 'not.expr) | 'and.{test then} (lift2 (rewrite test) (rewrite then) Func {test then} 'and.{test then}) | 'or.{test else} (lift2 (rewrite test) (rewrite else) Func {test else} 'or.{test else}) | 'list.exprs (lift1 (map exprs rewrite) Func {exprs} 'list.exprs) | 'labeled.{label expr} (lift1 (rewrite expr) Func {expr} 'labeled.{label expr}) | 'match.{expr clauses} Define (rewrite_clause {pat body}) Let bindings Match pat | 'default 'nil | 'labeled.{_ pat} (LIST.map (pattern_variables pat) Func {var} {var 'expr}) ; In (lift1 (in_context bindings (rewrite body)) Func {body} {pat body}) In (lift2 (rewrite expr) (map clauses rewrite_clause) Func {expr clauses} 'match.{expr clauses}) ; In ((rewrite expr) MAP.empty i 'nil {: map : rewrite}) Define (collect_constants program) Let package_table (package_table program) In Define (pure x) Func {state rec} {x state} Define (lift1 m1 f) Func {state rec} Let {x1 state} (m1 state rec) In {(f x1) state} Define (lift2 m1 m2 f) Func {state rec} Let {x1 state} (m1 state rec) In Let {x2 state} (m2 state rec) In {(f x1 x2) state} Define (lift3 m1 m2 m3 f) Func {state rec} Let {x1 state} (m1 state rec) In Let {x2 state} (m2 state rec) In Let {x3 state} (m3 state rec) In {(f x1 x2 x3) state} Define (bind1 m1 f) Func {state rec} Let {x1 state} (m1 state rec) In Let m2 (f x1) In (m2 state rec) Define (map items f) Func {state rec} ((rec.map items f) state rec) Define (rewrite expr) Func {state rec} ((rec.rewrite expr) state rec) In Define (map items f) Match items | 'nil (pure 'nil) | 'cons.{item items} (lift2 (f item) (map items f) LIST.cons) ; Define (rewrite expr) Match expr | 'true (pure expr) | 'false (pure expr) | 'num._ (pure expr) | 'str.s (intern_string s) | 'package.path (pure 'package.(package_table.lookup path)) | 'var._ (pure expr) | 'chain.{expr chain} Define (intern_access access) Match access | 'id.name (lift1 (intern_label name) Func {id} 'record_fetch.id) | 'num.i (pure 'tuple_fetch.i) ; In (lift2 (rewrite expr) (map chain intern_access) Func {expr chain} 'chain.{expr chain}) | 'tuple.exprs (lift1 (map exprs rewrite) Func {exprs} 'tuple.exprs) | 'record.{labels inits} (bind1 (map labels intern_label) Func {ids} Let {layout inits} For (LIST.unzip (sort (LIST.zip ids inits))) Define (sort pairs) (SORT.list_insertion Func {{i _} {j _}} (Z.compare i j) pairs) In (lift2 (intern_layout layout) (map inits rewrite) Func {layout_id inits} 'record.{layout_id inits})) | 'block.{binders expr} Let binder_exprs (LIST.map binders binder_expr) In (lift2 (map binder_exprs rewrite) (rewrite expr) Func {binder_exprs expr} Let binders (LIST.map (LIST.zip binders binder_exprs) Func {{binder expr}} Match binder | 'do._ 'do.expr | 'let.{pat _} 'let.{pat expr} ;) In 'block.{binders expr}) | 'app_known.{j func args} (lift2 (map args rewrite) (rewrite func) Func {args func} 'closure_app_known.{j func args}) | 'app.{func args} Match func | 'prim.name Cond | (STRING.equal name "cons") (rewrite 'labeled.{"cons" 'tuple.args}) | (STRING.equal name "not_equal") (rewrite 'if.{'app.{'prim."equal" args} 'false 'true}) | True (lift1 (map args rewrite) Func {args} 'prim_app.{name args}) ; | _ (lift2 (map args rewrite) (rewrite func) Func {args func} 'closure_app.{func args}) ; | 'closure._ (pure expr) | 'func.{j free param_pats expr} (lift1 (rewrite expr) Func {expr} 'func.{j free param_pats expr}) | 'iterate.{vars inits expr} (lift2 (map inits rewrite) (rewrite expr) Func {inits expr} 'iterate.{vars inits expr}) | 'continue.exprs (lift1 (map exprs rewrite) Func {exprs} 'continue.exprs) | 'cond.clauses Define (rewrite_clause {test body}) (lift2 (rewrite test) (rewrite body) Func {test body} {test body}) In (lift1 (map clauses rewrite_clause) Func {clauses} 'cond.clauses) | 'if.{test then else} (lift3 (rewrite test) (rewrite then) (rewrite else) Func {test then else} 'if.{test then else}) | 'not.expr (lift1 (rewrite expr) Func {expr} 'not.expr) | 'and.{test then} (lift2 (rewrite test) (rewrite then) Func {test then} 'and.{test then}) | 'or.{test else} (lift2 (rewrite test) (rewrite else) Func {test else} 'or.{test else}) | 'list.exprs Let expr (LIST.fold exprs 'labeled.{"nil" 'tuple.'nil} Func {expr rest} 'labeled.{"cons" 'tuple.[Right expr & rest & 'nil]}) In (rewrite expr) | 'labeled.{label expr} (bind1 (intern_label label) Func {id} (lift1 (rewrite expr) Func {expr} 'labeled.{id expr})) | 'match.{expr clauses} Define (rewrite_clause {pat body}) Match pat | 'default (lift1 (rewrite body) Func {body} {pat body}) | 'labeled.{label vars} (lift2 (intern_label label) (rewrite body) Func {id body} {'labeled.{id vars} body}) ; In (lift2 (rewrite expr) (map clauses rewrite_clause) Func {expr clauses} 'match.{expr clauses}) ; In Let {output state} Define (rewrite_package package) (lift2 (rewrite package.init) (map package.functions rewrite) Func {init functions} { : path package.path : imports package.imports : init : functions }) In Let rewriter (lift3 (intern_label "nil") (intern_label "cons") (map program rewrite_package) Func {nil_label cons_label packages} {nil_label cons_label packages}) In Let string_env {STRING_ID_MAP.empty 0} Let label_env { : name_of_id ID_LABEL_MAP.empty : id_of_name LABEL_ID_MAP.empty : i 0 } Let layout_env { : indexes 'nil : map LAYOUT_ID_MAP.empty : i 0 } In (rewriter {string_env label_env layout_env} {: map : rewrite}) In Let {nil_label cons_label packages} output Let {string_env label_env layout_env} state In Let constants Let {map _} string_env In (LIST.map (SORT.list_insertion Func {{_ i} {_ j}} (Z.compare i j) (STRING_ID_MAP.list map)) Func {{s _}} s) Let record_indexes (LIST.reverse layout_env.indexes) Let label_names (ID_LABEL_MAP.list label_env.name_of_id) In { : constants : label_names : record_indexes : packages : nil_label : cons_label } Where Define (package_table packages) Let MAP (SEARCH.MAP STRING.compare [Func {{key _}} key]) In Let {_ map} (LIST.reduce packages {0 MAP.empty} Func {{i map} package} {[i + 1] (MAP.insert map {package.path i})}) In Define (lookup path) Match (MAP.search map path) | 'just.{_ i} i ; In {: lookup} Define (intern_string s) Func {state _} Let {string_env label_env layout_env} state In Let {map i} string_env In Match (STRING_ID_MAP.search map s) | 'nothing Let map (STRING_ID_MAP.insert map {s i}) In {'const.i {{map [i + 1]} label_env layout_env}} | 'just.{_ j} {'const.j state} ; Define (intern_label name) Func {state _} Let {string_env label_env layout_env} state In Match (LABEL_ID_MAP.search label_env.id_of_name name) | 'just.{_ i} {i state} | 'nothing Let i label_env.i In Let label_env { : name_of_id (ID_LABEL_MAP.insert label_env.name_of_id {i name}) : id_of_name (LABEL_ID_MAP.insert label_env.id_of_name {name i}) : i [i + 1] } In {i {string_env label_env layout_env}} ; Define (intern_layout layout) Func {state _} Let {string_env label_env layout_env} state In Match (LAYOUT_ID_MAP.search layout_env.map layout) | 'just.{_ i} {i state} | 'nothing Let i layout_env.i In Let layout_env { : map (LAYOUT_ID_MAP.insert layout_env.map {layout i}) : indexes [layout & layout_env.indexes] : i [i + (LIST.length layout) + 1] } In {i {string_env label_env layout_env}} ; Where Let STRING_ID_MAP (SEARCH.MAP STRING.compare [Func {{key _}} key]) Let LABEL_ID_MAP (SEARCH.MAP STRING.compare [Func {{key _}} key]) Let ID_LABEL_MAP (SEARCH.MAP Z.compare [Func {{key _}} key]) Let LAYOUT_ID_MAP (SEARCH.MAP Func {a b} Let m (LIST.length a) Let n (LIST.length b) In Cond | [m < n] 'less | [m > n] 'greater | True (LIST.reduce (LIST.zip a b) 'equal Func {relation {ai bi}} Match relation | 'equal Cond | [ai < bi] 'less | [ai > bi] 'greater | True 'equal ; | _ relation ;) ; Func {{key _}} key) Where Define (pattern_variables pat) Match pat | 'tuple.vars vars | 'var.var [var & 'nil] | 'ignore 'nil ; Define (binder_variables binder) Match binder | 'let.{pat _} Match pat | 'tuple.vars vars | 'var.var [var & 'nil] ; | 'do._ 'nil ; Define (binder_expr binder) Match binder | 'do.expr expr | 'let.{_ expr} expr ; Where Let die OS.die Where Let LIST Package "list" Let OS Package "os" Let SEARCH Package "search" Let SORT Package "sort" Let STDIO Package "stdio" Let STRING Package "string" Let Z Package "z"