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