Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/clos/closure.sml

Parent Directory | Revision Log

---

Revision 99 - (view) (download)

1 :	monnier	98	(* 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 :			fun sortlud0 x = Sort.sort (fn ((_,_,i : int),(_,_,j)) => (i>j)) x
170 :
171 :			fun sortlud1 x =
172 :			let fun ludfud1((_,m:int,i:int),(_,n,j)) =
173 :			(i>j) orelse ((i=j) andalso (m>n))
174 :			in Sort.sort ludfud1 x
175 :			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 :			in map #1 (Sort.sort ludfud2 nl)
185 :			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 :			val clist = Sort.sort worse (foldr h [] closlist)
1127 :			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 :
2048 :			(*
2049 :			* $Log: nclosure.sml,v $
2050 :			* Revision 1.1.1.1 1998/04/08 18:39:45 george
2051 :			* Version 110.5
2052 :			*
2053 :			*)

---

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