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

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