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