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 162 - (view) (download)

1 : monnier 121 (* copyright 1998 YALE FLINT PROJECT *)
2 : monnier 159 (* monnier@cs.yale.edu *)
3 : monnier 121
4 :     signature FCONTRACT =
5 :     sig
6 :    
7 :     (* needs Collect to be setup properly *)
8 :     val contract : FLINT.fundec -> FLINT.fundec
9 :    
10 :     end
11 :    
12 :     (* All kinds of beta-reductions. In order to do as much work per pass as
13 :     * possible, the usage counts of each variable (maintained by the Collect
14 :     * module) is kept as much uptodate as possible. For instance as soon as a
15 :     * variable becomes dead, all the variables that were referenced have their
16 :     * usage counts decremented correspondingly. This means that we have to
17 :     * be careful to make sure that a dead variable will indeed not appear
18 :     * in the output lexp since it might else reference other dead variables *)
19 :    
20 : monnier 159 (* things that fcontract does:
21 :     * - several things not mentioned
22 :     * - elimination of Con(Decon x)
23 :     * - update counts when selecting a SWITCH alternative
24 : monnier 162 * - contracting RECORD(R.1,R.2) => R (only if the type is easily available)
25 : monnier 159 *)
26 :    
27 : monnier 121 (* things that lcontract.sml does that fcontract doesn't do (yet):
28 : monnier 159 * - inline across DeBruijn depths (will be solved by named-tvar)
29 : monnier 121 * - elimination of let [dead-vs] = pure in body
30 :     *)
31 :    
32 :     (* things that cpsopt/eta.sml did that fcontract doesn't do:
33 : monnier 159 * - let f vs = select(v,i,g,g vs)
34 : monnier 121 *)
35 :    
36 :     (* things that cpsopt/contract.sml did that fcontract doesn't do:
37 : monnier 159 * - IF-idiom (I still don't know what it is)
38 : monnier 121 * - unifying branches
39 :     * - Handler operations
40 :     * - primops expressions
41 :     * - branch expressions
42 :     * - dropping of arguments
43 :     *)
44 :    
45 :     (* things that could also be added:
46 :     * - elimination of dead vars in let (subsumes what lcontract does)
47 :     *)
48 :    
49 :     (* things that would require some type info:
50 :     * - dropping foo in LET vs = RAISE v IN foo
51 :     *)
52 :    
53 :     (* eta-reduction is tricky:
54 :     * - recognition of eta-redexes and introduction of the corresponding
55 :     * substitution in the table has to be done at the very beginning of
56 :     * the processing of the FIX
57 :     * - eta-reduction can turn a known function into an escaping function
58 :     * - fun f (g,v2,v3) = g(g,v2,v3) looks tremendously like an eta-redex
59 :     *)
60 :    
61 :     (* order of contraction is important:
62 :     * - the body of a FIX is contracted before the functions because the
63 :     * functions might end up being inlined in the body in which case they
64 :     * could be contracted twice.
65 :     *)
66 :    
67 :     (* When creating substitution f->g (as happens with eta redexes or with
68 :     * code like `LET [f] = RET[g]'), we need to make sure that the usage cout
69 :     * of f gets properly transfered to g. One way to do that is to make the
70 :     * transfer incremental: each time we apply the substitution, we decrement
71 :     * f's count and increment g's count. But this can be tricky since the
72 :     * elimination of the eta-redex (or the trivial binding) eliminates one of the
73 : monnier 159 * references to g and if this is the only one, we might trigger the killing
74 : monnier 121 * of g even though its count would be later incremented. Similarly, inlining
75 :     * of g would be dangerous as long as some references to f exist.
76 :     * So instead we do the transfer once and for all when we see the eta-redex,
77 :     * which frees us from those two problems but forces us to make sure that
78 :     * every existing reference to f will be substituted with g.
79 :     * Also, the transfer of counts from f to g is not quite straightforward
80 :     * since some of the references to f might be from inside g and without doing
81 :     * the transfer incrementally, we can't easily know which of the usage counts
82 :     * of f should be transfered to the internal counts of g and which to the
83 :     * external counts.
84 :     *)
85 :    
86 : monnier 159 (* Preventing infinite inlining:
87 :     * - inlining a function in its own body amounts to unrolling which has
88 :     * to be controlled (you only want to unroll some number of times).
89 :     * It's currently simply not allowed.
90 :     * - inlining a recursive function outside of tis body amounts to `peeling'
91 :     * one iteration. Here also, since the inlined body will have yet another
92 :     * call, the inlining risks non-termination. It's hence also
93 :     * not allowed.
94 :     * - inlining a mutually recursive function is just a more general form
95 :     * of the problem above although it can be safe and desirable in some cases.
96 :     * To be safe, you simply need that one of the functions forming the
97 :     * mutual-recursion loop cannot be inlined (to break the loop). This cannot
98 :     * be trivially checked. So we (foolishly?) trust the `inline' bit in
99 :     * those cases. This is mostly used to inline wrappers inside the
100 :     * function they wrap.
101 :     * - even if one only allows inlining of funtions showing no sign of
102 :     * recursion, we can be bitten by a program creating its own Y combinator:
103 :     * datatype dt = F of dt -> int -> int
104 :     * let fun f (F g) x = g (F g) x in f (F f) end
105 :     * To solve this problem, `cexp' has an `ifs' parameter containing the set
106 :     * of funtions that we are inlining in order to detect (and break) cycles.
107 :     * - funnily enough, if we allow inlining recursive functions the cycle
108 :     * detection will ensure that the unrolling (or peeling) will only be done
109 :     * once. In the future, maybe.
110 :     *)
111 :    
112 : monnier 121 (* Simple inlining (inlining called-once functions, which doesn't require
113 :     * alpha-renaming) seems inoffensive enough but is not always desirable.
114 : monnier 159 * The typical example is wrapper functions introduced by eta-expand: they
115 :     * usually (until inlined) contain the only call to the main function,
116 : monnier 121 * but inlining the main function in the wrapper defeats the purpose of the
117 :     * wrapper.
118 :     * cpsopt dealt with this problem by adding a `NO_INLINE_INTO' hint to the
119 : monnier 159 * wrapper function. In this file, the idea is the following:
120 :     * If you have a function declaration like `let f x = body in exp', first
121 :     * contract `exp' and only contract `body' afterwards. This ensures that
122 :     * the eta-wrapper gets a chance to be inlined before it is (potentially)
123 :     * eta-reduced away. Interesting details:
124 : monnier 121 * - all functions (even the ones that would have a `NO_INLINE_INTO') are
125 :     * contracted, because the "aggressive usage count maintenance" makes any
126 :     * alternative painful (the collect phase has already assumed that dead code
127 :     * will be eliminated, which means that fcontract should at the very least
128 : monnier 159 * do the dead-code elimination, so you can only avoid fcontracting a
129 :     * a function if you can be sure that the body doesn't contain any dead-code,
130 :     * which is generally not known).
131 : monnier 121 * - once a function is fcontracted it is marked as non-inlinable since
132 : monnier 159 * fcontraction might have changed its shape considerably (via inlining).
133 :     * This means that in the case of
134 :     * let fwrap x = body1 and f y = body2 in exp
135 :     * if fwrap is fcontracted before f, then fwrap cannot be inlined in f.
136 :     * To minimize the impact of this problem, we make sure that we fcontract
137 :     * inlinable functions only after fcontracting other mutually recursive
138 :     * functions.
139 : monnier 121 * - at the very end of the optimization phase, cpsopt had a special pass
140 :     * that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
141 :     * into it doesn't have any undesirable side effects any more). The present
142 :     * code doesn't need such a thing. On another hand, the cpsopt approach
143 :     * had the advantage of keeping the `inline' bit from one contract phase to
144 : monnier 159 * the next. If this ends up being important, one could add a global
145 : monnier 121 * "noinline" flag that could be set to true whenever fcontracting an
146 : monnier 159 * inlinable function (this would ensure that fcontracting such an inlinable
147 :     * function can only reduce its size, which would allow keeping the `inline'
148 :     * bit set after fcontracting).
149 : monnier 121 *)
150 :    
151 :     structure FContract :> FCONTRACT =
152 :     struct
153 :     local
154 :     structure F = FLINT
155 :     structure M = IntmapF
156 : monnier 159 structure S = IntSetF
157 : monnier 121 structure C = Collect
158 :     structure DI = DebIndex
159 :     structure PP = PPFlint
160 : monnier 159 structure FU = FlintUtil
161 :     structure LT = LtyExtern
162 :     structure CTRL = Control.FLINT
163 : monnier 121 in
164 :    
165 :     val say = Control.Print.say
166 :     fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
167 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
168 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
169 :    
170 :     (* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
171 :    
172 :     fun ASSERT (true,_) = ()
173 :     | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
174 :    
175 : monnier 159 val cplv = LambdaVar.dupLvar
176 : monnier 121
177 :     datatype sval
178 :     = Val of F.value (* F.value should never be F.VAR lv *)
179 :     | Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth
180 :     | TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth
181 :     | Record of F.lvar * F.value list
182 : monnier 159 | Con of F.lvar * F.value * F.dcon * F.tyc list
183 :     | Decon of F.lvar * F.value * F.dcon * F.tyc list
184 : monnier 121 | Select of F.lvar * F.value * int
185 :     | Var of F.lvar * F.lty option (* cop out case *)
186 :    
187 : monnier 159 fun sval2lty (Var(_,x)) = x
188 :     | sval2lty (Decon(_,_,(_,_,lty),tycs)) =
189 :     SOME(hd(#2 (LT.ltd_arrow (hd(LT.lt_inst(lty, tycs))))))
190 :     | sval2lty _ = NONE
191 : monnier 121
192 : monnier 159 fun tycs_eq ([],[]) = true
193 :     | tycs_eq (tyc1::tycs1,tyc2::tycs2) =
194 :     LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
195 :     | tycs_eq _ = false
196 : monnier 121
197 : monnier 159 (* cfg: is used for deBruijn renumbering when inlining at different depths
198 :     * ifs (inlined functions): records which functions we're currently inlining
199 :     * in order to detect loops
200 :     * m: is a map lvars to their defining expressions (svals) *)
201 :     fun cexp (cfg as (d,od)) ifs m le = let
202 :    
203 :     val loop = cexp cfg ifs
204 :    
205 : monnier 121 fun used lv = C.usenb lv > 0
206 :    
207 :     fun impurePO po = true (* if a PrimOP is pure or not *)
208 :    
209 :     fun eqConV (F.INTcon i1, F.INT i2) = i1 = i2
210 :     | eqConV (F.INT32con i1, F.INT32 i2) = i1 = i2
211 :     | eqConV (F.WORDcon i1, F.WORD i2) = i1 = i2
212 :     | eqConV (F.WORD32con i1, F.WORD32 i2) = i1 = i2
213 :     | eqConV (F.REALcon r1, F.REAL r2) = r1 = r2
214 :     | eqConV (F.STRINGcon s1, F.STRING s2) = s1 = s2
215 :     | eqConV (con,v) = bugval("unexpected comparison with val", v)
216 :    
217 :     fun lookup m lv = (M.lookup m lv)
218 :     (* handle e as M.IntmapF =>
219 :     (say "\nlooking up unbound ";
220 :     say (!PP.LVarString lv);
221 :     raise e) *)
222 :    
223 :     fun sval2val sv =
224 :     case sv
225 : monnier 159 of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...} | Decon{1=lv,...}
226 : monnier 121 | Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
227 :     | Val v => v
228 :    
229 :     fun val2sval m (F.VAR ov) = lookup m ov
230 :     | val2sval m v = Val v
231 :    
232 :     fun bugsv (msg,sv) = bugval(msg, sval2val sv)
233 :    
234 :     fun subst m ov = sval2val (lookup m ov)
235 :     val substval = sval2val o (val2sval m)
236 :     fun substvar lv =
237 :     case substval(F.VAR lv)
238 :     of F.VAR lv => lv
239 :     | v => bugval ("unexpected val", v)
240 :    
241 :     fun unuseval f (F.VAR lv) = C.unuse f false lv
242 :     | unuseval f _ = ()
243 :    
244 :     (* called when a variable becomes dead.
245 :     * it simply adjusts the use-counts *)
246 :     fun undertake m lv =
247 :     let val undertake = undertake m
248 :     in case lookup m lv
249 :     of Var {1=nlv,...} => ASSERT(nlv = lv, "nlv = lv")
250 :     | Val v => ()
251 :     | Fun (lv,le,args,_,_) =>
252 : monnier 159 (#2 (C.unuselexp undertake)) (lv, map #1 args, le)
253 :     | TFun{1=lv,2=le,...} => (#2 (C.unuselexp undertake)) (lv, [], le)
254 : monnier 121 | (Select {2=v,...} | Con {2=v,...}) => unuseval undertake v
255 :     | Record {2=vs,...} => app (unuseval undertake) vs
256 : monnier 159 (* decon's are implicit so we can't get rid of them *)
257 :     | Decon _ => ()
258 : monnier 121 end
259 :     handle M.IntmapF =>
260 :     (say "\nUnable to undertake "; PP.printSval(F.VAR lv))
261 :     | x =>
262 :     (say "\nwhile undertaking "; PP.printSval(F.VAR lv); raise x)
263 :    
264 :     fun addbind (m,lv,sv) = M.add(m, lv, sv)
265 :    
266 :     (* substitute a value sv for a variable lv and unuse value v.
267 :     * This doesn't quite work for eta-redex since the `use' we have
268 :     * to remove in that case is a non-escaping use, whereas this code
269 :     * assumes that we're getting rid of an escaping use *)
270 :     fun substitute (m, lv1, sv, v) =
271 :     (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
272 :     unuseval (undertake m) v;
273 :     addbind(m, lv1, sv)) handle x =>
274 :     (say "\nwhile substituting ";
275 :     PP.printSval (F.VAR lv1);
276 :     say " for ";
277 :     PP.printSval (sval2val sv);
278 :     raise x)
279 :    
280 :     (* common code for primops *)
281 :     fun cpo (SOME{default,table},po,lty,tycs) =
282 :     (SOME{default=substvar default,
283 :     table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
284 :     po,lty,tycs)
285 :     | cpo po = po
286 :    
287 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
288 :     (s, Access.EXN(Access.LVAR(substvar lv)), lty)
289 :     | cdcon dc = dc
290 :    
291 : monnier 159 (* F.APP inlining (if any)
292 :     * `ifs' is the set of function we are currently inlining
293 :     * `f' is the function, `vs' its arguments.
294 :     * return either (NONE, ifs) if inlining cannot be done or
295 :     * (SOME lexp, nifs) where `lexp' is the expansion of APP(f,vs) and
296 :     * `nifs' is the new set of functions we are currently inlining.
297 :     *)
298 :     fun inline ifs (f,vs) =
299 : monnier 121 case ((val2sval m f) handle x => raise x)
300 :     of Fun(g,body,args,F.FK_FUN{isrec,inline,...},od) =>
301 :     (ASSERT(C.usenb g > 0, "C.usenb g > 0");
302 :     if C.usenb g = 1 andalso od = d andalso not (C.recursive g)
303 :    
304 :     (* simple inlining: we should copy the body and then
305 :     * kill the function, but instead we just move the body
306 :     * and kill only the function name. This inlining strategy
307 :     * looks inoffensive enough, but still requires some care:
308 :     * see comments at the begining of this file and in cfun *)
309 :     then (C.unuse (fn _ => ()) true g; ASSERT(not (used g), "killed");
310 : monnier 159 (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
311 : monnier 121
312 :     (* aggressive inlining (but hopefully safe). We allow
313 :     * inlining for mutually recursive functions (isrec)
314 :     * despite the potential risk. The reason is that it can
315 :     * happen that a wrapper (that should be inlined) has to be made
316 :     * mutually recursive with its main function. On another hand,
317 :     * self recursion (C.recursive) is too dangerous to be inlined
318 :     * except for loop unrolling which we don't support yet *)
319 : monnier 159 else if inline andalso od = d andalso not(S.member ifs g) then
320 :     let val nle = FU.copy M.empty (F.LET(map #1 args, F.RET vs, body))
321 :     val _ = if C.recursive g then
322 :     (say "\n inlining recursive function ";
323 :     PP.printSval (F.VAR g)) else ()
324 : monnier 121 in C.uselexp nle;
325 :     app (unuseval (undertake m)) vs;
326 :     C.unuse (undertake m) true g;
327 : monnier 159 (SOME(nle, od), S.add(g, ifs))
328 : monnier 121 end
329 :    
330 : monnier 159 else (NONE, ifs))
331 :     | sv => (NONE, ifs)
332 : monnier 121 in
333 :     case le
334 :     of F.RET vs => F.RET((map substval vs) handle x => raise x)
335 :    
336 :     | F.LET (lvs,le,body) =>
337 :     let fun cassoc le = F.LET(lvs, le, body)
338 :     (* default behavior *)
339 :     fun clet () =
340 :     let val nle = loop m le
341 :     val nm = foldl (fn (lv,m) => addbind(m, lv, Var(lv, NONE)))
342 :     m lvs
343 :     in case loop nm body
344 :     of F.RET vs => if vs = (map F.VAR lvs) then nle
345 :     else F.LET(lvs, nle, F.RET vs)
346 :     | nbody => F.LET(lvs, nle, nbody)
347 :     end
348 :     val lopm = loop m
349 :     in case le
350 :     (* apply let associativity *)
351 :     of F.LET(lvs1,le',le) => lopm(F.LET(lvs1, le', cassoc le))
352 :     | F.FIX(fdecs,le) => lopm(F.FIX(fdecs, cassoc le))
353 :     | F.TFN(tfdec,le) => lopm(F.TFN(tfdec, cassoc le))
354 :     | F.CON(dc,tycs,v,lv,le) => lopm(F.CON(dc, tycs, v, lv, cassoc le))
355 :     | F.RECORD(rk,vs,lv,le) => lopm(F.RECORD(rk, vs, lv, cassoc le))
356 :     | F.SELECT(v,i,lv,le) => lopm(F.SELECT(v, i, lv, cassoc le))
357 :     | F.PRIMOP(po,vs,lv,le) => lopm(F.PRIMOP(po, vs, lv, cassoc le))
358 :     (* this is a hack originally meant to cleanup the BRANCH mess
359 :     * introduced in flintnm (where each branch returns just true or
360 :     * false which is generally only used as input to a SWITCH).
361 :     * The present code does slightly more than clean up this case *)
362 :     | F.BRANCH (po,vs,le1,le2) =>
363 :     let fun known (F.RECORD(_,_,_,le)) = known le
364 :     | known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')
365 :     | known (F.RET[F.VAR v]) = false
366 :     | known (F.RET[_]) = true
367 :     | known _ = false
368 :     fun cassoc (lv,v,body) wrap =
369 :     if lv = v andalso C.usenb lv = 1 andalso
370 :     known le1 andalso known le2 then
371 :     (* here I should also check that le1 != le2 *)
372 :     let val nle1 = F.LET([lv], le1, body)
373 : monnier 159 val nlv = cplv lv
374 :     val body2 = FU.copy (M.add(M.empty,lv,nlv)) body
375 : monnier 121 val nle2 = F.LET([nlv], le2, body2)
376 :     in C.new false nlv; C.uselexp body2;
377 :     lopm(wrap(F.BRANCH(po, vs, nle1, nle2)))
378 :     end
379 :     else
380 :     clet()
381 :     in case (lvs,body)
382 :     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
383 :     cassoc(lv, v, le) (fn x => x)
384 :     | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
385 :     cassoc(lv, v, le) (fn le => F.LET(lvs,le,rest))
386 :     | _ => clet()
387 :     end
388 :     | F.RET vs =>
389 :     (let fun simplesubst ((lv,v),m) =
390 :     let val sv = (val2sval m v) handle x => raise x
391 :     in substitute(m, lv, sv, sval2val sv)
392 :     end
393 :     in loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body
394 :     end handle x => raise x)
395 :     | F.APP(f,vs) =>
396 : monnier 159 (case inline ifs (f, vs)
397 :     of (SOME(le,od),ifs) => cexp (d,od) ifs m (F.LET(lvs, le, body))
398 :     | (NONE,_) => clet())
399 : monnier 121 | (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>
400 :     clet()
401 :     end
402 :    
403 :     | F.FIX (fs,le) =>
404 :     let fun cfun (m,[]:F.fundec list,acc) = acc
405 :     | cfun (m,fdec as (fk,f,args,body)::fs,acc) =
406 :     if used f then
407 :     let (* make up the bindings for args inside the body *)
408 :     fun addnobind ((lv,lty),m) =
409 :     addbind(m, lv, Var(lv, SOME lty))
410 :     val nm = foldl addnobind m args
411 :     (* contract the body and create the resulting fundec *)
412 :     val nbody = C.inside f (fn()=> loop nm body)
413 :     (* fixup the fkind info with new data.
414 :     * C.recursive only tells us if a fun is self-recursive
415 :     * but doesn't deal with mutual recursion.
416 :     * Also the `inline' bit has to be turned off because
417 :     * it applied to the function before contraction
418 :     * but might not apply to its new form (inlining might
419 :     * have increased its size substantially or made it
420 :     * recursive in a different way which could make further
421 :     * inlining even dangerous) *)
422 :     val nfk =
423 :     case fk of F.FK_FCT => fk
424 :     | F.FK_FUN {isrec,fixed,known,inline} =>
425 :     let val nisrec = if isSome isrec andalso
426 :     null fs andalso
427 :     null acc andalso
428 :     not(C.recursive f)
429 :     then NONE else isrec
430 :     val nknown = known orelse not(C.escaping f)
431 :     in F.FK_FUN{isrec=nisrec, fixed=fixed,
432 :     inline=false, known=nknown}
433 :     end
434 :     (* update the binding in the map. This step is not
435 :     * not just a mere optimization but is necessary
436 :     * because if we don't do it and the function
437 :     * gets inlined afterwards, the counts will reflect the
438 :     * new contracted code while we'll be working on the
439 :     * the old uncontracted code *)
440 :     val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))
441 :     in cfun(nm, fs, (nfk, f, args, nbody)::acc)
442 :     end
443 :     else cfun(m, fs, acc)
444 :    
445 :     (* check for eta redex *)
446 :     fun ceta ((fk,f,args,F.APP(g,vs)):F.fundec,(m,hs)) =
447 :     if vs = (map (F.VAR o #1) args) andalso
448 :     (* don't forget to check that g is not one of the args
449 :     * and not f itself either *)
450 :     (List.find (fn v => v = g) (F.VAR f::vs)) = NONE
451 :     then
452 :     let val svg = val2sval m g
453 :     val g = case sval2val svg
454 :     of F.VAR g => g
455 :     | v => bugval("not a variable", v)
456 :     (* NOTE: we don't want to turn a known function into an
457 :     * escaping one. It's dangerous for optimisations based
458 :     * on known functions (elimination of dead args, f.ex)
459 :     * and could generate cases where call>use in collect *)
460 :     in if not (C.escaping f andalso
461 :     not (C.escaping g))
462 :     then let
463 :     (* if an earlier function h has been eta-reduced
464 :     * to f, we have to be careful to update its
465 :     * binding to not refer to f any more since f
466 :     * will disappear *)
467 :     val nm = foldl (fn (h,m) =>
468 :     if sval2val(lookup m h) = F.VAR f
469 :     then addbind(m, h, svg) else m)
470 :     m hs
471 :     in
472 :     (* if g is one of the members of the FIX, f might
473 :     * appear in its body, so we don't know what parts
474 :     * of the counts of f should be counted as inside
475 :     * g and what parts should be counted as outside
476 :     * so we take the conservative approach of counting
477 :     * them in both *)
478 :     if isSome(List.find (fn (_,f,_,_) => f = g) fs)
479 :     then C.inside g (fn()=> C.addto(f,g)) else ();
480 :     C.transfer(f,g); C.unuse (undertake nm) true g;
481 :     (addbind(nm, f, svg),f::hs)
482 :     end
483 :     else (m, hs)
484 :     end
485 :     else (m, hs)
486 :     | ceta (_,(m,hs)) = (m, hs)
487 :    
488 :     (* junk unused funs *)
489 :     val fs = List.filter (used o #2) fs
490 :    
491 :     (* register the new bindings (uncontracted for now) *)
492 :     val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
493 :     addbind(m, f, Fun(f, body, args, fk, od)))
494 :     m fs
495 :     (* check for eta redexes *)
496 :     val (nm,_) = foldl ceta (nm,[]) fs
497 :    
498 :     (* move the inlinable functions to the end of the list *)
499 :     val (f1s,f2s) =
500 :     List.partition (fn (F.FK_FUN{inline,...},_,_,_) => inline
501 :     | _ => false) fs
502 :     val fs = f2s @ f1s
503 :    
504 :     (* contract the main body *)
505 :     val nle = loop nm le
506 :     (* contract the functions *)
507 :     val fs = cfun(nm, fs, [])
508 :     (* junk newly unused funs *)
509 :     val fs = List.filter (used o #2) fs
510 :     in
511 :     if List.null fs then nle else F.FIX(fs,nle)
512 :     end
513 :    
514 :     | F.APP (f,vs) =>
515 :     let val nvs = ((map substval vs) handle x => raise x)
516 : monnier 159 in case inline ifs (f, nvs)
517 :     of (SOME(le,od),ifs) => cexp (d,od) ifs m le
518 :     | (NONE,_) => F.APP((substval f) handle x => raise x, nvs)
519 : monnier 121 end
520 :    
521 :     | F.TFN ((f,args,body),le) =>
522 :     if used f then
523 : monnier 159 let val nbody = cexp (DI.next d, DI.next od) ifs m body
524 : monnier 121 val nm = addbind(m, f, TFun(f, nbody, args, od))
525 :     val nle = loop nm le
526 :     in
527 :     if used f then F.TFN((f, args, nbody), nle) else nle
528 :     end
529 :     else loop m le
530 :    
531 :     | F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)
532 :    
533 :     | F.SWITCH (v,ac,arms,def) =>
534 :     (case ((val2sval m v) handle x => raise x)
535 : monnier 162 of sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
536 :     | (* will probably never happen *) Record{1=lvc,...}) =>
537 : monnier 121 let fun carm (F.DATAcon(dc,tycs,lv),le) =
538 :     let val ndc = cdcon dc
539 : monnier 159 val nm = addbind(m, lv, Decon(lv, F.VAR lvc, ndc, tycs))
540 : monnier 162 (* we can rebind lv to a more precise value
541 :     * !!BEWARE!! This rebinding is misleading:
542 :     * - it gives the impression that `lvc' is built from
543 :     * `lv' although the reverse is true: if `lvc' is
544 :     * undertaken, `lv's count should *not* be updated!
545 :     * Luckily, `lvc' will not become dead while rebound
546 :     * to Con(lv) because it's used by the SWITCH.
547 :     * All in all, it works fine, but it's not as
548 :     * straightforward as it seems.
549 :     * - it seems to be a good idea, but it can hide
550 :     * other opt-opportunities since it hides the
551 :     * previous binding. *)
552 : monnier 159 val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))
553 : monnier 121 in (F.DATAcon(ndc, tycs, lv), loop nm le)
554 :     end
555 :     | carm (con,le) = (con, loop m le)
556 :     val narms = map carm arms
557 :     val ndef = Option.map (loop m) def
558 :     in
559 :     F.SWITCH(sval2val sv, ac, narms, ndef)
560 :     end
561 : monnier 159
562 :     | Con (lvc,v,dc1,tycs1) =>
563 :     let fun killle le = (#1 (C.unuselexp (undertake m))) le
564 :     fun kill lv le =
565 :     (#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le
566 :     fun killarm (F.DATAcon(_,_,lv),le) = kill lv le
567 :     | killarm _ = buglexp("bad arm in switch(con)", le)
568 :    
569 :     fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) =
570 :     if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
571 :     (map killarm tl; (* kill the rest *)
572 :     Option.map killle def; (* and the default case *)
573 :     loop (substitute(m, lv, val2sval m v, F.VAR lvc)) le)
574 :     else
575 :     (* kill this arm and continue with the rest *)
576 :     (kill lv le; carm tl)
577 : monnier 121 | carm [] = loop m (Option.valOf def)
578 :     | carm _ = buglexp("unexpected arm in switch(con,...)", le)
579 :     in carm arms
580 :     end
581 :    
582 :     | Val v =>
583 : monnier 159 let fun kill le = (#1 (C.unuselexp (undertake m))) le
584 :     fun carm ((con,le)::tl) =
585 :     if eqConV(con, v) then
586 :     (map (kill o #2) tl; Option.map kill def; loop m le)
587 :     else (kill le; carm tl)
588 : monnier 121 | carm [] = loop m (Option.valOf def)
589 :     in carm arms
590 :     end
591 :     | sv as (Fun _ | TFun _) =>
592 :     bugval("unexpected switch arg", sval2val sv))
593 :    
594 : monnier 159 | F.CON (dc1,tycs1,v,lv,le) =>
595 :     (* Here we should try to nullify CON(DECON x) => x *)
596 : monnier 121 if used lv then
597 : monnier 159 let val ndc = cdcon dc1
598 :     fun ccon sv =
599 :     let val nv = sval2val sv
600 :     val nm = addbind(m, lv, Con(lv, nv, ndc, tycs1))
601 :     val nle = loop nm le
602 :     in if used lv then F.CON(ndc, tycs1, nv, lv, nle) else nle
603 :     end
604 :     in case ((val2sval m v) handle x => raise x)
605 :     of sv as (Decon (lvd,vc,dc2,tycs2)) =>
606 :     if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
607 :     let val sv = (val2sval m vc) handle x => raise x
608 :     in loop (substitute(m, lv, sv, F.VAR lvd)) le
609 :     end
610 :     else ccon sv
611 :     | sv => ccon sv
612 : monnier 121 end
613 :     else loop m le
614 :    
615 :     | F.RECORD (rk,vs,lv,le) =>
616 :     (* Here I could try to see if I'm reconstructing a preexisting record.
617 :     * The `lty option' of Var is there just for that purpose *)
618 :     if used lv then
619 : monnier 159 (* g: check whether the record already exists *)
620 :     let fun g (n,Select(_,v1,i)::ss) =
621 :     if n = i then
622 :     (case ss
623 :     of Select(_,v2,_)::_ =>
624 :     if v1 = v2 then g(n+1, ss) else NONE
625 :     | [] =>
626 :     (case sval2lty (val2sval m v1)
627 :     of SOME lty =>
628 :     let val ltd = case rk
629 :     of F.RK_STRUCT => LT.ltd_str
630 :     | F.RK_TUPLE _ => LT.ltd_tuple
631 :     | _ => buglexp("bogus rk",le)
632 :     in if length(ltd lty) = n+1
633 :     then SOME v1 else NONE
634 :     end
635 :     | _ => NONE) (* sad case *)
636 :     | _ => NONE)
637 :     else NONE
638 :     | g _ = NONE
639 :     val svs = ((map (val2sval m) vs) handle x => raise x)
640 :     in case g (0,svs)
641 :     of SOME v =>
642 :     let val sv = (val2sval m v) handle x => raise x
643 :     in loop (substitute(m, lv, sv, F.INT 0)) le
644 :     before app (unuseval (undertake m)) vs
645 :     end
646 :     | _ =>
647 :     let val nvs = map sval2val svs
648 :     val nm = addbind(m, lv, Record(lv, nvs))
649 :     val nle = loop nm le
650 :     in if used lv then F.RECORD(rk, nvs, lv, nle) else nle
651 :     end
652 : monnier 121 end
653 :     else loop m le
654 :    
655 :     | F.SELECT (v,i,lv,le) =>
656 :     if used lv then
657 :     case ((val2sval m v) handle x => raise x)
658 :     of Record (lvr,vs) =>
659 :     let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x
660 :     in loop (substitute(m, lv, sv, F.VAR lvr)) le
661 :     end
662 :     | sv =>
663 :     let val nv = sval2val sv
664 :     val nm = addbind (m, lv, Select(lv, nv, i))
665 :     val nle = loop nm le
666 :     in if used lv then F.SELECT(nv, i, lv, nle) else nle
667 :     end
668 :     else loop m le
669 :    
670 :     | F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)
671 :    
672 :     | F.HANDLE (le,v) => F.HANDLE(loop m le, (substval v) handle x => raise x)
673 :    
674 :     | F.BRANCH (po,vs,le1,le2) =>
675 :     let val nvs = ((map substval vs) handle x => raise x)
676 :     val npo = cpo po
677 :     val nle1 = loop m le1
678 :     val nle2 = loop m le2
679 :     in F.BRANCH(npo, nvs, nle1, nle2)
680 :     end
681 :    
682 :     | F.PRIMOP (po,vs,lv,le) =>
683 :     let val impure = impurePO po
684 :     in if impure orelse used lv then
685 :     let val nvs = ((map substval vs) handle x => raise x)
686 :     val npo = cpo po
687 :     val nm = addbind(m, lv, Var(lv,NONE))
688 :     val nle = loop nm le
689 :     in
690 :     if impure orelse used lv
691 :     then F.PRIMOP(npo, nvs, lv, nle)
692 :     else nle
693 :     end
694 :     else loop m le
695 :     end
696 :     end
697 :    
698 :     fun contract (fdec as (_,f,_,_)) =
699 :     (C.collect fdec;
700 : monnier 159 case cexp (DI.top,DI.top) S.empty M.empty (F.FIX([fdec], F.RET[F.VAR f]))
701 : monnier 121 of F.FIX([fdec], F.RET[F.VAR f]) => fdec
702 :     | fdec => bug "invalid return fundec")
703 :    
704 :     end
705 :     end

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