Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/opt/fcontract.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/opt/fcontract.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 63 - (view) (download)

1 : monnier 58 (* copyright 1998 YALE FLINT PROJECT *)
2 :    
3 :     signature FCONTRACT =
4 :     sig
5 :    
6 :     (* needs Collect to be setup properly *)
7 :     val contract : FLINT.fundec -> FLINT.fundec
8 :    
9 :     end
10 :    
11 :     (* All kinds of beta-reductions. In order to do as much work per pass as
12 :     * possible, the usage counts of each variable (maintained by the Collect
13 :     * module) is kept as much uptodate as possible. For instance as soon as a
14 :     * variable becomes dead, all the variables that were referenced have their
15 :     * usage counts decremented correspondingly. This means that we have to
16 :     * be careful to make sure that a dead variable will indeed not appear
17 :     * in the output lexp since it might else reference other dead variables *)
18 :    
19 :     (* things that lcontract did that fcontract doesn't do (yet):
20 :     *
21 :     * - inline across DeBruijn depths
22 : monnier 63 * - elimination of let [dead-vs] = pure in body
23 :     *)
24 : monnier 58
25 :     structure FContract :> FCONTRACT =
26 :     struct
27 :     local
28 :     structure F = FLINT
29 :     structure M = Intmap
30 :     structure C = Collect
31 :     structure DI = DebIndex
32 :     structure PP = PPFlint
33 :     in
34 :    
35 :     val say = Control.Print.say
36 :     fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
37 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
38 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
39 :    
40 :     (* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
41 :    
42 :     fun ASSERT (true,_) = ()
43 :     | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
44 :    
45 :     datatype sval
46 :     = Val of F.value
47 :     | 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
49 :     | Record of F.lvar * F.value list
50 :     | Select of F.lvar * F.value * int
51 :     | Con of F.lvar * F.value * F.dcon
52 :    
53 :     exception NotFound
54 :     val m : sval M.intmap = M.new(128, NotFound)
55 :    
56 :     fun cexp (cfg as (d,od)) le = let
57 :    
58 :     val loop = cexp cfg
59 :    
60 :     fun used lv = C.usenb lv > 0
61 :    
62 :     fun impurePO po = true (* if a PrimOP is pure or not *)
63 :    
64 : monnier 63 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 : monnier 58 fun lookup lv = M.map m lv
73 :     (* handle e as NotFound => *)
74 :     (* (say (concat ["\nlooking up unbound ", *)
75 :     (* !PP.LVarString lv]); *)
76 :     (* raise e) *)
77 :    
78 :     fun sval2val sv =
79 :     case sv
80 : monnier 63 of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}
81 :     | Select{1=lv,...} | Con{1=lv,...}) => F.VAR lv
82 : monnier 58 | Val v => v
83 :    
84 : monnier 63 fun val2sval (F.VAR ov) = lookup ov
85 : monnier 58 | val2sval v = Val v
86 :    
87 :     fun bugsv (msg,sv) = bugval(msg, sval2val sv)
88 :    
89 :     fun subst ov = sval2val (lookup ov)
90 :     val substval = sval2val o val2sval
91 :     fun substvar lv =
92 :     case substval (F.VAR lv)
93 :     of F.VAR lv => lv
94 :     | v => bugval ("unexpected val", v)
95 :    
96 :     fun unuseval f (F.VAR lv) = C.unuse f false lv
97 :     | unuseval f _ = ()
98 :    
99 :     (* called when a variable becomes dead.
100 :     * it simply adjusts the use-counts *)
101 :     fun undertake lv =
102 : monnier 63 case lookup lv
103 :     of Val (F.VAR nlv) => ASSERT(nlv = lv, "nlv = lv")
104 :     | Val v => unuseval undertake v
105 : monnier 58 | ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) =>
106 : monnier 63 C.inside lv (fn()=> C.unuselexp undertake le)
107 : monnier 58 | ( Select {2=v,...} | Con {2=v,...} ) =>
108 : monnier 63 unuseval undertake v
109 :     | Record {2=vs,...} => app (unuseval undertake) vs
110 : monnier 58
111 :     fun addbind (lv,sv) =
112 :     let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2)
113 :     fun correct (Val v) = true
114 :     | correct sv =
115 :     let val F.VAR lv = sval2val sv
116 :     in eqsv(sv, M.map m lv)
117 :     end handle NotFound => true
118 :     in ASSERT(correct sv, "addbind");
119 :     M.add m (lv, sv)
120 :     end
121 :    
122 :     (* substitute a value sv for a variable lv and unuse value v *)
123 :     fun substitute (lv1, sv, v) =
124 :     (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
125 :     unuseval undertake v;
126 : monnier 63 addbind (lv1, sv))
127 : monnier 58
128 :     (* common code for all the lexps "let v = <op>[v1,...] in ..." *)
129 :     fun clet1 (svcon,lecon) (lv,vs,le) =
130 :     if used lv then
131 :     let val nvs = map substval vs
132 :     val _ = addbind (lv, svcon(nvs))
133 :     val nle = loop le
134 :     in if used lv then lecon(nvs, nle) else nle
135 :     end
136 :     else loop le
137 :    
138 :     (* common code for primops *)
139 :     fun cpo (SOME{default,table},po,lty,tycs) =
140 :     (SOME{default=substvar default,
141 :     table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
142 :     po,lty,tycs)
143 :     | cpo po = po
144 :    
145 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
146 :     (s, Access.EXN(Access.LVAR(substvar lv)), lty)
147 :     | cdcon dc = dc
148 :    
149 :     in
150 :     case le
151 : monnier 63 of F.RET vs => F.RET(map substval vs)
152 : monnier 58
153 :     | F.LET (lvs,le,body) =>
154 : monnier 63 let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2)
155 :     (* let associativity
156 :     * !!BEWARE!! applying the associativity rule might
157 :     * change the liveness of the bound variables *)
158 :     | clet (F.FIX(fdecs,le)) =
159 :     let val nbody = clet le
160 :     val nfdecs = List.filter (used o #2) fdecs
161 :     in if null nfdecs then nbody else F.FIX(nfdecs, nbody)
162 :     end
163 :     | clet (F.TFN(tfdec,le)) =
164 :     let val nbody = clet le
165 :     in if used (#1 tfdec) then F.TFN(tfdec, nbody) else nbody
166 :     end
167 :     | clet (F.CON(dc,tycs,v,lv,le)) =
168 :     let val nbody = clet le
169 :     in if used lv then F.CON(dc, tycs, v, lv, nbody) else nbody
170 :     end
171 :     | clet (F.RECORD(rk,vs,lv,le)) =
172 :     let val nbody = clet le
173 :     in if used lv then F.RECORD(rk, vs, lv, nbody) else nbody
174 :     end
175 :     | clet (F.SELECT(v,i,lv,le)) =
176 :     let val nbody = clet le
177 :     in if used lv then F.SELECT(v, i, lv, nbody) else nbody
178 :     end
179 :     | clet (F.PRIMOP(po,vs,lv,le)) =
180 :     let val nbody = clet le
181 :     in if impurePO po orelse used lv
182 :     then F.PRIMOP(po, vs, lv, nbody)
183 :     else nbody
184 :     end
185 :     (* F.RAISE never returns so the body of the let could be
186 :     * dropped on the floor, but since I don't propagate
187 :     * types I can't come up with the right return type
188 :     * | F.RAISE(v,ltys) =>
189 :     * (C.unuselexp undertake body;
190 :     * F.RAISE(v, ?????)) *)
191 :     | clet (F.RET vs) =
192 :     (* LET[lvs] = RET[vs] is replaced by substitutions *)
193 :     (app (fn (lv,v) => substitute (lv, val2sval v, v))
194 :     (ListPair.zip(lvs, vs));
195 :     loop body)
196 :     | clet le =
197 :     (app (fn lv => addbind (lv, Val(F.VAR lv))) lvs;
198 :     case loop body
199 :     of F.RET vs => if vs = (map F.VAR lvs) then le
200 :     else F.LET(lvs, le, F.RET vs)
201 :     | nbody => F.LET(lvs, le, nbody))
202 : monnier 58 in
203 :     clet (loop le)
204 : monnier 63 end
205 : monnier 58
206 :     | F.FIX (fs,le) =>
207 : monnier 63 let fun cfun [] acc = rev acc
208 :     | cfun (fdec as (fk,f,args,body)::fs) acc =
209 :     if used f then
210 :     let (* make up the bindings for args inside the body *)
211 :     val _ = app (fn lv => addbind (lv, Val(F.VAR lv)))
212 :     (map #1 args)
213 :     (* contract the body and create the resulting fundec *)
214 :     val nbody = C.inside f (fn()=> loop body)
215 :     val nsv = Fun(f, nbody, args, fk, od)
216 :    
217 :     val _ = (* update the subst with the new code *)
218 :     case nbody (* look for eta redex *)
219 :     of F.APP(g,vs) =>
220 :     if vs = (map (F.VAR o #1) args)
221 :     then substitute (f, val2sval g, g)
222 :     else addbind (f, nsv)
223 :     | _ => addbind (f, nsv)
224 :     in cfun fs ((fk, f, args, nbody)::acc)
225 :     end
226 :     else cfun fs acc
227 :    
228 :     (* register the new bindings. We register them
229 :     * uncontracted first, for the needs of mutual recursion,
230 :     * and then we replace the contracted versions as they
231 :     * become available *)
232 :     val _ = app (fn fdec as (fk,f,args,body) =>
233 :     addbind (f, Fun(f, body, args, fk, od)))
234 :     fs
235 :    
236 :     (* recurse on the bodies *)
237 :     val fs = cfun fs []
238 :    
239 :     val nle = loop le (* contract the main body *)
240 :     val fs = List.filter (used o #2) fs (* junk newly unused funs *)
241 : monnier 58 in
242 :     if List.null fs
243 :     then nle
244 :     else F.FIX(fs,nle)
245 : monnier 63 end
246 : monnier 58
247 :     | F.APP (f,vs) =>
248 : monnier 63 let val nvs = map substval vs
249 : monnier 58 in case val2sval f
250 :     of Fun(g,body,args,fk,od) =>
251 :     (ASSERT(C.usenb g > 0, "C.usenb g > 0");
252 :     if C.usenb g = 1 andalso od = d andalso not (C.recursive g)
253 :    
254 :     (* simple inlining: we should copy the body and then
255 :     * kill the function, but instead we keep the body
256 :     * and kill only the function name *)
257 :     then (C.unuse (fn lv => ()) true g;
258 :     cexp (d,od) (F.LET(map #1 args, F.RET nvs, body)))
259 :    
260 :     (* no inlining: just substitute the vars and vals *)
261 :     else F.APP(F.VAR g, nvs))
262 :    
263 :     | sv => F.APP(sval2val sv, nvs)
264 : monnier 63 end
265 : monnier 58
266 :     | F.TFN ((f,args,body),le) =>
267 : monnier 63 if used f then
268 :     let (* val _ = addbind (f, TFun(f, body, args, od)) *)
269 :     val nbody = cexp (DI.next d, DI.next od) body
270 :     val _ = addbind (f, TFun(f, nbody, args, od))
271 :     val nle = loop le
272 :     in
273 :     if used f
274 :     then F.TFN((f, args, nbody), nle)
275 :     else nle
276 :     end
277 :     else loop le
278 : monnier 58
279 :     | F.TAPP(f,tycs) => F.TAPP(substval f, tycs)
280 :    
281 :     | F.SWITCH (v,ac,arms,def) =>
282 : monnier 63 (case val2sval v
283 :     of sv as (Val(F.VAR lv) | Select(lv,_,_)) =>
284 :     (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))
287 :     | carm (con,le) = (con, loop le)
288 :     val narms = map carm arms
289 :     val ndef = Option.map loop def
290 :     in
291 :     F.SWITCH(sval2val sv, ac, narms, ndef)
292 :     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 : monnier 58
313 :     | F.CON (dc,tycs,v,lv,le) =>
314 :     let val ndc = cdcon dc
315 :     in clet1 (fn [nv] => Con(lv, nv, ndc),
316 :     fn ([nv],nle) => F.CON(ndc, tycs, nv, lv, nle))
317 :     (lv,[v],le)
318 :     end
319 :    
320 :     | F.RECORD (rk,vs,lv,le) =>
321 :     clet1 (fn nvs => Record(lv, nvs),
322 :     fn (nvs,nle) => F.RECORD(rk, nvs, lv, nle))
323 :     (lv,vs,le)
324 :    
325 :     | F.SELECT (v,i,lv,le) =>
326 :     if used lv then
327 :     case val2sval v
328 :     of Record (lvr,vs) =>
329 :     (let val sv = val2sval (List.nth(vs, i))
330 :     in substitute (lv, sv, F.VAR lvr);
331 :     loop le
332 :     end handle x => raise x)
333 :     | sv =>
334 :     (let val nv = sval2val sv
335 :     val _ = addbind (lv, Select(lv, nv, i))
336 :     val nle = loop le
337 :     in if used lv then F.SELECT(nv, i, lv, nle) else nle
338 :     end handle x => raise x)
339 :     else loop le
340 :    
341 :     | F.RAISE (v,ltys) => F.RAISE(substval v, ltys)
342 :    
343 :     | F.HANDLE (le,v) => F.HANDLE(loop le, substval v)
344 :    
345 :     | F.BRANCH (po,vs,le1,le2) =>
346 : monnier 63 let val nvs = map substval vs
347 :     val npo = cpo po
348 :     val nle1 = loop le1
349 :     val nle2 = loop le2
350 : monnier 58 in F.BRANCH(npo, nvs, nle1, le2)
351 : monnier 63 end
352 : monnier 58
353 :     | F.PRIMOP (po,vs,lv,le) =>
354 : monnier 63 let val nvs = map substval vs
355 :     val npo = cpo po
356 :     val _ = addbind(lv, Val(F.VAR lv))
357 :     val nle = loop le
358 : monnier 58 in if impurePO po orelse used lv
359 :     then F.PRIMOP(npo, nvs, lv, nle)
360 :     else nle
361 : monnier 63 end
362 : monnier 58
363 : monnier 63 end
364 : monnier 58
365 :     fun contract (fdec as (_,f,_,_)) =
366 :     let val _ = M.clear m
367 :     val F.FIX([fdec], F.RET[F.VAR f]) =
368 :     cexp (DI.top,DI.top) (F.FIX([fdec], F.RET[F.VAR f]))
369 :     val _ = M.clear m
370 :     in fdec
371 :     end
372 :    
373 :     end
374 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0