![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to spill.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 spill.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 SPILL = ! 3: sig val spill : (CPS.function * bool) list * (CPS.lvar -> bool) ! 4: * (int * int * CPS.cexp -> CPS.cexp) -> ! 5: (CPS.function * bool) list ! 6: end ! 7: ! 8: functor Spill(val maxfree : int) : SPILL = ! 9: struct ! 10: open FreeMap Access SortedList CPS ! 11: val error = ErrorMsg.impossible ! 12: fun sublist test = ! 13: let fun subl(a::r) = if test a then a::(subl r) else subl r ! 14: | subl [] = [] ! 15: in subl ! 16: end ! 17: ! 18: local val spillname = Symbol.symbol "spillrec" ! 19: in fun spillLvar() = namedLvar spillname ! 20: end ! 21: ! 22: val ilist = PrintUtil.printClosedSequence ("[",",","]") Integer.print ! 23: ! 24: fun cut(0,_) = [] ! 25: | cut(i,a::x) = a::cut(i-1,x) ! 26: | cut(_,[]) = [] ! 27: ! 28: fun nextuse x = ! 29: let fun xin[] = false | xin(y::r) = x=y orelse xin r ! 30: fun g(level,a) = ! 31: let val rec f = ! 32: fn ([],[]) => level ! 33: | ([],next) => g(level+1,next) ! 34: | (SWITCH(v,l)::r,next) => if x=v then level else f(r,l@next) ! 35: | (RECORD(l,w,c)::r,next) => ! 36: if xin(map #1 l) then level else f(r,c::next) ! 37: | (SELECT(i,v,w,c)::r,next) => if x=v then level else f(r,c::next) ! 38: | (OFFSET(i,v,w,c)::r,next) => if x=v then level else f(r,c::next) ! 39: | (PRIMOP(i,a,w,cl)::r,next) => if xin a then level else f(r,cl@next) ! 40: | (APP(v,vl)::r,next) => if xin(v::vl) then level else f(r,next) ! 41: in f(a,[]) ! 42: end ! 43: fun h y = g(0,[y]) ! 44: in h ! 45: end ! 46: ! 47: local val sort = Sort.sort (fn ((i:int,_),(j,_)) => i>j) ! 48: in fun sortdups(cexp,dups) = ! 49: map #2 (sort (map (fn dup as (v,w) => (nextuse v cexp, dup)) dups)) ! 50: end ! 51: ! 52: (* should do the first n and then only go ! 53: deep enough to prove that it is not needed *) ! 54: ! 55: fun next_n_dups(0,cexp,dups) = [] ! 56: | next_n_dups(n,cexp,dups) = ! 57: if n >= length dups ! 58: then dups ! 59: else cut(n,sortdups(cexp,dups)) ! 60: ! 61: fun show (SWITCH(v,l)) = (print "SWITCH "; print v; print "\n") ! 62: | show (RECORD(_,w,_)) = (print "RECORD "; print w; print "\n") ! 63: | show (SELECT(_,_,w,_)) = (print "SELECT "; print w; print "\n") ! 64: | show (OFFSET(_,_,w,_)) = (print "OFFSET "; print w; print "\n") ! 65: | show (PRIMOP(_,_,w::_,_)) = (print "PRIMOP "; print w; print "\n") ! 66: | show (PRIMOP(_,vl,_,_)) = (print "PRIMOP "; ilist vl; print "\n") ! 67: | show (APP(f,vl)) = (print "APP "; print f; ilist vl; print "\n") ! 68: ! 69: nonfix before ! 70: val \/ = merge and /\ = intersect ! 71: infix 6 \/ infix 7 /\ ! 72: fun mash (constant,freevars,spillmem) = ! 73: let fun f(results : lvar list, ! 74: uniques : lvar list, ! 75: dups : (lvar*lvar) list, ! 76: spill : (lvar list * lvar) option, ! 77: cexp : cexp) = ! 78: let fun prepare l = sublist (fn x => not(constant x)) (uniq l) ! 79: val (before,after) = (* variables free in this operation, and after ! 80: not including the newly-bound variables *) ! 81: let val rec free = ! 82: fn SWITCH(v,l) => foldmerge(prepare[v] :: map free l) ! 83: | RECORD(l,w,c) => prepare (map #1 l) \/ freevars w ! 84: | SELECT(i,v,w,c) => prepare[v] \/ freevars w ! 85: | OFFSET(i,v,w,c) => prepare[v] \/ freevars w ! 86: | PRIMOP(i,a,[],cl) => foldmerge(prepare a :: map free cl) ! 87: | PRIMOP(i,a,[res],cl) => prepare a \/ freevars res ! 88: | APP(f,vl) => prepare(f::vl) ! 89: fun here(vl,wl) = (prepare vl, wl) ! 90: in case cexp ! 91: of SWITCH(v,l) => here([v],foldmerge(map free l)) ! 92: | RECORD(l,w,c) => here(map #1 l,freevars w) ! 93: | SELECT(i,v,w,c) => here([v],freevars w) ! 94: | OFFSET(i,v,w,c) => here([v],freevars w) ! 95: | PRIMOP(i,a,[],cl) => here(a,foldmerge(map free cl)) ! 96: | PRIMOP(i,a,[res],cl) => here(a,freevars res) ! 97: | APP(f,vl) => here(f::vl,[]) ! 98: end ! 99: ! 100: val uniques = uniques \/ results ! 101: val uniques_after = uniques /\ after ! 102: val uniques_before = (uniques /\ before) \/ uniques_after ! 103: val spill_after = ! 104: case spill of ! 105: NONE => NONE ! 106: | SOME(contents,_) => ! 107: case uniq contents /\ after of ! 108: [] => NONE ! 109: | _ => spill ! 110: val maxfree' = case spill of NONE => maxfree | SOME _ => maxfree-1 ! 111: val maxfreeafter = case spill_after of ! 112: NONE => maxfree | SOME _ => maxfree-1 ! 113: val avail = maxfree' - length(uniques_before \/ results) ! 114: val dups = next_n_dups(avail,cexp,dups) ! 115: ! 116: fun getpath p v = ! 117: if constant v orelse member uniques_before v ! 118: then (v, OFFp 0) ! 119: else let fun try((w,x)::l) = if v=w then (x,OFFp 0) else try l ! 120: | try [] = let val SOME (l,sv) = spill ! 121: fun find(i,w::l) = ! 122: if v=w ! 123: then ((* if p ! 124: then (print "Retching "; ! 125: print v; ! 126: print "\n") ! 127: else (); *) ! 128: (sv,SELp(i,OFFp 0))) ! 129: else find(i+1,l) ! 130: | find(_,[]) = error "not found in spill" ! 131: in find(0,l) ! 132: end ! 133: in try dups ! 134: end ! 135: ! 136: fun makeSpillRec args = ! 137: let val contents = prepare args \/ after ! 138: val spillrec = map (getpath true) contents ! 139: val sv = spillLvar() ! 140: val dups' = map (fn x => (x,x)) uniques_before @ dups ! 141: in (* ilist contents; print "\n"; *) ! 142: RECORD(spillrec,sv,f([],[],dups',SOME(contents,sv),cexp)) ! 143: end ! 144: ! 145: fun g(args,res,conts,gen) = ! 146: if length(prepare args \/ uniques_after) > maxfreeafter orelse ! 147: length res + length uniques_after > maxfreeafter ! 148: then makeSpillRec args ! 149: else let val paths = map (fn x => (x, getpath false x)) (uniq args) ! 150: fun fetchit (_,(_,OFFp 0)) = false | fetchit _ = true ! 151: in case sublist fetchit paths of ! 152: [(v,(w,SELp(i,OFFp 0)))] => ! 153: let val x = dupLvar v ! 154: in (* print "Fetching "; ! 155: print v; ! 156: print "\n"; *) ! 157: SELECT(i,w,x,f([],uniques_before,(v,x)::dups, ! 158: spill_after,cexp)) ! 159: end ! 160: | (v,(w,SELp(i,OFFp 0)))::_ => ! 161: let val x = dupLvar v ! 162: in (* print "fetching "; ! 163: print v; ! 164: print "\n"; *) ! 165: SELECT(i,w,x,f([],uniques_before,(v,x)::dups,spill,cexp)) ! 166: end ! 167: | [] => let fun f' cexp = f(uniq res,uniques_after, ! 168: dups,spill_after,cexp) ! 169: in gen(map (#1 o (getpath false)) args,res,map f' conts) ! 170: end ! 171: end ! 172: ! 173: in case ((*show cexp;*) cexp) ! 174: of SWITCH(v,l) => g([v],[],l,fn([v],[],l)=>SWITCH(v,l)) ! 175: | RECORD(l,w,c) => ! 176: if 1+length uniques_after > maxfreeafter ! 177: then makeSpillRec (map #1 l) ! 178: else let val paths = map (fn (v,p) => ! 179: let val (v',p') = getpath true v ! 180: in (v', combinepaths(p',p)) ! 181: end) ! 182: l ! 183: in RECORD(paths,w,f([w],uniques_after,dups,spill_after,c)) ! 184: end ! 185: | SELECT(i,v,w,c) => g([v],[w],[c], fn([v],[w],[c])=>SELECT(i,v,w,c)) ! 186: | OFFSET(i,v,w,c) => g([v],[w],[c], fn([v],[w],[c])=>OFFSET(i,v,w,c)) ! 187: | PRIMOP(i,a,r,cl) => g(a,r,cl, fn(a,r,cl)=>PRIMOP(i,a,r,cl)) ! 188: | APP(f,vl) => g(f::vl,[],[],fn(f::vl,[],[])=>APP(f,vl)) ! 189: end ! 190: in f ! 191: end ! 192: ! 193: fun spill(carg,constant,prof) = ! 194: let ! 195: exception SpillCall ! 196: val callmap = Intmap.new(64,SpillCall) : (lvar list * lvar list) Intmap.intmap ! 197: val callinfo = Intmap.map callmap ! 198: val note = Intmap.add callmap ! 199: val t = Intset.new() ! 200: val spillarg = Intset.add t ! 201: val spillmem = Intset.mem t ! 202: ! 203: fun spill_call(arg as ((f,vl,body),k)) = ! 204: if length vl < maxfree ! 205: then (arg,uniq vl,[],NONE) ! 206: else let val dups = map (fn x => (x,x)) vl ! 207: val dups' = next_n_dups(maxfree-2,body,dups) ! 208: val sv = spillLvar() ! 209: val new = map #1 dups' ! 210: val new_vl = sv :: new ! 211: val spill = SOME(vl,sv) ! 212: in note(f,(new,vl)); ! 213: (((f,new_vl,body),k),[],dups',spill) ! 214: end ! 215: ! 216: val rec fixApp = ! 217: fn e as APP(f,vl) => ! 218: (let val (new,old) = callinfo f ! 219: val sv = spillLvar() ! 220: val sr = map (fn x => (x,OFFp 0)) vl ! 221: fun find [] = [] ! 222: | find(x::r) = ! 223: let fun loop(a::b,c::d) = ! 224: if x=a then c :: find r else loop(b,d) ! 225: | loop _ = error "fixApp in spill" ! 226: in loop(old,vl) ! 227: end ! 228: in spillarg sv; ! 229: RECORD(sr,sv,APP(f,sv :: find new)) ! 230: end handle SpillCall => e) ! 231: | SWITCH(v,l) => SWITCH(v,map fixApp l) ! 232: | RECORD(l,w,c) => RECORD(l,w,fixApp c) ! 233: | SELECT(i,v,w,c) => SELECT(i,v,w,fixApp c) ! 234: | OFFSET(i,v,w,c) => OFFSET(i,v,w,fixApp c) ! 235: | PRIMOP(i,a,w,l) => PRIMOP(i,a,w,map fixApp l) ! 236: val carg' = map spill_call carg ! 237: val carg'' = map (fn (((f,vl,b),k),uniq,dups,spill) => ! 238: (((f,vl,fixApp b),k),uniq,dups,spill)) carg' ! 239: val freevars = ! 240: let exception SpillFreemap ! 241: val m = Intmap.new(32, SpillFreemap) : lvar list Intmap.intmap ! 242: val _ = app (freemap constant (Intmap.add m) o #3 o #1 o #1) carg'' ! 243: in Intmap.map m ! 244: end ! 245: exception TooMany ! 246: fun checkv w = if length(freevars w) >= maxfree then raise TooMany else () ! 247: val rec check = ! 248: fn FIX _ => error "FIX in cps/spill" ! 249: | APP(l,args) => () ! 250: | SWITCH(v,l) => app check l ! 251: | RECORD(l,w,c) => (checkv w; check c) ! 252: | SELECT(i,v,w,c) => (checkv w; check c) ! 253: | OFFSET(i,v,w,c) => (checkv w; check c) ! 254: | PRIMOP(i,args,[],l) => app check l ! 255: | PRIMOP(i,args,w::_, l) => (checkv w; app check l) ! 256: val masher = mash(constant,freevars,spillmem) ! 257: ! 258: in map ! 259: (fn (((f,vl,body),k),uniq,dups,spill as SOME _) => ! 260: ((f,vl,masher([],uniq,dups,spill,body)), k) ! 261: | (arg as ((f,vl,body),k),uniq,dups,NONE) => ! 262: ((check body; arg) ! 263: handle TooMany => ((f,vl,masher([],uniq,dups,NONE,body)), k))) ! 264: carg'' ! 265: end ! 266: ! 267: end (* structure Spill *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.