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

Parent Directory | Revision Log

---

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

---

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