Annotation of /sml/trunk/src/compiler/FLINT/clos/nfreeclose.sml

Parent Directory | Revision Log

---

Revision 16 - (view) (download)

1 :	monnier	16	(* Copyright 1996 by Bell Laboratories *)
2 :			(* nfreeclose.sml *)
3 :
4 :			(***************************************************************************
5 :			* *
6 :			* freemapClose *
7 :			* *
8 :			* Produces a free variable mapping at each function binding. *
9 :			* The mapping includes the functions bound at the FIX, but not the *
10 :			* arguments of the function. *
11 :			* *
12 :			* Side-effect: all fundefs that are never referenced are removed *
13 :			* *
14 :			***************************************************************************)
15 :			signature NFREECLOSE =
16 :			sig
17 :			type snum
18 :			type fvinfo
19 :			val freemapClose : CPS.function -> (CPS.function * (CPS.lvar -> snum)
20 :			* (CPS.lvar -> fvinfo)
21 :			* (CPS.lvar -> bool))
22 :			end
23 :
24 :			structure NFreeClose : NFREECLOSE = struct
25 :
26 :			local
27 :			open Access CPS SortedList
28 :			structure LV = LambdaVar
29 :			in
30 :
31 :			(***************************************************************************
32 :			* Misc and utility functions *
33 :			***************************************************************************)
34 :			val say = Control.Print.say
35 :			fun vp v = say(LV.lvarName(v))
36 :
37 :			fun addvL(v,NONE) = NONE
38 :			| addvL(v,SOME l) = SOME(enter(v,l))
39 :
40 :			val enter = fn (VAR x,y) => enter(x,y) | (_,y) => y
41 :			val error = ErrorMsg.impossible
42 :			fun warn s = () (* app say ["WARNING: ",s,"\n"] *)
43 :
44 :			fun addL(v,NONE) = NONE
45 :			| addL(v,SOME l) = SOME(enter(v,l))
46 :
47 :			fun overL(r,NONE) = NONE
48 :			| overL(r,SOME l) = SOME (merge(r,l))
49 :
50 :			fun mergeL(NONE,r) = r
51 :			| mergeL(l,NONE) = l
52 :			| mergeL(SOME l,SOME r) = SOME (merge(l,r))
53 :
54 :			fun removeL(vl,NONE) = NONE
55 :			| removeL(vl,SOME r) = SOME (remove(vl,r))
56 :
57 :			fun rmvL(v,NONE) = NONE
58 :			| rmvL(v,SOME r) = SOME (rmv(v,r))
59 :
60 :			fun clean l =
61 :			let fun vars(l, (VAR x) :: rest) = vars(x::l, rest)
62 :			| vars(l, _::rest) = vars(l,rest)
63 :			| vars(l, nil) = uniq l
64 :			in vars(nil, l)
65 :			end
66 :
67 :			fun filter p vl =
68 :			let fun f(x::r,l) = if p x then f(r,x::l) else f(r,l)
69 :			| f([],l) = rev l
70 :			in f(vl,[])
71 :			end
72 :
73 :			fun exists pred l =
74 :			let fun f(a::r) = if pred a then true else f r
75 :			| f [] = false
76 :			in f l
77 :			end
78 :
79 :			fun partition f l =
80 :			foldr (fn (e,(a,b)) => if f e then (e::a,b) else (a,e::b)) ([], []) l
81 :
82 :			val infinity = 1000000000
83 :			fun minl l =
84 :			let fun f(i,nil) = i
85 :			| f(i,j::r) = if i < j then f(i,r) else f(j,r)
86 :			in f(infinity,l)
87 :			end
88 :
89 :			fun bfirst(P.boxed | P.pneq | P.strneq | P.cmp{oper=P.neq,...}) = true
90 :			| bfirst _ = false
91 :
92 :			fun bsecond(P.unboxed | P.peql | P.streq | P.cmp{oper=P.eql,...}) = true
93 :			| bsecond _ = false
94 :
95 :			(** datatype used to represent the free variable information **)
96 :			type vnum = lvar * int * int (* lvar and first-use-sn and last-use-sn *)
97 :			type snum = int (* stage number *)
98 :			type loopv = lvar list option
99 :			type fvinfo = {fv : vnum list, (* list of sorted free variables *)
100 :			lv : loopv, (* list of free variables on the loop path *)
101 :			sz : int * int} (* estimated frame-size of the current fun *)
102 :
103 :			fun freemapClose fe = let
104 :
105 :			(***************************************************************************
106 :			* Modify the fun_kind information for each fundef, new kind includes, *
107 :			* *
108 :			* (1) KNOWN_CONT known continuation function *
109 :			* (2) KNOWN_TAIL known tail-recursive function *
110 :			* (3) KNOWN general known function *
111 :			* (4) CONT general continuation function *
112 :			* (5) ESCAPE general escaping user function *
113 :			* (6) KNOWN_REC mutually recursive known function *
114 :			* *
115 :			***************************************************************************)
116 :			val escapes = Intset.new()
117 :			val escapesP = Intset.mem escapes
118 :			fun escapesM(VAR v) = Intset.add escapes v
119 :			| escapesM _ = ()
120 :
121 :			val users = Intset.new()
122 :			val usersP = Intset.mem users
123 :			val usersM = Intset.add users
124 :
125 :			val known = Intset.new()
126 :			val knownP = Intset.mem known
127 :			val knownM = Intset.add known
128 :			fun knownK k = (k <> CONT) andalso (k <> ESCAPE)
129 :
130 :			val contset = Intset.new()
131 :			val contP = Intset.mem contset
132 :			val contM = Intset.add contset
133 :			fun contK k = (k = CONT) orelse (k = KNOWN_CONT) (* continuation funs ? *)
134 :			fun econtK k = (k = CONT) (* escaping continuation funs ? *)
135 :
136 :			fun fixkind(fe as (CONT,f,vl,cl,ce)) =
137 :			if escapesP f then (contM f; fe)
138 :			else (knownM f; contM f; (KNOWN_CONT,f,vl,cl,ce))
139 :			| fixkind(fe as (fk,f,vl,cl as (CNTt::_),ce)) =
140 :			if escapesP f then (usersM f; (ESCAPE,f,vl,cl,ce))
141 :			else (knownM f; (KNOWN_REC,f,vl,cl,ce))
142 :			| fixkind(fe as (fk,f,vl,cl,ce)) =
143 :			if escapesP f then (vp f; say " ***** \n";
144 :			error "escaping-fun has zero cont, freeclose.sml")
145 :			else (knownM f; (KNOWN_TAIL,f,vl,cl,ce))
146 :
147 :			fun procfix(fk,f,vl,cl,ce) = (fk,f,vl,cl,proc ce)
148 :			and proc(ce) =
149 :			case ce
150 :			of FIX(fl,body) =>
151 :			let val body' = proc body
152 :			val nfl = map fixkind (map procfix fl)
153 :
154 :			(* Due to possible eta-splits of continuation functions,
155 :			* since it's always that CONT funs calls KNOWN_CONT funs,
156 :			* we split them into two FIXes, so that each FIX only
157 :			* contains at most one continuation definitions.
158 :			*)
159 :			val (fl1,fl2) = partition (econtK o #1) nfl
160 :			in case (fl1,fl2)
161 :			of ([],_) => FIX(fl2,body')
162 :			| (_,[]) => FIX(fl1,body')
163 :			| _ => FIX(fl2,FIX(fl1,body'))
164 :			end
165 :			| APP(v,args) => (app escapesM args; ce)
166 :			| SWITCH(v,c,l) => SWITCH(v,c,map proc l)
167 :			| RECORD(rk,l,w,ce) =>
168 :			(app (escapesM o #1) l; RECORD(rk,l,w,proc ce))
169 :			| SELECT(i,v,w,t,ce) => SELECT(i,v,w,t,proc ce)
170 :			| OFFSET(i,v,w,ce) => OFFSET(i,v,w,proc ce)
171 :			| LOOKER(p,vl,w,t,ce) =>
172 :			(app escapesM vl; LOOKER(p,vl,w,t,proc ce))
173 :			| ARITH(p,vl,w,t,ce) =>
174 :			(app escapesM vl; ARITH(p,vl,w,t,proc ce))
175 :			| PURE(p,vl,w,t,ce) =>
176 :			(app escapesM vl; PURE(p,vl,w,t,proc ce))
177 :			| SETTER(p,vl,ce) =>
178 :			(app escapesM vl; SETTER(p,vl,proc ce))
179 :			| BRANCH(p,vl,c,e1,e2) =>
180 :			(app escapesM vl; BRANCH(p,vl,c,proc e1,proc e2))
181 :
182 :			val fe' = procfix fe
183 :
184 :
185 :			(***************************************************************************
186 :			* Build the call graph and compute the scc number *
187 :			***************************************************************************)
188 :			exception Unseen
189 :			type info = {dfsnum : int ref, sccnum : int ref, edges : lvar list}
190 :			val m : info Intmap.intmap = Intmap.new(32,Unseen)
191 :			val lookup = Intmap.map m
192 :			val total : lvar list ref = ref nil
193 :
194 :			fun addinfo(f,vl) = (total := (f :: (!total));
195 :			Intmap.add m (f,{dfsnum=ref ~1,sccnum=ref ~1,edges=vl}))
196 :			fun KUC x = (contP x) orelse (knownP x) orelse (usersP x)
197 :			fun EC x = (contP x) orelse (escapesP x)
198 :
199 :			fun makenode (_,f,_,_,body) =
200 :			let fun edges (RECORD(_,_,_,e)) = edges e
201 :			| edges (SELECT(_,_,_,_,e)) = edges e
202 :			| edges (OFFSET(_,_,_,e)) = edges e
203 :			| edges (SWITCH(_,_,el)) = foldmerge (map edges el)
204 :			| edges (SETTER(P.sethdlr,vl,e)) =
205 :			merge(filter KUC (clean vl),edges e)
206 :			| edges (SETTER(_,_,e)) = edges e
207 :			| edges (LOOKER(_,_,_,_,e)) = edges e
208 :			| edges (ARITH(_,_,_,_,e)) = edges e
209 :			| edges (PURE(_,_,_,_,e)) = edges e
210 :			| edges (BRANCH(_,_,_,a,b)) = merge(edges a,edges b)
211 :			| edges (APP(u, ul)) = filter KUC (clean (u::ul))
212 :			| edges (FIX(fl,b)) = (app makenode fl; edges b)
213 :			in addinfo(f,edges body)
214 :			end
215 :
216 :			val compnums = ref 0 and id = ref 0
217 :			val stack : (int * int ref) list ref = ref nil
218 :			fun scc nodenum =
219 :			let fun newcomp(c,(n,sccnum)::rest) =
220 :			(sccnum := c;
221 :			if n=nodenum then rest else newcomp(c,rest))
222 :			| newcomp _ = error "newcomp in freeclose in the closure phase"
223 :
224 :			val info as {dfsnum as ref d, sccnum, edges} = lookup nodenum
225 :
226 :			in if d >= 0 then if (!sccnum >= 0) then infinity else d
227 :			else (let val v = !id before (id := !id+1)
228 :			val _ = (stack := (nodenum, sccnum) :: !stack;
229 :			dfsnum := v)
230 :			val b = minl (map scc edges)
231 :			in if v <= b
232 :			then let val c = !compnums before (compnums := !compnums+1)
233 :			val _ = (stack := newcomp(c,!stack))
234 :			in infinity (* v *)
235 :			end
236 :			else b
237 :			end)
238 :			end
239 :
240 :			val _ = makenode(fe') (* Build the call graph *)
241 :			val _ = app (fn x => (scc x; ())) (!total) (* Compute the scc number *)
242 :			val sccnum = ! o #sccnum o lookup
243 :			fun samescc(x,n) = if n < 0 then false else ((sccnum x) = n)
244 :
245 :			(***>>
246 :			fun plist p l = (app (fn v => (say " "; p v)) l; say "\n")
247 :			val ilist = plist vp
248 :			val _ = app (fn v => (vp v; say " edges : " ;
249 :			ilist(#edges(lookup v));
250 :			say "**** sccnum is ";
251 :			say (Int.toString(sccnum v)); say "\n")) (!total)
252 :			<<***)
253 :
254 :
255 :
256 :			(***************************************************************************
257 :			* Utility functions for lists of free variable unit, each unit "vnum" *
258 :			* contains three parts, the lvar, the first-use-sn and the last-use-sn *
259 :			***************************************************************************)
260 :			val V2L = let fun h (s:vnum) = #1 s
261 :			in map h (* given a vnum list, return an lvar list *)
262 :			end
263 :
264 :			(* add a single lvar used at stage n *)
265 :			fun addsV(VAR v,n,l) =
266 :			let fun h(v,[]) = [(v,n,n)]
267 :			| h(v,l as ((u as (x,a,b))::r)) =
268 :			if x < v then u::(h(v,r))
269 :			else if x = v then ((x,Int.min(a,n),Int.max(a,n))::r)
270 :			else ((v,n,n)::l)
271 :			in h(v,l)
272 :			end
273 :			| addsV(_,_,l) = l
274 :
275 :
276 :			(* remove a single lvar *)
277 :			fun rmvsV(v,[]) = []
278 :			| rmvsV(v,l as ((u as (x,_,_))::r)) =
279 :			if x < v then u::(rmvsV(v,r))
280 :			else if x = v then r
281 :			else l
282 :
283 :			(* remove a list of lvars *)
284 :			fun removeV(vl,l) =
285 :			let fun h(l1 as (x1::r1),l2 as ((u2 as (x2,_,_))::r2)) =
286 :			if x2 < x1 then u2::(h(l1,r2))
287 :			else if x2 > x1 then h(r1,l2)
288 :			else h(r1,r2)
289 :			| h([],l2) = l2
290 :			| h(l1,[]) = []
291 :			in h(vl,l)
292 :			end
293 :
294 :			(* add a list of lvars used at stage n *)
295 :			fun addV(vl,n,l) =
296 :			let fun h(l1 as (x1::r1), l2 as ((u2 as (x2,a2,b2))::r2)) =
297 :			if (x1 < x2) then (x1,n,n)::(h(r1,l2))
298 :			else if (x1 > x2) then u2::(h(l1,r2))
299 :			else (x1,Int.min(n,a2),Int.max(n,b2))::(h(r1,r2))
300 :			| h(l1,[]) = map (fn x => (x,n,n)) l1
301 :			| h([],l2) = l2
302 :			in h(vl,l)
303 :			end
304 :
305 :			(* merge two lists of free var unit (exclusively) *)
306 :			fun mergePV(n,l1,l2) =
307 :			let fun h(l1 as ((x1,a1,b1)::r1), l2 as ((x2,a2,b2)::r2)) =
308 :			if (x1 < x2) then (x1,n,n)::(h(r1,l2))
309 :			else if (x1 > x2) then (x2,n,n)::(h(l1,r2))
310 :			else if (b1 = b2) then
311 :			(x1,Int.min(a1,a2),b1)::(h(r1,r2))
312 :			else (x1,n,n)::(h(r1,r2))
313 :			| h(l1,[]) = map (fn (x,_,_) => (x,n,n)) l1
314 :			| h([],l2) = map (fn (x,_,_) => (x,n,n)) l2
315 :			in h(l1,l2)
316 :			end
317 :
318 :			(* merge two lists of free var unit (with union) *)
319 :			fun mergeUV(l1 : (lvar*int*int) list,l2) =
320 :			let fun h(l1 as ((u1 as (x1,a1,b1))::r1), l2 as ((u2 as (x2,a2,b2))::r2)) =
321 :			if (x1 < x2) then u1::(h(r1,l2))
322 :			else if (x1 > x2) then u2::(h(l1,r2))
323 :			else (x1,Int.min(a1,a2),Int.max(b1,b2))::(h(r1,r2))
324 :			| h(l1,[]) = l1
325 :			| h([],l2) = l2
326 :			in h(l1,l2)
327 :			end
328 :
329 :			(* fold merge lists of free vars (exclusively) *)
330 :			fun foldUV(l,b) = foldr mergeUV b l
331 :
332 :			(* lay a list of free var unit over another list of free var unit *)
333 :			fun overV(n,l1,l2) =
334 :			let fun h(l1 as ((u1 as (x1,_,_))::r1), l2 as ((x2,_,_)::r2)) =
335 :			if (x1 < x2) then u1::(h(r1,l2))
336 :			else if (x1 > x2) then (x2,n,n)::(h(l1,r2))
337 :			else u1::(h(r1,r2))
338 :			| h(l1,[]) = l1
339 :			| h([],l2) = map (fn (x,_,_) => (x,n,n)) l2
340 :			in h(l1,l2)
341 :			end
342 :
343 :
344 :
345 :			(***************************************************************************
346 :			* Two hash tables (1) lvar to stage number *
347 :			* (2) lvar to freevar information *
348 :			***************************************************************************)
349 :			exception STAGENUM
350 :			val snum : snum Intmap.intmap = Intmap.new(32,STAGENUM)
351 :			val addsn = Intmap.add snum (* add the stage number for a fundef *)
352 :			val getsn = Intmap.map snum (* get the stage number of a fundef *)
353 :
354 :			fun findsn(v,d,[]) = (warn ("Fundef " ^ (LV.lvarName v)
355 :			^ " unused in freeClose"); d)
356 :			| findsn(v,d,(x,_,m)::r) =
357 :			if v > x then findsn(v,d,r)
358 :			else if v = x then m
359 :			else (warn ("Fundef " ^ (LV.lvarName v) ^
360 :			" unused in freeClose"); d)
361 :
362 :			fun findsn2(v,d,[]) = d
363 :			| findsn2(v,d,(x,_,m)::r) =
364 :			if v > x then findsn2(v,d,r)
365 :			else if v = x then m else d
366 :
367 :
368 :			exception FREEVMAP
369 :			val vars : fvinfo Intmap.intmap = Intmap.new(32,FREEVMAP)
370 :
371 :			fun addEntry(v,l,x,s) = Intmap.add vars (v,{fv=l,lv=x,sz=s})
372 :			val freeV = Intmap.map vars (* get the freevar info *)
373 :			val loopV = #lv o freeV (* the free variables on the loop path *)
374 :
375 :			(***>>
376 :			val vars : (lvar list * (lvar list option)) Intmap.intmap
377 :			= Intmap.new(32, FREEVMAP)
378 :			val freeV = Intmap.map vars
379 :			fun loopV v = (#2 (freeV v)) handle FREEVMAP => error "loopV in closure"
380 :			<<***)
381 :
382 :			(***************************************************************************
383 :			* Split the pseudo-mutually-recursive bindings, a temporary hack. *
384 :			* *
385 :			* TODO: need to add code on identify those KNOWN_REC kind functions *
386 :			* check the older version of this file for details *
387 :			***************************************************************************)
388 :			fun knownOpt ([],_,_,_,_) = error "knownOpt in closure 4354"
389 :			| knownOpt (flinfo,died,freeb,gszb,fszb) =
390 :			let val newflinfo =
391 :			let val roots = filter (member died) (V2L freeb)
392 :			val graph = map (fn ((_,f,_,_,_),free,_,_) =>
393 :			(f,filter (member died) (V2L free))) flinfo
394 :			fun loop(old) =
395 :			let val new =
396 :			foldr (fn ((f,free),total) =>
397 :			if member old f then merge(free,total) else total)
398 :			old graph
399 :			in if length(new) = length(old) then new else loop(new)
400 :			end
401 :
402 :			val nroots = loop(roots)
403 :			in filter (fn ((_,f,_,_,_),_,_,_) => member nroots f) flinfo
404 :			end
405 :
406 :			val (nfl,freel,gsz,fsz) =
407 :			let val (known,other) =
408 :			partition (fn ((KNOWN_REC,_,_,_,_),_,_,_) => true
409 :			| _ => false) newflinfo
410 :
411 :			val known' =
412 :			case known
413 :			of u as [((_,v,args,cl,body),free,gsz,fsz)] =>
414 :			(if member (V2L free) v then u
415 :			else [((KNOWN,v,args,cl,body),free,gsz,fsz)])
416 :			| z => z
417 :
418 :			fun g((fe,vn,gsz',fsz'),(fl,vl,gsz,fsz)) =
419 :			(fe::fl,vn::vl,Int.max(gsz',gsz),Int.max(fsz',fsz))
420 :			in foldr g ([],[],gszb,fszb) (known'@other)
421 :			end
422 :
423 :			val header = case nfl of [] => (fn ce => ce)
424 :			| _ => (fn ce => FIX(nfl,ce))
425 :
426 :			in (header, freel, gsz, fsz)
427 :			end
428 :
429 :			(***************************************************************************
430 :			* The following procedure does five things: *
431 :			* *
432 :			* (1) Install a stage number for each function definition *
433 :			* (2) Collecting the free variable information for each fundef *
434 :			* (3) Infer the live range of each free variable at each fundef *
435 :			* (4) Infer the set of free variables on the looping path *
436 :			* (5) Do the simple branch-prediction transformation *
437 :			* *
438 :			* TODO: better branch-prediction heauristics will help the merge done *
439 :			* at each SWITCH and BRANCH *
440 :			***************************************************************************)
441 :
442 :			(*** major gross hack here ***)
443 :			val ekfuns = Intset.new()
444 :			val ekfunsP = Intset.mem ekfuns
445 :			val ekfunsM = Intset.add ekfuns
446 :
447 :			fun freefix (sn,freeb) (fk,f,vl,cl,ce) =
448 :			let val (ce',ul,wl,gsz,fsz) =
449 :			if contK fk then
450 :			(let val n = findsn(f,sn,freeb)
451 :			val nn = if econtK fk then n+1 else n
452 :			in addsn(f,nn); freevars(sccnum f,nn,ce)
453 :			end)
454 :			else if knownK fk then (addsn(f,sn); freevars(sccnum f,sn,ce))
455 :			else (addsn(f,sn+1); freevars(~1,sn+1,ce))
456 :			val args = uniq vl
457 :			val l = removeV(args,ul)
458 :			val z = removeL(args,wl)
459 :
460 :			(*** the following is a gross hack, needs more work ***)
461 :			val nl =
462 :			if ((findsn2(f,sn,l)) <= sn) then l
463 :			else (foldr (fn ((x,i,j),z) =>
464 :			(if knownP x then ekfunsM x else ();
465 :			(x,i+1,j+1)::z)) [] l)
466 :
467 :			val _ = addEntry(f,l,z,(gsz,fsz))
468 :			val (gsz',fsz') =
469 :			if econtK fk then (* only count escaping functions *)
470 :			(let val gn = length l (**** NEED MORE WORK HERE ****)
471 :			in (Int.max(gn,gsz),fsz)
472 :			end)
473 :			else (0,0)
474 :
475 :			in ((fk,f,vl,cl,ce'),nl,gsz',fsz')
476 :			end
477 :
478 :			and freevars(n,sn,ce) =
479 :			case ce
480 :			of FIX(fl,body) =>
481 :			let val died = uniq(map #2 fl)
482 :			val (body',freeb,wl,gszb,fszb) = freevars(n,sn,body)
483 :			val flinfo = map (freefix (sn,freeb)) fl
484 :			val (header,freel,gsz,fsz) = knownOpt(flinfo,died,freeb,gszb,fszb)
485 :			val free = removeV(died,foldUV(freel,freeb))
486 :			val nwl = case wl
487 :			of NONE => NONE
488 :			| SOME l =>
489 :			(let fun h(x,l) = if member died x then mergeL(loopV x,l)
490 :			else addvL(x,l)
491 :			in removeL(died,foldr h (SOME []) l)
492 :			end)
493 :			in (header(body'),free,nwl,gsz,fsz)
494 :			end
495 :			| APP(v,args) =>
496 :			let val free = clean(v::args)
497 :			val fns = filter KUC free
498 :			val wl = if (exists (fn x => samescc(x,n)) fns) then SOME free
499 :			else NONE
500 :			val freeb = addV(free,sn,[])
501 :			in (ce,freeb,wl,0,0)
502 :			end
503 :			| SWITCH(v,c,l) => (* add branch prediction heauristics in the future *)
504 :			let fun freelist(ce,(el,free1,free2,wl,gsz1,fsz1,gsz2,fsz2)) =
505 :			let val (ce',free',wl',gsz',fsz') = freevars(n,sn,ce)
506 :			in case wl'
507 :			of NONE =>
508 :			(ce'::el,free1,mergePV(sn,free',free2),wl,
509 :			gsz1,fsz1,Int.max(gsz2,gsz'),Int.max(fsz2,fsz'))
510 :			| SOME _ =>
511 :			(ce'::el,mergeUV(free',free1),free2,mergeL(wl',wl),
512 :			Int.max(gsz1,gsz'),Int.max(fsz1,fsz'),gsz2,fsz2)
513 :			end
514 :			val (l',free1,free2,wl,gsz1,fsz1,gsz2,fsz2) =
515 :			foldr freelist ([],[],[],NONE,0,0,0,0) l
516 :			val (free,gsz,fsz) = case wl
517 :			of NONE => (free2,gsz2,fsz2)
518 :			| SOME _ => (overV(sn,free1,free2),gsz1,fsz1)
519 :
520 :			in (SWITCH(v,c,l'),addsV(v,sn,free),addL(v,wl),gsz,fsz)
521 :			end
522 :			(* | SWITCH(v,c,l) => (* add branch prediction heauristics in the future *)
523 :			let fun freelist(ce,(el,free,wl,gsz,fsz)) =
524 :			let val (ce',free',wl',gsz',fsz') = freevars(n,sn,ce)
525 :			val ngsz = Int.max(gsz,gsz')
526 :			val nfsz = Int.max(fsz,fsz')
527 :			in (ce'::el,mergePV(sn,free',free),mergeL(wl',wl),ngsz,nfsz)
528 :			end
529 :			val (l',freel,wl,gsz,fsz) = foldr freelist ([],[],NONE,0,0) l
530 :			in (SWITCH(v,c,l'),addsV(v,sn,freel),addL(v,wl),gsz,fsz)
531 :			end
532 :			*)
533 :			| RECORD(rk,l,w,ce) =>
534 :			let val (ce',free,wl,gsz,fsz) = freevars(n,sn,ce)
535 :			val new = clean (map #1 l)
536 :			val free' = addV(new,sn,rmvsV(w,free))
537 :			val wl' = overL(new, rmvL(w,wl))
538 :			in (RECORD(rk,l,w,ce'),free',wl',gsz,fsz)
539 :			end
540 :			| SELECT(i,v,w,t,ce) =>
541 :			let val (ce',free,wl,gsz,fsz) = freevars(n,sn,ce)
542 :			val free' = addsV(v,sn,rmvsV(w,free))
543 :			val wl' = addL(v,rmvL(w,wl))
544 :			in (SELECT(i,v,w,t,ce'),free',wl',gsz,fsz)
545 :			end
546 :			| OFFSET(i,v,w,ce) =>
547 :			let val (ce',free,wl,gsz,fsz) = freevars(n,sn,ce)
548 :			val free' = addsV(v,sn,rmvsV(w,free))
549 :			val wl' = addL(v,rmvL(w,wl))
550 :			in (OFFSET(i,v,w,ce'),free',wl',gsz,fsz)
551 :			end
552 :			| LOOKER(p,vl,w,t,ce) =>
553 :			let val (ce',free,wl,gsz,fsz) = freevars(n,sn,ce)
554 :			val new = clean vl
555 :			val free' = addV(new,sn,rmvsV(w,free))
556 :			val wl' = overL(new,rmvL(w,wl))
557 :			in (LOOKER(p,vl,w,t,ce'),free',wl',gsz,fsz)
558 :			end
559 :			| ARITH(p,vl,w,t,ce) =>
560 :			let val (ce',free,wl,gsz,fsz) = freevars(n,sn,ce)
561 :			val new = clean vl
562 :			val free' = addV(new,sn,rmvsV(w,free))
563 :			val wl' = overL(new,rmvL(w,wl))
564 :			in (ARITH(p,vl,w,t,ce'),free',wl',gsz,fsz)
565 :			end
566 :			| PURE(p,vl,w,t,ce) =>
567 :			let val (ce',free,wl,gsz,fsz) = freevars(n,sn,ce)
568 :			val new = clean vl
569 :			val free' = addV(new,sn,rmvsV(w,free))
570 :			val wl' = overL(new,rmvL(w,wl))
571 :			in (PURE(p,vl,w,t,ce'),free',wl',gsz,fsz)
572 :			end
573 :			| SETTER(p as P.sethdlr,vl,ce) =>
574 :			let val (ce',free,wl,gsz,fsz) = freevars(n,sn,ce)
575 :			val new = clean vl
576 :			val free' = addV(new,sn,free)
577 :			val fns = filter KUC new
578 :			val wl' = if (exists(fn x => samescc(x,n)) fns)
579 :			then mergeL(SOME new,wl) else overL(new,wl)
580 :			in (SETTER(p,vl,ce'),free',wl',gsz,fsz)
581 :			end
582 :			| SETTER(p,vl,ce) =>
583 :			let val (ce',free,wl,gsz,fsz) = freevars(n,sn,ce)
584 :			val new = clean vl
585 :			val free' = addV(new,sn,free)
586 :			val wl' = overL(new,wl)
587 :			in (SETTER(p,vl,ce'),free',wl',gsz,fsz)
588 :			end
589 :			| BRANCH(p,vl,c,e1,e2) =>
590 :			let val (e1',free1,wl1,gsz1,fsz1) = freevars(n,sn,e1)
591 :			val (e2',free2,wl2,gsz2,fsz2) = freevars(n,sn,e2)
592 :			val new = clean vl
593 :			val wl = overL(new,mergeL(wl1,wl2))
594 :			in case (wl1,wl2)
595 :			of (NONE,SOME _) =>
596 :			(let val free = addV(new,sn,overV(sn,free2,free1))
597 :			in (BRANCH(P.opp p,vl,c,e2',e1'),free,wl,gsz2,fsz2)
598 :			end)
599 :			| (SOME _,NONE) =>
600 :			(let val free = addV(new,sn,overV(sn,free1,free2))
601 :			in (BRANCH(p,vl,c,e1',e2'),free,wl,gsz1,fsz1)
602 :			end)
603 :			| _ =>
604 :			(let val free = case wl1
605 :			of (SOME _) => addV(new,sn,mergeUV(free1,free2))
606 :			| _ =>
607 :			(if bfirst(p) then
608 :			addV(new,sn,overV(sn,free1,free2))
609 :			else if bsecond(p) then
610 :			addV(new,sn,overV(sn,free2,free1))
611 :			else addV(new,sn,mergePV(sn,free1,free2)))
612 :			val gsz = Int.max(gsz1,gsz2)
613 :			val fsz = Int.max(fsz1,fsz2)
614 :			in (BRANCH(p,vl,c,e1',e2'),free,wl,gsz,fsz)
615 :			end)
616 :			end
617 :
618 :			in (#1(freefix (0,[]) fe'), getsn, freeV, ekfunsP)
619 :			end (* function freemapClose *)
620 :
621 :			val freemapClose = Stats.doPhase(Stats.makePhase "Compiler 079 freemapClose")
622 :			freemapClose
623 :
624 :			end
625 :			end (* structure FreeClose *)
626 :
627 :
628 :			(*
629 :			* $Log: nfreeclose.sml,v $
630 :			* Revision 1.1.1.1 1997/01/14 01:38:32 george
631 :			* Version 109.24
632 :			*
633 :			*)

---

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