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 185 - (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 184 * - dropping of dead arguments
26 :     * - elimination of constant arguments
27 : monnier 159 *)
28 :    
29 : monnier 121 (* things that lcontract.sml does that fcontract doesn't do (yet):
30 : monnier 159 * - inline across DeBruijn depths (will be solved by named-tvar)
31 : monnier 121 * - elimination of let [dead-vs] = pure in body
32 :     *)
33 :    
34 :     (* things that cpsopt/eta.sml did that fcontract doesn't do:
35 : monnier 159 * - let f vs = select(v,i,g,g vs)
36 : monnier 121 *)
37 :    
38 :     (* things that cpsopt/contract.sml did that fcontract doesn't do:
39 : monnier 159 * - IF-idiom (I still don't know what it is)
40 : monnier 121 * - unifying branches
41 :     * - Handler operations
42 :     * - primops expressions
43 :     * - branch expressions
44 :     *)
45 :    
46 :     (* things that could also be added:
47 : monnier 184 * - elimination of dead vars in let
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 121 * - once a function is fcontracted it is marked as non-inlinable since
149 : monnier 159 * fcontraction might have changed its shape considerably (via inlining).
150 :     * This means that in the case of
151 :     * let fwrap x = body1 and f y = body2 in exp
152 :     * if fwrap is fcontracted before f, then fwrap cannot be inlined in f.
153 :     * To minimize the impact of this problem, we make sure that we fcontract
154 :     * inlinable functions only after fcontracting other mutually recursive
155 :     * functions.
156 : monnier 121 * - at the very end of the optimization phase, cpsopt had a special pass
157 :     * that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
158 :     * into it doesn't have any undesirable side effects any more). The present
159 :     * code doesn't need such a thing. On another hand, the cpsopt approach
160 :     * had the advantage of keeping the `inline' bit from one contract phase to
161 : monnier 159 * the next. If this ends up being important, one could add a global
162 : monnier 121 * "noinline" flag that could be set to true whenever fcontracting an
163 : monnier 159 * inlinable function (this would ensure that fcontracting such an inlinable
164 :     * function can only reduce its size, which would allow keeping the `inline'
165 :     * bit set after fcontracting).
166 : monnier 121 *)
167 :    
168 :     structure FContract :> FCONTRACT =
169 :     struct
170 :     local
171 :     structure F = FLINT
172 :     structure M = IntmapF
173 : monnier 159 structure S = IntSetF
174 : monnier 121 structure C = Collect
175 : monnier 184 structure O = Option
176 : monnier 121 structure DI = DebIndex
177 :     structure PP = PPFlint
178 : monnier 159 structure FU = FlintUtil
179 :     structure LT = LtyExtern
180 : monnier 163 structure OU = OptUtils
181 : monnier 159 structure CTRL = Control.FLINT
182 : monnier 121 in
183 :    
184 :     val say = Control.Print.say
185 :     fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
186 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
187 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
188 :    
189 :     (* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
190 :    
191 :     fun ASSERT (true,_) = ()
192 :     | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
193 :    
194 : monnier 159 val cplv = LambdaVar.dupLvar
195 : monnier 121
196 :     datatype sval
197 :     = Val of F.value (* F.value should never be F.VAR lv *)
198 :     | Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth
199 :     | TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth
200 :     | Record of F.lvar * F.value list
201 : monnier 159 | Con of F.lvar * F.value * F.dcon * F.tyc list
202 :     | Decon of F.lvar * F.value * F.dcon * F.tyc list
203 : monnier 121 | Select of F.lvar * F.value * int
204 :     | Var of F.lvar * F.lty option (* cop out case *)
205 :    
206 : monnier 159 fun sval2lty (Var(_,x)) = x
207 :     | sval2lty (Decon(_,_,(_,_,lty),tycs)) =
208 :     SOME(hd(#2 (LT.ltd_arrow (hd(LT.lt_inst(lty, tycs))))))
209 :     | sval2lty _ = NONE
210 : monnier 121
211 : monnier 159 fun tycs_eq ([],[]) = true
212 :     | tycs_eq (tyc1::tycs1,tyc2::tycs2) =
213 :     LT.tc_eqv(tyc1,tyc2) andalso tycs_eq(tycs1,tycs2)
214 :     | tycs_eq _ = false
215 : monnier 121
216 : monnier 185 fun contract (fdec as (_,f,_,_)) = let
217 :    
218 :     val inlineWitness = ref false
219 :    
220 : monnier 159 (* cfg: is used for deBruijn renumbering when inlining at different depths
221 :     * ifs (inlined functions): records which functions we're currently inlining
222 :     * in order to detect loops
223 :     * m: is a map lvars to their defining expressions (svals) *)
224 : monnier 184 fun cexp (cfg as (d,od)) ifs m le cont = let
225 : monnier 159
226 :     val loop = cexp cfg ifs
227 :    
228 : monnier 121 fun used lv = C.usenb lv > 0
229 :    
230 :     fun impurePO po = true (* if a PrimOP is pure or not *)
231 :    
232 :     fun eqConV (F.INTcon i1, F.INT i2) = i1 = i2
233 :     | eqConV (F.INT32con i1, F.INT32 i2) = i1 = i2
234 :     | eqConV (F.WORDcon i1, F.WORD i2) = i1 = i2
235 :     | eqConV (F.WORD32con i1, F.WORD32 i2) = i1 = i2
236 :     | eqConV (F.REALcon r1, F.REAL r2) = r1 = r2
237 :     | eqConV (F.STRINGcon s1, F.STRING s2) = s1 = s2
238 :     | eqConV (con,v) = bugval("unexpected comparison with val", v)
239 :    
240 :     fun lookup m lv = (M.lookup m lv)
241 :     (* handle e as M.IntmapF =>
242 :     (say "\nlooking up unbound ";
243 :     say (!PP.LVarString lv);
244 :     raise e) *)
245 :    
246 :     fun sval2val sv =
247 :     case sv
248 : monnier 159 of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...} | Decon{1=lv,...}
249 : monnier 121 | Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
250 :     | Val v => v
251 :    
252 : monnier 163 fun val2sval m (F.VAR ov) =
253 :     ((lookup m ov) handle x => (PP.printSval(F.VAR ov); raise x))
254 : monnier 121 | val2sval m v = Val v
255 :    
256 :     fun bugsv (msg,sv) = bugval(msg, sval2val sv)
257 :    
258 :     fun subst m ov = sval2val (lookup m ov)
259 :     val substval = sval2val o (val2sval m)
260 :     fun substvar lv =
261 :     case substval(F.VAR lv)
262 :     of F.VAR lv => lv
263 :     | v => bugval ("unexpected val", v)
264 :    
265 : monnier 164 fun unuseval f (F.VAR lv) = ((C.unuse f false lv) handle x => raise x)
266 : monnier 121 | unuseval f _ = ()
267 :    
268 :     (* called when a variable becomes dead.
269 :     * it simply adjusts the use-counts *)
270 :     fun undertake m lv =
271 :     let val undertake = undertake m
272 :     in case lookup m lv
273 :     of Var {1=nlv,...} => ASSERT(nlv = lv, "nlv = lv")
274 :     | Val v => ()
275 :     | Fun (lv,le,args,_,_) =>
276 : monnier 159 (#2 (C.unuselexp undertake)) (lv, map #1 args, le)
277 :     | TFun{1=lv,2=le,...} => (#2 (C.unuselexp undertake)) (lv, [], le)
278 : monnier 121 | (Select {2=v,...} | Con {2=v,...}) => unuseval undertake v
279 :     | Record {2=vs,...} => app (unuseval undertake) vs
280 : monnier 159 (* decon's are implicit so we can't get rid of them *)
281 :     | Decon _ => ()
282 : monnier 121 end
283 :     handle M.IntmapF =>
284 :     (say "\nUnable to undertake "; PP.printSval(F.VAR lv))
285 :     | x =>
286 :     (say "\nwhile undertaking "; PP.printSval(F.VAR lv); raise x)
287 :    
288 :     fun addbind (m,lv,sv) = M.add(m, lv, sv)
289 :    
290 : monnier 164 (* substitute a value sv for a variable lv and unuse value v. *)
291 : monnier 121 fun substitute (m, lv1, sv, v) =
292 :     (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
293 :     unuseval (undertake m) v;
294 :     addbind(m, lv1, sv)) handle x =>
295 : monnier 164 (say ("\nwhile substituting "^
296 :     (C.LVarString lv1)^
297 :     " -> ");
298 : monnier 121 PP.printSval (sval2val sv);
299 :     raise x)
300 :    
301 :     (* common code for primops *)
302 :     fun cpo (SOME{default,table},po,lty,tycs) =
303 :     (SOME{default=substvar default,
304 :     table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
305 :     po,lty,tycs)
306 :     | cpo po = po
307 :    
308 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
309 :     (s, Access.EXN(Access.LVAR(substvar lv)), lty)
310 :     | cdcon dc = dc
311 :    
312 : monnier 184 fun zip ([],[]) = []
313 :     | zip (x::xs,y::ys) = (x,y)::(zip(xs,ys))
314 :     | zip _ = bug "bad zip"
315 : monnier 163
316 : monnier 159 (* F.APP inlining (if any)
317 :     * `ifs' is the set of function we are currently inlining
318 :     * `f' is the function, `vs' its arguments.
319 :     * return either (NONE, ifs) if inlining cannot be done or
320 :     * (SOME lexp, nifs) where `lexp' is the expansion of APP(f,vs) and
321 :     * `nifs' is the new set of functions we are currently inlining.
322 :     *)
323 :     fun inline ifs (f,vs) =
324 : monnier 121 case ((val2sval m f) handle x => raise x)
325 : monnier 184 of Fun(g,body,args,{inline,...},od) =>
326 : monnier 164 (ASSERT(used g, "used "^(C.LVarString g));
327 : monnier 184 if d <> od then (NONE, ifs)
328 :     else if C.usenb g = 1 andalso not(S.member ifs g) then
329 : monnier 121
330 : monnier 184 (* simple inlining: we should copy the body and then
331 :     * kill the function, but instead we just move the body
332 :     * and kill only the function name. This inlining strategy
333 :     * looks inoffensive enough, but still requires some care:
334 :     * see comments at the begining of this file and in cfun *)
335 : monnier 185 (inlineWitness := true;
336 :     C.unuse (fn _ => ()) true g;
337 : monnier 184 ASSERT(not (used g), "killed");
338 :     (SOME(F.LET(map #1 args, F.RET vs, body), od), ifs))
339 : monnier 121
340 :     (* aggressive inlining (but hopefully safe). We allow
341 :     * inlining for mutually recursive functions (isrec)
342 :     * despite the potential risk. The reason is that it can
343 :     * happen that a wrapper (that should be inlined) has to be made
344 :     * mutually recursive with its main function. On another hand,
345 :     * self recursion (C.recursive) is too dangerous to be inlined
346 : monnier 184 * except for loop unrolling *)
347 :     else if (inline = F.IH_ALWAYS andalso not(S.member ifs g)) orelse
348 :     (inline = F.IH_UNROLL andalso (S.member ifs g)) then
349 : monnier 163 let val nle =
350 : monnier 164 C.copylexp M.empty (F.LET(map #1 args, F.RET vs, body))
351 : monnier 184 in
352 : monnier 185 inlineWitness := true;
353 : monnier 184 (* say ("\nInlining "^(C.LVarString g)); *)
354 : monnier 164 (app (unuseval (undertake m)) vs) handle x => raise x;
355 :     (C.unuse (undertake m) true g) handle x => raise x;
356 : monnier 184 (SOME(nle, od),
357 :     (* gross hack: to prevent further unrolling,
358 :     * I pretend that the rest is not inside the body *)
359 :     if inline = F.IH_UNROLL then S.rmv(g, ifs) else S.add(g, ifs))
360 : monnier 121 end
361 : monnier 159 else (NONE, ifs))
362 :     | sv => (NONE, ifs)
363 : monnier 121 in
364 :     case le
365 : monnier 184 of F.RET vs => cont(m, F.RET(map substval vs) handle x => raise x)
366 : monnier 121
367 :     | F.LET (lvs,le,body) =>
368 : monnier 184 let fun clet () =
369 :     loop m le
370 :     (fn (m,F.RET vs) =>
371 :     let fun simplesubst ((lv,v),m) =
372 :     let val sv = (val2sval m v) handle x => raise x
373 :     in substitute(m, lv, sv, sval2val sv)
374 :     end
375 :     val nm = (foldl simplesubst m (zip(lvs, vs)))
376 :     in loop nm body cont
377 :     end
378 :     | (m,nle) =>
379 :     let val nm = (foldl (fn (lv,m) =>
380 :     addbind(m, lv, Var(lv, NONE)))
381 :     m lvs)
382 :     in case loop nm body cont
383 :     of F.RET vs => if vs = (map F.VAR lvs) then nle
384 :     else F.LET(lvs, nle, F.RET vs)
385 :     | nbody => F.LET(lvs, nle, nbody)
386 :     end)
387 : monnier 121 in case le
388 : monnier 184 of F.BRANCH (po,vs,le1,le2) =>
389 :     (* this is a hack originally meant to cleanup the BRANCH mess
390 :     * introduced in flintnm (where each branch returns just true or
391 :     * false which is generally only used as input to a SWITCH).
392 :     * The present code does slightly more than clean up this case *)
393 : monnier 121 let fun known (F.RECORD(_,_,_,le)) = known le
394 :     | known (F.CON(_,_,_,v,F.RET[F.VAR v'])) = (v = v')
395 :     | known (F.RET[F.VAR v]) = false
396 :     | known (F.RET[_]) = true
397 :     | known _ = false
398 : monnier 184 fun cassoc (lv,v,body,wrap) =
399 : monnier 121 if lv = v andalso C.usenb lv = 1 andalso
400 :     known le1 andalso known le2 then
401 :     (* here I should also check that le1 != le2 *)
402 :     let val nle1 = F.LET([lv], le1, body)
403 : monnier 159 val nlv = cplv lv
404 : monnier 164 val _ = C.new NONE nlv
405 :     val body2 = C.copylexp (M.add(M.empty, lv, nlv))
406 :     body
407 : monnier 121 val nle2 = F.LET([nlv], le2, body2)
408 : monnier 164 in
409 : monnier 184 loop m (wrap(F.BRANCH(po, vs, nle1, nle2))) cont
410 : monnier 121 end
411 :     else
412 :     clet()
413 :     in case (lvs,body)
414 :     of ([lv],le as F.SWITCH(F.VAR v,_,_,NONE)) =>
415 : monnier 184 cassoc(lv, v, le, OU.id)
416 : monnier 121 | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,NONE),rest)) =>
417 : monnier 184 cassoc(lv, v, le, fn le => F.LET(lvs,le,rest))
418 : monnier 121 | _ => clet()
419 :     end
420 : monnier 184 | _ => clet()
421 : monnier 121 end
422 : monnier 184
423 : monnier 121 | F.FIX (fs,le) =>
424 : monnier 164 let (* register dump bindings *)
425 :     val m = foldl (fn (fdec as (_,f,_,_),m) =>
426 :     addbind(m, f, Var(f,NONE)))
427 :     m fs
428 :    
429 :     (* The actual function contraction *)
430 :     fun cfun (m,[]:F.fundec list,acc) = acc
431 : monnier 184 | cfun (m,fdec as ({inline,cconv,known,isrec},f,args,body)::fs,acc) =
432 : monnier 121 if used f then
433 : monnier 164 let (* val _ = say ("\nEntering "^(C.LVarString f)) *)
434 : monnier 185 val oldWitness =
435 :     (!inlineWitness before inlineWitness := false)
436 : monnier 164 (* make up the bindings for args inside the body *)
437 : monnier 121 fun addnobind ((lv,lty),m) =
438 :     addbind(m, lv, Var(lv, SOME lty))
439 :     val nm = foldl addnobind m args
440 :     (* contract the body and create the resulting fundec *)
441 : monnier 184 val nbody = cexp cfg (S.add(f, ifs)) nm body #2
442 : monnier 185 (* if inlining took place, the body might be completely
443 :     * changed (read: bigger), so we have to reset the
444 :     * `inline' bit *)
445 : monnier 184 val nfk = {isrec=isrec, cconv=cconv,
446 : monnier 185 known=known orelse not(C.escaping f),
447 :     inline=if !inlineWitness
448 :     then F.IH_SAFE
449 :     else (inline before
450 :     inlineWitness := oldWitness)}
451 : monnier 121 (* update the binding in the map. This step is not
452 :     * not just a mere optimization but is necessary
453 :     * because if we don't do it and the function
454 :     * gets inlined afterwards, the counts will reflect the
455 :     * new contracted code while we'll be working on the
456 :     * the old uncontracted code *)
457 :     val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))
458 :     in cfun(nm, fs, (nfk, f, args, nbody)::acc)
459 : monnier 164 (* before say ("\nExiting "^(C.LVarString f)) *)
460 : monnier 121 end
461 :     else cfun(m, fs, acc)
462 :    
463 :     (* check for eta redex *)
464 :     fun ceta ((fk,f,args,F.APP(g,vs)):F.fundec,(m,hs)) =
465 :     if vs = (map (F.VAR o #1) args) andalso
466 :     (* don't forget to check that g is not one of the args
467 :     * and not f itself either *)
468 :     (List.find (fn v => v = g) (F.VAR f::vs)) = NONE
469 :     then
470 :     let val svg = val2sval m g
471 :     val g = case sval2val svg
472 :     of F.VAR g => g
473 :     | v => bugval("not a variable", v)
474 :     (* NOTE: we don't want to turn a known function into an
475 :     * escaping one. It's dangerous for optimisations based
476 :     * on known functions (elimination of dead args, f.ex)
477 :     * and could generate cases where call>use in collect *)
478 : monnier 185 in if not (C.escaping f andalso not (C.escaping g))
479 : monnier 121 then let
480 :     (* if an earlier function h has been eta-reduced
481 :     * to f, we have to be careful to update its
482 :     * binding to not refer to f any more since f
483 :     * will disappear *)
484 :     val nm = foldl (fn (h,m) =>
485 :     if sval2val(lookup m h) = F.VAR f
486 :     then addbind(m, h, svg) else m)
487 :     m hs
488 : monnier 164 in
489 :     (* I could almost reuse `substitute' but the
490 :     * unuse in substitute assumes the val is escaping *)
491 :     C.transfer(f, g);
492 :     C.unuse (undertake m) true g;
493 :     (addbind(m, f, svg), f::hs)
494 : monnier 121 end
495 : monnier 163 (* the default case could ensure the inline *)
496 : monnier 121 else (m, hs)
497 :     end
498 :     else (m, hs)
499 :     | ceta (_,(m,hs)) = (m, hs)
500 :    
501 : monnier 164 (* drop constant arguments if possible *)
502 : monnier 184 fun cstargs (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec) = f
503 :     | cstargs (f as (fk,g,args,body):F.fundec) =
504 :     let val cst =
505 :     ListPair.map
506 :     (fn (NONE,_) => false
507 :     | (SOME(F.VAR lv),(v,_)) =>
508 :     ((lookup m lv;
509 :     if used v andalso used lv then
510 :     (C.use NONE lv; true)
511 :     else false)
512 :     handle M.IntmapF => false)
513 :     | _ => true)
514 :     (C.actuals g, args)
515 :     (* if all args are used, there's nothing we can do *)
516 :     in if List.all not cst then f else
517 :     let fun newarg lv =
518 :     let val nlv = cplv lv in C.new NONE nlv; nlv end
519 :     fun filter xs = OU.filter(cst, xs)
520 :     (* construct the new arg list *)
521 :     val nargs = ListPair.map
522 :     (fn ((a,t),true) => (newarg a,t)
523 :     | ((a,t),false) => (a,t))
524 :     (args, cst)
525 :     (* construct the new body *)
526 :     val nbody =
527 :     F.LET(map #1 (filter args),
528 : monnier 185 F.RET(map O.valOf (filter (C.actuals g))),
529 : monnier 184 body)
530 :     in (fk, g, nargs, nbody)
531 : monnier 164 end
532 : monnier 184 end
533 : monnier 164
534 : monnier 184 (* add wrapper for various purposes *)
535 :     fun wrap (f as ({inline=F.IH_ALWAYS,...},_,_,_):F.fundec,fs) = f::fs
536 :     | wrap (f as (fk as {isrec,...},g,args,body):F.fundec,fs) =
537 :     let fun dropargs filter =
538 :     let val (nfk,nfk') = OU.fk_wrap(fk, O.map #1 isrec)
539 : monnier 164 val args' = filter args
540 : monnier 163 val ng = cplv g
541 :     val nargs = map (fn (v,t) => (cplv v, t)) args
542 : monnier 164 val nargs' = map #1 (filter nargs)
543 :     val appargs = (map F.VAR nargs')
544 : monnier 184 val nf = (nfk, g, nargs, F.APP(F.VAR ng, appargs))
545 : monnier 164 val nf' = (nfk', ng, args', body)
546 : monnier 184 in
547 :     C.new (SOME(map #1 args')) ng;
548 :     C.use (SOME appargs) ng;
549 :     app ((C.new NONE) o #1) nargs;
550 :     app (C.use NONE) nargs';
551 :     nf'::nf::fs
552 : monnier 163 end
553 : monnier 184 val used = map (used o #1) args
554 :     in
555 :     (* if some args are not used, let's drop them *)
556 :     if not (List.all OU.id used) then
557 :     dropargs (fn xs => OU.filter(used, xs))
558 : monnier 163
559 : monnier 184 (* eta-split: add a wrapper for escaping uses *)
560 :     else if C.escaping g andalso C.called g then
561 :     (* like dropargs but keeping all args *)
562 :     dropargs OU.id
563 : monnier 121
564 : monnier 184 else f::fs
565 :     end
566 : monnier 163
567 : monnier 184 (* redirect cst args to their source value *)
568 :     val fs = map cstargs fs
569 :    
570 :     (* add various wrappers *)
571 :     val fs = foldl wrap [] fs
572 :    
573 : monnier 121 (* register the new bindings (uncontracted for now) *)
574 :     val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
575 :     addbind(m, f, Fun(f, body, args, fk, od)))
576 :     m fs
577 :     (* check for eta redexes *)
578 :     val (nm,_) = foldl ceta (nm,[]) fs
579 :    
580 :     (* move the inlinable functions to the end of the list *)
581 :     val (f1s,f2s) =
582 : monnier 184 List.partition (fn ({inline=F.IH_ALWAYS,...},_,_,_) => true
583 : monnier 121 | _ => false) fs
584 :     val fs = f2s @ f1s
585 :    
586 :     (* contract the main body *)
587 : monnier 184 val nle = loop nm le cont
588 : monnier 121 (* contract the functions *)
589 :     val fs = cfun(nm, fs, [])
590 :     (* junk newly unused funs *)
591 :     val fs = List.filter (used o #2) fs
592 :     in
593 : monnier 163 case fs
594 :     of [] => nle
595 : monnier 184 | [f1 as ({isrec=NONE,...},_,_,_),f2] =>
596 : monnier 163 (* gross hack: dropargs might have added a second
597 :     * non-recursive function. we need to split them into
598 : monnier 184 * 2 FIXes. This is _very_ ad-hoc *)
599 : monnier 163 F.FIX([f2], F.FIX([f1], nle))
600 :     | _ => F.FIX(fs, nle)
601 : monnier 121 end
602 :    
603 :     | F.APP (f,vs) =>
604 :     let val nvs = ((map substval vs) handle x => raise x)
605 : monnier 159 in case inline ifs (f, nvs)
606 : monnier 184 of (SOME(le,od),nifs) => cexp (d,od) ifs m le cont
607 :     | (NONE,_) => cont(m,F.APP((substval f) handle x => raise x, nvs))
608 : monnier 121 end
609 :    
610 :     | F.TFN ((f,args,body),le) =>
611 : monnier 184 let val nbody = cexp (DI.next d, DI.next od) ifs m body #2
612 : monnier 164 val nm = addbind(m, f, TFun(f, nbody, args, od))
613 : monnier 184 val nle = loop nm le cont
614 : monnier 164 in
615 :     if used f then F.TFN((f, args, nbody), nle) else nle
616 :     end
617 : monnier 121
618 : monnier 184 | F.TAPP(f,tycs) =>
619 :     cont(m, F.TAPP((substval f) handle x => raise x, tycs))
620 : monnier 121
621 :     | F.SWITCH (v,ac,arms,def) =>
622 :     (case ((val2sval m v) handle x => raise x)
623 : monnier 185 of sv as Con (lvc,v,dc1,tycs1) =>
624 : monnier 164 let fun killle le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
625 : monnier 159 fun kill lv le =
626 : monnier 164 ((#1 (C.unuselexp (undertake (addbind(m,lv,Var(lv,NONE)))))) le) handle x => raise x
627 : monnier 159 fun killarm (F.DATAcon(_,_,lv),le) = kill lv le
628 :     | killarm _ = buglexp("bad arm in switch(con)", le)
629 :    
630 :     fun carm ((F.DATAcon(dc2,tycs2,lv),le)::tl) =
631 : monnier 185 (* sometimes lty1 <> lty2 :-( so this doesn't work:
632 :     * FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) *)
633 :     if #2 dc1 = #2 (cdcon dc2) then
634 : monnier 159 (map killarm tl; (* kill the rest *)
635 : monnier 185 O.map killle def; (* and the default case *)
636 : monnier 184 loop (substitute(m, lv, val2sval m v, F.VAR lvc))
637 :     le cont)
638 : monnier 159 else
639 :     (* kill this arm and continue with the rest *)
640 :     (kill lv le; carm tl)
641 : monnier 185 | carm [] = loop m (O.valOf def) cont
642 : monnier 121 | carm _ = buglexp("unexpected arm in switch(con,...)", le)
643 :     in carm arms
644 :     end
645 :    
646 : monnier 185 | sv as Val v =>
647 : monnier 164 let fun kill le = ((#1 (C.unuselexp (undertake m))) le) handle x => raise x
648 : monnier 159 fun carm ((con,le)::tl) =
649 :     if eqConV(con, v) then
650 : monnier 184 (map (kill o #2) tl;
651 : monnier 185 O.map kill def;
652 : monnier 184 loop m le cont)
653 : monnier 159 else (kill le; carm tl)
654 : monnier 185 | carm [] = loop m (O.valOf def) cont
655 : monnier 121 in carm arms
656 :     end
657 : monnier 185
658 :     | sv as (Var{1=lvc,...} | Select{1=lvc,...} | Decon{1=lvc, ...}
659 :     | (* will probably never happen *) Record{1=lvc,...}) =>
660 :     (case (arms,def)
661 :     of ([(F.DATAcon(dc,tycs,lv),le)],NONE) =>
662 :     (* this is a mere DECON, so we can push the let binding
663 :     * (hidden in cont) inside and maybe even drop the DECON *)
664 :     let val ndc = cdcon dc
665 :     val nm = addbind(m, lv, Decon(lv, F.VAR lvc, ndc, tycs))
666 :     (* see below *)
667 :     val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc, tycs))
668 :     val nle = loop nm le cont
669 :     val nv = sval2val sv
670 :     in
671 :     if used lv then
672 :     F.SWITCH(nv,ac,[(F.DATAcon(ndc,tycs,lv),nle)],NONE)
673 :     else (unuseval (undertake m) nv; nle)
674 :     end
675 :     | (([(_,le)],NONE) | ([],SOME le)) =>
676 :     (* This should never happen, but we can optimize it away *)
677 :     (unuseval (undertake m) (sval2val sv); loop m le cont)
678 :     | _ =>
679 :     let fun carm (F.DATAcon(dc,tycs,lv),le) =
680 :     let val ndc = cdcon dc
681 :     val nm = addbind(m, lv,
682 :     Decon(lv, F.VAR lvc, ndc, tycs))
683 :     (* we can rebind lv to a more precise value
684 :     * !!BEWARE!! This rebinding is misleading:
685 :     * - it gives the impression that `lvc' is built
686 :     * from`lv' although the reverse is true:
687 :     * if `lvc' is undertaken, `lv's count should
688 :     * *not* be updated!
689 :     * Luckily, `lvc' will not become dead while
690 :     * rebound to Con(lv) because it's used by the
691 :     * SWITCH. All in all, it works fine, but it's
692 :     * not as straightforward as it seems.
693 :     * - it seems to be a good idea, but it can hide
694 :     * other opt-opportunities since it hides the
695 :     * previous binding. *)
696 :     val nm = addbind(nm, lvc,
697 :     Con(lvc, F.VAR lv, ndc, tycs))
698 :     in (F.DATAcon(ndc, tycs, lv), loop nm le #2)
699 :     end
700 :     | carm (con,le) = (con, loop m le #2)
701 :     val narms = map carm arms
702 :     val ndef = Option.map (fn le => loop m le #2) def
703 :     in cont(m, F.SWITCH(sval2val sv, ac, narms, ndef))
704 :     end)
705 :    
706 : monnier 121 | sv as (Fun _ | TFun _) =>
707 :     bugval("unexpected switch arg", sval2val sv))
708 :    
709 : monnier 159 | F.CON (dc1,tycs1,v,lv,le) =>
710 : monnier 164 let val ndc = cdcon dc1
711 :     fun ccon sv =
712 :     let val nv = sval2val sv
713 :     val nm = addbind(m, lv, Con(lv, nv, ndc, tycs1))
714 : monnier 184 val nle = loop nm le cont
715 : monnier 164 in if used lv then F.CON(ndc, tycs1, nv, lv, nle) else nle
716 :     end
717 :     in case ((val2sval m v) handle x => raise x)
718 :     of sv as (Decon (lvd,vc,dc2,tycs2)) =>
719 :     if FU.dcon_eq(dc1, dc2) andalso tycs_eq(tycs1,tycs2) then
720 :     let val sv = (val2sval m vc) handle x => raise x
721 : monnier 184 in loop (substitute(m, lv, sv, F.VAR lvd)) le cont
722 : monnier 164 end
723 :     else ccon sv
724 :     | sv => ccon sv
725 :     end
726 : monnier 121
727 :     | F.RECORD (rk,vs,lv,le) =>
728 : monnier 164 (* g: check whether the record already exists *)
729 :     let fun g (n,Select(_,v1,i)::ss) =
730 :     if n = i then
731 :     (case ss
732 :     of Select(_,v2,_)::_ =>
733 :     if v1 = v2 then g(n+1, ss) else NONE
734 :     | [] =>
735 :     (case sval2lty (val2sval m v1)
736 :     of SOME lty =>
737 :     let val ltd = case rk
738 :     of F.RK_STRUCT => LT.ltd_str
739 :     | F.RK_TUPLE _ => LT.ltd_tuple
740 :     | _ => buglexp("bogus rk",le)
741 :     in if length(ltd lty) = n+1
742 :     then SOME v1 else NONE
743 :     end
744 :     | _ => NONE) (* sad case *)
745 :     | _ => NONE)
746 :     else NONE
747 :     | g _ = NONE
748 :     val svs = ((map (val2sval m) vs) handle x => raise x)
749 :     in case g (0,svs)
750 :     of SOME v =>
751 :     let val sv = (val2sval m v) handle x => raise x
752 : monnier 184 in loop (substitute(m, lv, sv, F.INT 0)) le cont
753 : monnier 159 before app (unuseval (undertake m)) vs
754 : monnier 164 end
755 :     | _ =>
756 :     let val nvs = map sval2val svs
757 :     val nm = addbind(m, lv, Record(lv, nvs))
758 : monnier 184 val nle = loop nm le cont
759 : monnier 164 in if used lv then F.RECORD(rk, nvs, lv, nle) else nle
760 :     end
761 :     end
762 : monnier 121
763 :     | F.SELECT (v,i,lv,le) =>
764 : monnier 164 (case ((val2sval m v) handle x => raise x)
765 :     of Record (lvr,vs) =>
766 :     let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x
767 : monnier 184 in loop (substitute(m, lv, sv, F.VAR lvr)) le cont
768 : monnier 164 end
769 :     | sv =>
770 :     let val nv = sval2val sv
771 :     val nm = addbind (m, lv, Select(lv, nv, i))
772 : monnier 184 val nle = loop nm le cont
773 : monnier 164 in if used lv then F.SELECT(nv, i, lv, nle) else nle
774 :     end)
775 : monnier 121
776 : monnier 184 | F.RAISE (v,ltys) =>
777 :     cont(m, F.RAISE((substval v) handle x => raise x, ltys))
778 : monnier 121
779 : monnier 184 | F.HANDLE (le,v) =>
780 :     cont(m, F.HANDLE(loop m le #2, (substval v) handle x => raise x))
781 : monnier 121
782 :     | F.BRANCH (po,vs,le1,le2) =>
783 :     let val nvs = ((map substval vs) handle x => raise x)
784 :     val npo = cpo po
785 : monnier 184 val nle1 = loop m le1 #2
786 :     val nle2 = loop m le2 #2
787 :     in cont(m, F.BRANCH(npo, nvs, nle1, nle2))
788 : monnier 121 end
789 :    
790 :     | F.PRIMOP (po,vs,lv,le) =>
791 :     let val impure = impurePO po
792 : monnier 164 val nvs = ((map substval vs) handle x => raise x)
793 :     val npo = cpo po
794 :     val nm = addbind(m, lv, Var(lv,NONE))
795 : monnier 184 val nle = loop nm le cont
796 : monnier 164 in
797 :     if impure orelse used lv
798 :     then F.PRIMOP(npo, nvs, lv, nle)
799 :     else nle
800 : monnier 121 end
801 :     end
802 :    
803 : monnier 185 in
804 :     (* C.collect fdec; *)
805 :     case cexp (DI.top,DI.top) S.empty
806 :     M.empty (F.FIX([fdec], F.RET[F.VAR f])) #2
807 :     of F.FIX([fdec], F.RET[F.VAR f]) => fdec
808 :     | fdec => bug "invalid return fundec"
809 :     end
810 : monnier 121
811 :     end
812 :     end

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