From e37e3713e080606930a5f8442f03dabc4c26a7f9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Nov 2017 16:09:07 -0400 Subject: - Fixed some bugs. - Some small refactoring. --- new-luxc/source/luxc/lang/synthesis/case.lux | 69 ++++++++++-------- new-luxc/source/luxc/lang/synthesis/expression.lux | 84 +++++++++++----------- new-luxc/source/luxc/lang/synthesis/loop.lux | 39 +++++----- 3 files changed, 101 insertions(+), 91 deletions(-) (limited to 'new-luxc/source/luxc/lang/synthesis') diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux index dfe05e1bf..c35483dd8 100644 --- a/new-luxc/source/luxc/lang/synthesis/case.lux +++ b/new-luxc/source/luxc/lang/synthesis/case.lux @@ -13,45 +13,52 @@ (def: popPS ls;Path (' ("lux case pop"))) -(def: (path' outer-arity pattern) - (-> ls;Arity la;Pattern (List ls;Path)) +(def: (path' arity num-locals pattern) + (-> ls;Arity Nat la;Pattern [Nat (List ls;Path)]) (case pattern (^code ("lux case tuple" [(~@ membersP)])) (case membersP #;Nil - (list popPS) + [num-locals + (list popPS)] (#;Cons singletonP #;Nil) - (path' outer-arity singletonP) + (path' arity num-locals singletonP) (#;Cons _) (let [last-idx (n.dec (list;size membersP)) - [_ tuple-path] (list/fold (function [current-pattern [current-idx next]] - [(n.dec current-idx) - (|> (list (if (n.= last-idx current-idx) - (` ("lux case tuple right" (~ (code;nat current-idx)))) - (` ("lux case tuple left" (~ (code;nat current-idx)))))) - (list/compose (path' outer-arity current-pattern)) - (list/compose next))]) - [last-idx (list popPS)] - (list;reverse membersP))] - tuple-path)) + [_ output] (list/fold (: (-> la;Pattern [Nat [Nat (List ls;Path)]] [Nat [Nat (List ls;Path)]]) + (function [current-pattern [current-idx num-locals' next]] + (let [[num-locals'' current-path] (path' arity num-locals' current-pattern)] + [(n.dec current-idx) + num-locals'' + (|> (list (if (n.= last-idx current-idx) + (` ("lux case tuple right" (~ (code;nat current-idx)))) + (` ("lux case tuple left" (~ (code;nat current-idx)))))) + (list/compose current-path) + (list/compose next))]))) + [last-idx num-locals (list popPS)] + (list;reverse membersP))] + output)) (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP))) - (|> (list (if (n.= (n.dec num-tags) tag) - (` ("lux case variant right" (~ (code;nat tag)))) - (` ("lux case variant left" (~ (code;nat tag)))))) - (list/compose (path' outer-arity memberP)) - (list& popPS)) + (let [[num-locals' member-path] (path' arity num-locals memberP)] + [num-locals' (|> (list (if (n.= (n.dec num-tags) tag) + (` ("lux case variant right" (~ (code;nat tag)))) + (` ("lux case variant left" (~ (code;nat tag)))))) + (list/compose member-path) + (list& popPS))]) (^code ("lux case bind" (~ [_ (#;Nat register)]))) - (list popPS - (` ("lux case bind" (~ (code;nat (if (functionS;nested? outer-arity) - (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register) - register)))))) + [(n.inc num-locals) + (list popPS + (` ("lux case bind" (~ (code;nat (if (functionS;nested? arity) + (n.+ (n.dec arity) register) + register))))))] _ - (list popPS pattern))) + [num-locals + (list popPS pattern)])) (def: (clean-unnecessary-pops paths) (-> (List ls;Path) (List ls;Path)) @@ -64,12 +71,14 @@ #;Nil paths)) -(def: #export (path outer-arity pattern body) - (-> ls;Arity la;Pattern ls;Synthesis ls;Path) - (|> (path' outer-arity pattern) clean-unnecessary-pops - (list/fold (function [pre post] - (` ("lux case seq" (~ pre) (~ post)))) - (` ("lux case exec" (~ body)))))) +(def: #export (path arity num-locals synthesize pattern bodyA) + (-> ls;Arity Nat (-> Nat la;Analysis ls;Synthesis) la;Pattern la;Analysis ls;Path) + (let [[num-locals' pieces] (path' arity num-locals pattern)] + (|> pieces + clean-unnecessary-pops + (list/fold (function [pre post] + (` ("lux case seq" (~ pre) (~ post)))) + (` ("lux case exec" (~ (synthesize num-locals' bodyA)))))))) (def: #export (weave leftP rightP) (-> ls;Path ls;Path ls;Path) diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux index b9f5d56cc..aaa2cf2c7 100644 --- a/new-luxc/source/luxc/lang/synthesis/expression.lux +++ b/new-luxc/source/luxc/lang/synthesis/expression.lux @@ -59,33 +59,32 @@ (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis) (` ("lux call" (~ funcS) (~@ argsS)))) -(def: (synthesize-case synthesize outer-arity inputA branchesA) - (-> (-> la;Analysis ls;Synthesis) - ls;Arity la;Analysis (List [la;Pattern la;Analysis]) +(def: (synthesize-case arity num-locals synthesize inputA branchesA) + (-> ls;Arity Nat (-> Nat la;Analysis ls;Synthesis) + la;Analysis (List [la;Pattern la;Analysis]) ls;Synthesis) - (let [inputS (synthesize inputA)] + (let [inputS (synthesize num-locals inputA)] (case (list;reverse branchesA) (^multi (^ (list [(^code ("lux case bind" (~ [_ (#;Nat input-register)]))) (^code ((~ [_ (#;Int var)])))])) (not (variableL;captured? var)) - (n.= input-register (int-to-nat var))) + (n.= input-register (variableL;local-register var))) inputS (^ (list [(^code ("lux case bind" (~ [_ (#;Nat register)]))) bodyA])) - (let$ (if (functionS;nested? outer-arity) - (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register) + (let$ (if (functionS;nested? arity) + (n.+ (n.dec arity) register) register) inputS - (synthesize bodyA)) + (synthesize (n.inc num-locals) bodyA)) (^or (^ (list [(^code true) thenA] [(^code false) elseA])) (^ (list [(^code false) elseA] [(^code true) thenA]))) - (if$ inputS (synthesize thenA) (synthesize elseA)) + (if$ inputS (synthesize num-locals thenA) (synthesize num-locals elseA)) (#;Cons [lastP lastA] prevsPA) (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path) - (function [pattern expr] - (caseS;path outer-arity pattern (synthesize expr)))) + (caseS;path arity num-locals synthesize)) pathS (list/fold caseS;weave (transform-branch lastP lastA) (list/map (product;uncurry transform-branch) prevsPA))] @@ -95,23 +94,20 @@ (undefined) ))) -(def: (synthesize-apply synthesize outer-arity num-locals exprA) - (-> (-> la;Analysis ls;Synthesis) ls;Arity Nat la;Analysis ls;Synthesis) +(def: (synthesize-apply synthesize num-locals exprA) + (-> (-> la;Analysis ls;Synthesis) Nat la;Analysis ls;Synthesis) (let [[funcA argsA] (functionS;unfold-apply exprA) funcS (synthesize funcA) argsS (list/map synthesize argsA)] (case funcS - (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))]) + (^multi (^code ("lux function" (~ [_ (#;Nat _arity)]) [(~@ _env)] (~ _bodyS))) (and (n.= _arity (list;size argsS)) (not (loopS;contains-self-reference? _bodyS))) [(s;run _env (p;some s;int)) (#e;Success _env)]) - (let [register-offset (if (functionS;top? outer-arity) - num-locals - (|> outer-arity n.inc (n.+ num-locals)))] - (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)] - (~ (loopS;adjust _env register-offset _bodyS))))) + (` ("lux loop" (~ (code;nat (n.inc num-locals))) [(~@ argsS)] + (~ (loopS;adjust _env num-locals _bodyS)))) - (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))]) + (^code ("lux call" (~ funcS') (~@ argsS'))) (call$ funcS' (list/compose argsS' argsS)) _ @@ -119,58 +115,59 @@ (def: #export (synthesize expressionA) (-> la;Analysis ls;Synthesis) - (loop [outer-arity +0 + (loop [arity +0 resolver init-resolver direct? false num-locals +0 expressionA expressionA] (case expressionA (^code [(~ _left) (~ _right)]) - (` [(~@ (list/map (recur outer-arity resolver false num-locals) (la;unfold-tuple expressionA)))]) + (` [(~@ (list/map (recur arity resolver false num-locals) + (la;unfold-tuple expressionA)))]) (^or (^code ("lux sum left" (~ _))) (^code ("lux sum right" (~ _)))) (let [[tag last? value] (maybe;assume (la;unfold-variant expressionA))] - (variant$ tag last? (recur outer-arity resolver false num-locals value))) + (variant$ tag last? (recur arity resolver false num-locals value))) (^code ((~ [_ (#;Int var)]))) (if (variableL;local? var) - (if (functionS;nested? outer-arity) + (if (functionS;nested? arity) (if (variableL;self? var) - (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity)) + (call$ (var$ 0) (|> (list;n.range +1 (n.dec arity)) (list/map (|>. variableL;local code;int (~) () (`))))) - (var$ (functionS;adjust-var outer-arity var))) + (var$ (functionS;adjust-var arity var))) (var$ var)) (var$ (maybe;default var (dict;get var resolver)))) (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)]))) - (synthesize-case (recur outer-arity resolver false num-locals) outer-arity inputA branchesA) + (synthesize-case arity num-locals (recur arity resolver false) inputA branchesA) (^multi (^code ("lux function" [(~@ scope)] (~ bodyA))) [(s;run scope (p;some s;int)) (#e;Success raw-env)]) - (let [inner-arity (if direct? - (n.inc outer-arity) - +1) + (let [function-arity (if direct? + (n.inc arity) + +1) env (list/map (function [closure] (case (dict;get closure resolver) (#;Some resolved) (if (and (variableL;local? resolved) - (functionS;nested? outer-arity) - (|> resolved variableL;local-register (n.>= outer-arity))) - (functionS;adjust-var outer-arity resolved) + (functionS;nested? arity) + (|> resolved variableL;local-register (n.>= arity))) + (functionS;adjust-var arity resolved) resolved) #;None (if (and (variableL;local? closure) - (functionS;nested? outer-arity)) - (functionS;adjust-var outer-arity closure) + (functionS;nested? arity)) + (functionS;adjust-var arity closure) closure))) raw-env) env-vars (: (List Variable) (case raw-env #;Nil (list) _ (|> (list;size raw-env) n.dec (list;n.range +0) (list/map variableL;captured)))) - resolver' (if (and (functionS;nested? inner-arity) + resolver' (if (and (functionS;nested? function-arity) direct?) (list/fold (function [[from to] resolver'] (dict;put from to resolver')) @@ -180,19 +177,20 @@ (dict;put var var resolver')) init-resolver env-vars))] - (case (recur inner-arity resolver' true num-locals bodyA) - (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))]) - (let [arity (n.inc arity')] - (function$ arity env (prepare-body inner-arity arity bodyS'))) + (case (recur function-arity resolver' true function-arity bodyA) + (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat unmerged-arity)] env' bodyS'))]) + (let [merged-arity (n.inc unmerged-arity)] + (function$ merged-arity env + (prepare-body function-arity merged-arity bodyS'))) bodyS - (function$ +1 env (prepare-body inner-arity +1 bodyS)))) + (function$ +1 env (prepare-body function-arity +1 bodyS)))) (^code ("lux apply" (~@ _))) - (synthesize-apply (recur outer-arity resolver false num-locals) outer-arity num-locals expressionA) + (synthesize-apply (recur arity resolver false num-locals) num-locals expressionA) (^code ((~ [_ (#;Text name)]) (~@ args))) - (procedure$ name (list/map (recur outer-arity resolver false num-locals) args)) + (procedure$ name (list/map (recur arity resolver false num-locals) args)) _ expressionA))) diff --git a/new-luxc/source/luxc/lang/synthesis/loop.lux b/new-luxc/source/luxc/lang/synthesis/loop.lux index 86c37a3f0..ac72e69b2 100644 --- a/new-luxc/source/luxc/lang/synthesis/loop.lux +++ b/new-luxc/source/luxc/lang/synthesis/loop.lux @@ -108,7 +108,7 @@ exprS ))) -(def: #export (adjust env outer-offset exprS) +(def: #export (adjust env offset exprS) (-> (List Variable) Register ls;Synthesis ls;Synthesis) (let [resolve-captured (: (-> Variable Variable) (function [var] @@ -116,13 +116,13 @@ (|> env (list;nth idx) maybe;assume))))] (loop [exprS exprS] (case exprS - (^ [_ (#;Form (list [_ (#;Nat tag)] last? valueS))]) + (^code ((~ [_ (#;Nat tag)]) (~ last?) (~ valueS))) (` ((~ (code;nat tag)) (~ last?) (~ (recur valueS)))) - [_ (#;Tuple members)] - [_ (#;Tuple (list/map recur members))] + (^code [(~@ members)]) + (` [(~@ (list/map recur members))]) - (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (^code ("lux case" (~ inputS) (~ pathS))) (` ("lux case" (~ (recur inputS)) (~ (let [adjust' recur] (loop [pathS pathS] @@ -133,22 +133,25 @@ (["lux case alt"] ["lux case seq"]) + (^code ("lux case bind" (~ [_ (#;Nat register)]))) + (` ("lux case bind" (~ (code;nat (n.+ offset register))))) + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) (` ("lux case exec" (~ (adjust' bodyS)))) _ pathS)))))) - (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) + (^code ("lux function" (~ arity) [(~@ environment)] (~ bodyS))) (` ("lux function" (~ arity) - (~ [_ (#;Tuple (list/map (function [_var] - (case _var - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (` ((~ (code;int (resolve-captured var))))) - - _ - _var)) - environment))]) + [(~@ (list/map (function [_var] + (case _var + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (` ((~ (code;int (resolve-captured var))))) + + _ + _var)) + environment))] (~ (recur bodyS)))) (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) @@ -163,10 +166,10 @@ (^ [_ (#;Form (list [_ (#;Int var)]))]) (if (variableL;captured? var) (` ((~ (code;int (resolve-captured var))))) - (` ((~ (code;int (|> outer-offset nat-to-int (i.+ var))))))) + (` ((~ (code;int (|> offset nat-to-int (i.+ var))))))) (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS bodyS))]) - (` ("lux let" (~ (code;nat (n.+ outer-offset register))) + (` ("lux let" (~ (code;nat (n.+ offset register))) (~ (recur inputS)) (~ (recur bodyS)))) @@ -175,8 +178,8 @@ (~ (recur thenS)) (~ (recur elseS)))) - (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat inner-offset)] [_ (#;Tuple initsS)] bodyS))]) - (` ("lux loop" (~ (code;nat (n.+ outer-offset inner-offset))) + (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat loop-offset)] [_ (#;Tuple initsS)] bodyS))]) + (` ("lux loop" (~ (code;nat (n.+ offset loop-offset))) [(~@ (list/map recur initsS))] (~ (recur bodyS)))) -- cgit v1.2.3