![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to closure.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / cps|
Return to closure.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / cps |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: signature CLOSURE =
3: sig
4: val closeCPS : CPS.function * (CPS.lvar -> bool)
5: * (int * int * CPS.cexp -> CPS.cexp) ->
6: CPS.function * (CPS.lvar -> bool) * (CPS.lvar -> bool)
7: end
8:
9: functor Closure(val maxfree : int) : CLOSURE =
10: struct
11:
12: open CPS Access Profile SortedList
13: fun partition f l = fold (fn (e,(a,b)) => if f e then (e::a,b) else (a,e::b))
14: l ([],[])
15: fun sublist test =
16: let fun subl(a::r) = if test a then a::(subl r) else subl r
17: | subl [] = []
18: in subl
19: end
20: local val save = (!saveLvarNames before saveLvarNames := true)
21: val closure = namedLvar(Symbol.symbol "closure")
22: in val closureLvar = (saveLvarNames := save; fn () => dupLvar closure)
23: end
24: val error = ErrorMsg.impossible
25: datatype object = Value
26: | Function of {label:lvar,free:lvar list}
27: | Closure of {functions : (lvar * lvar) list,
28: contents : (lvar * object) list,
29: offset : int,
30: stamp : lvar}
31: datatype env = Env of (lvar * object) list
32: datatype access = Direct
33: | Path of (lvar * object * accesspath)
34:
35: fun mkClosure(functions,contents) =
36: Closure{functions=functions,contents=contents,
37: offset=0,stamp=mkLvar()}
38: val env0 = Env []
39: fun augment(m,Env e) = Env (m::e)
40:
41: val pr = output std_out
42: val vp = pr o Access.lvarName
43: fun plist p l = (app (fn v => (pr " "; p v)) l; pr "\n")
44: val ilist = plist vp
45: fun printEnv(Env e) =
46: let fun ip i = pr(Integer.makestring i)
47: fun sp() = pr " "
48: val tlist = plist (fn (a,b) => (vp a; pr "/L"; Integer.print b))
49: fun p(indent,l,seen) =
50: let fun v(true,(vl,Value)::tl) = (vp vl; sp(); v(true,tl))
51: | v(false,(vl,Value)::tl) = (indent(); vp vl; sp(); v(true,tl))
52: | v(nl,_::tl) = v(nl,tl)
53: | v(true,[]) = pr "\n"
54: | v(false,[]) = ()
55: fun f(true,(v,Function{label,...})::tl) =
56: (vp v; pr "/k"; vp label; sp(); f(true,tl))
57: | f(false,(v,Function{label,...})::tl) =
58: (indent(); vp v; pr "/k"; vp label; sp(); f(true,tl))
59: | f(nl,_::tl) = f(nl,tl)
60: | f(true,[]) = pr "\n"
61: | f(false,[]) = ()
62: fun c(v,Closure{functions,contents,offset,stamp}) =
63: (indent(); pr "Closure "; vp v; pr "/"; ip stamp;
64: pr " @"; ip offset;
65: if member seen stamp
66: then pr "(seen)\n"
67: else (pr ":\n";
68: case functions of
69: [] => ()
70: | _ => (indent(); pr " Funs:"; tlist functions; ());
71: p(fn() => (indent();pr " "),contents,enter(stamp,seen))))
72: | c _ = ()
73: in v(false,l); f(false,l); app c l
74: end
75: in p(fn () => (),e,[])
76: end
77:
78: (* "Alpha conversion": the closure converter introduces duplicate bindings
79: at function arguments (the free variables of known functions) and at
80: SELECT's and OFFSET's from closures. This function restores unique
81: bindings, and also eliminates OFFSET's of 0 (which are introduced as
82: a side effect of trying to improve lazy display). It assumes that a
83: FIX has no free variables. *)
84: fun unrebind ce =
85: let fun rename rebind v =
86: let fun f [] = v
87: | f ((w:int,v')::t) = if v=w then v' else f t
88: in f rebind
89: end
90: fun f (l,args,b) =
91: let val (args',rebind') = fold (fn(v,(args',rebind')) =>
92: let val v' = dupLvar v
93: in (v'::args',(v,v')::rebind')
94: end)
95: args ([],[])
96: in (l,args',g(b,rebind'))
97: end
98: and g(ce,rebind) =
99: let val rename = rename rebind
100: val rec h =
101: fn RECORD(vl,w,e) =>
102: RECORD(map (fn(v,p) => (rename v,p)) vl,w,h e)
103: | OFFSET(0,v,w,e) => g(e,(w,rename v)::rebind)
104: | OFFSET(i,v,w,e) =>
105: let val w' = dupLvar w
106: in OFFSET(i,rename v,w',g(e,(w,w')::rebind))
107: end
108: | SELECT(i,v,w,e as APP(x,args)) =>
109: let val w' = dupLvar w
110: in if w=x
111: then SELECT(i,rename v,w',APP(w',map rename args))
112: else SELECT(i,rename v,w',g(e,(w,w')::rebind))
113: end
114: | SELECT(i,v,w,e) =>
115: let val w' = dupLvar w
116: in SELECT(i,rename v,w',g(e,(w,w')::rebind))
117: end
118: | APP(f,vl) => APP(f,map rename vl)
119: (* HACK: f is always a label or from a SELECT, so
120: we never need rename. *)
121: | FIX(l,e) => FIX(map f l,h e)
122: | SWITCH(v,el) => SWITCH(rename v,map h el)
123: | PRIMOP(i,vl,wl,el) => PRIMOP(i,map rename vl,wl,map h el)
124: in h ce
125: end
126: in g(ce,[])
127: end
128:
129: (* TEMPORARY DEBUGGING STUFF *)
130: val alphac = System.Control.CG.alphac
131: val comment = ref false (* System.Control.CG.comment *)
132: val unrebind = fn x => if !alphac then unrebind x else x
133: fun COMMENT f = if !comment then (f(); ()) else ()
134:
135: fun formap f =
136: let fun iter([],_) = []
137: | iter(hd::tl,i) = f(hd,i)::iter(tl,i+1)
138: in iter o (fn l => (l,0))
139: end
140:
141: fun select(i,Closure{functions,contents,offset,stamp}) =
142: (let val index = offset + i - length functions
143: in (#2 o nth)(contents,index)
144: end handle Nth => error "bad select in cps/closure")
145: | select(_,Value) = Value
146: | select(_,Function _) = error "select from knownfunc in cps/closure"
147: fun offset(_,Value,_,_) = error "offset from value in cps/closure"
148: | offset(_,Function _,_,_) = error "offset from knownfunc in cps/closure"
149: | offset(i,Closure{functions,contents,offset,stamp},v,env) =
150: augment((v,Closure{functions=functions,contents=contents,
151: offset=offset+i,stamp=stamp}),env)
152: (* Merge the free variables of recursive register functions, and put
153: free variables into the closure if there are not enough registers.
154: A function which needs the closure for any reason (for example, to
155: call and escaping function of the fix) will always put all its free
156: variables in the closure - you can't use the closure and some registers
157: for free variables. *)
158: type info = {v:lvar,fns:lvar list,other:lvar list,args:lvar list,
159: body:cexp,label:lvar,env:env,callc:bool}
160: fun regf bindings =
161: let fun pack m =
162: let fun getother w =
163: let fun g(({v,...}:info,other,_)::tl) = if v=w then other
164: else g tl
165: | g [] = ErrorMsg.impossible "[] 4849 in cps/closure"
166: in g m
167: end
168: fun getcallc w =
169: let fun g(({v,...}:info,_,callc)::tl) = if v=w then callc
170: else g tl
171: | g [] = ErrorMsg.impossible "[] 4848 in cps/closure"
172: in g m
173: end
174: fun f (x as {args,fns,...}:info, other, callc) =
175: (x,
176: foldmerge(other :: map getother fns),
177: callc orelse
178: (length args + length other >= maxfree andalso
179: length other > 1) orelse
180: exists getcallc fns)
181: val m' = map f m
182: in if exists (fn ({callc,...}:info,_,callc') => callc <> callc') m'
183: then regf (map (fn ({v,fns,other,args,body,label,callc,env},_,cc') =>
184: {v=v,fns=fns,other=other,args=args,body=body,
185: label=label,env=env,callc=cc'}) m')
186: else if exists (fn x=>x)
187: (List2.map2 (fn ((_,other,_),(_,other',_)) =>
188: length other <> length other')
189: (m,m'))
190: then pack m'
191: else fold (fn(({v,args,body,label,env,...},other,callc),(b,f)) =>
192: if callc then
193: ({v=v,args=args,body=body,label=label,env=env,
194: free=[],callc=callc}::b,merge(other,f))
195: else
196: ({v=v,args=args,body=body,label=label,env=env,
197: free=other,callc=callc}::b,f))
198: m' ([],[])
199: end
200: in pack (map (fn (x as {other,callc,...}) => (x,other,callc)) bindings)
201: end
202:
203:
204: fun compute_escapes ce =
205: let val s = Intset.new()
206: val use = Intset.add s
207: val rec g =
208: fn RECORD (vl,_,e) => (app (use o #1) vl; g e)
209: | SELECT (_,v,_,e) => g e
210: | OFFSET (_,v,_,e) => g e
211: | APP(f,vl) => (app use vl)
212: | FIX(l, e) => (app (g o #3) l; g e)
213: | SWITCH(v,el) => app g el
214: | PRIMOP(_,vl,_,el) => (app use vl; app g el)
215: in g ce; Intset.mem s
216: end
217:
218:
219: fun closeCPS((f,vl,ce),constant,prof) =
220: let
221: val escapes = compute_escapes ce
222: val unknownset = Intset.new()
223: val knownset = Intset.new()
224: val markknown = Intset.add knownset
225: val markunknown = Intset.add unknownset
226: val freevars = FreeMap.freemapClose(ce,constant)
227: datatype looking = Found of object * access
228: | Pending of (lvar * object) list
229: exception Lookup
230: (* Closures may be duplicated in the 'tree'; don't look at them twice. *)
231: fun lookup(env as Env e,target) =
232: let fun bfs([],[],seen) = raise Lookup
233: | bfs([],next,seen) = bfs(next,[],seen)
234: | bfs((Closure{functions,contents,offset,stamp},p)::m,next,seen) =
235: let fun element i =
236: let val p' = i-offset
237: in if p'<0
238: then (print "\nNegSel target for ";
239: print(Access.lvarName target); print " in\n";
240: printEnv env)
241: else ();
242: p'::p
243: end
244: fun cnt([],i,next,seen) = bfs(m,next,seen)
245: | cnt((v,c as Closure{stamp,...})::t,i,next,seen) =
246: if target=v
247: then (element i,0,c)
248: else cnt(t,i+1,if member seen stamp
249: then next
250: else (c,element i)::next,seen)
251: | cnt((v,Value)::t,i,next,seen) =
252: if target=v
253: then (element i,0,Value)
254: else cnt(t,i+1,next,seen)
255: | cnt((_,Function _)::_,_,next,seen) =
256: error "Function in closure in lookup"
257: fun fns([],i,seen) = cnt(contents,i,next,seen)
258: | fns((v,l)::t,i,seen) =
259: if target=v
260: then (p,i-offset,Closure{functions=functions,
261: contents=contents,
262: stamp=stamp,
263: offset = i})
264: else fns(t,i+1,seen)
265: in if member seen stamp
266: then bfs(m,next,seen)
267: else fns(functions,0,enter(stamp,seen))
268: end
269: fun search closures =
270: let val (p,off,r) =
271: bfs(formap(fn((v,c),i) => (c,[i])) closures,[],[])
272: val (n::t) = rev p
273: fun f [] = OFFp off | f(h::t) = SELp(h,f t)
274: val (v,c) = nth(closures,n)
275: in (r,Path(v,c,f t))
276: end
277: fun look [] = raise Lookup
278: | look ((v,c as Closure{functions,contents,stamp,offset})::tl) =
279: if target=v then Found(c,Direct)
280: else let fun f(_,[]) = (false,0)
281: | f(i,(v,_)::t) = if target=v then (true,i) else f(i+1,t)
282: val (foundit,n) = f(0,functions)
283: (* this junk is a hack needed for linked closures *)
284: in if foundit
285: then Found(Closure{functions=functions,
286: contents=contents,
287: stamp=stamp,
288: offset=n},
289: Path(v,c,OFFp(n-offset)))
290: else ((case look tl of
291: f as Found _ => f
292: | Pending l => Pending ((v,c)::l))
293: handle Lookup => Pending [(v,c)])
294: end
295: | look ((v,f as Function _)::tl) =
296: if target=v then Found(f,Direct) else look tl
297: | look ((v,Value)::tl) =
298: if target=v then Found(Value,Direct) else look tl
299: in if constant target
300: then (Value,Direct)
301: else (case look e of
302: Found f => f
303: | Pending closures => search closures)
304: handle Lookup =>
305: (print "**LOOKUP: Can't find "; vp target;
306: print " in environment:\n";
307: printEnv env;
308: raise Lookup)
309: end
310:
311: fun flat(env,free) =
312: map (fn v => let val (obj,_) = lookup(env,v)
313: in case obj of Function _ => pr "weird\n"
314: | _ => ();
315: (v,obj)
316: end) free
317: fun link(env,free) =
318: let val contents = map (fn v => let val (obj,acc) = lookup(env,v)
319: in case obj of Function _ => pr "weird\n"
320: | _ => ();
321: (v,obj,acc)
322: end)
323: free
324: val direct = fold (fn ((v,obj,Direct),t) => (v,obj)::t
325: | ((v,obj,Path(_,_,OFFp _)),t) => (v,obj)::t
326: | (_,t) => t) contents []
327: in if length direct = length contents then direct
328: else case env of Env l =>
329: let fun getc ((m as (v,Closure _))::_) = m
330: | getc (_::tl) = getc tl
331: | getc [] = error "No closure in closureStrat"
332: val c = getc (rev l)
333: in c::direct
334: end
335: end
336:
337: fun closureStrategy(bindings,free,env) = (* temporary *)
338: let val m = case !CGoptions.closureStrategy
339: of 3 => link(env,free)
340: | 2 => link(env,free)
341: | _ => flat(env,free)
342: in mkClosure(map (fn(v,l,_,_) => (v,l)) bindings,m)
343: end
344:
345: (* Take a free variable list and replace knownfuncs by their
346: free variables. A new environment with the knownfunc mappings is
347: returned. Function aliasing could be added here. *)
348: fun funcAnalysis(free,env) =
349: fold (fn (v,(l,env')) =>
350: let val(obj,_) = lookup(env,v)
351: in case obj
352: of Function{free,...} => (merge(free,l),augment((v,obj),env'))
353: | _ => (enter(v,l),env')
354: end)
355: free ([],env0)
356: (* Function aliasing, separate for now, but always called after funcAnalysis. *)
357: fun sameClosureOpt(free,env) =
358: case !CGoptions.closureStrategy
359: of 0 => free (* flat without aliasing *)
360: | 2 => free (* linked without aliasing *)
361: | _ => (* all others have aliasing *)
362: let val mapping = map (fn v => let val (obj,_) = lookup(env,v)
363: in (v,obj)
364: end) free
365: fun uniq ((hd as (v,Closure{stamp,...}))::tl) =
366: let val m' = uniq tl
367: in if exists (fn (_,Closure{stamp=stamp',...}) => stamp=stamp'
368: | _ => false) m'
369: then m' else hd::m'
370: end
371: | uniq (hd::tl) = hd::uniq tl
372: | uniq [] = []
373: in map #1 (uniq mapping)
374: end
375:
376: fun fixAccess(args,env) =
377: let
378: fun access(rootvar,(env,header)) =
379: let val rec follow =
380: fn (_,Value,_,_,_) => error "fixAccess Value in cps/closure"
381: | (v,cl,env,OFFp off,h) =>
382: (offset(off,cl,rootvar,env),
383: h o (fn ce => OFFSET(off,v,rootvar,ce)))
384: | (v,cl,env,SELp(i,OFFp 0),h) =>
385: (augment((rootvar,select(i,cl)),env),
386: h o (fn ce => SELECT(i,v,rootvar,ce)))
387: | (v,cl,env,SELp(i,p),h) =>
388: let val w = mkLvar()
389: val cl = select(i,cl)
390: val env = augment((w,cl),env)
391: (* turn off lazy display here *)
392: in follow(w,cl,env,p,h o (fn ce => SELECT(i,v,w,ce)))
393: end
394: val (obj,acc) = lookup(env,rootvar)
395: in case acc
396: of Direct => (env,header)
397: | Path(start,cl,path) =>
398: let val a as (env,header) = follow(start,cl,env,path,header)
399: in if not(!CGoptions.profile) then a
400: else let val cost = lenp path
401: val h = if cost=0 then fn x => x else
402: if cost < LINKSLOTS
403: then fn ce => prof(LINKS+cost,1,ce)
404: else fn ce => prof(LINKS,1,prof(LINKOVFL,cost,ce))
405: in (env,h o header)
406: end
407: end
408: end
409: in fold access args (env,fn x => x)
410: end
411:
412: fun recordEl(l,env) =
413: if not(!CGoptions.profile)
414: then (map (fn (v,p) =>
415: case lookup(env,v)
416: of (_,Direct) => (v,p)
417: | (_,Path(start,_,path)) => (start,combinepaths(path,p))) l,
418: fn x => x)
419: else fold (fn ((v,p),(l,h)) =>
420: let val (_,acc) = lookup(env,v)
421: val (m,cost) = case acc of Direct => ((v,p),0)
422: | Path(start,_,path) =>
423: ((start,combinepaths(path,p)),lenp path)
424: val h' = if cost=0 then fn x => x else
425: if cost < LINKSLOTS then fn ce => prof(LINKS+cost,1,ce)
426: else fn ce => prof(LINKS,1,prof(LINKOVFL,cost,ce))
427: in (m::l,h o h')
428: end) l ([],fn x => x)
429:
430:
431: fun makenv(env,bindings: (lvar * lvar list * cexp) list) =
432: let
433: val _ = COMMENT(fn() => (pr "Beginning makenv.\nInitial environment:\n";
434: printEnv env; pr "\n"))
435:
436: (* A debugging version of freevars *)
437: fun fpr(v,free) = COMMENT(fn() => (pr "Free in "; vp v; pr ":"; ilist free))
438: val freevars =
439: (fn v => let val free = freevars v
440: in fpr(v,free);
441: free
442: end)
443:
444: (* Separate functions into those that escape and those which are knownfuncs *)
445: val (escape,known) = partition (escapes o #1) bindings
446: val escaping = uniq(map #1 escape)
447:
448: val _ = COMMENT(fn() => pr "Knownfuncs...\n")
449: (* Mark each known function of the FIX with its free variables. *)
450: val known
451: = map (fn(v,args,body) => {v=v,free=freevars v,args=args,body=body}) known
452:
453: (* For each known function of the FIX, remove any escaping functions of the
454: FIX from its free list and mark that the function requires the closure. *)
455: val known
456: = map (fn {v,free,args,body} =>
457: let val free' = difference(free,escaping)
458: in {v=v,free=free',
459: callc=(free<>free'),
460: args=args,body=body}
461: end) known
462:
463: (* Separate known functions defined in this FIX from other free variables. *)
464: local val knownlvars = map #v known
465: in val knownlvar = fn v => exists (fn w => v=w) knownlvars
466: end
467: val known
468: = map (fn {v,free,callc,args,body} =>
469: let val (fns,other) = partition knownlvar free
470: in {v=v,fns=fns,other=other,callc=callc,args=args,body=body}
471: end)
472: known
473:
474: (* Replace knownfuncs defined in other FIX'es by their free variables, and
475: escaping functions defined in other FIX'es by their closures. Label
476: each knownfunc. *)
477: val known
478: = map (fn{v,fns,other,callc,args,body} =>
479: let val (other,env') = funcAnalysis(other,env)
480: val other = sameClosureOpt(other,env)
481: in {v=v,fns=fns,other=other,callc=callc,args=args,body=body,
482: env=env',label=dupLvar v}
483: end)
484: known
485:
486: (* Merge free variables of knownfuncs that call each other. *)
487: (* Look at the number of free variables and arguments to each known function
488: to be defined. The cps converter ensures that there are enough registers
489: to hold the arguments and leaves one register free for the free variables,
490: if any. Therefore some free variables may have to be spilled into the closure,
491: and these must be collected. *)
492: val (known,collected)
493: = regf known
494:
495: val _ = COMMENT(fn() => pr "Escaping functions...\n")
496: (* Get the combined list of the free variables of all the escaping functions
497: of the FIX. *)
498: val free : lvar list = remove(escaping, foldmerge(map (freevars o #1) escape))
499: val _ = COMMENT(fn() => (pr "AAA"; ilist free))
500:
501: (* Replace knownfuncs defined in this FIX with their free variables. *)
502: val free : lvar list
503: = let val (fns,other) = partition knownlvar free
504: in fold (fn ({v,free,...},b) =>
505: if exists (fn w => v=w) fns
506: then merge(free,b)
507: else b) known other
508: end
509: val _ = COMMENT(fn() => (pr "BBB"; ilist free))
510:
511: val free = merge(collected,free)
512: val _ = COMMENT(fn() => (pr "CCC"; ilist free))
513:
514:
515: (* Replace knownfuncs defined elsewhere with their free variables, and escaping
516: functions defined elsewhere with their closures. The function environment
517: which tells that certain free variables are known functions and gives their
518: free variables must be kept for applications of the functions in the bodies
519: of the escaping functions of the FIX. *)
520: val (free,functionEnv) : lvar list * env (* only need function mapping here *)
521: = let val (free,env') = funcAnalysis(free,env)
522: val free = sameClosureOpt(free,env)
523: in (free,env')
524: end
525: val _ = COMMENT(fn() => (pr "DDD"; ilist free))
526:
527:
528: (* Given the functions to be defined in the closure (escape), the free variables
529: which should be contained in the closure (free), and their current locations
530: (env), decide on a closure representation. *)
531: val escape = map (fn(v,args,body) => (v,dupLvar v,args,body)) escape
532: val closure = closureStrategy(escape,free,env)
533: val _ = COMMENT(fn() =>
534: let val Closure{contents,...} = closure
535: in pr "EEE"; ilist (map #1 contents)
536: end)
537:
538: fun mkFnMap c : (lvar * object) list
539: = map (fn{v,free,callc,label,...} =>
540: if callc then (v,Function{label=label,free=enter(c,free)})
541: else (v,Function{label=label,free=free}))
542: known
543:
544: (* Final construction of the environment for each standard function. *)
545: val closureFrags : (lvar * lvar list * cexp * env) list
546: = case escape of [] => []
547: | ((v,_,_,_)::_) =>
548: let val env = fold augment (mkFnMap v) functionEnv
549: fun f ((v,l,args,body),i) =
550: let val cname = closureLvar()
551: val env = fold (fn (v,b) => augment((v,Value),b))
552: args (offset(i,closure,cname,env))
553: val _ = COMMENT(fn () => (print "\nEnvironment at escaping ";
554: vp v; print ":\n";
555: printEnv env))
556: in markunknown l; (l,cname::args,body,env)
557: end
558: in formap f escape
559: end
560:
561:
562: (* Final construction of the environment for each known function. *)
563: val cname = closureLvar()
564: val fnMap = mkFnMap cname
565: val registerFrags : (lvar * lvar list * cexp * env) list
566: = map (fn{v,free,callc,args,body,env=env',label} =>
567: let val env =
568: fold (fn (v,env') =>
569: case lookup(env,v)
570: of (Function _,_) => error "cps/closure.223"
571: | (obj,_) => augment((v,obj),env'))
572: free
573: (fold (fn (v,b) => augment((v,Value),b))
574: args
575: (fold augment fnMap
576: (if callc
577: then (inc System.Control.CG.knowncl;
578: augment((cname,closure),env'))
579: else env')))
580: val _ = COMMENT(fn () => (print "\nEnvironment at known ";
581: vp v; print ":\n";
582: printEnv env))
583: val args = args @ free @ if callc then [cname] else []
584: in markknown label; (label,args,body,env)
585: end)
586: known
587:
588:
589: val contents = let val Closure{functions,contents,...} = closure
590: in map #2 functions @ map #1 contents
591: end
592:
593:
594: (* Add profiling code if flag is on. *)
595: fun mkrexp(contents,cname) =
596: if not(!CGoptions.profile) then fn ce => RECORD(contents,cname,ce)
597: else let val len = length contents
598: val (closures,slots,ovfl) =
599: fold (fn((v,[_],_),b as (closures,_,_)) =>
600: if closures=CLOSURES then b
601: else if escapes v
602: then (CCLOSURES,CCLOSURESLOTS,CCLOSUREOVFL)
603: else b
604: |((v,args,_),b as (closures,_,_)) =>
605: if closures=CLOSURES then b
606: else if escapes v
607: then (CLOSURES,CLOSURESLOTS,CLOSUREOVFL)
608: else b)
609: bindings (KCLOSURES,KCLOSURESLOTS,KCLOSUREOVFL)
610: in if len < slots
611: then fn ce => prof(closures+len,1,RECORD(contents,cname,ce))
612: else fn ce => prof(closures,1,
613: prof(ovfl,len,RECORD(contents,cname,ce)))
614: end
615:
616:
617: in case contents
618: of [] => (fn ce => ce,registerFrags,fold augment fnMap env)
619: | _ =>
620: let val frags = closureFrags@registerFrags
621: val env = fold (fn(a,b) => augment((#1 a,Value),b)) closureFrags env
622: val (contents,header) = recordEl(recordpath contents,env)
623: val env = fold augment fnMap env
624: val env = augment((cname,closure),env)
625: val _ = COMMENT(fn () => (print "\nEnvironment after FIX:\n";
626: printEnv env))
627: in (header o mkrexp(contents,cname),frags,env)
628: end
629: before COMMENT(fn() => pr "makenv done.\n\n")
630: end
631:
632:
633: val env1 = fold (fn(v,b) => augment((v,Value),b)) (f::vl) env0
634: fun close(ce,env) =
635: case ce
636: of FIX(bindings,b) =>
637: (let val (header,frags,env') = makenv(env,bindings)
638: in FIX(map (fn(v,args,a,env) =>
639: (v,args,close(a,env))) frags,
640: header(close(b,env')))
641: end handle Lookup => APP(0,[]))
642: | APP(f,args) =>
643: let val(obj,_) = lookup(env,f)
644: handle Lookup => (print "LOOKUP FAILS in close(APP)\n"; (Value,Direct))
645: in case obj
646: of Closure{functions,offset,...} =>
647: let val (_,header) = fixAccess(f::args,env)
648: val (_,label) = nth(functions,offset)
649: val call = APP(label,f::args)
650: in if !CGoptions.profile
651: then header(prof(STDKCALLS,1,call))
652: else header call
653: end
654: | Function{label,free} =>
655: let val args' = args@free
656: val (_,header) = fixAccess(args',env)
657: val call = APP(label,args')
658: in if !CGoptions.profile
659: then header(prof(KNOWNCALLS,1,call))
660: else header call
661: end
662: | Value =>
663: let val l = mkLvar()
664: val (_,header) = fixAccess(f::args,env)
665: val call = SELECT(0,f,l,APP(l,f::args))
666: in if !CGoptions.profile
667: then case args
668: of [_] => header(prof(CNTCALLS,1,call))
669: | _ => header(prof(STDCALLS,1,call))
670: else header call
671: end
672: end
673: | SWITCH(v,l) =>
674: let val (env',header) = fixAccess([v],env)
675: in header (SWITCH(v,map (fn c => close(c,env')) l))
676: end
677: | RECORD(l,v,c) =>
678: let val (l,header) = recordEl(l,env)
679: val ce = close(c,augment((v,Value),env))
680: val len = length l
681: in header(
682: if not(!CGoptions.profile) then RECORD(l,v,ce)
683: else if len < RECORDSLOTS
684: then prof(RECORDS+len,1,RECORD(l,v,ce))
685: else prof(RECORDS,1,prof(RECORDOVFL,len,RECORD(l,v,ce))))
686: end
687: | SELECT(i,v,w,c) =>
688: let val (env,header) = fixAccess([v],env)
689: val (obj,_) = lookup(env,v)
690: handle Lookup => (print "LOOKUP FAILS in close(SELECT)\n"; (Value,Direct))
691: in header(SELECT(i,v,w,close(c,augment((w,select(i,obj)),env))))
692: end
693: | OFFSET(i,v,w,c) => error "OFFSET in cps/closure.sml!"
694: | PRIMOP(i,args,rets,l) =>
695: let val (env,header) = fixAccess(args,env)
696: val env = fold (fn (v,b) => augment((v,Value),b)) rets env
697: in header (PRIMOP(i,args,rets,map (fn c => close(c,env)) l))
698: end
699: in ((mkLvar(),f::vl,unrebind(close(ce,env1))),
700: Intset.mem knownset,Intset.mem unknownset)
701: end
702:
703: end (* structure Closure *)
704:
705:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.