![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cpsopt.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 cpsopt.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / cps |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* All record paths must be "OFFp 0" in cpsopt.sml *)
3:
4: functor CPSopt(val maxfree : int) :
5: sig val reduce : (CPS.const Intmap.intmap) -> CPS.cexp -> CPS.cexp
6: end =
7: struct
8:
9: open Access CPS SortedList
10:
11: fun map1 f (a,b) = (f a, b)
12:
13: fun member(i : int, a::b) = i=a orelse member(i,b)
14: | member(i,[]) = false
15:
16: fun choose(a::b,true::d) = a::choose(b,d)
17: | choose(a::b,false::d) = choose(b,d)
18: | choose _ = []
19:
20: fun sum f = let fun h [] = 0
21: | h (a::r) = f a + h r
22: in h
23: end
24:
25: val debug = false
26: fun debugprint s = if debug then print(s:string) else ()
27: fun debugflush() = if debug then flush_out std_out else ()
28:
29: fun reduce ctab cexp =
30: let
31: val clicked = ref 0
32: fun click (s:string) = (debugprint s; inc clicked)
33:
34: fun eta cexp =
35: let exception M2
36: val m : lvar Intmap.intmap = Intmap.new(32, M2)
37: val name = Intmap.map m
38: fun rename v = rename(name v) handle M2 => v
39: fun newname x = (Access.sameName x; Intmap.add m x)
40: val rec eta =
41: fn RECORD(vl,w,e) => RECORD(map (map1 rename) vl, w, eta e)
42: | SELECT(i,v,w,e) => SELECT(i, v, w, eta e)
43: | APP(f,vl) => APP(rename f, map rename vl)
44: | SWITCH(v,el) => SWITCH(v, map eta el)
45: | PRIMOP(i,vl,wl,el) => PRIMOP(i, map rename vl, wl, map eta el)
46: | FIX(l,e) =>
47: let fun h((f,vl,body as APP(g,wl))::r) =
48: if wl=vl andalso not (member(g, f::vl))
49: then (newname(f,rename g); h r)
50: else let val vl' = map dupLvar vl
51: and f' = dupLvar f
52: in (f,vl',APP(f',vl'))::(f',vl,body) :: h r
53: end
54: | h((f,vl,body)::r) =
55: let val vl' = map dupLvar vl
56: and f' = dupLvar f
57: in (f,vl',APP(f',vl'))::(f',vl,body) :: h r
58: end
59: | h [] = []
60: in case h l of
61: [] => eta e
62: | l' => FIX(map (fn(f,vl,e)=>(f,vl,eta e)) l', eta e)
63: end
64: in eta cexp
65: end
66:
67: val hoist = Hoist.hoist click
68: fun contract last cexp =
69: let val mkconst = Intmap.add ctab
70: datatype cv = CO of const | VA of lvar
71: fun ctable v = CO(Intmap.map ctab v) handle Ctable => VA v
72: fun isconst v = case ctable v of CO _ => true | VA _ => false
73: datatype arity = BOT | COUNT of int | TOP | NOTUSED
74: val botlist = map (fn _ => BOT)
75: datatype info = FNinfo of {arity: arity list ref,
76: args: lvar list,
77: body : cexp,
78: reduce_ok : bool ref}
79: | RECinfo of (lvar * accesspath) list * (lvar * int) list ref
80: | MISCinfo
81:
82: exception Escapemap
83: val m : {info: info, used : int ref, escape : int ref} Intmap.intmap =
84: Intmap.new(128, Escapemap)
85: val get = Intmap.map m
86: val enter = Intmap.add m
87: fun use v = inc(#used(get v)) handle Escapemap => ()
88: fun used v = !(#used(get v)) > 0 handle Escapemap => true
89: fun escape v = let val {escape,used,...} = get v
90: in inc escape; inc used
91: end handle Escapemap => ()
92: fun escapes r = !(#escape(get r)) handle Escapemap => 0
93: fun flatfun(f,n) =
94: (case get f of
95: {info=FNinfo{arity=ref al,reduce_ok=ref false,...},escape=ref 0,...} =>
96: (case nth(al,n) of
97: COUNT i => 1
98: | _ => 0)
99: | _ => 0) handle Escapemap => 0
100: fun selectonly r = 0 = !(#escape(get r)) handle Escapemap => false
101: fun enterREC(w,vl) = enter(w,{info=RECinfo(vl,ref[]),escape=ref 0,used=ref 0})
102: fun enterMISC w = enter(w,{info=MISCinfo, escape=ref 0, used = ref 0})
103: fun enterFN (f,vl,cexp) =
104: (enter(f,{escape=ref 0,used=ref 0,
105: info=FNinfo{arity=ref(botlist vl), args=vl, body=cexp,
106: reduce_ok=ref true}});
107: app enterMISC vl)
108:
109: fun checkreduce(f,vl,body) =
110: case get f of
111: {escape=ref 0,used=ref i,
112: info=FNinfo{reduce_ok,arity as ref al,...},...} =>
113: if i>1
114: then
115: let fun loop(v::vl,a::al) =
116: if used v
117: then if selectonly v
118: then a::loop(vl,al)
119: else TOP::loop(vl,al)
120: else NOTUSED::loop(vl,al)
121: | loop _ = []
122: in reduce_ok := false;
123: arity := loop(vl,al)
124: end
125: else ()
126: | {info=FNinfo{reduce_ok,...},...} =>
127: (reduce_ok := false;
128: if last
129: then ()
130: else (case body of
131: APP(g,_) =>
132: (case get g of
133: {info=FNinfo{reduce_ok,...},...} =>
134: reduce_ok := false
135: | _ => ())
136: | _ => ()))
137:
138: exception ConstFold
139:
140: val rec pass1 =
141: fn RECORD(vl,w,e) => (enterREC(w,vl); app (escape o #1) vl; pass1 e)
142: | SELECT (i,v,w,e) => (enterMISC w; use v; pass1 e)
143: | APP(f,vl) =>
144: ((case get f of
145: {info=FNinfo{arity as ref al,...},...} =>
146: let fun loop(TOP::r,v::vl,n) = TOP::loop(r,vl,n+1)
147: | loop(BOT::r,v::vl,n) =
148: ((case get v of
149: {info=RECinfo(wl,flr as ref fl), ...} =>
150: (flr := (f,n)::fl; COUNT(length wl)::loop(r,vl,n+1))
151: | _ => raise Escapemap)
152: handle Escapemap => TOP::loop(r,vl,n+1))
153: | loop((cnt as COUNT a)::r,v::vl,n) =
154: ((case get v of
155: {info=RECinfo(wl,flr as ref fl), ...} =>
156: if a = length wl
157: then (flr := (f,n)::fl; cnt::loop(r,vl,n+1))
158: else TOP::loop(r,vl,n+1)
159: | _ => raise Escapemap)
160: handle Escapemap => TOP::loop(r,vl,n+1))
161: | loop _ = []
162: in arity := loop(al,vl,0)
163: end
164: | _ => ())
165: handle Escapemap => ();
166: use f; app escape vl)
167: | FIX(l, e) => (app enterFN l;
168: app (fn(* (f,vl,APP(g,wl)) => (use g; app escape wl)
169: |*) (f,vl,body) => pass1 body) l;
170: pass1 e;
171: app checkreduce l)
172: | SWITCH(v,el) => (use v; app pass1 el)
173: | PRIMOP(i,vl,wl,el) =>
174: (case i of
175: P.:= => app escape vl
176: | P.makeref => app escape vl
177: | P.sethdlr => app escape vl
178: | P.store => app escape vl
179: | P.unboxedassign => app escape vl
180: | P.unboxedupdate => app escape vl
181: | P.update => app escape vl
182: | _ => app use vl;
183: app enterMISC wl;
184: app pass1 el)
185: | OFFSET _ => ErrorMsg.impossible "OFFSET in cpsopt"
186:
187: exception Beta
188: val m2 : lvar Intmap.intmap = Intmap.new(32, Beta)
189: fun ren v = ren(Intmap.map m2 v) handle Beta => v
190: fun newname x = (Access.sameName x; Intmap.add m2 x)
191: fun newnames(v::vl, w::wl) = (newname(v,w); newnames(vl,wl))
192: | newnames _ = ()
193: val one = let val x = mkLvar() in mkconst(x, INTconst 1); x end
194:
195: val rec reduce = fn cexp => g NONE cexp
196: and g = fn hdlr =>
197: let val rec g' =
198: fn RECORD (vl,w,e) =>
199: let val {info=RECinfo(_,ref fl),escape=ref esc,...} = get w
200: in if esc = sum flatfun fl
201: then (click "rec "; g' e)
202: else RECORD(map (map1 ren) vl, w, g' e)
203: end
204: | SELECT(i,v,w,e) =>
205: if not(used w)
206: then (click "Sel "; g' e)
207: else let val v' = ren v
208: in (case get v' of
209: {info=RECinfo(vl,_),...} =>
210: let val (x,OFFp 0) = nth(vl,i)
211: in click "sel ";
212: newname(w,ren x);
213: g' e
214: end
215: | _ => raise Escapemap)
216: handle Escapemap => SELECT(i,v',w,g' e)
217: end
218: | OFFSET _ => ErrorMsg.impossible "OFFSET in cpsopt"
219: | APP(f,vl) =>
220: ((case get(ren f) of
221: {info=FNinfo{args,body,reduce_ok=ref true,...},...} =>
222: (newnames(args, map ren vl); g' body)
223: | {info=FNinfo{arity=ref al,...},escape=ref 0,...} =>
224: let fun loop(COUNT _ :: r,v::vl) =
225: let val {info=RECinfo(wl,_),...} = get(ren v)
226: val wl' = map (fn (x,OFFp 0) => ren x) wl
227: in wl' @ loop(r,vl)
228: end
229: | loop(NOTUSED::r,v::vl) = loop(r,vl)
230: | loop(_::r,v::vl) = (ren v)::loop(r,vl)
231: | loop _ = []
232: in APP(ren f,loop(al,vl))
233: end
234: | _ => raise Escapemap)
235: handle Escapemap => APP(ren f, map ren vl))
236: | FIX(l,e) =>
237: let fun h((f,vl,body)::r) =
238: (case get f
239: of {info=FNinfo{reduce_ok=ref true,...},...} =>
240: (click "fn "; h r)
241: | {info=FNinfo{arity=ref al,...},escape=ref 0,...} =>
242: let fun vars 0 = []
243: | vars i = mkLvar()::vars(i-1)
244: fun newargs(COUNT j :: r,v::vl) =
245: let val new = vars j
246: in enterREC(v, map (fn x =>(x,OFFp 0)) new);
247: click "flt ";
248: new @ newargs(r,vl)
249: end
250: | newargs(NOTUSED::r,v::vl) =
251: (click "drp "; newargs(r,vl))
252: | newargs(TOP::r,v::vl) = v::newargs(r,vl)
253: | newargs _ = []
254: in (f, newargs(al,vl), reduce body) :: h r
255: end
256: | _ => (f, vl, reduce body) :: h r)
257: | h [] = []
258: in case h l of [] => g' e | l' => FIX(l', g' e)
259: end
260: | SWITCH(v,el) =>
261: (case ctable (ren v)
262: of CO(INTconst i) => (click "swt "; g' (nth(el,i)))
263: | VA v' => SWITCH(v', map g' el)
264: | _ => ErrorMsg.impossible "3121 in cpsopt")
265: | PRIMOP(P.gethdlr,vl,wl as [w],[e]) =>
266: (case hdlr of
267: NONE => if used w then PRIMOP(P.gethdlr,vl,wl,[g (SOME w) e])
268: else (click "gth "; g' e)
269: | SOME w' => (click "gth "; newname(w,w'); g' e))
270: | PRIMOP(P.sethdlr,[v],wl,[e]) =>
271: let val v' = ren v
272: val e' = g (SOME v') e
273: in case hdlr of
274: NONE => PRIMOP(P.sethdlr,[v'],wl,[e'])
275: | SOME v'' => if v'=v'' then (click "sth "; e')
276: else PRIMOP(P.sethdlr,[v'],wl,[e'])
277: end
278: | PRIMOP(i, vl, wl, el as [e1,e2]) =>
279: if e1 = e2
280: then (click "tst "; g' e1)
281: else let val vl' = map ren vl
282: in g' (primops(i,map ctable vl', wl, el))
283: handle ConstFold => PRIMOP(i, vl', wl, map g' el)
284: end
285: | PRIMOP(i, vl, wl as [w], el as [e]) =>
286: if not(used w) andalso Prim.pure i
287: then (click "prm "; g' e)
288: else let val vl' = map ren vl
289: in g' (primops(i,map ctable vl', wl, el))
290: handle ConstFold => PRIMOP(i, vl', wl, map g' el)
291: end
292: | PRIMOP(i,vl,wl,el) =>
293: let val vl' = map ren vl
294: in g' (primops(i,map ctable vl', wl, el))
295: handle ConstFold => PRIMOP(i, vl', wl, map g' el)
296: end
297: in g'
298: end
299:
300: and primops =
301: fn (P.boxed, CO(INTconst _)::_,_,_::b::_) => (click "A"; b)
302: | (P.boxed, CO(STRINGconst s)::_,_,a::b::_) =>
303: (click "A"; if size s = 1 then b else a)
304: | (P.boxed, VA v :: _,_,a::_) =>
305: ((case get v of
306: {info=RECinfo _, ...} => (click "A"; a)
307: | _ => raise ConstFold)
308: handle Escapemap => raise ConstFold)
309: | (P.<, [CO(INTconst i),CO(INTconst j)],_,[a,b]) =>
310: (click "B"; if Integer.<(i,j) then a else b)
311: | (P.<=, [CO(INTconst i),CO(INTconst j)],_,[a,b]) =>
312: (click "C"; if Integer.<=(i,j) then a else b)
313: | (P.> , [CO(INTconst i),CO(INTconst j)],_,[a,b]) =>
314: (click "D"; if Integer.>(i,j) then a else b)
315: | (P.>=, [CO(INTconst i),CO(INTconst j)],_,[a,b]) =>
316: (click "E"; if Integer.>=(i,j) then a else b)
317: | (P.ieql, [CO(INTconst i),CO(INTconst j)],_,[a,b]) =>
318: (click "F"; if i=j then a else b)
319: | (P.ineq, [CO(INTconst i),CO(INTconst j)],_,[a,b]) =>
320: (click "G"; if i=j then b else a)
321: | (P.*, [CO(INTconst 1), VA(v)],[w],[c]) =>
322: (click "H"; newname(w,v); c)
323: | (P.*, [VA(v), CO(INTconst 1)],[w],[c]) =>
324: (click "H"; newname(w,v); c)
325: | (P.*, [CO(INTconst 0), _],[w],[c]) =>
326: (click "H"; mkconst(w,INTconst 0); c)
327: | (P.*, [_, CO(INTconst 0)],[w],[c]) =>
328: (click "H"; mkconst(w,INTconst 0); c)
329: | (P.*, [CO(INTconst i),CO(INTconst j)], [w], [c]) =>
330: (let val x = i*j
331: in x+x; mkconst(w,INTconst x); click "H"; c
332: end handle Overflow => raise ConstFold)
333: | (P.div, [VA(v), CO(INTconst 1)],[w],[c]) =>
334: (click "I"; newname(w,v); c)
335: | (P.div, [CO(INTconst i),CO(INTconst j)],[w],[c]) =>
336: (let val x = i div j
337: in click "I"; mkconst(w,INTconst x); c
338: end handle Div => raise ConstFold)
339: | (P.+, [CO(INTconst 0), VA(v)],[w],[c]) =>
340: (click "J"; newname(w,v); c)
341: | (P.+, [VA(v), CO(INTconst 0)],[w],[c]) =>
342: (click "J"; newname(w,v); c)
343: | (P.+, [CO(INTconst i),CO(INTconst j)], [w], [c]) =>
344: (let val x = i+j
345: in x+x; mkconst(w,INTconst x); click "J"; c
346: end handle Overflow => raise ConstFold)
347: | (P.-, [VA(v), CO(INTconst 0)],[w],[c]) =>
348: (click "K";newname(w,v); c)
349: | (P.-, [CO(INTconst i),CO(INTconst j)], [w], [c]) =>
350: (let val x = i-j
351: in x+x; mkconst(w,INTconst x); click "K"; c
352: end handle Overflow => raise ConstFold)
353: | (P.rshift, [CO(INTconst i),CO(INTconst j)],[w],[c]) =>
354: (click "L"; mkconst(w,INTconst(Bits.rshift(i,j))); c)
355: | (P.rshift, [CO(INTconst 0), VA v],[w],[c]) =>
356: (click "L"; mkconst(w,INTconst 0); c)
357: | (P.rshift, [VA v, CO(INTconst 0)],[w],[c]) =>
358: (click "L"; newname(w,v); c)
359: | (P.slength, [CO(INTconst _)],[w],[c]) =>
360: (click "M"; mkconst(w, INTconst 1); c)
361: | (P.slength, [CO(STRINGconst s)], [w],[c]) =>
362: (click "M"; mkconst(w, INTconst(size s)); c)
363: | (P.ordof, [CO(STRINGconst s), CO(INTconst i)],[w],[c]) =>
364: (click "N"; mkconst(w, INTconst (ordof(s,i))); c)
365: | (P.~, [CO(INTconst i)], [w], [c]) =>
366: (let val x = ~i
367: in x+x; mkconst(w,INTconst x); click "O"; c
368: end handle Overflow => raise ConstFold)
369: | (P.lshift, [CO(INTconst i),CO(INTconst j)],[w],[c]) =>
370: (let val x = Bits.lshift(i,j)
371: in x+x; mkconst(w,INTconst x); click "P"; c
372: end handle Overflow => raise ConstFold)
373: | (P.lshift, [CO(INTconst 0), VA v],[w],[c]) =>
374: (click "P"; mkconst(w,INTconst 0); c)
375: | (P.lshift, [VA v, CO(INTconst 0)],[w],[c]) =>
376: (click "P"; newname(w,v); c)
377: | (P.orb, [CO(INTconst i),CO(INTconst j)],[w],[c]) =>
378: (click "Q"; mkconst(w,INTconst(Bits.orb(i,j))); c)
379: | (P.orb, [CO(INTconst 0),VA v],[w],[c]) =>
380: (click "Q"; newname(w,v); c)
381: | (P.orb, [VA v, CO(INTconst 0)],[w],[c]) =>
382: (click "Q"; newname(w,v); c)
383: | (P.xorb, [CO(INTconst i),CO(INTconst j)],[w],[c]) =>
384: (click "R"; mkconst(w,INTconst(Bits.xorb(i,j))); c)
385: | (P.xorb, [CO(INTconst 0),VA v],[w],[c]) =>
386: (click "R"; newname(w,v); c)
387: | (P.xorb, [VA v, CO(INTconst 0)],[w],[c]) =>
388: (click "R"; newname(w,v); c)
389: | (P.notb, [CO(INTconst i)], [w], [c]) =>
390: (mkconst(w,INTconst(Bits.notb i)); click "S"; c)
391: | (P.andb, [CO(INTconst i),CO(INTconst j)],[w],[c]) =>
392: (click "T"; mkconst(w,INTconst(Bits.andb(i,j))); c)
393: | (P.andb, [CO(INTconst 0),VA v],[w],[c]) =>
394: (click "T"; mkconst(w,INTconst 0); c)
395: | (P.andb, [VA v, CO(INTconst 0)],[w],[c]) =>
396: (click "T"; mkconst(w,INTconst 0); c)
397: | _ => raise ConstFold
398:
399: val _ = (debugprint "\nContract: "; debugflush())
400: in (pass1 cexp; reduce cexp)
401: end
402:
403: fun expand(cexp,bodysize) =
404: let
405: datatype info = Fun of {escape: int ref, call: int ref, size: int ref,
406: args: lvar list, body: cexp}
407: | Arg of {escape: int ref, savings: int ref,
408: record: (int * lvar) list ref}
409: | Sel of {savings: int ref}
410: | Rec of {escape: int ref, size: int,
411: vars: (lvar * accesspath) list}
412:
413: exception Expand
414: val m : info Intmap.intmap = Intmap.new(128,Expand)
415: val get = Intmap.map m
416: fun call(v,args) = (case get v
417: of Fun{call,...} => inc call
418: | Arg{savings,...} => savings := !savings+1
419: | Sel{savings} => savings := !savings+1
420: | Rec _ => () (* impossible *)
421: ) handle Expand => ()
422: fun escape v = (case get v
423: of Fun{escape,...} => inc escape
424: | Arg{escape,...} => inc escape
425: | Sel _ => ()
426: | Rec{escape,...} => inc escape
427: ) handle Expand => ()
428: fun escapeargs v = (case get v
429: of Fun{escape,...} => inc escape
430: | Arg{escape,savings, ...} =>
431: (inc escape; savings := !savings + 1)
432: | Sel{savings} => savings := !savings + 1
433: | Rec{escape,...} => inc escape)
434: handle Expand => ()
435: fun unescapeargs v = (case get v
436: of Fun{escape,...} => dec escape
437: | Arg{escape,savings, ...} =>
438: (dec escape; savings := !savings - 1)
439: | Sel{savings} => savings := !savings - 1
440: | Rec{escape,...} => dec escape)
441: handle Expand => ()
442: fun setsize(f,n) = case get f of Fun{size,...} => (size := n; n)
443: fun enter (f,vl,e) = (Intmap.add m(f,Fun{escape=ref 0, call=ref 0, size=ref 0,
444: args=vl, body=e});
445: app (fn v => Intmap.add m (v,
446: Arg{escape=ref 0,savings=ref 0,
447: record=ref []})) vl)
448: fun noterec(w, vl, size) = Intmap.add m (w,Rec{size=size,escape=ref 0,vars=vl})
449: fun notesel(i,v,w) = (Intmap.add m (w, Sel{savings=ref 0});
450: (case get v of
451: Arg{savings,record,...} => (inc savings;
452: record := (i,w)::(!record))
453: | _ => ()) handle Expand => ())
454: fun save(v,k) = (case get v
455: of Arg{savings,...} => savings := !savings + k
456: | Sel{savings} => savings := !savings + k
457: | _ => ()
458: ) handle Expand => ()
459: fun nsave(v,k) = (case get v
460: of Arg{savings,...} => savings := k
461: | Sel{savings} => savings := k
462: | _ => ()
463: ) handle Expand => ()
464: fun savesofar v = (case get v
465: of Arg{savings,...} => !savings
466: | Sel{savings} => !savings
467: | _ => 0
468: ) handle Expand => 0
469: val rec prim = fn (_,vl,wl,el) =>
470: let fun vbl v = (Intmap.map ctab v; 0)
471: handle Ctable =>
472: ((case get v of
473: Rec _ => 0
474: | _ => 1) handle Expand => 1)
475: val nonconst = sum vbl vl
476: val len = length el
477: val sl = map savesofar vl
478: val branches = sum pass1 el
479: val zl = map savesofar vl
480: val overhead = length vl + length wl
481: val potential = overhead + (branches*(len-1)) div len
482: val savings = case nonconst of
483: 1 => potential
484: | 2 => potential div 4
485: | _ => 0
486: fun app3 f = let fun loop (a::b,c::d,e::r) = (f(a,c,e); loop(b,d,r))
487: | loop _ = ()
488: in loop
489: end
490: in app3(fn (v,s,z)=> nsave(v,s + savings + (z-s) div len)) (vl,sl,zl);
491: overhead+branches
492: end
493:
494: and pass1 =
495: fn RECORD(vl,w,e) =>
496: (app (escape o #1) vl;
497: noterec(w,vl,length vl);
498: 2 + length vl + pass1 e)
499: | SELECT (i,v,w,e) => (notesel(i,v,w); 1 + pass1 e)
500: | APP(f,vl) => (call(f,length vl); app escapeargs vl; 1 + length vl)
501: | FIX(l, e) =>
502: (app enter l;
503: sum (fn (f,_,e) => setsize(f, pass1 e)) l + length l + pass1 e)
504: | SWITCH(v,el) => let val len = length el
505: val jumps = 4 + len
506: val branches = sum pass1 el
507: in save(v, (branches*(len-1)) div len + jumps);
508: jumps+branches
509: end
510: | PRIMOP(args as (P.boxed,_,_,_)) => prim args
511: | PRIMOP(args as (P.<,_,_,_)) => prim args
512: | PRIMOP(args as (P.<=,_,_,_)) => prim args
513: | PRIMOP(args as (P.>,_,_,_)) => prim args
514: | PRIMOP(args as (P.>=,_,_,_)) => prim args
515: | PRIMOP(args as (P.ieql,_,_,_)) => prim args
516: | PRIMOP(args as (P.ineq,_,_,_)) => prim args
517: | PRIMOP(args as (P.*,_,_,_)) => prim args
518: | PRIMOP(args as (P.div,_,_,_)) => prim args
519: | PRIMOP(args as (P.+,_,_,_)) => prim args
520: | PRIMOP(args as (P.-,_,_,_)) => prim args
521: | PRIMOP(args as (P.rshift,_,_,_)) => prim args
522: | PRIMOP(args as (P.slength,_,_,_)) => prim args
523: | PRIMOP(args as (P.ordof,_,_,_)) => prim args
524: | PRIMOP(args as (P.~,_,_,_)) => prim args
525: | PRIMOP(args as (P.lshift,_,_,_)) => prim args
526: | PRIMOP(args as (P.orb,_,_,_)) => prim args
527: | PRIMOP(args as (P.xorb,_,_,_)) => prim args
528: | PRIMOP(args as (P.notb,_,_,_)) => prim args
529: | PRIMOP(args as (P.andb,_,_,_)) => prim args
530: | PRIMOP(_,vl,wl,el) =>
531: (app escape vl; length vl + length wl + sum pass1 el)
532:
533: fun substitute(args,wl,e) =
534: let exception Alpha
535: val vm : lvar Intmap.intmap = Intmap.new(16, Alpha)
536: fun use v = Intmap.map vm v handle Alpha => v
537: fun def v = let val w = dupLvar v
538: in Intmap.add vm (v,w); w
539: end
540: fun bind(a::args,w::wl) = (Intmap.add vm (w,a); bind(args,wl))
541: | bind _ = ()
542: val rec g =
543: fn RECORD(vl,w,ce) => RECORD(map (map1 use) vl, def w, g ce)
544: | SELECT(i,v,w,ce) => SELECT(i, use v, def w, g ce)
545: | APP(v,vl) => APP(use v, map use vl)
546: | FIX(l,ce) =>
547: let fun h1(f,vl,e) = (f,def f, vl, e)
548: fun h2(f,f',vl,e) =
549: let val vl' = map def vl
550: val e'= g e
551: in (f', vl', e')
552: end
553: in FIX(map h2(map h1 l), g ce)
554: end
555: | SWITCH(v,l) => SWITCH(use v, map g l)
556: | PRIMOP(i,vl,wl,ce) => PRIMOP(i, map use vl, map def wl, map g ce)
557: val cexp = (bind(args,wl); g e)
558: in debugprint(makestring(pass1 cexp)); debugprint " "; cexp
559: end
560:
561: fun beta(n, d, e) = case e
562: of RECORD(vl,w,ce) => RECORD(vl, w, beta(n,d+2+length vl, ce))
563: | SELECT(i,v,w,ce) => SELECT(i, v, w, beta(n,d+1, ce))
564: | APP(v,vl) =>
565: ((case get v
566: of Fun{escape,call as ref calls,size,args,body} =>
567: let val size = !size
568: fun whatsave(acc, v::vl, a::al) =
569: if acc>=size
570: then acc
571: else
572: (case get a of
573: Arg{escape=ref esc,savings=ref save,record=ref rl} =>
574: let val (this,nvl,nal) =
575: if (Intmap.map ctab v; true) handle Ctable => false
576: then (save,vl,al)
577: else (case get v of
578: Fun{escape=ref 1,...} =>
579: (if esc>0 then save else 6+save,vl,al)
580: | Fun _ => (save,vl,al)
581: | Rec{escape=ref ex,vars,size} =>
582: let fun loop([],nvl,nal) =
583: (if ex>1 orelse esc>0
584: then save
585: else save+size+2,nvl,nal)
586: | loop((i,w)::rl,nvl,nal) =
587: let val (v,OFFp 0) = nth(vars,i)
588: in loop(rl,v::nvl,w::nal)
589: end
590: in loop(rl,vl,al)
591: end
592: | _ => (0,vl,al)) handle Expand => (0,vl,al)
593: in whatsave(acc + this - (acc*this) div size, nvl,nal)
594: end
595: | Sel{savings=ref save} =>
596: let val this =
597: if (Intmap.map ctab v; true) handle Ctable => false
598: then save
599: else (case get v of
600: Fun _ => save
601: | Rec _ => save
602: | _ => 0) handle Expand => 0
603: in whatsave(acc + this - (acc*this) div size, vl,al)
604: end)
605: | whatsave(acc,_,_) = acc
606: val predicted = calls*((size-whatsave(0,vl,args))-(1+length vl))
607: val depth = 2
608: val max = 5
609: val increase = (bodysize*(depth - n)) div depth
610: in if (predicted <= increase
611: orelse (!escape=0 andalso
612: (calls = 1
613: orelse (case vl of
614: [_] => calls = 2 andalso
615: predicted - (size+1) <= increase
616: | _ => false))))
617: andalso (n <= max orelse (debugprint "n>";
618: debugprint(makestring max);
619: debugprint "\n"; false))
620: then let val new = beta(n+1, d+1, substitute(vl,args,body))
621: in click "";
622: call := calls-1;
623: app unescapeargs vl;
624: new
625: end
626: else e
627: end
628: | _ => e) handle Expand => e)
629: | FIX(l,ce) => let fun h(f,vl,e) =
630: case get f
631: of Fun{escape=ref 0,...} => (f,vl, beta(n,0,e))
632: | _ => (f,vl,e)
633: in FIX(if n<1 then map h l else l,
634: beta(n,d+length l, ce))
635: end
636: | SWITCH(v,l) => SWITCH(v, map (fn e => beta(n,d+2,e)) l)
637: | PRIMOP(i,vl,wl,ce) => PRIMOP(i, vl, wl, map (fn e => beta(n,d+2,e)) ce)
638:
639: in debugprint("\nExpand ("); debugprint(makestring(pass1 cexp));
640: debugprint("): "); debugflush();
641: beta(0,0,cexp)
642: end
643:
644: val bodysize = !System.Control.CG.bodysize
645: val rounds = !System.Control.CG.rounds
646: val reducemore = !System.Control.CG.reducemore
647:
648: fun contracter last cexp =
649: let val cexp = (clicked := 0; contract false cexp)
650: in if !clicked <= reducemore
651: then if last
652: then contract last cexp
653: else cexp
654: else contracter last cexp
655: end
656:
657: fun cycle(0,cexp) = contract true cexp
658: | cycle(1,cexp) =
659: let val _ = debugprint "\nHoist: "
660: val cexp = hoist cexp
661: val _ = clicked := 0
662: val cexp = expand(cexp,bodysize div rounds)
663: val cl = !clicked before clicked := 0
664: in if cl <= reducemore
665: then contract true cexp
666: else contracter true cexp
667: end
668: | cycle(k,cexp) =
669: let val _ = debugprint "\nHoist: "
670: val cexp = hoist cexp
671: val _ = clicked := 0
672: val cexp = expand(cexp,(bodysize * k) div rounds)
673: val cl = !clicked before clicked := 0
674: in if cl <= reducemore
675: then contract true cexp
676: else cycle(k-1, contract false cexp)
677: end
678: in cycle(rounds,contracter false (eta cexp))
679: before (debugprint "\n"; debugflush())
680: end
681: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.