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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 419 - (view) (download)

1 : monnier 245 (* Copyright 1996 by Bell Laboratories *)
2 :     (* closure.sml *)
3 :    
4 :     (****************************************************************************
5 :     * *
6 :     * ASSUMPTIONS: (1) Five possible combinations of bindings in the same *
7 :     * FIX : known,escape,cont,known-cont,known+escape; *
8 :     * *
9 :     * (2) Continuation function is never recursive; there is *
10 :     * at most ONE continuation function definition per FIX; *
11 :     * *
12 :     * (3) The outermost function is always a non-recursive *
13 :     * escaping funciton. *
14 :     * *
15 :     ****************************************************************************)
16 :    
17 :     signature CLOSURE = sig
18 :     val closeCPS : CPS.function -> CPS.function
19 :     end (* signature CLOSURE *)
20 :    
21 :     functor Closure(MachSpec : MACH_SPEC) : CLOSURE = struct
22 :    
23 :     local
24 :     open CPS AllocProf SortedList
25 :     structure CGoptions = Control.CG
26 :     structure SProf = StaticProf(MachSpec)
27 :     structure LV = LambdaVar
28 :     val saveLvarNames = LV.saveLvarNames
29 :     val dupLvar = LV.dupLvar
30 :     val mkLvar = LV.mkLvar
31 :    
32 :     val OFFp0 = OFFp 0
33 :    
34 :     val dumcs = NONE (* dummy callee-save reg contents *)
35 :     val zip = ListPair.zip
36 :     val pr = Control.Print.say
37 :     fun inc (ri as ref i) = ri := i+1
38 :     in
39 :    
40 :    
41 :     fun bug s = ErrorMsg.impossible ("Closure: " ^ s)
42 :    
43 :     (****************************************************************************
44 :     * MISC UTILITY FUNCTIONS *
45 :     ****************************************************************************)
46 :    
47 :     fun partition f l =
48 :     foldr (fn (e,(a,b)) => if f e then (e::a,b) else (a,e::b)) ([], []) l
49 :    
50 :     fun sublist test =
51 :     let fun subl arg =
52 :     let fun s(a::r,l) = if test a then s(r,a::l) else s(r,l)
53 :     | s(nil,l) = rev l
54 :     in s(arg,nil)
55 :     end
56 :     in subl
57 :     end
58 :    
59 :     fun formap f =
60 :     let fun iter(nil,_) = nil
61 :     | iter(hd::tl,i) = f(hd,i)::iter(tl,i+1)
62 :     in iter o (fn l => (l,0))
63 :     end
64 :    
65 :     (* clean reverses the order of the argument list *)
66 :     fun clean l =
67 :     let fun vars(l, VAR x :: rest) = vars(x::l, rest)
68 :     | vars(l, _::rest) = vars(l,rest)
69 :     | vars(l, nil) = l
70 :     in vars(nil,l)
71 :     end
72 :    
73 :     fun uniqvar l = uniq(clean l)
74 :    
75 :     fun entervar(VAR v,l) = enter(v,l)
76 :     | entervar(_,l) = l
77 :    
78 :     fun member l (v:int) =
79 :     let fun f [] = false
80 :     | f (a::r) = if a<v then f r else (v=a)
81 :     in f l
82 :     end
83 :    
84 :     fun member3 l (v:int) =
85 :     let fun h [] = false
86 :     | h ((a,_,_)::r) = if a<v then h r else (v=a)
87 :     in h l
88 :     end
89 :    
90 :     fun mergeV(l1 : (lvar*int*int) list,l2) =
91 :     let fun h(l1 as ((u1 as (x1,a1,b1))::r1), l2 as ((u2 as (x2,a2,b2))::r2)) =
92 :     if (x1 < x2) then u1::(h(r1,l2))
93 :     else if (x1 > x2) then u2::(h(l1,r2))
94 :     else (x1,Int.min(a1,a2),Int.max(b1,b2))::(h(r1,r2))
95 :     | h(l1,[]) = l1
96 :     | h([],l2) = l2
97 :     in h(l1,l2)
98 :     end
99 :    
100 :     fun addV(vl,m,n,l) = mergeV(map (fn x => (x,m,n)) vl, l)
101 :    
102 :     fun uniqV z =
103 :     let fun h([],l) = l
104 :     | h(a::r,l) = h(r,mergeV([a],l))
105 :     in h(z,[])
106 :     end
107 :    
108 :     fun removeV(vl : lvar list,l) =
109 :     let fun h(l1 as (x1::r1),l2 as ((u2 as (x2,_,_))::r2)) =
110 :     if x2 < x1 then u2::(h(l1,r2))
111 :     else if x2 > x1 then h(r1,l2)
112 :     else h(r1,r2)
113 :     | h([],l2) = l2
114 :     | h(l1,[]) = []
115 :     in h(vl,l)
116 :     end
117 :    
118 :     fun accumV([],_) = ([],1000000,0,0)
119 :     | accumV(vl,free) =
120 :     let fun h((v,m,n),(z,i,j,k)) =
121 :     if member vl v then (v::z,Int.min(m,i),Int.max(n,j),k+1)
122 :     else (z,i,j,k)
123 :     in foldr h ([],1000000,0,0) free
124 :     end
125 :    
126 :     fun partBindings fl =
127 :     let fun h((fe as (ESCAPE,_,_,_,_))::r,el,kl,rl,cl,jl) =
128 :     h(r,fe::el,kl,rl,cl,jl)
129 :     | h((fe as (KNOWN,_,_,_,_))::r,el,kl,rl,cl,jl) =
130 :     h(r,el,fe::kl,rl,cl,jl)
131 :     | h((fe as (KNOWN_REC,_,_,_,_))::r,el,kl,rl,cl,jl) =
132 :     h(r,el,fe::kl,fe::rl,cl,jl)
133 :     | h((fe as (CONT,_,_,_,_))::r,el,kl,rl,cl,jl) =
134 :     h(r,el,kl,rl,fe::cl,jl)
135 :     | h((fe as (KNOWN_CONT,_,_,_,_))::r,el,kl,rl,cl,jl) =
136 :     h(r,el,kl,rl,fe::cl,fe::jl)
137 :     | h((fe as (KNOWN_TAIL,_,_,_,_))::r,el,kl,rl,cl,jl) =
138 :     h(r,el,fe::kl,rl,cl,jl)
139 :     | h(_::r,el,kl,rl,cl,jl) = bug "partBindings in closure phase 231"
140 :     | h([],el,kl,rl,cl,jl) = (el,kl,rl,cl,jl)
141 :     in h(fl,[],[],[],[],[])
142 :     end
143 :    
144 :     val closureLvar =
145 :     let val save = (!saveLvarNames before saveLvarNames := true)
146 :     val closure = LV.namedLvar(Symbol.varSymbol "closure")
147 :     in (saveLvarNames := save; fn () => dupLvar closure)
148 :     end
149 :    
150 :     (* build a list of k dummy cells *)
151 :     fun extraDummy(k) =
152 :     let fun ec(k,l) = if k <= 0 then l else ec(k-1,dumcs::l)
153 :     in ec(k,[])
154 :     end
155 :    
156 :     fun extraLvar (k,t) =
157 :     let fun h (n,l,z) = if n < 1 then (rev l,z) else h(n-1,(mkLvar()::l),t::z)
158 :     in h(k,[],[])
159 :     end
160 :    
161 :     (* cut out the first n elements from a list *)
162 :     fun cuthead(n,[]) = []
163 :     | cuthead(n,l as (_::r)) = if n <= 0 then l else cuthead(n-1,r)
164 :    
165 :     (* cut out the last n elements from a list *)
166 :     fun cuttail(n,l) = rev(cuthead(n,rev l))
167 :    
168 :     (* sort according to each variable's life time etc. *)
169 : monnier 411 fun sortlud0 x = ListMergeSort.sort (fn ((_,_,i : int),(_,_,j)) => (i>j)) x
170 : monnier 245
171 :     fun sortlud1 x =
172 :     let fun ludfud1((_,m:int,i:int),(_,n,j)) =
173 :     (i>j) orelse ((i=j) andalso (m>n))
174 : monnier 411 in ListMergeSort.sort ludfud1 x
175 : monnier 245 end
176 :    
177 :     fun sortlud2(l,vl) =
178 :     let fun h(v,m,i) =
179 :     if member vl v then (i*1000+m*10) else (i*1000+m*10+1)
180 :     fun ludfud2((_,m,v),(_,n,w)) =
181 :     (m>n) orelse ((m=n) andalso (v<w))
182 :    
183 :     val nl = map (fn (u as (v,_,_)) => (u,h u,v)) l
184 : monnier 411 in map #1 (ListMergeSort.sort ludfud2 nl)
185 : monnier 245 end
186 :    
187 :     (* cut out the first n elements, returns both the header and the rest *)
188 :     fun partvnum(l,n) =
189 :     let fun h(vl,[],n) = (vl,[])
190 :     | h(vl,s as ((a,_,_)::r),n) =
191 :     if n <= 0 then (vl,s) else h(enter(a,vl),r,n-1)
192 :     in h([],l,n)
193 :     end
194 :    
195 :     (* spill (into sbase) if too many free variables (>n) *)
196 :     fun spillFree(free,n,vbase,sbase) =
197 :     let val len = length free
198 :     in if (len < n) then (merge(map #1 free,vbase),sbase)
199 :     else (let val (nfree,nspill) = partvnum(sortlud1 free,n)
200 :     in (merge(nfree,vbase),uniqV(nspill@sbase))
201 :     end)
202 :     end
203 :    
204 :     fun get_vn([],v) = NONE
205 :     | get_vn((a,m,n)::r,v : lvar) =
206 :     if v > a then get_vn(r,v)
207 :     else if v = a then SOME (m,n) else NONE
208 :    
209 :     (* check if x is a subset of y, x and y must be sorted lists *)
210 :     fun subset (x,y) = (case difference(x,y) of [] => true | _ => false)
211 :    
212 :     (* check if a CPS type is a small constant size object *)
213 :     fun smallObj(FLTt | INTt) = true
214 :     | smallObj _ = false
215 :    
216 :     (* check if a record_kind is sharable by a function of fun_kind *)
217 :     fun sharable((RK_CONT|RK_FCONT),(ESCAPE|KNOWN)) = not (MachSpec.quasiStack)
218 :     | sharable _ = true
219 :    
220 :     (* given a fun_kind return the appropriate unboxed closure kind *)
221 :     (* need runtime support for RK_FCONT (new tags etc.) CURRENTLY NOT SUPPORTED *)
222 :     fun unboxedKind (CONT | KNOWN_CONT) = RK_FCONT
223 :     | unboxedKind _ = RK_FBLOCK
224 :    
225 :     (* given a fix kind return the appropriate boxed closure kind *)
226 :     fun boxedKind (CONT | KNOWN_CONT) = RK_CONT
227 :     | boxedKind KNOWN = RK_KNOWN
228 :     | boxedKind _ = RK_ESCAPE
229 :    
230 :     fun COMMENT f = if !CGoptions.comment then (f(); ()) else ()
231 :    
232 :     (****************************************************************************
233 :     * CLOSURE REPRESENTATIONS *
234 :     ****************************************************************************)
235 :    
236 :     type csregs = (value list * value list) option
237 :    
238 :     datatype closureRep = CR of int * closure
239 :     withtype closure = {functions : (lvar * lvar) list,
240 :     values : lvar list,
241 :     closures : (lvar * closureRep) list,
242 :     kind : record_kind,
243 :     core : lvar list,
244 :     free : lvar list,
245 :     stamp : lvar}
246 :    
247 :     type knownfunRep = {label : lvar,
248 :     gpfree : lvar list,
249 :     fpfree : lvar list,
250 :     csdef : (value list * value list) option}
251 :    
252 :     type calleeRep = value * value list * value list
253 :    
254 :     datatype object = Value of cty
255 :     | Callee of calleeRep
256 :     | Closure of closureRep
257 :     | Function of knownfunRep
258 :    
259 :     datatype access = Direct
260 :     | Path of lvar * accesspath * (lvar * closureRep) list
261 :    
262 :    
263 :     (****************************************************************************
264 :     * UTILITY FUNCTIONS FOR ELIMINATING THE CLOSURE OFFSET *
265 :     ****************************************************************************)
266 :     (** should we adjust the offset *)
267 :     fun adjOff (i, off) =
268 :     if i > 0 then 1
269 :     else if off = 0 then 0 else bug "unexpected case in adjOff"
270 :    
271 :     (** should we treat the mutually recursive functions specially *)
272 :     fun mutRec [] = false
273 :     | mutRec [_] = false
274 :     | mutRec _ = true
275 :    
276 :     (* if no_offset is false, use the following versions:
277 :    
278 :     fun adjOff (i, off) = i - off
279 :     fun mutRec _ = false
280 :     *)
281 :    
282 :     (****************************************************************************
283 :     * STATIC ENVIRONMENT *
284 :     ****************************************************************************)
285 :    
286 :     abstype env = Env of lvar list * (* values *)
287 :     (lvar * closureRep) list * (* closures *)
288 :     lvar list * (* disposable cells *)
289 :     object Intmap.intmap (* what map *)
290 :     with
291 :    
292 :     (****************************************************************************
293 :     * Environment Initializations and Augmentations *
294 :     ****************************************************************************)
295 :    
296 :     exception NotBound
297 :     fun emptyEnv() = Env([],[],[],Intmap.new(32,NotBound))
298 :    
299 :     (* add a new object to an environment *)
300 :     fun augment(m as (v,obj),e as Env(valueL,closureL,dispL,whatMap)) =
301 :     (Intmap.add whatMap m;
302 :     case obj
303 :     of Value _ => Env(v::valueL,closureL,dispL,whatMap)
304 :     | Closure cr => Env(valueL,(v,cr)::closureL,dispL,whatMap)
305 :     | _ => e)
306 :    
307 :     (* add a simple program variable "v" with type t into env *)
308 :     fun augValue(v,t,env) = augment((v,Value t),env)
309 :    
310 :     (* add a list of value variables into env *)
311 :     fun faugValue([],[],env) = env
312 :     | faugValue(a::r,t::z,env) = faugValue(r,z,augValue(a,t,env))
313 :     | faugValue _ = bug "faugValue in closure.249"
314 :    
315 :     (* add a callee-save continuation object into env *)
316 :     fun augCallee(v,c,csg,csf,env) = augment((v,Callee(c,csg,csf)),env)
317 :    
318 :     (* add a known continuation function object into env *)
319 :     fun augKcont(v,l,gfree,ffree,csg,csf,env) =
320 :     let val kobj = Function {label=l,gpfree=gfree,fpfree=ffree,
321 :     csdef=SOME(csg,csf)}
322 :     in augment((v,kobj),env)
323 :     end
324 :    
325 :     (* add a general known function object into env *)
326 :     fun augKnown(v,l,gfree,ffree,env) =
327 :     let val kobj = Function {label=l,gpfree=gfree,fpfree=ffree,csdef=NONE}
328 :     in augment((v,kobj),env)
329 :     end
330 :    
331 :     (* add an escaping function object into env *)
332 :     fun augEscFun(v,i,CR(off,x),env) =
333 :     let val clo = Closure(CR(off+i,x))
334 :     in augment((v,clo),env)
335 :     end
336 :    
337 :     (****************************************************************************
338 :     * Environment Printing (for debugging) *
339 :     ****************************************************************************)
340 :    
341 :     val im : int -> string = Int.toString
342 :     val vp = pr o LambdaVar.lvarName
343 :     fun Vp (v,m,n) = (vp v; pr " fd="; pr (im m); pr " ld=";
344 :     pr (im n))
345 :     fun ifkind (KNOWN_TAIL) = pr " KNOWN_TAIL "
346 :     | ifkind (KNOWN) = pr " KNOWN "
347 :     | ifkind (KNOWN_REC) = pr " KNOWN_REC "
348 :     | ifkind (ESCAPE) = pr " ESCAPE "
349 :     | ifkind (CONT) = pr " CONT "
350 :     | ifkind (KNOWN_CONT) = pr " KNOWN_CONT "
351 :     | ifkind _ = pr " STRANGE_KIND "
352 :     fun plist p l = (app (fn v => (pr " "; p v)) l; pr "\n")
353 :     val ilist = plist vp
354 :     val iVlist = plist Vp
355 :     val iKlist = plist ifkind
356 :     fun sayv(VAR v) = vp v
357 :     | sayv(LABEL v) = (pr "(L)"; vp v)
358 :     | sayv(INT i) = (pr "(I)"; pr(Int.toString i))
359 :     | sayv(INT32 i) = (pr "(I32)"; pr(Word32.toString i))
360 :     | sayv(REAL r) = pr r
361 :     | sayv(STRING s) = (pr "\""; pr s; pr "\"")
362 :     | sayv(OBJECT _) = pr "**OBJECT**"
363 :     | sayv(VOID) = pr "**VOID**"
364 :     val vallist = plist sayv
365 :    
366 :     fun printEnv(Env(valueL,closureL,dispL,whatMap)) =
367 :     let fun ip (i : int) = pr(Int.toString i)
368 :     val tlist = plist (fn (a,b) => (vp a; pr "/"; sayv(LABEL b)))
369 :     fun fp(v,Function{label,gpfree,fpfree,...}) =
370 :     (vp v; pr "/known "; sayv(LABEL label); pr " -";
371 :     ilist (gpfree@fpfree))
372 :     | fp _ = ()
373 :     fun cp (v,Callee(v',gl, fl)) =
374 :     (vp v; pr "/callee(G) "; sayv v'; pr " -"; vallist gl;
375 :     vp v; pr "/callee(F) "; sayv v'; pr " -"; vallist fl)
376 :     | cp _ = ()
377 :     fun p(indent,l,seen) =
378 :     let fun c(v,CR(off, {functions,values,closures,stamp,kind,...})) =
379 :     (indent(); pr "Closure "; vp v; pr "/"; ip stamp;
380 :     pr " @"; ip off;
381 :     if member seen stamp
382 :     then pr "(seen)\n"
383 :     else (pr ":\n";
384 :     case functions
385 :     of nil => ()
386 :     | _ => (indent(); pr " Funs:"; tlist functions);
387 :     case values
388 :     of nil => ()
389 :     | _ => (indent(); pr " Vals:"; ilist values);
390 :     p(fn() => (indent();pr " "),closures,enter(stamp,seen))))
391 :     in app c l
392 :     end
393 :     in pr "Values:"; ilist valueL;
394 :     pr "Closures:\n"; p(fn () => (),closureL,nil);
395 :     pr "Disposable records:\n"; ilist dispL;
396 :     pr "Known function mapping:\n"; Intmap.app fp whatMap;
397 :     pr "Callee-save continuation mapping:\n";
398 :     Intmap.app cp whatMap
399 :     end
400 :    
401 :     (****************************************************************************
402 :     * Environment Lookup (whatIs, returning object type) *
403 :     ****************************************************************************)
404 :    
405 :     exception Lookup of lvar * env
406 :     fun whatIs(env as Env(_,_,_,whatMap),v) =
407 :     Intmap.map whatMap v handle NotBound => raise Lookup(v,env)
408 :    
409 :     (* Add v to the access environment, v must be in whatMap already *)
410 :     fun augvar(v,e as Env(valueL,closureL,dispL,whatMap)) =
411 :     case whatIs(e,v)
412 :     of Value _ => Env(v::valueL,closureL,dispL,whatMap)
413 :     | Closure cr => Env(valueL,(v,cr)::closureL,dispL,whatMap)
414 :     | _ => bug "augvar in cps/closure.223"
415 :    
416 :     (****************************************************************************
417 :     * Environment Access (whereIs, returning object access path) *
418 :     ****************************************************************************)
419 :    
420 :     fun whereIs(env as Env(valueL,closureL,_,whatMap),target) =
421 :     let fun bfs(nil,nil) = raise Lookup(target,env)
422 :     | bfs(nil,next) = bfs(next,nil)
423 :     | bfs((h, ox as (_, CR(off, {functions,values,
424 :     closures,stamp,...})))::m, next) =
425 :     let fun cls(nil, _, next) = bfs(m,next)
426 :     | cls((u as (v,cr))::t, i, next) =
427 :     if target=v then h(SELp(i, OFFp 0), [])
428 :     else let val nh = fn (p,z) => h(SELp(i, p), u::z)
429 :     in cls(t, i+1, (nh,u)::next)
430 :     end
431 :     fun vls(nil,i) = cls(closures, i, next)
432 :     | vls(v::t,i) =
433 :     if target=v then h(SELp(i, OFFp 0), [])
434 :     else vls(t, i+1)
435 :     fun fns(nil,i) = vls(values, adjOff(i,off))
436 :     | fns((v,l)::t,i) =
437 :     if target=v then
438 :     if i = off then h(OFFp 0, [])
439 :     else h(OFFp(i-off),[ox])
440 :     else fns(t,i+1)
441 :     in if target=stamp
442 :     then if off = 0 then h(OFFp 0, [])
443 :     else h(OFFp(~off), [ox])
444 :     else fns(functions, 0)
445 :     end
446 :     fun search closures =
447 :     let val s = map (fn x => (fn (p,z) => (#1 x,p,z), x)) closures
448 :     in Path (bfs(s,nil))
449 :     end
450 :     fun withTgt(v,CR(_,{free,...})) = member free target
451 :     fun lookC ((v,cr)::tl) =
452 :     if target=v then Direct
453 :     else (case cr
454 :     of CR(_, {functions=[], ...}) => lookC tl
455 :     | CR(off, {functions, ...}) =>
456 :     let val (y, _) = List.nth(functions, off)
457 :     in if (target=y) then Path (v, OFFp 0, [])
458 :     else lookC tl
459 :     end)
460 :     | lookC nil = search (sublist withTgt closureL)
461 :     fun lookV (v::tl) =
462 :     if target=v then Direct else lookV tl
463 :     | lookV nil = search closureL
464 :     in case whatIs(env,target)
465 :     of Function _ => Direct
466 :     | Callee _ => Direct
467 :     | Closure _ => lookC closureL
468 :     | Value _ => lookV valueL
469 :     end
470 :    
471 :    
472 :     (****************************************************************************
473 :     * Environment Filtering (get the set of current reusable closures) *
474 :     ****************************************************************************)
475 :    
476 :     (* extract all closures at top n levels, containing duplicates. *)
477 :     fun extractClosures (l,n,base) =
478 :     let fun g(_,CR(_,{closures,...})) = closures
479 :    
480 :     fun h(k,[],z) = z
481 :     | h(k,r,z) =
482 :     if k <= 0 then z
483 :     else (let val nl = List.concat (map g r)
484 :     in h(k-1,nl,nl@z)
485 :     end)
486 :    
487 :     fun s([],vl,r) = r
488 :     | s((u as (v,_))::z,vl,r) =
489 :     if member vl v then s(z,vl,r)
490 :     else s(z,enter(v,vl),u::r)
491 :    
492 :     in s(h(n,l,l@base),[],[])
493 :     end
494 :    
495 :     (* fetch all free variables residing above level n in the closure cr *)
496 :     fun fetchFree(v,CR(_,{closures,functions,values,...}),n) =
497 :     if n <= 0 then [v]
498 :     else (let fun g((x,cr),z) = merge(fetchFree(x,cr,n-1),z)
499 :     in foldr g (uniq (v::values@(map #1 functions))) closures
500 :     end)
501 :    
502 :     (* filter out all closures in the current env that are safe to reuse *)
503 :     fun fetchClosures(env as Env(_,closureL,_,_),lives,fkind) =
504 :     let val (closlist,lives) =
505 :     foldr (fn (v,(z,l)) => case whatIs(env,v)
506 :     of (Closure (cr as (CR(_,{free,...})))) =>
507 :     ((v,cr)::z,merge(free,l))
508 :     | _ => (z,l)) ([],lives) lives
509 :    
510 :     fun reusable (v,CR(_,{core,kind,...})) =
511 :     ((sharable(kind,fkind)) andalso
512 :     ((subset(core,lives)) orelse (member lives v)))
513 :    
514 :     fun reusable2 (_,CR(_,{kind,...})) = sharable(kind,fkind)
515 :    
516 :     fun fblock (_,CR(_,{kind=(RK_FBLOCK|RK_FCONT),...})) = true
517 :     | fblock _ = false
518 :    
519 :     val level = 4 (* should be made adjustable in the future *)
520 :     val closlist = extractClosures(closureL,level,closlist)
521 :     val (fclist,gclist) = partition fblock closlist
522 :    
523 :     in (sublist reusable gclist, sublist reusable2 fclist)
524 :     end
525 :    
526 :     (* return the immediately enclosing closure, if any. This is a hack. *)
527 :     fun getImmedClosure (Env(_,closureL,_,_)) =
528 :     let fun getc ([z]) = SOME z
529 :     | getc (_::tl) = getc tl
530 :     | getc nil = NONE
531 :     in getc closureL
532 :     end
533 :    
534 :     (****************************************************************************
535 :     * Continuation Frames Book-keeping (in support of quasi-stack frames) *
536 :     ****************************************************************************)
537 :    
538 :     (* vl is a list of continuation frames that were reused along this path *)
539 :     fun recoverFrames(vl,Env(valueL,closureL,dispL,whatMap)) =
540 :     let fun h(a,l) = if member vl a then l else a::l
541 :     val ndispL = foldr h [] dispL
542 :     in Env(valueL,closureL,ndispL,whatMap)
543 :     end
544 :    
545 :     (* save the continuation closure "v" and its descendants *)
546 :     fun saveFrames(v,CR(_,{free,kind=(RK_CONT|RK_FCONT),...}),env) =
547 :     recoverFrames(free,env)
548 :     | saveFrames(_,_,env) = env
549 :    
550 :     (* install the set of live frames at the entrance of this continuations *)
551 :     fun installFrames(newd,env as Env(valueL,closureL,dispL,whatMap)) =
552 :     Env(valueL,closureL,newd@dispL,whatMap)
553 :    
554 :     (* split the current disposable frame list into two based on the context *)
555 :     fun splitEnv(Env(valueL,closureL,dispL,w),inherit) =
556 :     let val (d1,d2) = partition inherit dispL
557 :     in (Env([],[],d1,w),Env(valueL,closureL,d2,w))
558 :     end
559 :    
560 :     (* return the set of disposable frames *)
561 :     fun deadFrames(Env(_,_,dispL,_)) = dispL
562 :    
563 :     end (* abstype env *)
564 :    
565 :     type frags = (fun_kind * lvar * lvar list * cty list * cexp * env *
566 :     int * value list * value list * lvar option) list
567 :    
568 :     (****************************************************************************
569 :     * UTILITY FUNCTIONS FOR CALLEE-SAVE REGISTERS *
570 :     ****************************************************************************)
571 :    
572 :     (* it doesnot take the looping freevar into account, NEEDS MORE WORK *)
573 :     fun fetchCSregs(c,m,n,env) =
574 :     case whatIs(env,c)
575 :     of Callee (_,csg,csf) => (cuthead(m,csg),cuthead(n,csf))
576 :     | Function {csdef=SOME(csg,csf),...} => (cuthead(m,csg),cuthead(n,csf))
577 :     | _ => ([],[])
578 :    
579 :     (* fetch m csgpregs and n csfpgregs from the default continuation c *)
580 :     fun fetchCSvars(c,m,n,env) =
581 :     let val (gpregs,fpregs) = fetchCSregs(c,m,n,env)
582 :     in (uniqvar gpregs,uniqvar fpregs)
583 :     end
584 :    
585 :     (* fill the empty csgpregs with the closure *)
586 :     fun fillCSregs(csg,c) =
587 :     let fun g([],l) = l
588 :     | g(a::r,l) = g(r,a::l)
589 :     fun h(NONE::r,x,c) = g(x,c::r)
590 :     | h(u::r,x,c) = h(r,u::x,c)
591 :     | h([],x,c) = bug "no empty slot in fillCSregs in closure.sml"
592 :     in h(csg,[],c)
593 :     end
594 :    
595 :     (* fill the empty cs formals with new variables, augment the environment *)
596 :     fun fillCSformals(gpbase,fpbase,env,ft) =
597 :     let fun h(SOME v,(e,a,c)) = (augvar(v,e),v::a,(ft v)::c)
598 :     | h(NONE,(e,a,c)) =
599 :     let val v = mkLvar()
600 :     in (augValue(v,BOGt,e),v::a,BOGt::c)
601 :     end
602 :    
603 :     fun g(SOME v,(e,a,c)) = (augvar(v,e),v::a,(FLTt)::c)
604 :     | g(NONE,(e,a,c)) =
605 :     let val v = mkLvar()
606 :     in (augValue(v,FLTt,e),v::a,FLTt::c)
607 :     end
608 :    
609 :     in foldr h (foldr g (env,[],[]) fpbase) gpbase
610 :     end
611 :    
612 :     (* get all free variables in cs regs, augment the environment *)
613 :     fun varsCSregs(gpbase,fpbase,env) =
614 :     let fun h(NONE,(e,l)) = (e,l)
615 :     | h(SOME v,(e,l)) = (augvar(v,e),enter(v,l))
616 :    
617 :     val (env,gfree) = foldr h (env,[]) gpbase
618 :     val (env,ffree) = foldr h (env,[]) fpbase
619 :     in (gfree,ffree,env)
620 :     end
621 :    
622 :     (* get all free variables covered by the cs regs *)
623 :     fun freevCSregs(gpbase,env) =
624 :     let fun h(NONE,l) = l
625 :     | h(SOME v,l) = case whatIs(env,v)
626 :     of (Closure (CR(_,{free,kind=(RK_CONT|RK_FCONT),...}))) =>
627 :     (merge(free,l))
628 :     | _ => l
629 :     in foldr h [] gpbase
630 :     end
631 :    
632 :     (* partnull cuts out the head of csregs till the first empty position *)
633 :     fun partnull l =
634 :     let fun h([],r) = bug "partnull. no empty position in closure 343"
635 :     | h(NONE::z,r) = (rev(NONE::r),z)
636 :     | h(u::z,r) = h(z,u::r)
637 :     in h(l,[])
638 :     end
639 :    
640 :     (* create a template of the base callee-save registers (n : extra cs regs) *)
641 :     fun mkbase(regs,free,n) =
642 :     let fun h((VAR v),(r,z)) =
643 :     if member free v then ((SOME v)::r,enter(v,z))
644 :     else (dumcs::r,z)
645 :     | h(_,(r,z)) = (dumcs::r,z)
646 :     in foldr h (extraDummy(n),[]) regs
647 :     end
648 :    
649 :     (* modify the base, retain only those variables in free *)
650 :     fun modifybase(base,free,n) =
651 :     let fun h(s as (SOME v),(r,z,m)) =
652 :     if member free v then (s::r,rmv(v,z),m)
653 :     else (if m > 0 then (s::r,z,m-1) else (dumcs::r,z,m))
654 :     | h(NONE,(r,z,m)) = (NONE::r,z,m)
655 :     in foldr h ([],free,n) base
656 :     end
657 :    
658 :     (* fill the empty callee-save registers, assuming newv can be put in base *)
659 :     fun fillbase(base,newv) =
660 :     let fun g([],s) = s
661 :     | g(a::r,s) = g(r,a::s)
662 :     fun h(s,l,[]) = g(l,s)
663 :     | h(NONE::z,l,a::r) = h(z,(SOME a)::l,r)
664 :     | h((u as (SOME _))::z,l,r) = h(z,u::l,r)
665 :     | h([],l,_) = bug "no enough slots: fillbase 398 in closure.sml"
666 :     in h(base,[],newv)
667 :     end
668 :    
669 :     (****************************************************************************
670 :     * VARIABLE ACCESS PATH LOOKUP *
671 :     ****************************************************************************)
672 :    
673 :     (** simulating the OFFSET operation by reconstructing the closures *)
674 :     fun offset ((z, CR(n,{functions,values,closures,...})), i, u, x, env) =
675 :     let (* invariants: length functions > 1 *)
676 :     val (_,l) = List.nth(functions, n+i)
677 :     val _ = case u of VAR z' => if z = z' then ()
678 :     else bug "unexpected case in offset 1"
679 :     | _ => bug "unexpected case in offset 2"
680 :     val lab = (LABEL l, OFFp0)
681 :     val vl =
682 :     case (closures, values)
683 :     of (([(v,_)], []) | ([], [v])) => [lab, (VAR v, OFFp0)]
684 :     | ([], []) => [lab]
685 :     | _ => bug "unexpected case in offset 3"
686 :     val (hdr, env) = recordEl(RK_ESCAPE, vl, x, env)
687 :     in (hdr, env)
688 :     end
689 :    
690 :     (* if no_offset is false, use this version
691 :    
692 :     fun offset (_, i, u, x, env) =
693 :     let val hdr = fn ce => OFFSET(i, u, x, ce)
694 :     in (hdr, env)
695 :     end
696 :     *)
697 :    
698 :     (* build the header by partially following an access path *)
699 :     and pfollow (p, env, hdr) =
700 :     (case p
701 :     of (v, np as ((OFFp 0) | (SELp(_,OFFp 0))), []) => ((VAR v,np), env, hdr)
702 :     | (v, np as (OFFp i), [c as (_, cr as CR(n,z))]) =>
703 :     let val w = closureLvar()
704 :     val (nh, env) = offset(c, i, VAR v, w, env)
705 :     val env = augment((w, Closure (CR(n+i,z))), env)
706 :     in ((VAR w, OFFp 0), env, hdr o nh)
707 :     end
708 :     | (v, SELp(i,np), (w,cr)::z) =>
709 :     let val env = augment((w,Closure cr),env)
710 :     val nhdr = fn ce => SELECT(i,VAR v,w,BOGt,ce)
711 :     in pfollow((w,np,z), env, hdr o nhdr)
712 :     end
713 :     | _ => bug "pfollow on an inconsistent path")
714 :    
715 :     (* build the header by following an access path *)
716 :     and follow (rootvar, t) =
717 :     let fun g ((v, OFFp 0, []), env, h) =
718 :     (env, h o (fn ce => OFFSET(0,VAR v,rootvar,ce)))
719 :     | g ((v, OFFp i, [c]), env, h) =
720 :     let val (nh, env) = offset(c, i, VAR v, rootvar, env)
721 :     (* environment is update by the client of "follow" *)
722 :     in (env, h o nh)
723 :     end
724 :     | g ((v, SELp(i,OFFp 0),[]), env, h) =
725 :     (env, h o (fn ce => SELECT(i,VAR v,rootvar,t,ce)))
726 :     | g ((v, SELp(i,p), (w,cr)::z), env, h) =
727 :     let val env = augment((w,Closure cr), env)
728 :     in g((w,p,z), env, h o (fn ce => SELECT(i,VAR v,w,BOGt,ce)))
729 :     end
730 :     | g _ = bug "follow on an inconsistent path"
731 :     in g
732 :     end
733 :    
734 :     (****************************************************************************
735 :     * recordEl finds the complete access paths for elements of a record. It *
736 :     * returns a header for profiling purposes if needed. *
737 :     ****************************************************************************)
738 :     and recordEl(rk, l, w, env) =
739 :     let fun g(u as (VAR v, OFFp 0),(l,cl,hdr,env)) =
740 :     let val env = case whatIs(env,v) (* maybe unnecessary *)
741 :     of Closure cr => saveFrames(v,cr,env)
742 :     | _ => env
743 :    
744 :     val (m,cost,nhdr,env) = case whereIs(env,v)
745 :     of Direct => (u,0,hdr,env)
746 :     | Path(np as (start,path,_)) =>
747 :     (let val n = lenp path
748 :     val nhdr =
749 :     if (!CGoptions.staticprof) then
750 :     (SProf.incln (n); hdr o (fn ce =>
751 :     SETTER(P.acclink,[INT n,VAR start],ce)))
752 :     else hdr
753 :     val (u,env,nhdr) =
754 :     if (!CGoptions.sharepath)
755 :     then pfollow(np, env, nhdr)
756 :     else ((VAR start,path), env, nhdr)
757 :     in (u,n,nhdr,env)
758 :     end)
759 :     in (m::l,cost::cl,nhdr,env)
760 :     end
761 :     | g(u as (VAR _, _), _) = bug "unexpected case in recordEl"
762 :     | g(u,(l,cl,hdr,env)) = (u::l,0::cl,hdr,env)
763 :    
764 :     val (rl,cl,hdr,env) = foldr g (nil,nil,fn ce => ce,env) l
765 :     val hdr = if (!CGoptions.allocprof)
766 :     then hdr o (profRecLinks cl) else hdr
767 :     val nhdr = fn ce => hdr (RECORD(rk, rl, w, ce))
768 :     in (nhdr, env)
769 :     end
770 :    
771 :     (****************************************************************************
772 :     * fixAccess finds the access path to a variable. A header to select the *
773 :     * variable from the environment is returned, along with a new environment *
774 :     * that reflects the actions of the header (this last implements a "lazy *
775 :     * display"). fixAccess actually causes rebindings -- the variable *
776 :     * requested is rebound if it is not immediately available in the *
777 :     * environment, these rebindings are later eliminated by an "unrebind" pass *
778 :     * which basically does the alpha convertions. *
779 :     ****************************************************************************)
780 :    
781 :     fun fixAccess(args,env) =
782 :     let fun access(VAR rootvar,(env,header)) =
783 :     let val what = whatIs(env,rootvar)
784 :     val (env,t) = case what
785 :     of Value x => (env,x)
786 :     | Closure cr => (saveFrames(rootvar,cr,env),BOGt)
787 :     | _ => bug "Callee or Known in fixAccess closure"
788 :    
789 :     in case whereIs(env,rootvar)
790 :     of Direct => (env,header)
791 :     | Path (p as (_,path,_)) =>
792 :     let val (env,header) = follow (rootvar,t) (p,env,header)
793 :     val env = augment((rootvar,what),env)
794 :     fun profL(n) =
795 :     if not(!CGoptions.allocprof) then
796 :     (if (n>0) andalso (!CGoptions.staticprof) then
797 :     ((SProf.incln (n);
798 :     fn ce => SETTER(P.acclink,
799 :     [INT n,VAR rootvar],ce)))
800 :     else (fn ce => ce))
801 :     else profLinks(n)
802 :     in (env, header o profL(lenp path))
803 :     end
804 :     end
805 :     | access(_,y) = y
806 :     in foldr access (env,fn x => x) args
807 :     end
808 :    
809 :     (****************************************************************************
810 :     * fixArgs is a slightly modified version of fixAccess. It's used to find *
811 :     * the access path of function arguments in the APP expressions *
812 :     ****************************************************************************)
813 :    
814 :     fun fixArgs(args,env) =
815 :     let fun access(z as (VAR rootvar),(res,env,h)) =
816 :     let val what = whatIs(env,rootvar)
817 :     val (env,t) = case what
818 :     of Value x => (env,x)
819 :     | Closure cr => (saveFrames(rootvar,cr,env),BOGt)
820 :     | _ => (env,BOGt)
821 :     in case what
822 :     of Function _ => bug "Known in fixArgs closure.sml"
823 :     | Callee(l,csg,csf) =>
824 :     (let val nargs = (l::csg)@csf@res
825 :     val (env,hdr) = fixAccess(nargs,env)
826 :     in (nargs,env,h o hdr)
827 :     end)
828 :     | _ => (case whereIs(env,rootvar)
829 :     of Direct => (z::res,env,h)
830 :     | Path (p as (_,path,_)) =>
831 :     let val (env,hdr) = follow (rootvar,t) (p,env,h)
832 :     val env = augment((rootvar,what),env)
833 :     fun profL(n) =
834 :     if not(!CGoptions.allocprof) then
835 :     if (n>0) andalso (!CGoptions.staticprof)
836 :     then (SProf.incln (n);
837 :     fn ce => SETTER(P.acclink,
838 :     [INT n,VAR rootvar],ce))
839 :     else (fn ce => ce)
840 :     else profLinks(n)
841 :     in (z::res,env,hdr o profL(lenp path))
842 :     end)
843 :     end
844 :     | access(z,(res,env,h)) = (z::res,env,h)
845 :     in foldr access ([],env,fn x => x) args
846 :     end
847 :    
848 :     (****************************************************************************
849 :     * CLOSURE DISPOSAL *
850 :     ****************************************************************************)
851 :    
852 :     (* dispose the set of dead continuation closures *)
853 :     fun disposeFrames(env) =
854 :     if (MachSpec.quasiStack) then
855 :     (let val vl = deadFrames(env)
856 :     val (env,hdr) = fixAccess(map VAR vl,env)
857 :     fun g(v::r,h) = g(r,h o (fn ce => SETTER(P.free,[VAR v],ce)))
858 :     | g([],h) = if (!CGoptions.allocprof)
859 :     then ((profRefCell(length vl)) o hdr o h)
860 :     else hdr o h
861 :     in (env,g(vl,hdr))
862 :     end)
863 :     else (env,fn ce => ce)
864 :    
865 :     (****************************************************************************
866 :     * CLOSURE STRATEGIES *
867 :     ****************************************************************************)
868 :    
869 :     (* produce the CPS header and modify the environment for the new closure *)
870 :     fun mkClosure(cname,contents,cr,rkind,fkind,env) =
871 :     let val _ = if !CGoptions.staticprof
872 :     then SProf.incfk(fkind,length contents) else ()
873 :     val l = map (fn v => (v, OFFp0)) contents
874 :     val (hdr, env) = recordEl(rkind, l, cname, env)
875 :     val nhdr =
876 :     if (!CGoptions.allocprof) then
877 :     let val prof = case fkind of KNOWN => profKClosure
878 :     | ESCAPE => profClosure
879 :     | _ => profCClosure
880 :     in (prof (length contents)) o hdr
881 :     end
882 :     else hdr
883 :     val env = augment((cname, Closure cr), env)
884 :     in case fkind of (CONT|KNOWN_CONT) => (nhdr, env, [cname])
885 :     | _ => (nhdr, env ,[])
886 :     end
887 :    
888 :     (* build an unboxed closure, currently not disposable even if fkind=cont *)
889 :     (* Place int32's after floats for proper alignment *)
890 :    
891 :     fun closureUbGen(cn, free, rk, fk, env) =
892 :     let val nfree = map (fn (v, _, _) => v) free
893 :     val ul = map VAR nfree
894 :     val cr = CR(0,{functions=[],closures=[],values=nfree,
895 :     core=[],free=enter(cn,nfree),kind=rk,stamp=cn})
896 :     in (mkClosure(cn, ul, cr, rk, fk, env), cr)
897 :     end
898 :    
899 :     fun closureUnboxed(cn,int32free,otherfree,fk,env) =
900 :     (case (int32free, otherfree)
901 :     of ([], []) => bug "unexpected case in closureUnboxed 333"
902 :     | ([], _) =>
903 :     (let val rk = unboxedKind(fk)
904 :     in #1(closureUbGen(cn, otherfree, rk, fk, env))
905 :     end)
906 :     | (_, []) =>
907 :     (let val rk = RK_I32BLOCK
908 :     in #1(closureUbGen(cn, int32free, rk, fk, env))
909 :     end)
910 :     | _ =>
911 :     (let val rk1 = unboxedKind(fk)
912 :     val cn1 = closureLvar()
913 :     val ((nh1, env, nf1), cr1) =
914 :     closureUbGen(cn1, otherfree, rk1, fk, env)
915 :     val rk2 = RK_I32BLOCK
916 :     val cn2 = closureLvar()
917 :     val ((nh2, env, nf2), cr2) =
918 :     closureUbGen(cn2, int32free, rk2, fk, env)
919 :     val rk = boxedKind(fk)
920 :     val nfree = map (fn (v, _, _) => v) (int32free@otherfree)
921 :     val nfs = [cn1, cn2]
922 :     val ncs = [(cn1,cr1), (cn2,cr2)]
923 :     val ul = map VAR nfs
924 :     val cr = CR(0, {functions=[],closures=ncs,values=[],
925 :     core=[],free=enter(cn,nfs@nfree),
926 :     kind=rk,stamp=cn})
927 :     val (nh, env, nfs) = mkClosure(cn, ul, cr, rk, fk, env)
928 :     in (nh1 o nh2 o nh, env, nfs)
929 :     end))
930 :    
931 :     (*
932 :     * old code
933 :     *
934 :     * let val nfree = map (fn (v,_,_) => v) (otherfree @ int32free)
935 :     * val ul = map VAR nfree
936 :     * val rk = unboxedKind(fk)
937 :     * val rk = case (int32free,otherfree)
938 :     * of ([],_) => rk
939 :     * | (_,[]) => RK_I32BLOCK
940 :     * | _ => bug "unimplemented int32 + float (nclosure.1)"
941 :     * val cr = CR(0,{functions=[],closures=[],values=nfree,
942 :     * core=[],free=enter(cn,nfree),kind=rk,stamp=cn})
943 :     * in mkClosure(cn,ul,cr,rk,fk,env)
944 :     * end
945 :     *)
946 :    
947 :     (* partition a set of free variables into small frames *)
948 :     fun partFrame(free) =
949 :     if not (MachSpec.quasiStack) then (free,[])
950 :     else
951 :     (let val sz = MachSpec.quasiFrameSz
952 :     fun h([],n,t) = (t,[])
953 :     | h([v],n,t) = (v::t,[])
954 :     | h(z as (v::r),n,t) =
955 :     if n <= 1 then
956 :     (let val (nb,nt) = h(z,sz,[])
957 :     val cn = closureLvar()
958 :     in (cn::t,(cn,nb)::nt)
959 :     end)
960 :     else h(r,n-1,v::t)
961 :     in h(free,sz,[])
962 :     end)
963 :    
964 :     (* partition the free variables into closures and non-closures *)
965 :     fun partKind(cfree,env) =
966 :     let fun g(v,(vls,cls,fv,cv)) =
967 :     let val obj = whatIs(env,v)
968 :     in case obj
969 :     of Value t => (v::vls,cls,enter(v,fv),
970 :     if (smallObj t) then cv else enter(v,cv))
971 :     | Closure (cr as CR (_,{free,core,...})) =>
972 :     (vls,(v,cr)::cls,merge(free,fv),merge(core,cv))
973 :     | _ => bug "unexpected obj in kind in cps/closure.sml"
974 :     end
975 :     in foldr g (nil,nil,nil,nil) cfree
976 :     end
977 :    
978 :     (* closure strategy : flat *)
979 :     fun flat(env,cfree,rk,fk) =
980 :     let val (topfv,clist) = case rk
981 :     of (RK_CONT | RK_FCONT) => partFrame(cfree)
982 :     | _ => (cfree,[])
983 :    
984 :     fun g((cn,free),(env,hdr,nf)) =
985 :     let val (vls,cls,fvs,cvs) = partKind(free,env)
986 :     val cr = CR(0,{functions=[],values=vls,closures=cls,
987 :     kind=rk,stamp=cn,core=cvs,free=enter(cn,fvs)})
988 :     val ul = (map VAR vls) @ (map (VAR o #1) cls)
989 :     val (nh,env,nf2) = mkClosure(cn,ul,cr,rk,fk,env)
990 :     in (env,hdr o nh,nf2@nf)
991 :     end
992 :     val (env,hdr,frames) = foldr g (env,fn ce => ce,[]) clist
993 :     val (values,closures,fvars,cvars) = partKind(topfv,env)
994 :    
995 :     in (closures,values,hdr,env,fvars,cvars,frames)
996 :     end
997 :    
998 :     (* closure strategy : linked *)
999 :     fun link(env,cfree,rk,fk) =
1000 :     case getImmedClosure(env)
1001 :     of NONE => flat(env,cfree,rk,fk)
1002 :     | SOME (z,CR(_,{free,...})) =>
1003 :     let val notIn = sublist (not o (member free)) cfree
1004 :     in if (length(notIn) = length(cfree))
1005 :     then flat(env,cfree,rk,fk)
1006 :     else flat(env,enter(z,cfree),rk,fk)
1007 :     end
1008 :    
1009 :     (* partition a set of free variables into layered groups based on their lud *)
1010 :     fun partLayer(free,ccl) =
1011 :     let fun find(r,(v,all)::z) = if subset(r,all) then SOME v else find(r,z)
1012 :     | find(r,[]) = NONE
1013 :    
1014 :     (* current limit of a new layer : 3 *)
1015 :     fun m([],t,b) = bug "unexpected case in partLayer in closure"
1016 :     | m([v],t,b) = (enter(v,t),b)
1017 :     | m([v,w],t,b) = (enter(v,enter(w,t)),b)
1018 :     | m(r,t,b) = (case find(r,ccl)
1019 :     of NONE =>
1020 :     let val nc = closureLvar() in (enter(nc,t),(nc,r)::b) end
1021 :     | SOME v => (enter(v,t),b))
1022 :    
1023 :     (* process the rest groups in free *)
1024 :     fun h([],i,r,t,b) = m(r,t,b)
1025 :     | h((v,_,j)::z,i,r,t,b) =
1026 :     if j = i then h(z,i,enter(v,r),t,b)
1027 :     else let val (nt,nb) = m(r,t,b)
1028 :     in h(z,j,[v],nt,nb)
1029 :     end
1030 :    
1031 :     (* cut out the top group and then process the rest *)
1032 :     fun g((v,_,i)::z,j,t) =
1033 :     if i = j then g(z,j,enter(v,t)) else h(z,i,[v],t,[])
1034 :     | g([],j,t) = (t,[])
1035 :    
1036 :     val (topfv,botclos) =
1037 :     case (sortlud0 free)
1038 :     of [] => ([],[])
1039 :     | (u as ((_,_,j)::_)) => g(u,j,[])
1040 :     in (topfv,botclos)
1041 :     end (* function partLayer *)
1042 :    
1043 :     (* closure strategy : layered *)
1044 :     fun layer(env,cfree,rk,fk,ccl) =
1045 :     let val (topfv,clist) = partLayer(cfree,ccl)
1046 :    
1047 :     fun g((cn,vfree),(bh,env,nf)) =
1048 :     let val (cls,vls,nh1,env,fvs,cvs,nf1) = flat(env,vfree,rk,fk)
1049 :     val cr = CR(0,{functions=[],values=vls,closures=cls,
1050 :     kind=rk,stamp=cn,core=cvs,free=enter(cn,fvs)})
1051 :     val ul = (map VAR vls) @ (map (VAR o #1) cls)
1052 :     val (nh2,env,nf2) = mkClosure(cn,ul,cr,rk,fk,env)
1053 :     in (bh o nh1 o nh2, env, nf2@nf1@nf)
1054 :     end
1055 :     val (hdr,env,frames) = foldr g (fn ce => ce,env,[]) clist
1056 :     val (cls,vls,nh,env,fvs,cvs,nfr) = flat(env,topfv,rk,fk)
1057 :    
1058 :     in (cls,vls,hdr o nh,env,fvs,cvs,nfr@frames)
1059 :     end (* function layer *)
1060 :    
1061 :     (* build a general closure, CGoptions.closureStrategy matters *)
1062 :     fun closureBoxed(cn, fns, free, fk, ccl, env) =
1063 :     let val rk = boxedKind(fk)
1064 :     val (cls, vls, hdr, env, fvs, cvs, frames) =
1065 :     case !CGoptions.closureStrategy
1066 :     of (4|3) => link(env, map #1 free, rk, fk)
1067 :     | (2|1) => flat(env, map #1 free, rk, fk)
1068 :     | _ => layer(env, free, rk, fk, ccl)
1069 :    
1070 :     val (cls, vls, hdr, env, fvs, cvs, frames, labels) =
1071 :     if mutRec fns then (* invariants length fns > 1 *)
1072 :     let val nlabs = [LABEL (#2 (hd fns))] (** no sharing **)
1073 :     in (case (cls, vls)
1074 :     of (([],[_]) | ([_],[]) | ([],[])) =>
1075 :     (cls, vls, hdr, env, fvs, cvs, frames, nlabs)
1076 :     | _ =>
1077 :     let val nv = closureLvar()
1078 :     val ul = (map VAR vls) @ (map (VAR o #1) cls)
1079 :     val nfvs = enter(nv, fvs)
1080 :     val cr = CR(0,{functions=[],values=vls,closures=cls,
1081 :     kind=rk,stamp=nv,core=cvs,free=nfvs})
1082 :     val (nh, nenv, nf) = mkClosure(nv,ul,cr,rk,fk,env)
1083 :     in ([(nv,cr)], [], hdr o nh, nenv, nfvs,
1084 :     cvs, nf@frames, nlabs)
1085 :     end)
1086 :     end
1087 :     else (cls, vls, hdr, env, fvs, cvs, frames, map (LABEL o #2) fns)
1088 :    
1089 :     val nfvs = foldr enter (enter(cn,fvs)) (map #1 fns)
1090 :     val cr = CR(0,{functions=fns,values=vls,closures=cls,
1091 :     kind=rk,stamp=cn,core=cvs,free=nfvs})
1092 :     val ul = labels @ (map VAR vls) @ (map (VAR o #1) cls)
1093 :     val (nh, nenv, nf) = mkClosure(cn,ul,cr,rk,fk,env)
1094 :     in (hdr o nh, nenv, cr, nf@frames)
1095 :     end (* function closureBoxed *)
1096 :    
1097 :     (****************************************************************************
1098 :     * CLOSURE SHARING VIA THINNING *
1099 :     ****************************************************************************)
1100 :    
1101 :     (* check if some free variables are really not necessary *)
1102 :     fun shortenFree([],[],_) = ([],[])
1103 :     | shortenFree(gpfree,fpfree,cclist) =
1104 :     let fun g((v,free),l) =
1105 :     if member3 gpfree v then merge(rmv(v,free),l) else l
1106 :     val all = foldr g [] cclist
1107 :     in (removeV(all,gpfree),removeV(all,fpfree))
1108 :     end
1109 :    
1110 :     (* check if ok to share with some closures in the enclosing environment *)
1111 :     fun thinFree(vfree,vlen,closlist,limit) =
1112 :     let fun g(v,(l,m,n)) =
1113 :     if member3 vfree v then (v::l,m+1,n) else (l,m,n+1)
1114 :     fun h((v,cr as CR(_,{free,...})),x) =
1115 :     let val (zl,m,n) = foldr g ([],0,0) free
1116 :     in if m < limit then x else (v,zl,m*10000-n)::x
1117 :     end
1118 :     fun worse((_,_,i),(_,_,j)) = (i<j)
1119 :     fun m([],s,r,k) = (s,r)
1120 :     | m((v,x,_)::y,s,r,k) =
1121 :     if k < limit then (s,r)
1122 :     else (let val (nx,i,n,len) = accumV(x,r)
1123 :     in if len < limit then m(y,s,r,k)
1124 :     else m(y,addV([v],i,n,s),removeV(nx,r),k-len)
1125 :     end)
1126 : monnier 411 val clist = ListMergeSort.sort worse (foldr h [] closlist)
1127 : monnier 245 in m(clist,[],vfree,vlen)
1128 :     end
1129 :    
1130 :     fun thinFpFree(free,closlist) = thinFree(free,length free,closlist,1)
1131 :     fun thinGpFree(free,closlist) =
1132 :     let val len = length free
1133 :     val (spill,free) =
1134 :     if len <= 1 then ([],free)
1135 :     else thinFree(free,len,closlist,Int.min(3,len))
1136 :     in mergeV(spill,free)
1137 :     end
1138 :    
1139 :     (* check if there is a closure containing all the free variables *)
1140 :     fun thinAll([],_,_) = []
1141 :     | thinAll(free as [v],_,_) = free
1142 :     | thinAll(free,cclist,n) =
1143 :     let val vfree = map (fn (v,_,_) => v) free
1144 :     fun g((v,nfree),(x,y)) =
1145 :     if not (subset(vfree,nfree)) then (x,y)
1146 :     else (let val len = length(difference(nfree,vfree))
1147 :     in if len < y then (SOME v,len) else (x,y)
1148 :     end)
1149 :     val (res,_) = foldr g (NONE,100000) cclist
1150 :     in case res of NONE => free
1151 :     | SOME u => [(u,n,n)]
1152 :     end
1153 :    
1154 :     (****************************************************************************
1155 :     * Generating the true free variables (freeAnalysis), each knownfunc is *
1156 :     * replaced by its free variables and each continuation by its callee-save *
1157 :     * registers. Finally, if two free variables are functions from the same *
1158 :     * closure, just one of them is sufficient to access both. *
1159 :     ****************************************************************************)
1160 :    
1161 :     fun sameClosureOpt(free,env) =
1162 :     case !CGoptions.closureStrategy
1163 :     of 1 => free (* flat without aliasing *)
1164 :     | 3 => free (* linked without aliasing *)
1165 :     | _ => (* all others have aliasing *)
1166 :     let fun g(v as (z,_,_)) = (v,whatIs(env,z))
1167 :     fun uniq ((hd as (v,Closure(CR(_,{stamp=s1,...}))))::tl) =
1168 :     let val m' = uniq tl
1169 :     fun h(_,Closure(CR(_,{stamp=s2,...}))) = (s1 = s2)
1170 :     | h _ = false
1171 :     in if List.exists h m' then m' else (hd::m')
1172 :     end
1173 :     | uniq (hd::tl) = hd::uniq tl
1174 :     | uniq nil = nil
1175 :     in map #1 (uniq (map g free))
1176 :     end
1177 :    
1178 :     fun freeAnalysis(gfree,ffree,env) =
1179 :     let fun g(w as (v,m,n),(x,y)) =
1180 :     case whatIs(env,v)
1181 :     of Callee(u,csg,csf) =>
1182 :     let val gv = addV(entervar(u,uniqvar csg),m,n,x)
1183 :     val fv = addV(uniqvar csf,m,n,y)
1184 :     in (gv,fv)
1185 :     end
1186 :     | Function{gpfree,fpfree,...} =>
1187 :     (addV(gpfree,m,n,x),addV(fpfree,m,n,y))
1188 :     | _ => (mergeV([w],x),y)
1189 :    
1190 :     val (ngfree,nffree) = foldr g ([],ffree) gfree
1191 :     in (sameClosureOpt(ngfree,env),nffree)
1192 :     end
1193 :    
1194 :     (****************************************************************************
1195 :     * MAIN FUNCTION : closeCPS *
1196 :     ****************************************************************************)
1197 :    
1198 :     fun closeCPS(fk,f,vl,cl,ce) = let
1199 :    
1200 :     (****************************************************************************
1201 :     * utility functions that depends on register configurations *
1202 :     ****************************************************************************)
1203 :    
1204 :     (* get the current register configuration *)
1205 :     val maxgpregs = MachSpec.numRegs
1206 :     val maxfpregs = MachSpec.numFloatRegs - 2 (* need 1 or 2 temps *)
1207 :     val numCSgpregs = MachSpec.numCalleeSaves
1208 :     val numCSfpregs = MachSpec.numFloatCalleeSaves
1209 :     val unboxedfloat = MachSpec.unboxedFloats
1210 :     val untaggedint = MachSpec.untaggedInt
1211 :    
1212 :     (* check the validity of the callee-save configurations *)
1213 :     val (numCSgpregs,numCSfpregs) =
1214 :     if (numCSgpregs <= 0) then
1215 :     (if (numCSfpregs > 0) then bug "Wrong CS config 434 - closure.sml"
1216 :     else (0,0))
1217 :     else (if (numCSfpregs >= 0) then (numCSgpregs,numCSfpregs)
1218 :     else (numCSgpregs,0))
1219 :    
1220 :     (* Initialize the base environment *)
1221 :     val baseEnv = emptyEnv()
1222 :    
1223 :     (* Find out the CPS type of an arbitrary program variable *)
1224 :     fun get_cty v = (case whatIs(baseEnv,v) of Value t => t | _ => BOGt)
1225 :    
1226 :     (* check if a variable is a float number *)
1227 :     val isFlt = if unboxedfloat then
1228 :     (fn v => (case (get_cty v) of FLTt => true | _ => false))
1229 :     else (fn _ => false)
1230 :     fun isFlt3 (v,_,_) = isFlt v
1231 :    
1232 :     (* check if a variable is of boxed type --- no longer used! *)
1233 :     (*
1234 :     val isBoxed3 =
1235 :     if untaggedint then
1236 :     (fn (v,_,_) =>
1237 :     (case (get_cty v)
1238 :     of FLTt => bug "isBoxed never applied to floats in closure.sml"
1239 :     | INTt => false
1240 :     | _ => true))
1241 :     else
1242 :     (fn (v,_,_) =>
1243 :     ((case (get_cty v)
1244 :     of INT32t => false
1245 :     | _ => true) handle _ => true))
1246 :     *)
1247 :    
1248 :     (* check if a variable is an int32 *)
1249 :     fun isInt32 (v,_,_) = case get_cty v of INT32t => true | _ => false
1250 :    
1251 :     (* count the number of GP and FP registers needed for a list of lvars *)
1252 :     fun isFltCty FLTt = unboxedfloat
1253 :     | isFltCty _ = false
1254 :    
1255 :     fun numgp (m,CNTt::z) = numgp(m-numCSgpregs-1,z)
1256 :     | numgp (m,x::z) = if isFltCty(x) then numgp(m,z) else numgp(m-1,z)
1257 :     | numgp (m,[]) = m
1258 :    
1259 :     fun numfp (m,CNTt::z) = numfp(m-numCSfpregs,z)
1260 :     | numfp (m,x::z) = if isFltCty(x) then numfp(m-1,z) else numfp(m,z)
1261 :     | numfp (m,[]) = m
1262 :    
1263 :     (****************************************************************************
1264 :     * adjustArgs checks the formal arguments of a function, replace the *
1265 :     * continuation variable with a set of variables representing its callee- *
1266 :     * save register environment variables. *
1267 :     ****************************************************************************)
1268 :    
1269 :     val adjustArgs =
1270 :     let fun adjust1(args,l,env) =
1271 :     let fun g((a,t),(al,cl,cg,cf,rt,env)) =
1272 :     if (t = CNTt) then
1273 :     (let val w = dupLvar a
1274 :     val (csg,clg) = extraLvar(numCSgpregs,BOGt)
1275 :     val (csf,clf) = extraLvar(numCSfpregs,FLTt)
1276 :     val csgv = map VAR csg
1277 :     val csfv = map VAR csf
1278 :     val env = augCallee(a,VAR w,csgv,csfv,env)
1279 :     val nargs = w::(csg@csf)
1280 :     val ncl = CNTt::(clg@clf)
1281 :     val env = faugValue(nargs,ncl,env)
1282 :     in case rt
1283 :     of NONE => (nargs@al,ncl@cl,csgv,csfv,SOME a,env)
1284 :     | SOME _ => bug "closure/adjustArgs: >1 cont"
1285 :     end)
1286 :     else (a::al,t::cl,cg,cf,rt,augValue(a,t,env))
1287 :    
1288 :     in foldr g (nil,nil,nil,nil,NONE,env) (zip(args,l))
1289 :     end
1290 :    
1291 :     fun adjust2(args,l,env) =
1292 :     let fun g((a,t),(al,cl,cg,cf,rt,env)) =
1293 :     (a::al,t::cl,cg,cf,rt,augValue(a,t,env))
1294 :     in foldr g (nil,nil,nil,nil,NONE,env) (zip(args,l))
1295 :     end
1296 :    
1297 :     in if (numCSgpregs > 0) then adjust1 else adjust2
1298 :     end
1299 :    
1300 :     (****************************************************************************
1301 :     * FreeClose.freemapClose calculates the set of free variables and their *
1302 :     * live range for each function binding. (check freeclose.sml) *
1303 :     ****************************************************************************)
1304 :    
1305 :     val ((fk,f,vl,cl,ce),snum,nfreevars,ekfuns) =
1306 :     FreeClose.freemapClose(fk,f,vl,cl,ce)
1307 :    
1308 :     (* old freevars code, now obsolete, but left here for debugging *)
1309 :     (* val (ofreevars,_,_) = FreeMap.freemapClose ce *)
1310 :    
1311 :     (***************************************************************************
1312 :     * makenv: create the environments for functions in a FIX. *
1313 :     * here bcsg and bcsf are the current contents of callee-save registers *
1314 :     * bret is the default return continuations, sn is the stage number of *
1315 :     * the enclosing function, initEnv has the same "whatIs" table as the *
1316 :     * the baseEnv, however it has the different "whereIs" table. *
1317 :     ***************************************************************************)
1318 :     fun makenv(initEnv, bindings, bsn, bcsg, bcsf, bret) = let
1319 :    
1320 :     (***>
1321 :     fun checkfree(v) =
1322 :     let val free = ofreevars v
1323 :     val {fv=nfree,lv=loopv,sz=_} = nfreevars v
1324 :     val nfree = map #1 nfree
1325 :     val _ = if (free <> nfree)
1326 :     then (pr "^^^^ wrong free variable subset ^^^^ \n";
1327 :     pr "OFree in "; vp v; pr ":"; ilist free;
1328 :     pr "NFree in "; vp v; pr ":"; ilist nfree;
1329 :     pr "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ \n")
1330 :     else ()
1331 :     val _ = case loopv
1332 :     of NONE => ()
1333 :     | SOME sfree =>
1334 :     (if subset (sfree,nfree) then ()
1335 :     else (pr "****wrong free variable subset*** \n";
1336 :     pr "Free in "; vp v; pr ":"; ilist nfree;
1337 :     pr "SubFree in "; vp v; pr ":";ilist sfree;
1338 :     pr "*************************** \n"))
1339 :     in ()
1340 :     end
1341 :     val _ = app checkfree (map #2 bindings)
1342 :     <***)
1343 :    
1344 :     (***>
1345 :     val _ = COMMENT(fn() => (pr "BEGINNING MAKENV.\nFunctions: ";
1346 :     ilist (map #2 bindings); pr "Initial environment:\n";
1347 :     printEnv initEnv; pr "\n"))
1348 :     val _ = COMMENT(fn() => (pr "BASE CALLEE SAVE REGISTERS: ";
1349 :     vallist bcsg; vallist bcsf; pr "\n"))
1350 :     <***)
1351 :    
1352 :     (* partition the function bindings into different fun_kinds *)
1353 :     val (escapeB,knownB,recB,calleeB,kcontB) = partBindings(bindings)
1354 :    
1355 :     (* For the "numCSgpregs = 0" case, treat kcontB and calleeB as escapeB *)
1356 :     val (escapeB,calleeB,kcontB) =
1357 :     if (numCSgpregs > 0) then (escapeB,calleeB,kcontB)
1358 :     else (escapeB@calleeB,[],[])
1359 :    
1360 :     val escapeV = uniq(map #2 escapeB)
1361 :     val knownV = uniq(map #2 knownB)
1362 :     fun knownlvar3(v,_,_) = member knownV v
1363 :    
1364 :     (*** check whether the basic closure assumptions are valid or not ***)
1365 :     val (fixKind,nret) =
1366 :     case (escapeB,knownB,calleeB,recB,kcontB)
1367 :     of ([],_,[],_,[]) => (KNOWN,bret)
1368 :     | ([],[],[v],[],[_]) => (KNOWN_CONT,SOME(#2 v))
1369 :     | ([],[],[v],[],[]) => (CONT,SOME(#2 v))
1370 :     | (_,_,[],_,[]) => (ESCAPE,bret)
1371 :     | _ => (pr "^^^ Assumption No.2 is violated in closure phase ^^^\n";
1372 :     pr "KNOWN bindings: "; ilist (map #2 knownB);
1373 :     pr "ESCAPE bindings: "; ilist (map #2 escapeB);
1374 :     pr "CONT bindings: "; ilist (map #2 calleeB);
1375 :     pr "KNOWN_CONT bindings: "; ilist (map #2 kcontB);
1376 :     pr "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ \n";
1377 :     bug "Violating basic closure conventions closure.sml")
1378 :    
1379 :     (****************************************************************************
1380 :     * Initial processing of known functions *
1381 :     ****************************************************************************)
1382 :    
1383 :     (***>
1384 :     val _ = COMMENT(fn() => (pr "Known functions:"; ilist (map #2 knownB);
1385 :     pr " "; iKlist (map #1 knownB)))
1386 :     <***)
1387 :    
1388 :     (*** Get the call graph of all known functions in this FIX. ***)
1389 :     val knownB =
1390 :     map (fn (fe as (_,v,_,_,_)) =>
1391 :     let val {fv=vn,lv=lpv,sz=s} = nfreevars v
1392 :     val (fns,other) = partition knownlvar3 vn
1393 :     in ({v=v,fe=fe,other=other,fsz=s,lpv=lpv},length fns,fns)
1394 :     end) knownB
1395 :    
1396 :     (*** Compute the closure of the call graph of the known functions. ***)
1397 :     val knownB =
1398 :     let fun closeCallGraph g =
1399 :     let fun getNeighbors l =
1400 :     foldr (fn (({v,fe,other,fsz,lpv},_,nbrs),n) =>
1401 :     if member3 l v then mergeV(nbrs,n) else n) l g
1402 :     fun traverse ((x,len,nbrs),(l,change)) =
1403 :     let val nbrs' = getNeighbors nbrs
1404 :     val len' = length nbrs'
1405 :     in ((x,len',nbrs')::l,change orelse len<>len')
1406 :     end
1407 :     val (g',change) = foldr traverse (nil,false) g
1408 :     in if change then closeCallGraph g' else g'
1409 :     end
1410 :     in closeCallGraph knownB
1411 :     end
1412 :    
1413 :     (*** Compute the closure of the set of free variables ***)
1414 :     val knownB =
1415 :     let fun gatherNbrs l init =
1416 :     foldr (fn (({v,other,...},_,_),free) => case get_vn(l,v)
1417 :     of NONE => free
1418 :     | SOME(m,n) =>
1419 :     mergeV(map (fn (z,i,j) =>
1420 :     (z,Int.min(i,m),Int.max(n,j))) other ,free))
1421 :     init knownB
1422 :     in map (fn ({v,fe=(k,_,args,cl,body),other,fsz,lpv},_,fns) =>
1423 :     {v=v,kind=k,args=args,cl=cl,body=body,lpv=lpv,fsz=fsz,
1424 :     other=gatherNbrs fns other,fns=fns}) knownB
1425 :     end
1426 :    
1427 :     (*** See which known function requires a closure, pass 1. ***)
1428 :     val (knownB,recFlag) = foldr
1429 :     (fn ((x as {v,kind,args,cl,other,fns,fsz,lpv,body}),(zz,flag)) =>
1430 :     let val free = removeV(escapeV,other)
1431 :     val callc = (length other) <> (length free) (* calls escaping-funs *)
1432 :    
1433 :     (* if its arguments doesn't contain a return cont, supply one *)
1434 :     val defCont = case (kind,bret)
1435 :     of (KNOWN_TAIL,SOME z) =>
1436 :     if (member3 free z) then bret else NONE (* issue warnings *)
1437 :     | _ => NONE
1438 :    
1439 :     (* find out the true set of free variables *)
1440 :     val (fpfree,gpfree) = partition isFlt3 free
1441 :     val (gpfree,fpfree) = freeAnalysis(gpfree,fpfree,initEnv)
1442 :    
1443 :     (***>
1444 :     val _ = COMMENT(fn() => (pr "*** Current Known Free Variables: ";
1445 :     iVlist gpfree; pr "\n"))
1446 :     <***)
1447 :    
1448 :     (* some free variables must stay in registers for KNOWN_TAIL *)
1449 :     val (rcsg,rcsf) = case defCont
1450 :     of NONE => ([],[])
1451 :     | SOME k => fetchCSvars(k,#1 fsz,#2 fsz,initEnv)
1452 :     val gpfree = removeV(rcsg,gpfree)
1453 :     val fpfree = removeV(rcsf,fpfree)
1454 :    
1455 :     (* the stage number of the current function *)
1456 :     val sn = snum v
1457 :     fun deep1(_,_,n) = (n > sn)
1458 :     fun deep2(_,m,n) = (m > sn)
1459 :    
1460 :     (***>
1461 :     val _ = COMMENT(fn() => (pr "*** Current Stage number and fun kind: ";
1462 :     ilist [sn]; ifkind kind; pr "\n"))
1463 :     <***)
1464 :    
1465 :     (* for recursive functions, always spill deeper level free variables *)
1466 :     val ((gpspill,gpfree),(fpspill,fpfree),nflag) = case lpv
1467 :     of SOME _ => (partition deep1 gpfree,partition deep1 fpfree,true)
1468 :     | NONE => if ekfuns v then ((gpfree,[]),(fpfree,[]),flag)
1469 :     else (partition deep2 gpfree,partition deep2 fpfree,flag)
1470 :    
1471 :     (***>
1472 :     val _ = COMMENT(fn() => (pr "*** Current Spilled Known Free Variables: ";
1473 :     iVlist gpspill; pr "\n"))
1474 :     <***)
1475 :    
1476 :     (* find out the register limit for this known functions *)
1477 :     val (gpnmax,fpnmax) = (maxgpregs,maxfpregs) (* reglimit v *)
1478 :    
1479 :     (* check if the set of free variables fit into FP registers *)
1480 :     val n = Int.min(numfp(maxfpregs-1,cl),fpnmax) - length(rcsf)
1481 :     val (fpfree,fpspill) = spillFree(fpfree,n,rcsf,fpspill)
1482 :    
1483 :     (* check if the set of free variables fit into GP registers *)
1484 :     val m = Int.min(numgp(maxgpregs-1,cl),gpnmax) - length(rcsg)
1485 :    
1486 :     val (gpfree,gpspill) = spillFree(gpfree,m,rcsg,gpspill)
1487 :    
1488 :     in ((case (gpspill,fpspill)
1489 :     of ([],[]) => (x,gpfree,fpfree,[],[],callc,sn,fns)::zz
1490 :     (*
1491 :     | ([(z,_,_)],[]) =>
1492 :     if callc then
1493 :     ((x,gpfree,fpfree,gpspill,[],callc,sn,fns)::zz)
1494 :     else ((x,enter(z,gpfree),fpfree,[],[],false,sn,fns)::zz)
1495 :     *)
1496 :     | _ => ((x,gpfree,fpfree,gpspill,fpspill,true,sn,fns)::zz)),nflag)
1497 :     end) ([],false) knownB
1498 :    
1499 :     (* See which known functions require a closure, pass 2. *)
1500 :     val (knownB,gpcollected,fpcollected) =
1501 :     let fun checkNbrs l init =
1502 :     foldr (fn (({v,...},_,_,_,_,callc,_,_),c) =>
1503 :     c orelse (callc andalso (member3 l v))) init knownB
1504 :    
1505 :     fun g(({kind,v,args,cl,body,fns,fsz,lpv,other},gpfree,fpfree,gpspill,
1506 :     fpspill,callc,sn,zfns),(z,gv,fv)) =
1507 :     let val callc = checkNbrs zfns callc
1508 :     val l = dupLvar v
1509 :     in ({kind=kind,sn=sn,v=v,l=l,args=args,cl=cl,body=body,gpfree=gpfree,
1510 :     fpfree=fpfree,callc=callc}::z,mergeV(gpspill,gv),
1511 :     mergeV(fpspill,fv))
1512 :     end
1513 :     in foldr g ([],[],[]) knownB
1514 :     end
1515 :    
1516 :     (****************************************************************************
1517 :     * Initial processing of escaping functions *
1518 :     ****************************************************************************)
1519 :    
1520 :     (***>
1521 :     val _ = COMMENT(fn() => (pr "Escaping functions:"; ilist (map #2 escapeB)))
1522 :     <***)
1523 :    
1524 :     (* get the set of free variables for escaping functions *)
1525 :     val (escapeB,escapeFree) =
1526 :     let fun g((k,v,a,cl,b),(z,c)) =
1527 :     let val free = #fv (nfreevars v)
1528 :     val l = dupLvar v
1529 :     in ({kind=k,v=v,l=l,args=a,cl=cl,body=b}::z,mergeV(free,c))
1530 :     end
1531 :     in foldr g ([],[]) escapeB
1532 :     end
1533 :    
1534 :     (* get the true set of free variables for escaping functions *)
1535 :     val (gpfree,fpfree) =
1536 :     let val (fns,other) = partition knownlvar3 (removeV(escapeV,escapeFree))
1537 :     val (fpfree,gpfree) = partition isFlt3 other
1538 :     val (gpfree,fpfree) =
1539 :     foldr (fn ({v,gpfree=gv,fpfree=fv,...},(x,y)) =>
1540 :     (case get_vn(fns,v)
1541 :     of NONE => (x,y)
1542 :     | SOME (m,n) => (addV(gv,m,n,x),addV(fv,m,n,y))))
1543 :     (gpfree,fpfree) knownB
1544 :     in freeAnalysis(gpfree,fpfree,initEnv)
1545 :     end
1546 :    
1547 :     (* here are all free variables that ought to be put in the closure *)
1548 :     val gpFree = mergeV(gpfree,gpcollected)
1549 :     val fpFree = mergeV(fpfree,fpcollected)
1550 :    
1551 :    
1552 :     (***************************************************************************
1553 :     * Initial processing of callee-save continuation functions *
1554 :     ***************************************************************************)
1555 :    
1556 :     (***>
1557 :     val _ = COMMENT(fn() => (pr "CS continuations:"; ilist (map #2 calleeB);
1558 :     pr " "; iKlist (map #1 calleeB)))
1559 :     <***)
1560 :    
1561 :     (* get the set of free variables for continuation functions *)
1562 :     val (calleeB,calleeFree,gpn,fpn,pF) =
1563 :     let fun g((k,v,a,cl,b),(z,c,gx,fx,pf)) =
1564 :     let val {fv=free,lv=_,sz=(gsz,fsz)} = nfreevars v
1565 :     val l = dupLvar v
1566 :     val sn = snum v
1567 :     val (gpn,fpn,pflag) = case k
1568 :     of KNOWN_CONT =>
1569 :     if gsz > 0 then (0,0,false) (* a temporary gross hack *)
1570 :     else
1571 :     (let val x = numgp(maxgpregs-1,CNTt::cl)
1572 :     val y = numfp(maxfpregs-1,CNTt::cl)
1573 :     in (Int.min(x,gx),Int.min(y,fx),false)
1574 :     end)
1575 :     | _ => (0,0,sn = (bsn+1))
1576 :    
1577 :     in ({kind=k,sn=sn,v=v,l=l,args=a,cl=cl,body=b}::z,mergeV(free,c),
1578 :     Int.min(gpn,gx),Int.min(fpn,fx),pflag)
1579 :     end
1580 :     in case calleeB
1581 :     of [] => ([],[],0,0,true)
1582 :     | _ => foldr g ([],[],maxgpregs,maxfpregs,true) calleeB
1583 :     end
1584 :    
1585 :     (* get the true set of free variables for continuation functions *)
1586 :     val (fpcallee,gpcallee) = partition isFlt3 calleeFree
1587 :     val (gpcallee,fpcallee) = freeAnalysis(gpcallee,fpcallee,initEnv)
1588 :    
1589 :     (* get all sharable closures from the enclosing environment *)
1590 :     val (gpclist,fpclist) =
1591 :     let val lives = merge(map #1 gpcallee, map #1 gpFree)
1592 :     val lives = case (knownB,escapeB)
1593 :     of ([{gpfree=gv,...}],[]) => merge(gv,lives)
1594 :     | _ => lives
1595 :     in fetchClosures(initEnv,lives,fixKind)
1596 :     end
1597 :    
1598 :     (* initializing the callee-save register default *)
1599 :     val safev = merge(uniq(map #1 gpclist),uniq(map #1 fpclist))
1600 :     val (gpbase,gpsrc) = mkbase(bcsg,merge(safev,map #1 gpcallee),gpn)
1601 :     val (fpbase,fpsrc) = mkbase(bcsf,map #1 fpcallee,fpn)
1602 :    
1603 :     (* thinning the set of free variables based on each's contents *)
1604 :     val cclist = (* for user function, be more conservative *)
1605 :     case calleeB
1606 :     of [] => map (fn (v,cr) => (v,fetchFree(v,cr,2))) (fpclist@gpclist)
1607 :     | _ => map (fn (v,CR(_,{free,...})) => (v,free)) (fpclist@gpclist)
1608 :    
1609 :     val (gpcallee,fpcallee) = shortenFree(gpcallee,fpcallee,cclist)
1610 :     val (gpFree,fpFree) = if recFlag then (gpFree,fpFree)
1611 :     else shortenFree(gpFree,fpFree,cclist)
1612 :    
1613 :     (***************************************************************************
1614 :     * Targeting callee-save registers for continuation functions *
1615 :     ***************************************************************************)
1616 :    
1617 :     (* decide variables that are being put into FP callee-save registers *)
1618 :     val (gpspill,fpspill,fpbase) =
1619 :     let val numv = length fpcallee
1620 :     val numr = numCSfpregs + fpn
1621 :     in if (numv <= numr) then
1622 :     (let val fpv = map #1 fpcallee
1623 :     val p = if pF then numr-numv else 0
1624 :     val (fpbase,fpv,_) = modifybase(fpbase,fpv,p)
1625 :     val nbase = fillbase(fpbase,fpv)
1626 :     in ([],[],nbase)
1627 :     end)
1628 :     else (* need spill *)
1629 :     (let val (gpfree,fpcallee) = thinFpFree(fpcallee,fpclist)
1630 :     val numv = length fpcallee
1631 :     in if (numv <= numr) then
1632 :     (let val fpv = map #1 fpcallee
1633 :     val p = if pF then numr-numv else 0
1634 :     val (fpbase,fpv,_) = modifybase(fpbase,fpv,p)
1635 :     val nbase = fillbase(fpbase,fpv)
1636 :     in (gpfree,[],nbase)
1637 :     end)
1638 :     else
1639 :     (let val fpfree = sortlud2(fpcallee,fpsrc)
1640 :     val (cand,rest) = partvnum(fpfree,numr)
1641 :     val (nbase,ncand,_) = modifybase(fpbase,cand,0)
1642 :     val nbase = fillbase(nbase,ncand)
1643 :     in (gpfree,uniqV rest,nbase)
1644 :     end)
1645 :     end)
1646 :     end
1647 :    
1648 :     (* INT32: here is a place to filter out all the variables with INT32 types,
1649 :     they have to be put into closure (gpspill), because by default, callee-save
1650 :     registers always contain pointer values. *)
1651 :     val (i32gpcallee, gpcallee) = partition isInt32 gpcallee
1652 :     val (i32gpFree, gpFree) = partition isInt32 gpFree
1653 :    
1654 :     (* collect all the FP free variables and build a closure if necessary *)
1655 :     val allfpFree = mergeV(fpspill,fpFree)
1656 :     val (gpspill,gpFree,fpcInfo) = case allfpFree
1657 :     of [] => (gpspill,gpFree,NONE)
1658 :     | _ => (let val (gpextra,ufree) = thinFpFree(allfpFree,fpclist)
1659 :     val (gpextra,fpc) =
1660 :     case ufree
1661 :     of [] => (gpextra,NONE)
1662 :     | ((_,m,n)::r) =>
1663 :     (let fun h((_,x,y),(i,j)) = (Int.min(x,i),Int.max(y,j))
1664 :     val (m,n) = foldr h (m,n) r
1665 :     val cname = closureLvar()
1666 :     val gpextra = mergeV([(cname,m,n)],gpextra)
1667 :     in (gpextra,SOME(cname,ufree))
1668 :     end)
1669 :     in case fixKind
1670 :     of (CONT|KNOWN_CONT) => (mergeV(gpextra,gpspill),gpFree,fpc)
1671 :     | _ => (gpspill,mergeV(gpextra,gpFree),fpc)
1672 :     end)
1673 :    
1674 :     (* here are free variables that should be put in GP callee-save registers *)
1675 :     (* by convention: gpspill must not contain any int32 variables ! *)
1676 :     val gpcallee = mergeV(gpspill,gpcallee)
1677 :    
1678 :     val (gpcallee,fpcInfo) = case (i32gpcallee, fpcInfo)
1679 :     of ([],_) => (gpcallee,fpcInfo)
1680 :     | ((_,m,n)::r,NONE) =>
1681 :     let fun h((_,x,y),(i,j)) = (Int.min(x,i),Int.max(y,j))
1682 :     val (m,n) = foldr h (m,n) r
1683 :     val cname = closureLvar()
1684 :     in (mergeV([(cname,m,n)],gpcallee), SOME(cname,i32gpcallee))
1685 :     end
1686 :     | (vs, SOME(cname, ufree)) => (gpcallee, SOME(cname, mergeV(vs, ufree)))
1687 :     (*
1688 :     | (_,SOME (cname,ufree)) => bug "unimplemented int32 + float (nclosure.2)"
1689 :     *)
1690 :    
1691 :     (* if gpspill is not null, there must be an empty position in gpbase *)
1692 :     val (gpspill,gpbase) =
1693 :     let val numv = length gpcallee
1694 :     val numr = numCSgpregs + gpn
1695 :     in if (numv <= numr) then
1696 :     (let val gpv = map #1 gpcallee
1697 :     val p = if pF then numr-numv else 0
1698 :     val (gpbase,gpv,_) = modifybase(gpbase,gpv,p)
1699 :     val nbase = fillbase(gpbase,gpv)
1700 :     in ([],nbase)
1701 :     end)
1702 :     else
1703 :     (let val gpcallee = thinGpFree(gpcallee,gpclist)
1704 :     val numv = length gpcallee
1705 :     in if (numv <= numr) then
1706 :     (let val gpv = map #1 gpcallee
1707 :     val p = if pF then numr-numv else 0
1708 :     val (gpbase,gpv,_) = modifybase(gpbase,gpv,p)
1709 :     val nbase = fillbase(gpbase,gpv)
1710 :     in ([],nbase)
1711 :     end)
1712 :     else
1713 :     (let val gpfree = sortlud2(gpcallee,gpsrc)
1714 :     val (cand,rest) = partvnum(gpfree,numr-1)
1715 :     val (nbase,ncand,_) = modifybase(gpbase,cand,0)
1716 :     val (nbhd,nbtl) = partnull(nbase)
1717 :     val nbtl = fillbase(nbtl,ncand)
1718 :     in (uniqV rest,nbhd@nbtl)
1719 :     end)
1720 :     end)
1721 :     end
1722 :    
1723 :     (***************************************************************************
1724 :     * Building the closures for all bindings in this FIX *
1725 :     ***************************************************************************)
1726 :    
1727 :     (* collect all GP free variables that should be put in closures *)
1728 :     (* assumption: gpspill does not contain any Int32s; they can should
1729 :     not be put into gpcallee anyway. *)
1730 :     val allgpFree = mergeV(gpspill,gpFree)
1731 :     val unboxedFree = i32gpFree
1732 :    
1733 :     (* filter out all unboxed-values *)
1734 :     (* INT32: here is the place to filter out all 32-bit integers,
1735 :     put them into unboxedFree, then you have to find a way to put both
1736 :     32-bit integers and unboxed float numbers in the same record.
1737 :     Currently, I use RK_FBLOCK to denote this kind of record_kind,
1738 :     you might want to put all floats ahead of all 32-bit ints. *)
1739 :     (* val (allgpFree,unboxedFree) = partition isBoxed3 allgpFree *)
1740 :    
1741 :     val (allgpFree,fpcInfo) =
1742 :     case (fpcInfo,unboxedFree)
1743 :     of (NONE,[]) => (allgpFree,fpcInfo)
1744 :     | (NONE,(_,m,n)::r) =>
1745 :     (let val c = closureLvar()
1746 :     fun h((_,x,y),(i,j)) = (Int.min(x,i),Int.max(y,j))
1747 :     val (m,n) = foldr h (m,n) r
1748 :     in (mergeV([(c,m,n)],allgpFree),SOME(c,unboxedFree))
1749 :     end)
1750 :     | (SOME(c,a),r) => (allgpFree,SOME(c,mergeV(a,r)))
1751 :    
1752 :     (* actually building the closure for unboxed values *)
1753 :     val (fphdr,env,nframes) =
1754 :     case fpcInfo
1755 :     of NONE => (fn ce => ce,initEnv,[])
1756 :     | SOME(c,a) => let val (int32a,a) = partition isInt32 a
1757 :     in closureUnboxed(c,int32a,a,fixKind,initEnv)
1758 :     end
1759 :    
1760 :     (* sharing with the enclosing closures if possible *)
1761 :     val (allgpFree,ccl) = (* for recursive function, be more conservative *)
1762 :     if recFlag then (thinAll(allgpFree,cclist,bsn),cclist)
1763 :     else (thinGpFree(allgpFree,gpclist),[])
1764 :    
1765 :     (* actually building the closure for all GP (or boxed) values *)
1766 :     val (closureInfo,closureName,env,gphdr,nframes) =
1767 :     case (escapeB,allgpFree)
1768 :     of ([],[]) => (NONE,NONE,env,fphdr,nframes)
1769 :     | ([],[(v,_,_)]) => (NONE,SOME v,env,fphdr,nframes)
1770 :     | _ =>
1771 :     (let val fns = map (fn {v,l,...} => (v,l)) escapeB
1772 :     val cn = closureLvar()
1773 :     val (hdr,env,cr,nf) = closureBoxed(cn,fns,allgpFree,fixKind,ccl,env)
1774 :     in (SOME cr,SOME cn,env,fphdr o hdr,nf@nframes)
1775 :     end)
1776 :    
1777 :     (***************************************************************************
1778 :     * Final construction of the environment for each known function *
1779 :     ***************************************************************************)
1780 :    
1781 :     (* add new known functions to the environment (side-efffect) *)
1782 :     val nenv = case closureName
1783 :     of NONE =>
1784 :     (foldr (fn ({v,l,gpfree,fpfree,...},env) =>
1785 :     augKnown(v,l,gpfree,fpfree,env)) env knownB)
1786 :     | SOME cname =>
1787 :     (foldr (fn ({v,l,gpfree,fpfree,callc,...},env) =>
1788 :     if callc then augKnown(v,l,enter(cname,gpfree),fpfree,env)
1789 :     else augKnown(v,l,gpfree,fpfree,env)) env knownB)
1790 :    
1791 :     val knownFrags : frags =
1792 :     let fun g({kind,sn,v,l,args,cl,body,gpfree,fpfree,callc},z) =
1793 :     let val env = baseEnv (* empty whereIs map but same whatMap as nenv *)
1794 :     val env = foldr augvar env gpfree
1795 :     val env = foldr augvar env fpfree
1796 :     val (ngpfree,env) =
1797 :     case (callc,closureName)
1798 :     of (false,_) => (inc CGoptions.knownGen; (gpfree,env))
1799 :     | (true,SOME cn) => (inc CGoptions.knownClGen;
1800 :     (enter(cn,gpfree),augvar(cn,env)))
1801 :     | (true,NONE) => bug "unexpected 23324 in closure"
1802 :    
1803 :     val (nargs,ncl,ncsg,ncsf,nret,env) = adjustArgs(args,cl,env)
1804 :     val nargs = nargs @ ngpfree @ fpfree
1805 :     val ncl = ncl @ (map get_cty ngpfree) @ (map get_cty fpfree)
1806 :    
1807 :     (***>
1808 :     val _ = COMMENT(fn () => (pr "\nEnvironment in known ";
1809 :     vp v; pr ":\n"; printEnv env))
1810 :     <***)
1811 :     in case nret
1812 :     of NONE => ((KNOWN,l,nargs,ncl,body,env,sn,bcsg,bcsf,bret)::z)
1813 :     | SOME _ => ((KNOWN,l,nargs,ncl,body,env,sn,ncsg,ncsf,nret)::z)
1814 :     end
1815 :     in foldr g [] knownB
1816 :     end
1817 :    
1818 :     (***************************************************************************
1819 :     * Final construction of the environment for each escaping function *
1820 :     ***************************************************************************)
1821 :    
1822 :     (* the whatMap in nenv is side-effected with new escape bindings *)
1823 :     val escapeFrags : frags =
1824 :     case (closureInfo,escapeB)
1825 :     of (_,[]) => []
1826 :     | (NONE,_) => bug "unexpected 23422 in closure"
1827 :     | (SOME cr,_) =>
1828 :     (let val env = baseEnv (* empty whereIs map but same whatMap as nenv *)
1829 :     fun f ({kind,v,l,args,cl,body},i) =
1830 :     let val myCname = v (* my closure name *)
1831 :     val env = augEscFun(myCname,i,cr,env)
1832 :     val (nargs,ncl,ncsg,ncsf,nret,env) = adjustArgs(args,cl,env)
1833 :     val nargs = mkLvar()::myCname::nargs
1834 :     val ncl = BOGt::BOGt::ncl
1835 :     val sn = snum v
1836 :     (***>
1837 :     val _ = COMMENT(fn () => (pr "\nEnvironment in escaping ";
1838 :     vp v; pr ":\n";printEnv env))
1839 :     <***)
1840 :     in inc CGoptions.escapeGen; (* nret must not be NONE *)
1841 :     case nret
1842 :     of NONE => bug "no cont in escapefun in closure.sml"
1843 :     | SOME _ => (kind,l,nargs,ncl,body,env,sn,ncsg,ncsf,nret)
1844 :     end
1845 :     in formap f escapeB
1846 :     end)
1847 :    
1848 :     (***************************************************************************
1849 :     * Final construction of the environment for each callee-save continuation *
1850 :     ***************************************************************************)
1851 :    
1852 :     (* the whatMap in nenv is side-effected with new callee bindings *)
1853 :     val (nenv, calleeFrags : frags) =
1854 :     case calleeB
1855 :     of [] => (nenv, [])
1856 :     | _ =>
1857 :     (let val gpbase = case closureName
1858 :     of NONE => gpbase
1859 :     | SOME _ => fillCSregs(gpbase,closureName)
1860 :    
1861 :     val ncsg = map (fn (SOME v) => VAR v | NONE => INT 0) gpbase
1862 :     val ncsf = map (fn (SOME v) => VAR v | NONE => VOID) fpbase
1863 :     val (benv,nenv) = splitEnv(nenv,member (freevCSregs(gpbase,nenv)))
1864 :    
1865 :     fun g({kind,sn,v,l,args,cl,body},z) =
1866 :     let val env = installFrames(nframes,benv)
1867 :     val (nk,env,nargs,ncl,csg,csf) =
1868 :     case kind
1869 :     of CONT =>
1870 :     (let val env = augCallee(v,LABEL l,ncsg,ncsf,env)
1871 :     val (env,a,c) =
1872 :     fillCSformals(gpbase,fpbase,env,get_cty)
1873 :     in (CONT,env,(mkLvar())::(a@args),BOGt::(c@cl),
1874 :     ncsg,ncsf)
1875 :     end)
1876 :     | KNOWN_CONT =>
1877 :     (let val (gfv,ffv,env) =
1878 :     varsCSregs(gpbase,fpbase,env)
1879 :     val csg = cuttail(gpn,ncsg)
1880 :     val csf = cuttail(fpn,ncsf)
1881 :     val env = augKcont(v,l,gfv,ffv,csg,csf,env)
1882 :     val gcl = map get_cty gfv
1883 :     val fcl = map (fn _ => FLTt) ffv
1884 :     in (KNOWN,env,args@gfv@ffv,cl@gcl@fcl,csg,csf)
1885 :     end)
1886 :     | _ => bug "calleeFrags in closure.sml 748"
1887 :    
1888 :     val env = faugValue(args,cl,env)
1889 :     (***>
1890 :     val _ = COMMENT(fn () =>
1891 :     (pr "\nEnvironment in callee-save continuation ";
1892 :     vp v; pr ":\n"; printEnv env))
1893 :     <***)
1894 :     in inc CGoptions.calleeGen;
1895 :     (nk,l,nargs,ncl,body,env,sn,csg,csf,bret)::z
1896 :     end
1897 :     in (nenv,foldr g [] calleeB)
1898 :     end)
1899 :    
1900 :     val frags = escapeFrags@knownFrags@calleeFrags
1901 :    
1902 :     (***>
1903 :     val _ = COMMENT(fn () => (pr "\nEnvironment after FIX:\n";
1904 :     printEnv nenv; pr "MAKENV DONE.\n\n"));
1905 :     <***)
1906 :    
1907 :     in (* body of makenv *)
1908 :     (gphdr,frags,nenv,nret)
1909 :     end
1910 :    
1911 :     (****************************************************************************
1912 :     * MAIN LOOP (closefix and close) *
1913 :     ****************************************************************************)
1914 :    
1915 :     fun closefix(fk,f,vl,cl,ce,env,sn,csg,csf,ret) =
1916 :     ((fk,f,vl,cl,close(ce,env,sn,csg,csf,ret))
1917 :     handle Lookup(v,env) => (pr "LOOKUP FAILS on "; vp v;
1918 :     pr "\nin environment:\n";
1919 :     printEnv env;
1920 :     pr "\nin function:\n";
1921 :     PPCps.prcps ce;
1922 :     bug "Lookup failure in cps/closure.sml"))
1923 :    
1924 :     and close(ce,env,sn,csg,csf,ret) =
1925 :     case ce
1926 :     of FIX(fl,b) =>
1927 :     let val (hdr,frags,nenv,nret) = makenv(env,fl,sn,csg,csf,ret)
1928 :     in FIX(map closefix frags, hdr(close(b,nenv,sn,csg,csf,nret)))
1929 :     end
1930 :     | APP(f,args) =>
1931 :     let val obj = (case f of VAR v => whatIs(env,v) | _ => Value BOGt)
1932 :     in case obj
1933 :     of Closure(CR(off,{functions,...})) =>
1934 :     let val (env,h) = fixAccess([f],env)
1935 :     val (nargs,env,nh) = fixArgs(args,env)
1936 :     val (env,dh) = disposeFrames(env)
1937 :     val (_,label) = List.nth(functions,off)
1938 :     val call = APP(LABEL label,LABEL label::f::nargs)
1939 :     in if not(!CGoptions.allocprof)
1940 :     then h(nh(dh(call)))
1941 :     else h(nh(dh(case args
1942 :     of [_] => profCntkCall call
1943 :     | _ => profStdkCall call)))
1944 :     end
1945 :     | Function{label,gpfree,fpfree,csdef} =>
1946 :     let val free = map VAR (gpfree@fpfree)
1947 :     val (nargs,env,h) = fixArgs(args@free,env)
1948 :     val (env,nh) = disposeFrames(env)
1949 :     val call = APP(LABEL label,nargs)
1950 :     in if not(!CGoptions.allocprof)
1951 :     then h(nh(call))
1952 :     else (case csdef
1953 :     of NONE => h(nh(profKnownCall call))
1954 :     | _ => h(nh(profCSCntkCall call)))
1955 :     end
1956 :     | Callee(label,ncsg,ncsf) =>
1957 :     let val nargs = ncsg@ncsf@args
1958 :     val (env,h) = fixAccess(label::nargs,env)
1959 :     val (env,nh) = disposeFrames(env)
1960 :     val call = APP(label,label::nargs)
1961 :     in if not(!CGoptions.allocprof)
1962 :     then h(nh(call))
1963 :     else (case label
1964 :     of LABEL _ => h(nh(profCSCntkCall call))
1965 :     | _ => h(nh(profCSCntCall call)))
1966 :     end
1967 :     | Value t =>
1968 :     let val (env,h) = fixAccess([f],env)
1969 :     val (nargs,env,nh) = fixArgs(args,env)
1970 :     val (env,dh) = disposeFrames(env)
1971 :     val l = mkLvar()
1972 :     val call = SELECT(0,f,l,t,
1973 :     (APP(VAR l,(VAR l)::f::nargs)))
1974 :     in if not(!CGoptions.allocprof) then h(nh(dh(call)))
1975 :     else h(nh(dh(profStdCall call)))
1976 :     end
1977 :     end
1978 :     | SWITCH(v,c,l) =>
1979 :     let val (env,header) = fixAccess([v],env)
1980 :     in header(SWITCH(v,c,map (fn c => close(c,env,sn,csg,csf,ret)) l))
1981 :     end
1982 :     | RECORD(k as RK_FBLOCK,l,v,c) =>
1983 :     let val (env,header) = fixAccess(map #1 l,env)
1984 :     val env = augValue(v,BOGt,env)
1985 :     in header(RECORD(k,l,v,close(c,env,sn,csg,csf,ret)))
1986 :     end
1987 :     | RECORD(k,l,v,c) =>
1988 :     let val (hdr, env) = recordEl(k, l, v, env)
1989 :     val nc = hdr (close(c,augValue(v,BOGt,env),sn,csg,csf,ret))
1990 :     in if not(!CGoptions.allocprof) then nc
1991 :     else profRecord (length l) nc
1992 :     end
1993 :     | SELECT(i,v,w,t,c) =>
1994 :     let val (env,header) = fixAccess([v],env)
1995 :     val nc = close(c,augValue(w,t,env),sn,csg,csf,ret)
1996 :     in header(SELECT(i,v,w,t,nc))
1997 :     end
1998 :     | OFFSET(i,v,w,c) => bug "OFFSET in pre-closure in cps/closure.sml"
1999 :     | BRANCH(i,args,c,e1,e2) =>
2000 :     let val (env,header) = fixAccess(args,env)
2001 :     val ne1 = close(e1,env,sn,csg,csf,ret)
2002 :     val ne2 = close(e2,env,sn,csg,csf,ret)
2003 :     in header(BRANCH(i,args,c,ne1,ne2))
2004 :     end
2005 :     | SETTER(i,args,e) =>
2006 :     let val (env,header) = fixAccess(args,env)
2007 :     val ne = close(e,env,sn,csg,csf,ret)
2008 :     in header(SETTER(i,args,ne))
2009 :     end
2010 :     | LOOKER(i,args,w,t,e) =>
2011 :     let val (env,header) = fixAccess(args,env)
2012 :     val ne = close(e,augValue(w,t,env),sn,csg,csf,ret)
2013 :     in header(LOOKER(i,args,w,t,ne))
2014 :     end
2015 :     | ARITH(i,args,w,t,e) =>
2016 :     let val (env,header) = fixAccess(args,env)
2017 :     val ne = close(e,augValue(w,t,env),sn,csg,csf,ret)
2018 :     in header(ARITH(i,args,w,t,ne))
2019 :     end
2020 :     | PURE(i,args,w,t,e) =>
2021 :     let val (env,header) = fixAccess(args,env)
2022 :     val ne = close(e,augValue(w,t,env),sn,csg,csf,ret)
2023 :     in header(PURE(i,args,w,t,ne))
2024 :     end
2025 :    
2026 :     (***************************************************************************
2027 :     * Calling the "close" on the CPS expression with proper initializations *
2028 :     ***************************************************************************)
2029 :     val nfe =
2030 :     let val _ = if !CGoptions.staticprof then SProf.initfk() else ()
2031 :     val (nvl,ncl,csg,csf,ret,env) = adjustArgs(vl,cl,baseEnv)
2032 :     val env = augValue(f,BOGt,env)
2033 :     val nce = close(ce,env,snum f,csg,csf,ret)
2034 :     in (fk,mkLvar(),mkLvar()::f::nvl,BOGt::BOGt::ncl,nce)
2035 :     end
2036 :    
2037 :     (* temporary hack: measuring static allocation sizes of closures *)
2038 :     (* previous calls to incfk and initfk are also part of this hack *)
2039 :     val _ = if !CGoptions.staticprof then SProf.reportfk() else ()
2040 :    
2041 :     in (* body of closeCPS *)
2042 :     UnRebind.unrebind nfe
2043 :     end
2044 :     end (* local of open *)
2045 :     end (* functor Closure *)
2046 :    
2047 :    

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