![[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.