diff options
author | Eduardo Julian | 2017-06-09 20:53:26 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-06-09 20:53:26 -0400 |
commit | c50667a431a5ca67328a230f0c59956dc6ff43fa (patch) | |
tree | d07416c74b5e4a477038bcf3fcfbd79106cc3fb4 /new-luxc/source/luxc/synthesizer.lux | |
parent | 4480e41e949ba3ba0c9bceeed43e3f144f82103b (diff) |
- Added loop synthesis.
- Some refactoring.
Diffstat (limited to 'new-luxc/source/luxc/synthesizer.lux')
-rw-r--r-- | new-luxc/source/luxc/synthesizer.lux | 171 |
1 files changed, 47 insertions, 124 deletions
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 5dc4fa258..2f7344c6e 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -2,105 +2,30 @@ lux (lux (data text/format [number] - (coll [list "L/" Functor<List> Fold<List>] + (coll [list "L/" Functor<List> Fold<List> Monoid<List>] ["d" dict]))) (luxc ["&" base] (lang ["la" analysis] ["ls" synthesis]) (synthesizer ["&&;" structure] - ["&&;" function]) + ["&&;" function] + ["&&;" loop]) )) -## (def: (has-self-reference? exprS) -## (-> ls;Synthesis Bool) -## (case exprS -## (#ls;Tuple membersS) -## (list;any? has-self-reference? membersS) - -## (#ls;Procedure name argsS) -## (list;any? has-self-reference? argsS) - -## (#ls;Variant tag last? memberS) -## (has-self-reference? memberS) - -## (#ls;Variable idx) -## (i.= 0 idx) - -## (#ls;Recur offset argsS) -## (list;any? has-self-reference? argsS) - -## (#ls;Call funcS argsS) -## (or (has-self-reference? funcS) -## (list;any? has-self-reference? argsS)) - -## (#ls;Let register inputS bodyS) -## (or (has-self-reference? inputS) -## (has-self-reference? bodyS)) - -## (#ls;If inputS thenS elseS) -## (or (has-self-reference? inputS) -## (has-self-reference? thenS) -## (has-self-reference? elseS)) - -## (#ls;Function num-args scope bodyS) -## (not (list;any? (i.= 0) scope)) - -## (#ls;Loop offset argsS bodyS) -## (or (list;any? has-self-reference? argsS) -## (has-self-reference? bodyS)) - -## _ -## false -## )) - -## (def: (shift-loop-variables scope offset exprS) -## (-> (List Int) Nat ls;Synthesis ls;Synthesis) -## (loop [exprS exprS] -## (case exprS -## (#ls;Tuple members) -## (#ls;Tuple (L/map recur members)) - -## (#ls;Procedure name argsS) -## (#ls;Procedure name (L/map recur argsS)) - -## (#ls;Variant tag last? valueS) -## (#ls;Variant tag last? (recur valueS)) - -## (#ls;Variable idx) -## (if (captured-ref? idx) -## (let [scope-idx (|> idx (n.+ 1) (n.* -1) int-to-nat)] -## (|> scope (list;nth scope-idx) assume #ls;Variable)) -## (#ls;Variable (i.+ idx (nat-to-int offset)))) - -## (#ls;Recur _offset argsS) -## (#ls;Recur (n.+ offset _offset) (L/map recur argsS)) - -## (#ls;Call funcS argsS) -## (#ls;Call (recur funcS) (L/map recur argsS)) - -## (#ls;Let register inputS bodyS) -## (#ls;Let (n.+ offset register) (recur inputS) (recur bodyS)) - -## (#ls;If inputS thenS elseS) -## (#ls;If (recur inputS) (recur thenS) (recur elseS)) - -## (#ls;Function _num-args _scope _bodyS) -## ... - -## (#ls;Loop _offset _argsS _bodyS) -## (#ls;Loop (n.+ offset _offset) (L/map recur _argsS) (recur _bodyS)) - -## _ -## exprS -## ))) - (def: init-env (List ls;Variable) (list)) (def: init-resolver (d;Dict Int Int) (d;new number;Hash<Int>)) +(def: (prepare-body inner-arity arity body) + (-> Nat Nat ls;Synthesis ls;Synthesis) + (if (&&function;nested? inner-arity) + body + (&&loop;reify-recursion arity body))) + (def: #export (synthesize analysis) (-> la;Analysis ls;Synthesis) - (loop [scope-args +0 + (loop [outer-arity +0 resolver init-resolver + num-locals +0 exprA analysis] (case exprA (^template [<from> <to>] @@ -117,34 +42,29 @@ [#la;Absolute #ls;Definition]) (#la;Product _) - (#ls;Tuple (L/map (recur +0 resolver) (&&structure;unfold-tuple exprA))) + (#ls;Tuple (L/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA))) (#la;Sum choice) (let [[tag last? value] (&&structure;unfold-variant choice)] - (#ls;Variant tag last? (recur +0 resolver value))) + (#ls;Variant tag last? (recur +0 resolver num-locals value))) (#la;Relative ref) - (if (&&function;nested-function? scope-args) - (case ref - (#;Local local) - (if (n.= +0 local) + (case ref + (#;Local register) + (if (&&function;nested? outer-arity) + (if (n.= +0 register) (<| (#ls;Call (#ls;Variable 0)) - (L/map (|>. nat-to-int #ls;Variable)) - (list;n.range +1 (n.dec scope-args))) - (#ls;Variable (&&function;adjust-var scope-args (nat-to-int local)))) - - (#;Captured register) - (#ls;Variable (default (&&function;to-captured register) - (d;get (&&function;to-captured register) resolver)))) - (case ref - (#;Local local) - (#ls;Variable (nat-to-int local)) - - (#;Captured register) - (#ls;Variable (&&function;to-captured register)))) + (L/map (|>. &&function;to-local #ls;Variable)) + (list;n.range +1 (n.dec outer-arity))) + (#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register)))) + (#ls;Variable (&&function;to-local register))) + + (#;Captured register) + (#ls;Variable (let [var (&&function;to-captured register)] + (default var (d;get var resolver))))) (#la;Function scope bodyA) - (let [num-args (n.inc scope-args) + (let [inner-arity (n.inc outer-arity) raw-env (&&function;environment scope) env (L/map (function [var] (default var (d;get var resolver))) raw-env) env-vars (let [env-size (list;size raw-env)] @@ -152,7 +72,7 @@ (case env-size +0 (list) _ (L/map &&function;to-captured (list;n.range +0 (n.dec env-size)))))) - resolver' (if (&&function;nested-function? num-args) + resolver' (if (&&function;nested? inner-arity) (L/fold (function [[from to] resolver'] (d;put from to resolver')) init-resolver @@ -161,33 +81,36 @@ (d;put var var resolver')) init-resolver env-vars))] - (case (recur num-args resolver' bodyA) - (#ls;Function args' env' bodyS') - (#ls;Function (n.inc args') env bodyS') + (case (recur inner-arity resolver' +0 bodyA) + (#ls;Function arity' env' bodyS') + (let [arity (n.inc arity')] + (#ls;Function arity env (prepare-body inner-arity arity bodyS'))) bodyS - (#ls;Function +1 env bodyS))) - + (#ls;Function +1 env (prepare-body inner-arity +1 bodyS)))) + (#la;Apply _) (let [[funcA argsA] (&&function;unfold-apply exprA) - funcS (recur +0 resolver funcA) - argsS (L/map (recur +0 resolver) argsA)] + funcS (recur +0 resolver num-locals funcA) + argsS (L/map (recur +0 resolver num-locals) argsA)] (case funcS - ## (^multi (#ls;Variable idx) - ## (and (|> scope-args n.dec nat-to-int (i.* -1) (i.= idx)) - ## tail?)) - ## (#ls;Recur +1 argsS) - - ## (^multi (#ls;Function _scope-args _scope _bodyS) - ## (and (n.= _scope-args (list;size argsS)) - ## (not (has-self-reference? _bodyS)))) - ## (#ls;Loop local-offset argsS (shift-loop-variables local-offset _bodyS)) + (^multi (#ls;Function _arity _env _bodyS) + (and (n.= _arity (list;size argsS)) + (not (&&loop;contains-self-reference? _bodyS)))) + (let [register-offset (if (&&function;top? outer-arity) + num-locals + (|> outer-arity n.inc (n.+ num-locals)))] + (#ls;Loop register-offset argsS + (&&loop;adjust _env register-offset _bodyS))) + + (#ls;Call funcS' argsS') + (#ls;Call funcS' (L/append argsS' argsS)) _ (#ls;Call funcS argsS))) (#la;Procedure name args) - (#ls;Procedure name (L/map (recur +0 resolver) args)) + (#ls;Procedure name (L/map (recur +0 resolver num-locals) args)) _ (undefined) |