19 |
(* things that lcontract did that fcontract doesn't do (yet): |
(* things that lcontract did that fcontract doesn't do (yet): |
20 |
* |
* |
21 |
* - inline across DeBruijn depths |
* - inline across DeBruijn depths |
22 |
* - switch(con) concellation |
* - elimination of let [dead-vs] = pure in body |
23 |
* - elimination of let [dead-vs] = pure in body *) |
*) |
24 |
|
|
25 |
structure FContract :> FCONTRACT = |
structure FContract :> FCONTRACT = |
26 |
struct |
struct |
44 |
|
|
45 |
datatype sval |
datatype sval |
46 |
= Val of F.value |
= Val of F.value |
|
| Var of F.lvar |
|
47 |
| Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth |
| Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth |
48 |
| TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth |
| TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth |
49 |
| Record of F.lvar * F.value list |
| Record of F.lvar * F.value list |
61 |
|
|
62 |
fun impurePO po = true (* if a PrimOP is pure or not *) |
fun impurePO po = true (* if a PrimOP is pure or not *) |
63 |
|
|
64 |
|
fun eqConV (F.INTcon i1, F.INT i2) = i1 = i2 |
65 |
|
| eqConV (F.INT32con i1, F.INT32 i2) = i1 = i2 |
66 |
|
| eqConV (F.WORDcon i1, F.WORD i2) = i1 = i2 |
67 |
|
| eqConV (F.WORD32con i1, F.WORD32 i2) = i1 = i2 |
68 |
|
| eqConV (F.REALcon r1, F.REAL r2) = r1 = r2 |
69 |
|
| eqConV (F.STRINGcon s1, F.STRING s2) = s1 = s2 |
70 |
|
| eqConV (con,v) = bugval("unexpected comparison with val", v) |
71 |
|
|
72 |
fun lookup lv = M.map m lv |
fun lookup lv = M.map m lv |
73 |
(* handle e as NotFound => *) |
(* handle e as NotFound => *) |
74 |
(* (say (concat ["\nlooking up unbound ", *) |
(* (say (concat ["\nlooking up unbound ", *) |
77 |
|
|
78 |
fun sval2val sv = |
fun sval2val sv = |
79 |
case sv |
case sv |
80 |
of (Var lv | Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...} |
of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...} |
81 |
| Select{1=lv,...} | Con{1=lv,...} | Val (F.VAR lv)) => F.VAR lv |
| Select{1=lv,...} | Con{1=lv,...}) => F.VAR lv |
82 |
| Val v => v |
| Val v => v |
83 |
|
|
84 |
fun val2sval (F.VAR ov) = ((lookup ov) handle x => raise x) |
fun val2sval (F.VAR ov) = lookup ov |
85 |
| val2sval v = Val v |
| val2sval v = Val v |
86 |
|
|
87 |
fun bugsv (msg,sv) = bugval(msg, sval2val sv) |
fun bugsv (msg,sv) = bugval(msg, sval2val sv) |
99 |
(* called when a variable becomes dead. |
(* called when a variable becomes dead. |
100 |
* it simply adjusts the use-counts *) |
* it simply adjusts the use-counts *) |
101 |
fun undertake lv = |
fun undertake lv = |
102 |
(case lookup lv |
case lookup lv |
103 |
of Val v => unuseval undertake v |
of Val (F.VAR nlv) => ASSERT(nlv = lv, "nlv = lv") |
104 |
| Var nlv => ASSERT(nlv = lv, "nlv = lv") |
| Val v => unuseval undertake v |
105 |
| ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) => |
| ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) => |
106 |
C.inside lv (fn()=> C.unuselexp undertake le) |
C.inside lv (fn()=> C.unuselexp undertake le) |
107 |
| ( Select {2=v,...} | Con {2=v,...} ) => |
| ( Select {2=v,...} | Con {2=v,...} ) => |
108 |
unuseval undertake v |
unuseval undertake v |
109 |
| Record {2=vs,...} => app (unuseval undertake) vs) |
| Record {2=vs,...} => app (unuseval undertake) vs |
|
handle x => |
|
|
(say "while undertaking "; PP.printSval(F.VAR lv); say "\n"; |
|
|
raise x) |
|
110 |
|
|
111 |
fun addbind (lv,sv) = |
fun addbind (lv,sv) = |
112 |
let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2) |
let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2) |
123 |
fun substitute (lv1, sv, v) = |
fun substitute (lv1, sv, v) = |
124 |
(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => (); |
(case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => (); |
125 |
unuseval undertake v; |
unuseval undertake v; |
126 |
addbind (lv1, sv)) handle x => raise x |
addbind (lv1, sv)) |
127 |
|
|
128 |
(* common code for all the lexps "let v = <op>[v1,...] in ..." *) |
(* common code for all the lexps "let v = <op>[v1,...] in ..." *) |
129 |
fun clet1 (svcon,lecon) (lv,vs,le) = |
fun clet1 (svcon,lecon) (lv,vs,le) = |
148 |
|
|
149 |
in |
in |
150 |
case le |
case le |
151 |
of F.RET vs => (F.RET (map substval vs) handle x => raise x) |
of F.RET vs => F.RET(map substval vs) |
152 |
|
|
153 |
| F.LET (lvs,le,body) => |
| F.LET (lvs,le,body) => |
154 |
(let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2) |
let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2) |
155 |
(* let associativity |
(* let associativity |
156 |
* !!BEWARE!! applying the associativity rule might |
* !!BEWARE!! applying the associativity rule might |
157 |
* change the liveness of the bound variables *) |
* change the liveness of the bound variables *) |
194 |
(ListPair.zip(lvs, vs)); |
(ListPair.zip(lvs, vs)); |
195 |
loop body) |
loop body) |
196 |
| clet le = |
| clet le = |
197 |
(app (fn lv => addbind (lv, Var lv)) lvs; |
(app (fn lv => addbind (lv, Val(F.VAR lv))) lvs; |
198 |
case loop body |
case loop body |
199 |
of F.RET vs => if vs = (map F.VAR lvs) then le |
of F.RET vs => if vs = (map F.VAR lvs) then le |
200 |
else F.LET(lvs, le, F.RET vs) |
else F.LET(lvs, le, F.RET vs) |
201 |
| nbody => F.LET(lvs, le, nbody)) |
| nbody => F.LET(lvs, le, nbody)) |
202 |
in |
in |
203 |
clet (loop le) |
clet (loop le) |
204 |
end handle x => raise x) |
end |
205 |
|
|
206 |
| F.FIX (fs,le) => |
| F.FIX (fs,le) => |
207 |
(let fun cfun [] acc = rev acc |
let fun cfun [] acc = rev acc |
208 |
| cfun (fdec as (fk,f,args,body)::fs) acc = |
| cfun (fdec as (fk,f,args,body)::fs) acc = |
209 |
if used f then |
if used f then |
210 |
let (* make up the bindings for args inside the body *) |
let (* make up the bindings for args inside the body *) |
211 |
val _ = app (fn lv => addbind (lv, Var lv)) |
val _ = app (fn lv => addbind (lv, Val(F.VAR lv))) |
212 |
(map #1 args) |
(map #1 args) |
213 |
(* contract the body and create the resulting fundec *) |
(* contract the body and create the resulting fundec *) |
214 |
val nbody = C.inside f (fn()=> loop body) |
val nbody = C.inside f (fn()=> loop body) |
242 |
if List.null fs |
if List.null fs |
243 |
then nle |
then nle |
244 |
else F.FIX(fs,nle) |
else F.FIX(fs,nle) |
245 |
end handle x => raise x) |
end |
246 |
|
|
247 |
| F.APP (f,vs) => |
| F.APP (f,vs) => |
248 |
(let val nvs = map substval vs |
let val nvs = map substval vs |
249 |
in case val2sval f |
in case val2sval f |
250 |
of Fun(g,body,args,fk,od) => |
of Fun(g,body,args,fk,od) => |
251 |
(ASSERT(C.usenb g > 0, "C.usenb g > 0"); |
(ASSERT(C.usenb g > 0, "C.usenb g > 0"); |
261 |
else F.APP(F.VAR g, nvs)) |
else F.APP(F.VAR g, nvs)) |
262 |
|
|
263 |
| sv => F.APP(sval2val sv, nvs) |
| sv => F.APP(sval2val sv, nvs) |
264 |
end handle x => raise x) |
end |
265 |
|
|
266 |
| F.TFN ((f,args,body),le) => |
| F.TFN ((f,args,body),le) => |
267 |
((if used f then |
if used f then |
268 |
let (* val _ = addbind (f, TFun(f, body, args, od)) *) |
let (* val _ = addbind (f, TFun(f, body, args, od)) *) |
269 |
val nbody = cexp (DI.next d, DI.next od) body |
val nbody = cexp (DI.next d, DI.next od) body |
270 |
val _ = addbind (f, TFun(f, nbody, args, od)) |
val _ = addbind (f, TFun(f, nbody, args, od)) |
274 |
then F.TFN((f, args, nbody), nle) |
then F.TFN((f, args, nbody), nle) |
275 |
else nle |
else nle |
276 |
end |
end |
277 |
else loop le) handle x => raise x) |
else loop le |
278 |
|
|
279 |
| F.TAPP(f,tycs) => F.TAPP(substval f, tycs) |
| F.TAPP(f,tycs) => F.TAPP(substval f, tycs) |
280 |
|
|
281 |
| F.SWITCH (v,ac,arms,def) => |
| F.SWITCH (v,ac,arms,def) => |
282 |
(let val nv = substval v |
(case val2sval v |
283 |
fun carm (F.DATAcon(dc,tycs,lv),le) = |
of sv as (Val(F.VAR lv) | Select(lv,_,_)) => |
284 |
(addbind(lv, Var lv); |
(let fun carm (F.DATAcon(dc,tycs,lv),le) = |
285 |
|
(addbind(lv, Val(F.VAR lv)); |
286 |
(F.DATAcon(cdcon dc, tycs, lv), loop le)) |
(F.DATAcon(cdcon dc, tycs, lv), loop le)) |
287 |
| carm (con,le) = (con, loop le) |
| carm (con,le) = (con, loop le) |
288 |
val narms = map carm arms |
val narms = map carm arms |
289 |
val ndef = Option.map loop def |
val ndef = Option.map loop def |
290 |
in |
in |
291 |
F.SWITCH(nv,ac,narms,ndef) |
F.SWITCH(sval2val sv, ac, narms, ndef) |
292 |
end handle x => raise x) |
end handle x => raise x) |
293 |
|
|
294 |
|
| Con (lvc,v,(_,conrep,_)) => |
295 |
|
let fun carm ((F.DATAcon((_,crep,_),tycs,lv),le)::tl) = |
296 |
|
if crep = conrep then |
297 |
|
(substitute(lv, val2sval v, F.VAR lvc); |
298 |
|
loop le) |
299 |
|
else carm tl |
300 |
|
| carm [] = loop (Option.valOf def) |
301 |
|
| carm _ = buglexp("unexpected arm in switch(con,...)", le) |
302 |
|
in carm arms |
303 |
|
end |
304 |
|
|
305 |
|
| Val v => |
306 |
|
let fun carm ((con,le)::tl) = |
307 |
|
if eqConV(con, v) then loop le else carm tl |
308 |
|
| carm [] = loop(Option.valOf def) |
309 |
|
in carm arms |
310 |
|
end |
311 |
|
| sv => bugval("unexpected switch argument", sval2val sv)) |
312 |
|
|
313 |
| F.CON (dc,tycs,v,lv,le) => |
| F.CON (dc,tycs,v,lv,le) => |
314 |
let val ndc = cdcon dc |
let val ndc = cdcon dc |
315 |
in clet1 (fn [nv] => Con(lv, nv, ndc), |
in clet1 (fn [nv] => Con(lv, nv, ndc), |
343 |
| F.HANDLE (le,v) => F.HANDLE(loop le, substval v) |
| F.HANDLE (le,v) => F.HANDLE(loop le, substval v) |
344 |
|
|
345 |
| F.BRANCH (po,vs,le1,le2) => |
| F.BRANCH (po,vs,le1,le2) => |
346 |
(let val nvs = map substval vs |
let val nvs = map substval vs |
347 |
val npo = cpo po |
val npo = cpo po |
348 |
val nle1 = loop le1 |
val nle1 = loop le1 |
349 |
val nle2 = loop le2 |
val nle2 = loop le2 |
350 |
in F.BRANCH(npo, nvs, nle1, le2) |
in F.BRANCH(npo, nvs, nle1, le2) |
351 |
end handle x => raise x) |
end |
352 |
|
|
353 |
| F.PRIMOP (po,vs,lv,le) => |
| F.PRIMOP (po,vs,lv,le) => |
354 |
(let val nvs = map substval vs |
let val nvs = map substval vs |
355 |
val npo = cpo po |
val npo = cpo po |
356 |
val _ = addbind(lv, Var lv) |
val _ = addbind(lv, Val(F.VAR lv)) |
357 |
val nle = loop le |
val nle = loop le |
358 |
in if impurePO po orelse used lv |
in if impurePO po orelse used lv |
359 |
then F.PRIMOP(npo, nvs, lv, nle) |
then F.PRIMOP(npo, nvs, lv, nle) |
360 |
else nle |
else nle |
361 |
end handle x => raise x) |
end |
362 |
|
|
363 |
end handle x => raise x |
end |
364 |
|
|
365 |
fun contract (fdec as (_,f,_,_)) = |
fun contract (fdec as (_,f,_,_)) = |
366 |
let val _ = M.clear m |
let val _ = M.clear m |