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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

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

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