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/clos/nfreeclose.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 70 - (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 : monnier 69 (*
622 : monnier 16 val freemapClose = Stats.doPhase(Stats.makePhase "Compiler 079 freemapClose")
623 :     freemapClose
624 : monnier 69 *)
625 : monnier 16
626 :     end
627 :     end (* structure FreeClose *)
628 :    
629 :    
630 :     (*
631 :     * $Log: nfreeclose.sml,v $
632 :     * Revision 1.1.1.1 1997/01/14 01:38:32 george
633 :     * Version 109.24
634 :     *
635 :     *)

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