blob: bd62203374269f0bac821190a159b57cde1e65bd (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
(;module:
lux
(lux (data text/format
[number]
[product]
(coll [list "L/" Functor<List> Fold<List> Monoid<List>]
["d" dict])))
(luxc ["&" base]
(lang ["la" analysis]
["ls" synthesis])
(synthesizer ["&&;" structure]
["&&;" case]
["&&;" function]
["&&;" loop])
))
(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 [outer-arity +0
resolver init-resolver
num-locals +0
exprA analysis]
(case exprA
(^template [<from> <to>]
(<from> value)
(<to> 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;Text #ls;Text]
[#la;Definition #ls;Definition])
(#la;Product _)
(#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 num-locals value)))
(#la;Variable ref)
(case ref
(#;Local register)
(if (&&function;nested? outer-arity)
(if (n.= +0 register)
(<| (#ls;Call (#ls;Variable 0))
(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;Case inputA branchesA)
(let [inputS (recur +0 resolver num-locals inputA)]
(case (list;reverse branchesA)
(^multi (^ (list [(#la;BindP input-register)
(#la;Variable (#;Local output-register))]))
(n.= input-register output-register))
inputS
(^ (list [(#la;BindP register) bodyA]))
(#ls;Let register inputS (recur +0 resolver num-locals bodyA))
(^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA]))
(^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA])))
(#ls;If inputS
(recur +0 resolver num-locals thenA)
(recur +0 resolver num-locals elseA))
(#;Cons [lastP lastA] prevsPA)
(let [transform-branch (: (-> la;Pattern la;Analysis ls;Path)
(function [pattern expr]
(|> (recur +0 resolver num-locals expr)
#ls;ExecP
(#ls;SeqP (&&case;path pattern)))))]
(#ls;Case inputS
(L/fold &&case;weave
(transform-branch lastP lastA)
(L/map (product;uncurry transform-branch) prevsPA))))
_
(undefined)
))
(#la;Function scope bodyA)
(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)]
(: (List ls;Variable)
(case env-size
+0 (list)
_ (L/map &&function;to-captured (list;n.range +0 (n.dec env-size))))))
resolver' (if (&&function;nested? inner-arity)
(L/fold (function [[from to] resolver']
(d;put from to resolver'))
init-resolver
(list;zip2 env-vars env))
(L/fold (function [var resolver']
(d;put var var resolver'))
init-resolver
env-vars))]
(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 (prepare-body inner-arity +1 bodyS))))
(#la;Apply _)
(let [[funcA argsA] (&&function;unfold-apply exprA)
funcS (recur +0 resolver num-locals funcA)
argsS (L/map (recur +0 resolver num-locals) argsA)]
(case funcS
(^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 num-locals) args))
)))
|
