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 199 - (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 : monnier 190 val contract : FLINT.prog * Stats.counter -> FLINT.prog
9 : monnier 121
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 184 * - dropping of dead arguments
26 : monnier 159 *)
27 :    
28 : monnier 121 (* things that lcontract.sml does that fcontract doesn't do (yet):
29 : monnier 159 * - inline across DeBruijn depths (will be solved by named-tvar)
30 : monnier 121 * - elimination of let [dead-vs] = pure in body
31 :     *)
32 :    
33 :     (* things that cpsopt/eta.sml did that fcontract doesn't do:
34 : monnier 159 * - let f vs = select(v,i,g,g vs)
35 : monnier 121 *)
36 :    
37 :     (* things that cpsopt/contract.sml did that fcontract doesn't do:
38 : monnier 159 * - IF-idiom (I still don't know what it is)
39 : monnier 121 * - unifying branches
40 :     * - Handler operations
41 :     * - primops expressions
42 :     * - branch expressions
43 :     *)
44 :    
45 :     (* things that could also be added:
46 : monnier 184 * - elimination of dead vars in let
47 : monnier 191 * - elimination of constant arguments
48 : monnier 121 *)
49 :    
50 :     (* things that would require some type info:
51 :     * - dropping foo in LET vs = RAISE v IN foo
52 :     *)
53 :    
54 :     (* eta-reduction is tricky:
55 :     * - recognition of eta-redexes and introduction of the corresponding
56 :     * substitution in the table has to be done at the very beginning of
57 :     * the processing of the FIX
58 :     * - eta-reduction can turn a known function into an escaping function
59 :     * - fun f (g,v2,v3) = g(g,v2,v3) looks tremendously like an eta-redex
60 :     *)
61 :    
62 :     (* order of contraction is important:
63 :     * - the body of a FIX is contracted before the functions because the
64 :     * functions might end up being inlined in the body in which case they
65 :     * could be contracted twice.
66 :     *)
67 :    
68 :     (* When creating substitution f->g (as happens with eta redexes or with
69 :     * code like `LET [f] = RET[g]'), we need to make sure that the usage cout
70 :     * of f gets properly transfered to g. One way to do that is to make the
71 :     * transfer incremental: each time we apply the substitution, we decrement
72 :     * f's count and increment g's count. But this can be tricky since the
73 :     * elimination of the eta-redex (or the trivial binding) eliminates one of the
74 : monnier 159 * references to g and if this is the only one, we might trigger the killing
75 : monnier 121 * of g even though its count would be later incremented. Similarly, inlining
76 :     * of g would be dangerous as long as some references to f exist.
77 :     * So instead we do the transfer once and for all when we see the eta-redex,
78 :     * which frees us from those two problems but forces us to make sure that
79 :     * every existing reference to f will be substituted with g.
80 :     * Also, the transfer of counts from f to g is not quite straightforward
81 :     * since some of the references to f might be from inside g and without doing
82 :     * the transfer incrementally, we can't easily know which of the usage counts
83 :     * of f should be transfered to the internal counts of g and which to the
84 :     * external counts.
85 :     *)
86 :    
87 : monnier 159 (* Preventing infinite inlining:
88 :     * - inlining a function in its own body amounts to unrolling which has
89 :     * to be controlled (you only want to unroll some number of times).
90 :     * It's currently simply not allowed.
91 :     * - inlining a recursive function outside of tis body amounts to `peeling'
92 :     * one iteration. Here also, since the inlined body will have yet another
93 :     * call, the inlining risks non-termination. It's hence also
94 :     * not allowed.
95 :     * - inlining a mutually recursive function is just a more general form
96 :     * of the problem above although it can be safe and desirable in some cases.
97 :     * To be safe, you simply need that one of the functions forming the
98 :     * mutual-recursion loop cannot be inlined (to break the loop). This cannot
99 :     * be trivially checked. So we (foolishly?) trust the `inline' bit in
100 :     * those cases. This is mostly used to inline wrappers inside the
101 :     * function they wrap.
102 :     * - even if one only allows inlining of funtions showing no sign of
103 :     * recursion, we can be bitten by a program creating its own Y combinator:
104 :     * datatype dt = F of dt -> int -> int
105 :     * let fun f (F g) x = g (F g) x in f (F f) end
106 :     * To solve this problem, `cexp' has an `ifs' parameter containing the set
107 :     * of funtions that we are inlining in order to detect (and break) cycles.
108 :     * - funnily enough, if we allow inlining recursive functions the cycle
109 :     * detection will ensure that the unrolling (or peeling) will only be done
110 :     * once. In the future, maybe.
111 :     *)
112 :    
113 : monnier 184 (* Dropping useless arguments.
114 :     * Arguments whose value is constant (i.e. the function is known and each
115 :     * call site provides the same value for that argument (or the argument
116 :     * itself in the case of recursive calls) can be safely removed and replaced
117 :     * inside the body by a simple let binding. The only problem is that the
118 :     * constant argument might be out of scope at the function definition site.
119 :     * It is obviously always possible to move the function to bring the argument
120 :     * in scope, but since we don't do any code motion here, we're stuck.
121 :     * If it wasn't for this little problem, we could do the cst-arg removal in
122 :     * collect (we don't gain anything from doing it here).
123 :     * The removal of dead arguments (args not used in the body) on the other
124 :     * hand can quite well be done in collect, the only problem being that it
125 :     * is convenient to do it after the cst-arg removal so that we can rely
126 :     * on deadarg to do the actual removal of the cst-arg.
127 :     *)
128 :    
129 : monnier 121 (* Simple inlining (inlining called-once functions, which doesn't require
130 :     * alpha-renaming) seems inoffensive enough but is not always desirable.
131 : monnier 159 * The typical example is wrapper functions introduced by eta-expand: they
132 :     * usually (until inlined) contain the only call to the main function,
133 : monnier 121 * but inlining the main function in the wrapper defeats the purpose of the
134 :     * wrapper.
135 :     * cpsopt dealt with this problem by adding a `NO_INLINE_INTO' hint to the
136 : monnier 159 * wrapper function. In this file, the idea is the following:
137 :     * If you have a function declaration like `let f x = body in exp', first
138 :     * contract `exp' and only contract `body' afterwards. This ensures that
139 :     * the eta-wrapper gets a chance to be inlined before it is (potentially)
140 :     * eta-reduced away. Interesting details:
141 : monnier 121 * - all functions (even the ones that would have a `NO_INLINE_INTO') are
142 :     * contracted, because the "aggressive usage count maintenance" makes any
143 :     * alternative painful (the collect phase has already assumed that dead code
144 :     * will be eliminated, which means that fcontract should at the very least
145 : monnier 159 * do the dead-code elimination, so you can only avoid fcontracting a
146 :     * a function if you can be sure that the body doesn't contain any dead-code,
147 :     * which is generally not known).
148 : monnier 190 * - once a function is fcontracted, its inlinable status is re-examined.
149 :     * More specifically, if no inlining occured during its fcontraction, then
150 :     * we assume that the code has just become smaller and should hence
151 :     * still be considered inlinable. On another hand, if inlining took place,
152 :     * then we have to reset the inline-bit because the new body might
153 :     * be completely different (i.e. much bigger) and inlining it might be
154 :     * undesirable.
155 : monnier 159 * This means that in the case of
156 :     * let fwrap x = body1 and f y = body2 in exp
157 : monnier 190 * if fwrap is fcontracted before f and something gets inlined into it,
158 :     * then fwrap cannot be inlined in f.
159 : monnier 159 * To minimize the impact of this problem, we make sure that we fcontract
160 :     * inlinable functions only after fcontracting other mutually recursive
161 : monnier 190 * functions. One way to solve the problem more thoroughly would be
162 :     * to keep the uncontracted fwrap around until f has been contracted.
163 :     * Such a trick hasn't seemed necessary yet.
164 : monnier 121 * - at the very end of the optimization phase, cpsopt had a special pass
165 :     * that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
166 :     * into it doesn't have any undesirable side effects any more). The present
167 :     * code doesn't need such a thing. On another hand, the cpsopt approach
168 :     * had the advantage of keeping the `inline' bit from one contract phase to
169 : monnier 159 * the next. If this ends up being important, one could add a global
170 : monnier 121 * "noinline" flag that could be set to true whenever fcontracting an
171 : monnier 159 * inlinable function (this would ensure that fcontracting such an inlinable
172 :     * function can only reduce its size, which would allow keeping the `inline'
173 :     * bit set after fcontracting).
174 : monnier 121 *)
175 :    
176 :     structure FContract :> FCONTRACT =
177 :     struct
178 :     local
179 :     structure F = FLINT
180 :     structure M = IntmapF
181 : monnier 159 structure S = IntSetF
182 : monnier 121 structure C = Collect
183 : monnier 184 structure O = Option
184 : monnier 121 structure DI = DebIndex
185 :     structure PP = PPFlint
186 : monnier 159 structure FU = FlintUtil
187 :     structure LT = LtyExtern
188 : monnier 163 structure OU = OptUtils
189 : monnier 159 structure CTRL = Control.FLINT
190 : monnier 121 in
191 :    
192 :     val say = Control.Print.say
193 :     fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
194 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
195 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
196 :    
197 :     (* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
198 :    
199 : monnier 159 val cplv = LambdaVar.dupLvar
200 : monnier 121
201 :     datatype sval
202 :     = Val of F.value (* F.value should never be F.VAR lv *)
203 : monnier 197 | Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind
204 :     | TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list
205 : monnier 189 | Record of F.lvar * sval list
206 :     | Con of F.lvar * sval * F.dcon * F.tyc list
207 :     | Decon of F.lvar * sval * F.dcon * F.tyc list
208 :     | Select of F.lvar * sval * int
209 : monnier 121 | Var of F.lvar * F.lty option (* cop out case *)
210 :    
211 : monnier 159 fun sval2lty (Var(_,x)) = x
212 :     | sval2lty (Decon(_,_,(_,_,lty),tycs)) =
213 :     SOME(hd(#2 (LT.ltd_arrow (hd(LT.lt_inst(lty, tycs))))))
214 : monnier 199 | sval2lty (Select(_,sv,i)) =
215 :     (case sval2lty sv of SOME lty => SOME(LT.lt_select(lty, i)) | _ => NONE)
216 : monnier 159 | sval2lty _ = NONE
217 : monnier 121
218 : monnier 159 fun tycs_eq ([],[]) = true
219 :     | tycs_eq (tyc1::tycs1,tyc2::tycs2) =
220 :     LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
221 :     | tycs_eq _ = false
222 : monnier 121
223 : monnier 189 fun click s c = (if !CTRL.misc = 1 then say s else (); Stats.addCounter c 1)
224 : monnier 185
225 : monnier 189 (* val c_inline = Stats.newCounter[] *)
226 :     (* val c_deadval = Stats.newCounter[] *)
227 :     (* val c_deadlexp = Stats.newCounter[] *)
228 :     (* val c_select = Stats.newCounter[] *)
229 :     (* val c_record = Stats.newCounter[] *)
230 :     (* val c_lacktype = Stats.newCounter[] *)
231 :     (* val c_con = Stats.newCounter[] *)
232 :     (* val c_switch = Stats.newCounter[] *)
233 :     (* val c_eta = Stats.newCounter[] *)
234 :     (* val c_etasplit = Stats.newCounter[] *)
235 :     (* val c_branch = Stats.newCounter[] *)
236 :     (* val c_dropargs = Stats.newCounter[] *)
237 : monnier 185
238 : monnier 189 fun contract (fdec as (_,f,_,_), counter) = let
239 :    
240 :     val c_dummy = Stats.newCounter[]
241 :     val c_miss = Stats.newCounter[]
242 :    
243 :     fun click_deadval () = (click "d" counter)
244 :     fun click_deadlexp () = (click "D" counter)
245 :     fun click_select () = (click "s" counter)
246 :     fun click_record () = (click "r" counter)
247 :     fun click_con () = (click "c" counter)
248 :     fun click_switch () = (click "s" counter)
249 :     fun click_eta () = (click "e" counter)
250 :     fun click_etasplit () = (click "E" counter)
251 :     fun click_branch () = (click "b" counter)
252 :     fun click_dropargs () = (click "a" counter)
253 :    
254 :     fun click_lacktype () = (click "t" c_miss)
255 :    
256 :     (* this counters is actually *used* by fcontract.
257 :     * It's not used just for statistics. *)
258 :     val c_inline = Stats.newCounter[counter]
259 :     (* val c_inline1 = Stats.newCounter[c_inline] *)
260 :     (* val c_inline2 = Stats.newCounter[c_inline] *)
261 :     (* val c_unroll = Stats.newCounter[c_inline] *)
262 :     fun click_simpleinline () = (click "i" c_inline)
263 :     fun click_copyinline () = (click "I" c_inline)
264 :     fun click_unroll () = (click "u" c_inline)
265 :     fun inline_count () = Stats.getCounter c_inline
266 :    
267 : monnier 186 fun used lv = (C.usenb(C.get lv) > 0)
268 : monnier 199 (* handle x =>
269 : monnier 186 (say("while in FContract.used "^(C.LVarString lv)^"\n");
270 : monnier 199 raise x) *)
271 : monnier 121
272 :     fun impurePO po = true (* if a PrimOP is pure or not *)
273 :    
274 :     fun eqConV (F.INTcon i1, F.INT i2) = i1 = i2
275 :     | eqConV (F.INT32con i1, F.INT32 i2) = i1 = i2
276 :     | eqConV (F.WORDcon i1, F.WORD i2) = i1 = i2
277 :     | eqConV (F.WORD32con i1, F.WORD32 i2) = i1 = i2
278 :     | eqConV (F.REALcon r1, F.REAL r2) = r1 = r2
279 :     | eqConV (F.STRINGcon s1, F.STRING s2) = s1 = s2
280 :     | eqConV (con,v) = bugval("unexpected comparison with val", v)
281 :    
282 :     fun lookup m lv = (M.lookup m lv)
283 :     (* handle e as M.IntmapF =>
284 :     (say "\nlooking up unbound ";
285 :     say (!PP.LVarString lv);
286 :     raise e) *)
287 :    
288 :     fun sval2val sv =
289 :     case sv
290 : monnier 159 of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...} | Decon{1=lv,...}
291 : monnier 121 | Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
292 :     | Val v => v
293 :    
294 : monnier 163 fun val2sval m (F.VAR ov) =
295 : monnier 199 ((lookup m ov) (* handle x =>
296 :     (say("val2sval "^(C.LVarString ov)^"\n"); raise x) *) )
297 : monnier 121 | val2sval m v = Val v
298 :    
299 :     fun bugsv (msg,sv) = bugval(msg, sval2val sv)
300 :    
301 :     fun subst m ov = sval2val (lookup m ov)
302 : monnier 199 fun substval m = sval2val o (val2sval m)
303 :     fun substvar m lv =
304 :     case substval m (F.VAR lv)
305 : monnier 121 of F.VAR lv => lv
306 :     | v => bugval ("unexpected val", v)
307 :    
308 :     (* called when a variable becomes dead.
309 :     * it simply adjusts the use-counts *)
310 :     fun undertake m lv =
311 :     let val undertake = undertake m
312 :     in case lookup m lv
313 : monnier 186 of Var {1=nlv,...} => ()
314 : monnier 121 | Val v => ()
315 : monnier 197 | Fun (lv,le,args,_) =>
316 : monnier 187 C.unuselexp undertake
317 :     (F.LET(map #1 args,
318 :     F.RET (map (fn _ => F.INT 0) args),
319 :     le))
320 :     | TFun{1=lv,2=le,...} =>
321 :     C.unuselexp undertake le
322 : monnier 189 | (Select {2=sv,...} | Con {2=sv,...}) => unusesval m sv
323 :     | Record {2=svs,...} => app (unusesval m) svs
324 : monnier 159 (* decon's are implicit so we can't get rid of them *)
325 :     | Decon _ => ()
326 : monnier 121 end
327 :     handle M.IntmapF =>
328 : monnier 186 (say("Unable to undertake "^(C.LVarString lv)^"\n"))
329 : monnier 121 | x =>
330 : monnier 186 (say("while undertaking "^(C.LVarString lv)^"\n"); raise x)
331 : monnier 121
332 : monnier 189 and unusesval m sv = unuseval m (sval2val sv)
333 : monnier 187 and unuseval m (F.VAR lv) =
334 :     if (C.unuse false (C.get lv)) then undertake m lv else ()
335 :     | unuseval f _ = ()
336 :     fun unusecall m lv =
337 :     if (C.unuse true (C.get lv)) then undertake m lv else ()
338 :    
339 :    
340 : monnier 121 fun addbind (m,lv,sv) = M.add(m, lv, sv)
341 :    
342 : monnier 164 (* substitute a value sv for a variable lv and unuse value v. *)
343 : monnier 121 fun substitute (m, lv1, sv, v) =
344 :     (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
345 : monnier 187 unuseval m v;
346 : monnier 199 addbind(m, lv1, sv)) (* handle x =>
347 : monnier 186 (say ("while substituting "^
348 : monnier 164 (C.LVarString lv1)^
349 :     " -> ");
350 : monnier 121 PP.printSval (sval2val sv);
351 : monnier 199 raise x) *)
352 : monnier 121
353 :     (* common code for primops *)
354 : monnier 199 fun cpo m (SOME{default,table},po,lty,tycs) =
355 :     (SOME{default=substvar m default,
356 :     table=map (fn (tycs,lv) => (tycs, substvar m lv)) table},
357 : monnier 121 po,lty,tycs)
358 : monnier 199 | cpo _ po = po
359 : monnier 121
360 : monnier 199 fun cdcon m (s,Access.EXN(Access.LVAR lv),lty) =
361 :     (s, Access.EXN(Access.LVAR(substvar m lv)), lty)
362 :     | cdcon _ dc = dc
363 : monnier 121
364 : monnier 199 (* cfg: is used for deBruijn renumbering when inlining at different depths
365 :     * ifs (inlined functions): records which functions we're currently inlining
366 :     * in order to detect loops
367 :     * m: is a map lvars to their defining expressions (svals) *)
368 :     fun cexp ifs m le cont = let
369 :     val loop = cexp ifs
370 :     val substval = substval m
371 :     val cdcon = cdcon m
372 :     val cpo = cpo m
373 :     in case le
374 :     of F.RET vs => cont(m, F.RET(map substval vs))
375 : monnier 163
376 : monnier 121 | F.LET (lvs,le,body) =>
377 : monnier 184 let fun clet () =
378 :     loop m le
379 :     (fn (m,F.RET vs) =>
380 : monnier 190 let fun simplesubst (lv,v,m) =
381 : monnier 199 let val sv = val2sval m v
382 : monnier 184 in substitute(m, lv, sv, sval2val sv)
383 :     end
384 : monnier 190 val nm = (ListPair.foldl simplesubst m (lvs, vs))
385 : monnier 184 in loop nm body cont
386 :     end
387 :     | (m,nle) =>
388 :     let val nm = (foldl (fn (lv,m) =>
389 :     addbind(m, lv, Var(lv, NONE)))
390 :     m lvs)
391 :     in case loop nm body cont
392 :     of F.RET vs => if vs = (map F.VAR lvs) then nle
393 :     else F.LET(lvs, nle, F.RET vs)
394 :     | nbody => F.LET(lvs, nle, nbody)
395 :     end)
396 : monnier 199 in (* case le
397 : monnier 184 of F.BRANCH (po,vs,le1,le2) =>
398 :     (* this is a hack originally meant to cleanup the BRANCH mess
399 :     * introduced in flintnm (where each branch returns just true or
400 :     * false which is generally only used as input to a SWITCH).
401 :     * The present code does slightly more than clean up this case *)
402 : monnier 121 let fun known (F.RECORD(_,_,_,le)) = known le
403 :     | known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')
404 :     | known (F.RET[F.VAR v]) = false
405 :     | known (F.RET[_]) = true
406 :     | known _ = false
407 : monnier 184 fun cassoc (lv,v,body,wrap) =
408 : monnier 186 if lv = v andalso ((C.usenb(C.get lv)) handle x=> raise x) = 1 andalso
409 : monnier 121 known le1 andalso known le2 then
410 :     (* here I should also check that le1 != le2 *)
411 :     let val nle1 = F.LET([lv], le1, body)
412 : monnier 159 val nlv = cplv lv
413 : monnier 164 val _ = C.new NONE nlv
414 :     val body2 = C.copylexp (M.add(M.empty, lv, nlv))
415 :     body
416 : monnier 121 val nle2 = F.LET([nlv], le2, body2)
417 : monnier 164 in
418 : monnier 189 click_branch();
419 : monnier 184 loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont
420 : monnier 121 end
421 :     else
422 :     clet()
423 :     in case (lvs,body)
424 :     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
425 : monnier 190 cassoc(lv, v, le, fn x => x)
426 : monnier 121 | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
427 : monnier 184 cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))
428 : monnier 121 | _ => clet()
429 :     end
430 : monnier 199 | _ => *) clet()
431 : monnier 121 end
432 : monnier 184
433 : monnier 121 | F.FIX (fs,le) =>
434 : monnier 189 let (* The actual function contraction *)
435 : monnier 164 fun cfun (m,[]:F.fundec list,acc) = acc
436 : monnier 184 | cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
437 : monnier 189 let val fi = C.get f
438 :     in if C.dead fi then cfun(m, fs, acc)
439 :     else if C.iusenb fi = C.usenb fi then
440 :     (* we need to be careful that undertake not be called
441 :     * recursively *)
442 :     (C.use NONE fi; undertake m f; cfun(m, fs, acc))
443 :     else
444 : monnier 164 let (* val _ = say ("\nEntering "^(C.LVarString f)) *)
445 : monnier 189 val saved_ic = inline_count()
446 : monnier 164 (* make up the bindings for args inside the body *)
447 : monnier 121 fun addnobind ((lv,lty),m) =
448 :     addbind(m, lv, Var(lv, SOME lty))
449 :     val nm = foldl addnobind m args
450 :     (* contract the body and create the resulting fundec *)
451 : monnier 197 val nbody = cexp (S.add(f, ifs)) nm body #2
452 : monnier 185 (* if inlining took place, the body might be completely
453 :     * changed (read: bigger), so we have to reset the
454 :     * `inline' bit *)
455 : monnier 184 val nfk = {isrec=isrec, cconv=cconv,
456 : monnier 189 known=known orelse not(C.escaping fi),
457 :     inline=if inline_count() = saved_ic
458 :     then inline
459 :     else F.IH_SAFE}
460 : monnier 199 (* update the binding in the map. This step is
461 : monnier 121 * not just a mere optimization but is necessary
462 :     * because if we don't do it and the function
463 :     * gets inlined afterwards, the counts will reflect the
464 :     * new contracted code while we'll be working on the
465 :     * the old uncontracted code *)
466 : monnier 197 val nm = addbind(m, f, Fun(f, nbody, args, nfk))
467 : monnier 121 in cfun(nm, fs, (nfk, f, args, nbody)::acc)
468 : monnier 164 (* before say ("\nExiting "^(C.LVarString f)) *)
469 : monnier 121 end
470 : monnier 189 end
471 : monnier 121
472 :     (* check for eta redex *)
473 : monnier 199 fun ceta (fdec as (fk,f,args,F.APP(F.VAR g,vs)):F.fundec,
474 :     (m,fs,hs)) =
475 :     if List.length args = List.length vs andalso
476 :     OU.ListPair_all (fn (v,(lv,t)) =>
477 :     case v of F.VAR v => v = lv andalso lv <> g
478 :     | _ => false)
479 :     (vs, args)
480 : monnier 121 then
481 : monnier 199 let val svg = lookup m g
482 : monnier 121 val g = case sval2val svg
483 :     of F.VAR g => g
484 :     | v => bugval("not a variable", v)
485 :     (* NOTE: we don't want to turn a known function into an
486 :     * escaping one. It's dangerous for optimisations based
487 :     * on known functions (elimination of dead args, f.ex)
488 :     * and could generate cases where call>use in collect *)
489 : monnier 189 in if (C.escaping(C.get f)) andalso not(C.escaping(C.get g))
490 :     (* the default case could ensure the inline *)
491 :     then (m, fdec::fs, hs)
492 :     else let
493 : monnier 121 (* if an earlier function h has been eta-reduced
494 :     * to f, we have to be careful to update its
495 :     * binding to not refer to f any more since f
496 :     * will disappear *)
497 :     val nm = foldl (fn (h,m) =>
498 :     if sval2val(lookup m h) = F.VAR f
499 :     then addbind(m, h, svg) else m)
500 :     m hs
501 : monnier 164 in
502 :     (* I could almost reuse `substitute' but the
503 :     * unuse in substitute assumes the val is escaping *)
504 : monnier 189 click_eta();
505 : monnier 164 C.transfer(f, g);
506 : monnier 187 unusecall m g;
507 : monnier 186 (addbind(m, f, svg), fs, f::hs)
508 : monnier 121 end
509 :     end
510 : monnier 186 else (m, fdec::fs, hs)
511 :     | ceta (fdec,(m,fs,hs)) = (m,fdec::fs,hs)
512 : monnier 121
513 : monnier 184 (* add wrapper for various purposes *)
514 :     fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs
515 :     | wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
516 : monnier 189 let val gi = C.get g
517 :     fun dropargs filter =
518 : monnier 184 let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)
519 : monnier 164 val args' = filter args
520 : monnier 163 val ng = cplv g
521 :     val nargs = map (fn (v,t) => (cplv v, t)) args
522 : monnier 164 val nargs' = map #1 (filter nargs)
523 :     val appargs = (map F.VAR nargs')
524 : monnier 184 val nf = (nfk, g, nargs, F.APP(F.VAR ng, appargs))
525 : monnier 164 val nf' = (nfk', ng, args', body)
526 : monnier 186
527 :     val ngi = C.new (SOME(map #1 args')) ng
528 : monnier 184 in
529 : monnier 189 C.ireset gi;
530 :     app (ignore o (C.new NONE) o #1) nargs;
531 : monnier 186 C.use (SOME appargs) ngi;
532 : monnier 189 app (C.use NONE o C.get) nargs';
533 : monnier 184 nf'::nf::fs
534 : monnier 163 end
535 : monnier 190 in
536 : monnier 189 (* Don't introduce wrappers for escaping-only functions.
537 :     * This is debatable since although wrappers are useless
538 :     * on escaping-only functions, some of the escaping uses
539 :     * might turn into calls in the course of fcontract, so
540 :     * by not introducing wrappers here, we avoid useless work
541 :     * but we also postpone useful work to later invocations. *)
542 : monnier 190 if C.dead gi then fs else
543 :     let val used = map (used o #1) args
544 :     in if C.called gi then
545 :     (* if some args are not used, let's drop them *)
546 :     if not (List.all (fn x => x) used) then
547 :     (click_dropargs();
548 :     dropargs (fn xs => OU.filter(used, xs)))
549 :    
550 :     (* eta-split: add a wrapper for escaping uses *)
551 :     else if C.escaping gi then
552 :     (* like dropargs but keeping all args *)
553 :     (click_etasplit(); dropargs (fn x => x))
554 :    
555 :     else f::fs
556 :     else f::fs
557 :     end
558 : monnier 184 end
559 : monnier 163
560 : monnier 184 (* add various wrappers *)
561 :     val fs = foldl wrap [] fs
562 :    
563 : monnier 121 (* register the new bindings (uncontracted for now) *)
564 :     val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
565 : monnier 197 addbind(m, f, Fun(f, body, args, fk)))
566 : monnier 121 m fs
567 :     (* check for eta redexes *)
568 : monnier 186 val (nm,fs,_) = foldl ceta (nm,[],[]) fs
569 : monnier 121
570 :     (* move the inlinable functions to the end of the list *)
571 :     val (f1s,f2s) =
572 : monnier 184 List.partition (fn ({inline=F.IH_ALWAYS,...},_,_,_) => true
573 : monnier 121 | _ => false) fs
574 :     val fs = f2s @ f1s
575 :    
576 :     (* contract the main body *)
577 : monnier 184 val nle = loop nm le cont
578 : monnier 121 (* contract the functions *)
579 :     val fs = cfun(nm, fs, [])
580 :     (* junk newly unused funs *)
581 :     val fs = List.filter (used o #2) fs
582 :     in
583 : monnier 163 case fs
584 :     of [] => nle
585 : monnier 184 | [f1 as ({isrec=NONE,...},_,_,_),f2] =>
586 : monnier 186 (* gross hack: `wrap' might have added a second
587 : monnier 163 * non-recursive function. we need to split them into
588 : monnier 184 * 2 FIXes. This is _very_ ad-hoc *)
589 : monnier 163 F.FIX([f2], F.FIX([f1], nle))
590 :     | _ => F.FIX(fs, nle)
591 : monnier 121 end
592 :    
593 :     | F.APP (f,vs) =>
594 : monnier 199 let val nvs = map substval vs
595 :     val svf = val2sval m f
596 :     (* F.APP inlining (if any) *)
597 :     in case svf
598 :     of Fun(g,body,args,{inline,...}) =>
599 :     if (C.usenb(C.get g)) = 1 andalso not(S.member ifs g) then
600 :    
601 :     (* simple inlining: we should copy the body and then
602 :     * kill the function, but instead we just move the body
603 :     * and kill only the function name.
604 :     * This inlining strategy looks inoffensive enough,
605 :     * but still requires some care: see comments at the
606 :     * begining of this file and in cfun *)
607 :     (click_simpleinline();
608 :     ignore(C.unuse true (C.get g));
609 :     loop m (F.LET(map #1 args, F.RET vs, body)) cont)
610 :    
611 :     (* aggressive (but safe) inlining. We allow pretty much
612 :     * any inlinling, but we detect and reject inlining
613 :     * recursively which would else lead to infinite loop *)
614 :     (* unrolling is not as straightforward as it seems:
615 :     * if you inline the function you're currently
616 :     * fcontracting, you're asking for trouble: there is a
617 :     * hidden assumption in the counting that the old code
618 :     * will be replaced by the new code (and is hence dead).
619 :     * If the function to be unrolled has the only call to
620 :     * function f, then f might get simpleinlined before
621 :     * unrolling, which means that unrolling will introduce
622 :     * a second occurence of the `only call' but at that point
623 :     * f has already been killed. *)
624 :     else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) then
625 :     let val nle =
626 :     C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
627 :     in
628 :     click_copyinline();
629 :     (app (unuseval m) vs);
630 :     unusecall m g;
631 :     cexp (S.add(g, ifs)) m nle cont
632 :     end
633 :     else cont(m,F.APP(sval2val svf, nvs))
634 :     | sv => cont(m,F.APP(sval2val svf, nvs))
635 : monnier 121 end
636 :    
637 :     | F.TFN ((f,args,body),le) =>
638 : monnier 189 let val fi = C.get f
639 :     in if C.dead fi then (click_deadlexp(); loop m le cont) else
640 : monnier 197 let val nbody = cexp ifs m body #2
641 :     val nm = addbind(m, f, TFun(f, nbody, args))
642 : monnier 186 val nle = loop nm le cont
643 :     in
644 : monnier 189 if C.dead fi then nle else F.TFN((f, args, nbody), nle)
645 : monnier 186 end
646 : monnier 189 end
647 : monnier 121
648 : monnier 184 | F.TAPP(f,tycs) =>
649 : monnier 189 (* (case val2sval m f
650 :     of TFun(g,body,args,od) =>
651 :     if d = od andalso C.usenb(C.get g) = 1 then
652 :     let val (_,_,_,le) =
653 :     ({inline=false,isrec=NONE,known=false,cconv=F.CC_FCT},
654 :     LV.mkLvar(),[],
655 :     F.TFN((g,args,body),TAPP(g,tycs)))
656 :     in
657 :     inlineWitness := true;
658 :     ignore(C.unuse true (C.get g));
659 :     end *)
660 : monnier 199 cont(m, F.TAPP(substval f, tycs))
661 : monnier 121
662 :     | F.SWITCH (v,ac,arms,def) =>
663 : monnier 199 (case val2sval m v
664 : monnier 189 of sv as Con (lvc,svc,dc1,tycs1) =>
665 : monnier 187 let fun killle le = C.unuselexp (undertake m) le
666 : monnier 159 fun kill lv le =
667 : monnier 187 C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))) le
668 : monnier 159 fun killarm (F.DATAcon(_,_,lv),le) = kill lv le
669 :     | killarm _ = buglexp("bad arm in switch(con)", le)
670 :    
671 :     fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) =
672 : monnier 185 (* sometimes lty1 <> lty2 :-( so this doesn't work:
673 :     * FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) *)
674 :     if #2 dc1 = #2 (cdcon dc2) then
675 : monnier 159 (map killarm tl; (* kill the rest *)
676 : monnier 185 O.map killle def; (* and the default case *)
677 : monnier 189 loop (substitute(m, lv, svc, F.VAR lvc))
678 : monnier 184 le cont)
679 : monnier 159 else
680 :     (* kill this arm and continue with the rest *)
681 :     (kill lv le; carm tl)
682 : monnier 185 | carm [] = loop m (O.valOf def) cont
683 : monnier 121 | carm _ = buglexp("unexpected arm in switch(con,...)", le)
684 : monnier 189 in click_switch(); carm arms
685 : monnier 121 end
686 :    
687 : monnier 185 | sv as Val v =>
688 : monnier 187 let fun kill le = C.unuselexp (undertake m) le
689 : monnier 159 fun carm ((con,le)::tl) =
690 :     if eqConV(con, v) then
691 : monnier 184 (map (kill o #2) tl;
692 : monnier 185 O.map kill def;
693 : monnier 184 loop m le cont)
694 : monnier 159 else (kill le; carm tl)
695 : monnier 185 | carm [] = loop m (O.valOf def) cont
696 : monnier 189 in click_switch(); carm arms
697 : monnier 121 end
698 : monnier 185
699 :     | sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
700 :     | (* will probably never happen *) Record{1=lvc,...}) =>
701 :     (case (arms,def)
702 :     of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>
703 :     (* this is a mere DECON, so we can push the let binding
704 :     * (hidden in cont) inside and maybe even drop the DECON *)
705 :     let val ndc = cdcon dc
706 : monnier 189 val slv = Decon(lv, sv, ndc, tycs)
707 :     val nm = addbind(m, lv, slv)
708 : monnier 185 (* see below *)
709 : monnier 199 (* val nm = addbind(nm, lvc, Con(lvc, slv, ndc, tycs)) *)
710 : monnier 185 val nle = loop nm le cont
711 :     val nv = sval2val sv
712 :     in
713 :     if used lv then
714 :     F.SWITCH(nv,ac,[(F.DATAcon(ndc,tycs,lv),nle)],NONE)
715 : monnier 187 else (unuseval m nv; nle)
716 : monnier 185 end
717 :     | (([(_,le)],NONE) | ([],SOME le)) =>
718 :     (* This should never happen, but we can optimize it away *)
719 : monnier 189 (unuseval m (sval2val sv); loop m le cont)
720 : monnier 185 | _ =>
721 :     let fun carm (F.DATAcon(dc,tycs,lv),le) =
722 :     let val ndc = cdcon dc
723 : monnier 189 val slv = Decon(lv, sv, ndc, tycs)
724 :     val nm = addbind(m, lv, slv)
725 : monnier 185 (* we can rebind lv to a more precise value
726 :     * !!BEWARE!! This rebinding is misleading:
727 :     * - it gives the impression that `lvc' is built
728 :     * from`lv' although the reverse is true:
729 :     * if `lvc' is undertaken, `lv's count should
730 :     * *not* be updated!
731 :     * Luckily, `lvc' will not become dead while
732 :     * rebound to Con(lv) because it's used by the
733 :     * SWITCH. All in all, it works fine, but it's
734 :     * not as straightforward as it seems.
735 :     * - it seems to be a good idea, but it can hide
736 :     * other opt-opportunities since it hides the
737 :     * previous binding. *)
738 : monnier 199 (* val nm = addbind(nm, lvc, Con(lvc,slv,ndc,tycs)) *)
739 : monnier 185 in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
740 :     end
741 :     | carm (con,le) = (con, loop m le #2)
742 :     val narms = map carm arms
743 :     val ndef = Option.map (fn le => loop m le #2) def
744 :     in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))
745 :     end)
746 :    
747 : monnier 121 | sv as (Fun _ | TFun _) =>
748 :     bugval("unexpected switch arg", sval2val sv))
749 :    
750 : monnier 159 | F.CON (dc1,tycs1,v,lv,le) =>
751 : monnier 189 let val lvi = C.get lv
752 :     in if C.dead lvi then (click_deadval(); loop m le cont) else
753 : monnier 186 let val ndc = cdcon dc1
754 :     fun ccon sv =
755 : monnier 189 let val nm = addbind(m, lv, Con(lv, sv, ndc, tycs1))
756 : monnier 186 val nle = loop nm le cont
757 : monnier 189 in if C.dead lvi then nle
758 :     else F.CON(ndc, tycs1, sval2val sv, lv, nle)
759 : monnier 186 end
760 : monnier 199 in case val2sval m v
761 : monnier 189 of sv as (Decon (lvd,sv',dc2,tycs2)) =>
762 : monnier 186 if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
763 : monnier 189 (click_con();
764 :     loop (substitute(m, lv, sv', F.VAR lvd)) le cont)
765 : monnier 186 else ccon sv
766 :     | sv => ccon sv
767 :     end
768 : monnier 189 end
769 : monnier 121
770 :     | F.RECORD (rk,vs,lv,le) =>
771 : monnier 164 (* g: check whether the record already exists *)
772 : monnier 189 let val lvi = C.get lv
773 :     in if C.dead lvi then (click_deadval(); loop m le cont) else
774 :     let fun g (Select(_,sv,0)::ss) =
775 :     let fun g' (n,Select(_,sv',i)::ss) =
776 :     if n = i andalso (sval2val sv) = (sval2val sv')
777 :     then g'(n+1,ss) else NONE
778 :     | g' (n,[]) =
779 :     (case sval2lty sv
780 :     of SOME lty =>
781 :     let val ltd = case rk
782 :     of F.RK_STRUCT => LT.ltd_str
783 :     | F.RK_TUPLE _ => LT.ltd_tuple
784 :     | _ => buglexp("bogus rk",le)
785 :     in if length(ltd lty) = n
786 :     then SOME sv else NONE
787 :     end
788 :     | _ => (click_lacktype(); NONE)) (* sad *)
789 :     | g' _ = NONE
790 :     in g'(1,ss)
791 :     end
792 : monnier 186 | g _ = NONE
793 : monnier 199 val svs = map (val2sval m) vs
794 : monnier 189 in case g svs
795 :     of SOME sv => (click_record();
796 :     loop (substitute(m, lv, sv, F.INT 0)) le cont
797 :     before app (unuseval m) vs)
798 :     | _ =>
799 :     let val nm = addbind(m, lv, Record(lv, svs))
800 : monnier 186 val nle = loop nm le cont
801 : monnier 189 in if C.dead lvi then nle
802 :     else F.RECORD(rk, map sval2val svs, lv, nle)
803 : monnier 186 end
804 :     end
805 : monnier 189 end
806 : monnier 121
807 :     | F.SELECT (v,i,lv,le) =>
808 : monnier 189 let val lvi = C.get lv
809 :     in if C.dead lvi then (click_deadval(); loop m le cont) else
810 : monnier 199 (case val2sval m v
811 : monnier 189 of Record (lvr,svs) =>
812 :     let val sv = List.nth(svs, i)
813 :     in click_select();
814 :     loop (substitute(m, lv, sv, F.VAR lvr)) le cont
815 : monnier 186 end
816 :     | sv =>
817 : monnier 189 let val nm = addbind (m, lv, Select(lv, sv, i))
818 : monnier 186 val nle = loop nm le cont
819 : monnier 189 in if C.dead lvi then nle
820 :     else F.SELECT(sval2val sv, i, lv, nle)
821 : monnier 186 end)
822 : monnier 189 end
823 : monnier 121
824 : monnier 184 | F.RAISE (v,ltys) =>
825 : monnier 199 cont(m, F.RAISE(substval v, ltys))
826 : monnier 121
827 : monnier 184 | F.HANDLE (le,v) =>
828 : monnier 199 cont(m, F.HANDLE(loop m le #2, substval v))
829 : monnier 121
830 :     | F.BRANCH (po,vs,le1,le2) =>
831 : monnier 199 let val nvs = map substval vs
832 : monnier 121 val npo = cpo po
833 : monnier 184 val nle1 = loop m le1 #2
834 :     val nle2 = loop m le2 #2
835 :     in cont(m, F.BRANCH(npo, nvs, nle1, nle2))
836 : monnier 121 end
837 :    
838 :     | F.PRIMOP (po,vs,lv,le) =>
839 : monnier 189 let val lvi = C.get lv
840 :     val pure = not(impurePO po)
841 :     in if pure andalso C.dead lvi then (click_deadval();loop m le cont) else
842 : monnier 199 let val nvs = map substval vs
843 : monnier 186 val npo = cpo po
844 :     val nm = addbind(m, lv, Var(lv,NONE))
845 :     val nle = loop nm le cont
846 :     in
847 : monnier 189 if pure andalso C.dead lvi then nle
848 :     else F.PRIMOP(npo, nvs, lv, nle)
849 : monnier 186 end
850 : monnier 121 end
851 :     end
852 :    
853 : monnier 185 in
854 :     (* C.collect fdec; *)
855 : monnier 197 case cexp S.empty
856 : monnier 185 M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
857 :     of F.FIX([fdec], F.RET[F.VAR f]) => fdec
858 :     | fdec => bug "invalid return fundec"
859 :     end
860 : monnier 121
861 :     end
862 :     end

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