From aa3dcb411db1bfbf41ca59c334c6c792b9e40d0c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 31 May 2017 21:35:39 -0400 Subject: - Implemented some synthesis algorithms and tests for primitives, structures, procedures and function application. - Some refactoring. --- new-luxc/source/luxc/synthesizer.lux | 278 ++++++++++++++++++++++++++++++----- 1 file changed, 238 insertions(+), 40 deletions(-) (limited to 'new-luxc/source/luxc/synthesizer.lux') diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 6acd2a0a2..04a699993 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -1,45 +1,243 @@ (;module: lux - (lux (control monad) - (data text/format - (coll [list "L/" Functor])) - [macro #+ Monad]) + (lux (data (coll [list "L/" Functor]))) (luxc ["&" base] - (lang ["la" analysis #+ Analysis] - ["ls" synthesis #+ Synthesis]) - ["&;" analyser])) + (lang ["la" analysis] + ["ls" synthesis]) + ## (synthesizer ["&&;" case]) + )) + +## (do-template [ ] +## [(def: ( ref) +## (-> Int Bool) +## ( 0 ref))] + +## [function-ref? i.=] +## [local-ref? i.>] +## [captured-ref? i.<] +## ) + +(def: (unfold-tuple tuple) + (-> la;Analysis (List la;Analysis)) + (case tuple + (#la;Product left right) + (#;Cons left (unfold-tuple right)) + + _ + (list tuple))) + +(def: (unfold-apply apply) + (-> la;Analysis [la;Analysis (List la;Analysis)]) + (loop [apply apply + args (list)] + (case apply + (#la;Apply arg func) + (recur func (#;Cons arg args)) + + _ + [apply args]))) + +(def: (unfold-variant variant) + (-> (Either la;Analysis la;Analysis) [Nat Bool la;Analysis]) + (loop [so-far +0 + variantA variant] + (case variantA + (#;Left valueA) + (case valueA + (#la;Sum choice) + (recur (n.inc so-far) choice) + + _ + [so-far false valueA]) + + (#;Right valueA) + [(n.inc so-far) true valueA]))) + +## (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;Relative 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;Relative idx) +## (if (captured-ref? idx) +## (let [scope-idx (|> idx (n.+ 1) (n.* -1) int-to-nat)] +## (|> scope (list;nth scope-idx) assume #ls;Relative)) +## (#ls;Relative (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: #export (synthesize analysis) - (-> Analysis Synthesis) - (case analysis - (^template [ ] - ( value) - ( value)) - ([#la;Bool #ls;Bool] - [#la;Nat #ls;Nat] - [#la;Int #ls;Int] - [#la;Deg #ls;Deg] - [#la;Real #ls;Real] - [#la;Char #ls;Char] - [#la;Text #ls;Text] - [#la;Relative #ls;Relative] - [#la;Absolute #ls;Absolute]) - - (#la;Tuple values) - (#ls;Tuple (L/map synthesize values)) - - (#la;Variant tag last? value) - (undefined) - - (#la;Case input matches) - (undefined) - - (#la;Function scope body) - (undefined) - - (#la;Apply arg func) - (undefined) - - (#la;Procedure name args) - (#ls;Procedure name (L/map synthesize args)) - )) + (-> la;Analysis ls;Synthesis) + (loop [num-args +0 + local-offset +0 + tail? true + exprA analysis] + (case exprA + (^template [ ] + ( value) + ( value)) + ([#la;Unit #ls;Unit] + [#la;Bool #ls;Bool] + [#la;Nat #ls;Nat] + [#la;Int #ls;Int] + [#la;Deg #ls;Deg] + [#la;Real #ls;Real] + [#la;Char #ls;Char] + [#la;Text #ls;Text] + [#la;Absolute #ls;Absolute]) + + (#la;Product _) + (#ls;Tuple (L/map (recur +0 local-offset false) (unfold-tuple exprA))) + + (#la;Sum choice) + (let [[tag last? value] (unfold-variant choice)] + (#ls;Variant tag last? (recur +0 local-offset false value))) + + (#la;Apply _) + (let [[funcA argsA] (unfold-apply exprA) + funcS (recur +0 local-offset false funcA) + argsS (L/map (recur +0 local-offset false) argsA)] + (case funcS + ## (^multi (#ls;Relative idx) + ## (and (|> num-args n.dec nat-to-int (i.* -1) (i.= idx)) + ## tail?)) + ## (#ls;Recur +1 argsS) + + ## (^multi (#ls;Function _num-args _scope _bodyS) + ## (and (n.= _num-args (list;size argsS)) + ## (not (has-self-reference? _bodyS)))) + ## (#ls;Loop local-offset argsS (shift-loop-variables local-offset _bodyS)) + + _ + (#ls;Call funcS argsS))) + + (#la;Procedure name args) + (#ls;Procedure name (L/map (recur +0 local-offset false) args)) + + _ + (undefined) + + ## (#la;Relative ref) + ## (case ref + ## (#;Local local) + ## (case local + ## +0 + ## (if (n.> +1 num-args) + ## (<| (#ls;Call (#ls;Relative 0)) + ## (L/map (|>. #ls;Relative)) + ## (list;range +1 (n.dec num-args))) + ## (#ls;Relative 0)) + + ## _ + ## (#ls;Relative (nat-to-int (n.+ (n.inc num-args) local)))) + + ## (#;Captured captured) + ## (#ls;Relative (|> captured nat-to-int (n.* -1) (n.+ -1)))) + + ## (#la;Function scope bodyA) + ## (case (recur (n.inc num-args) local-offset true bodyA) + ## (#ls;Function num-args' scope' bodyS') + ## (#ls;Function (n.inc num-args') scope bodyS') + + ## bodyS + ## (#ls;Function +1 scope bodyS)) + + ## (#la;Case inputA branchesA) + ## (let [inputS (recur num-args local-offset false inputA)] + ## (case branchesA + ## (^multi (^ (list [(#lp;Bind input-register) + ## (#la;Relative (#;Local output-register))])) + ## (n.= input-register output-register)) + ## inputS + + ## (^ (list [(#lp;Bind register) bodyA])) + ## (#ls;Let register inputS (recur num-args local-offset tail? bodyA)) + + ## (^or (^ (list [(#lp;Bool true) thenA] [(#lp;Bool false) elseA])) + ## (^ (list [(#lp;Bool false) elseA] [(#lp;Bool true) thenA]))) + ## (#ls;If inputS + ## (recur num-args local-offset tail? thenA) + ## (recur num-args local-offset tail? elseA)) + + ## (#;Cons [headP headA] tailPA) + ## (let [headP+ (|> (recur num-args local-offset tail? headA) + ## #ls;ExecP + ## (#ls;SeqP (&&case;path headP))) + ## tailP+ (L/map (function [[pattern bodyA]] + ## (|> (recur num-args local-offset tail? bodyA) + ## #ls;ExecP + ## (#ls;SeqP (&&case;path pattern)))) + ## tailPA)] + ## (#ls;Case inputS (&&case;weave-paths headP+ tailP+))) + ## )) + ))) -- cgit v1.2.3