![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to opt.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 / codegen|
Return to opt.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / codegen |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: (* structure Opt: extended by NICK, to add a new lambda-lifting function, ! 3: bareCloseTop, a more general form of closeTop. *) ! 4: ! 5: structure CGoptions = System.Control.CG ! 6: ! 7: signature OPT = ! 8: sig ! 9: structure L : LAMBDA sharing L=Lambda ! 10: structure A : ACCESS sharing A=Access ! 11: val reduce : L.lexp -> L.lexp ! 12: exception BadSwitch ! 13: val switch : L.lexp -> L.lexp ! 14: val hoist : L.lexp -> L.lexp ! 15: val closestr : (int -> string) * L.lexp * int list -> L.lexp ! 16: val bareCloseTop: ! 17: {lambda: L.lexp, looker: int, extras: int list, keepFree: int list} -> L.lexp ! 18: (* bareCloseTop is a more general form of closetop. It is passed an already ! 19: existing looker lvar, and also a keepFree list of lvars which it must ! 20: keep free (they'll be abstracted later). *) ! 21: ! 22: val closetop : L.lexp * int list -> L.lexp ! 23: val closeModDecl: L.lexp * A.lvar list * int list -> L.lexp ! 24: (* closeModDecl will be obselete when I finish the new moduleComp, but I'll ! 25: keep it here for the old moduleComp. *) ! 26: exception Freevars ! 27: val free : L.lexp -> A.lvar -> A.lvar list ! 28: val mix0free : L.lexp -> A.lvar -> A.lvar list * A.lvar list ! 29: val alphaConvert : L.lexp -> L.lexp ! 30: val mapfree : (A.lvar -> L.lexp) -> (L.lexp -> L.lexp) ! 31: val pure : L.lexp -> bool ! 32: end ! 33: ! 34: structure Opt : OPT = ! 35: struct ! 36: ! 37: structure A : ACCESS = Access ! 38: structure L : LAMBDA = Lambda ! 39: ! 40: open A Basics L ! 41: ! 42: fun root [v] = v | root (_::p) = root p ! 43: | root _ = ErrorMsg.impossible "root [] in codegen/opt"; ! 44: ! 45: exception Freevars ! 46: ! 47: fun mapfree lookfree = ! 48: let val m = Intmap.new(32, Freevars) : lexp Intmap.intmap ! 49: val add = Intmap.add m ! 50: fun look v = Intmap.map m v ! 51: handle Freevars => ! 52: let val x = lookfree v in add(v,x); x end ! 53: fun copycon (DATAcon(DATACON{rep=(VARIABLE(Access.PATH p)),const,name,typ,sign})) = ! 54: let fun f [v] = let val VAR w = look v in [w] end ! 55: | f (i::r) = i::(f r) ! 56: in DATAcon(DATACON{rep=(VARIABLE (Access.PATH(f p))),const=const, ! 57: name=name,typ=typ,sign=sign}) ! 58: end ! 59: | copycon c = c ! 60: fun newvar v = let val w = dupLvar v in add(v,VAR w); w end ! 61: val rec f = ! 62: fn VAR v => look v ! 63: | FN(v,b) => FN(newvar v, f b) ! 64: | FIX(vl,el,b) => FIX(map newvar vl, map f el, f b) ! 65: | APP(a,b) => APP(f a, f b) ! 66: | SELECT(i,a) => SELECT(i, f a) ! 67: | RECORD l => RECORD(map f l) ! 68: | SWITCH(a, l, SOME d) => ! 69: SWITCH(f a, map(fn(c,x)=>(copycon c, f x))l, SOME(f d)) ! 70: | SWITCH(a, l, NONE) => ! 71: SWITCH(f a,map(fn(c,x)=>(copycon c, f x))l,NONE) ! 72: | HANDLE(a,b) => HANDLE(f a, f b) ! 73: | RAISE x => RAISE(f x) ! 74: | e as INT _ => e ! 75: | e as STRING _ => e ! 76: | e as REAL _ => e ! 77: | e as PRIM _ => e ! 78: in f ! 79: end ! 80: ! 81: val alphaConvert = mapfree VAR ! 82: ! 83: val simple = fn VAR _ => true ! 84: | RECORD [] => true ! 85: | INT _ => true ! 86: | STRING s => size s = 1 ! 87: | _ => false ! 88: ! 89: fun all f = not o (exists (not o f)) ! 90: ! 91: val rec pure = ! 92: fn VAR _ => true ! 93: | APP(FN(_,a),b) => pure a andalso pure b ! 94: | FIX(vl,el,b) => pure b ! 95: | APP(PRIM P.callcc, FN(_,b)) => pure b ! 96: | APP(PRIM i, z) => Prim.pure i andalso pure z ! 97: | FN _ => true ! 98: | INT _ => true ! 99: | REAL _ => true ! 100: | PRIM _ => true ! 101: | STRING _ => true ! 102: | SELECT(_, x) => pure x ! 103: | RECORD l => all pure l ! 104: | SWITCH(a, l, NONE) => pure a andalso all (pure o #2) l ! 105: | SWITCH(a, l, SOME d) => pure a andalso pure d andalso ! 106: all (pure o #2) l ! 107: | _ => false ! 108: ! 109: exception BadSwitch ! 110: ! 111: fun testint i = fn INTcon j => i=j ! 112: | DATAcon(DATACON{rep=(CONSTANT j),...}) => i=j ! 113: | STRINGcon j => size j = 1 andalso i = ord j ! 114: | DATAcon(DATACON{rep=(TRANSU),...}) => true ! 115: | _ => false ! 116: val testboxed = fn DATAcon(DATACON{rep=(TRANSB),...}) => true ! 117: | DATAcon(DATACON{rep=(TRANSPARENT),...}) => true ! 118: | DATAcon(DATACON{rep=(TAGGED j),...}) => raise BadSwitch ! 119: | DATAcon(DATACON{rep=(VARIABLE j),...}) => raise BadSwitch ! 120: | _ => false ! 121: fun testtag i = fn DATAcon(DATACON{rep=(TRANSB),...}) => true ! 122: | DATAcon(DATACON{rep=(TRANSPARENT),...}) => true ! 123: | DATAcon(DATACON{rep=(TAGGED j),...}) => i=j ! 124: | _ => false ! 125: fun teststring s = fn STRINGcon j => s=j ! 126: | _ => false ! 127: ! 128: fun switch(SWITCH(e,l,d)) = ! 129: let val test = case e ! 130: of INT i => testint i ! 131: | STRING s => if size s = 1 then testint(ord s) ! 132: else teststring s ! 133: | RECORD[_,INT i] => testtag i ! 134: | RECORD [] => testtag 0 ! 135: | RECORD _ => testboxed ! 136: | FN _ => testboxed ! 137: | FIX _ => testboxed ! 138: | REAL _ => testboxed ! 139: | _ => raise BadSwitch ! 140: fun f ((c,x)::r) = if test c then x else f r ! 141: | f [] = case d ! 142: of SOME z => z ! 143: | NONE => ErrorMsg.impossible "no default" ! 144: in f l ! 145: end ! 146: ! 147: fun reduce exp = ! 148: let val clicked = ref false ! 149: fun click() = clicked := true ! 150: exception Reducemap ! 151: val t = Intmap.new(32, Reducemap) : lexp Intmap.intmap ! 152: val set = Intmap.add t ! 153: val set = fn x as (v, VAR w) => (sameName(v,w); set x) ! 154: | x => set x ! 155: val unset = Intmap.rem t ! 156: val imap = Intmap.map t ! 157: val s = Intset.new() ! 158: val mark = Intset.add s ! 159: val marked = Intset.mem s ! 160: fun mapvar v = (imap v handle Reducemap => VAR v) ! 161: fun makp [v] = ((case imap v of VAR w => makp[w] ! 162: | _ => (mark v; [v])) ! 163: handle Reducemap => (mark v; [v])) ! 164: | makp (i::p) = i :: makp p ! 165: val rec makcon = ! 166: fn (DATAcon(DATACON{rep=(VARIABLE(PATH p)), ! 167: name,const,typ,sign}), e) => ! 168: (DATAcon(DATACON{rep=(VARIABLE(PATH(makp p))), ! 169: name=name,const=const,typ=typ,sign=sign}), ! 170: mak e) ! 171: | (c,e) => (c, mak e) ! 172: and mak = ! 173: fn FN(v,b as APP(l,VAR w)) => ! 174: if v=w andalso pure l ! 175: then let val body = mak l ! 176: in if marked v then FN(v,mak(APP(body,VAR v))) ! 177: else (click(); body) ! 178: end ! 179: else FN(v, mak b) ! 180: | APP(FN(v, sw as SWITCH(VAR v',l,d)), e) => ! 181: if v=v' then ! 182: let val e' = mak e ! 183: val _ = set(v,e') ! 184: in let val sw' = mak(switch(SWITCH(e',l,d))) ! 185: val _ = unset v ! 186: in if marked v orelse not (pure e') ! 187: then APP(FN(v,sw'),e') else (click(); sw') ! 188: end ! 189: handle BadSwitch => ! 190: let val l' = map makcon l ! 191: val d' = case d of NONE => NONE | SOME a => SOME(mak a) ! 192: val _ = unset v ! 193: in if marked v then APP(FN (v, SWITCH(VAR v, l', d')), e') ! 194: else (click(); SWITCH(e', l', d')) ! 195: end ! 196: end ! 197: else let val arg = mak e ! 198: val body = (set(v, arg); mak sw before unset v) ! 199: in if marked v orelse not(pure arg) ! 200: then APP(FN(v,body),arg) ! 201: else (click(); body) ! 202: end ! 203: | APP(FN(v,e'),e) => ! 204: let val arg = mak e ! 205: val body = (set(v, arg); mak e' before unset v) ! 206: in if marked v orelse not(pure arg) ! 207: then APP(FN(v,body),arg) ! 208: else (click(); body) ! 209: end ! 210: | FIX([],[],b) => (click(); mak b) ! 211: | FIX(vl,el,b) => FIX(vl,map (fn FN(v,e) => FN(v,mak e)) el,mak b) ! 212: | e as VAR v => (let val e' = imap v ! 213: in if simple e' then (click(); mak e') ! 214: else (mark v; e) ! 215: end handle Reducemap => (mark v; e)) ! 216: | e as SELECT(i, VAR v) => ! 217: ((case imap v ! 218: of RECORD l => ! 219: let val e' = nth(l,i) ! 220: in if simple e' then (click(); e') ! 221: else (mark v; e) ! 222: end ! 223: | ew as VAR w => mak(SELECT(i,ew)) ! 224: | _ => (mark v; e)) ! 225: handle Reducemap => (mark v; e)) ! 226: | FN (w,b) => FN(w,mak b) ! 227: | APP (f,a) => APP(mak f, mak a) ! 228: | SWITCH(e,l,d) => ! 229: ((case e ! 230: of VAR v => mak(switch(SWITCH(imap v ! 231: handle Reducemap => raise BadSwitch ! 232: , l, d))) ! 233: | _ => raise BadSwitch ! 234: ) handle BadSwitch => ! 235: let val e' = mak e ! 236: in mak(switch(SWITCH(e', l, d))) ! 237: handle BadSwitch => SWITCH(e', map makcon l, ! 238: case d of NONE => NONE ! 239: | SOME a => SOME(mak a)) ! 240: end) ! 241: | RECORD l => RECORD(map mak l) ! 242: | SELECT (i,e) => SELECT(i,mak e) ! 243: | HANDLE (a,h) => HANDLE(mak a, mak h) ! 244: | RAISE e => RAISE(mak e) ! 245: | e as INT _ => e ! 246: | e as REAL _ => e ! 247: | e as STRING _ => e ! 248: | e as PRIM _ => e ! 249: val exp' = mak exp ! 250: in if !clicked then reduce exp' else exp' ! 251: end ! 252: ! 253: (* minimal hoist function: does not move bindings around, evaluation order ! 254: is unchanged. *) ! 255: fun hoist (FN(v,b)) = FN(v,hoist b) ! 256: | hoist (APP(FN(v,b),f as FN _)) = hoist(FIX([v],[f],b)) ! 257: | hoist (APP(l,r)) = APP(hoist l,hoist r) ! 258: | hoist (FIX(vl,bl,FIX(vs,bs,b))) = hoist(FIX(vl@vs,bl@bs,b)) ! 259: | hoist (FIX(vl,bl,APP(FN(v,b),f as FN _))) = hoist(FIX(v::vl,f::bl,b)) ! 260: | hoist (FIX(vl,bl,b)) = FIX(vl,map hoist bl, hoist b) ! 261: | hoist (SWITCH(e,l,d)) = ! 262: SWITCH(hoist e, map (fn (c,e) => (c, hoist e)) l, ! 263: case d of NONE => NONE ! 264: | SOME a => SOME(hoist a)) ! 265: | hoist (RECORD l) = RECORD(map hoist l) ! 266: | hoist (SELECT (i,e)) = SELECT(i,hoist e) ! 267: | hoist (RAISE e) = RAISE(hoist e) ! 268: | hoist (HANDLE (a,h)) = HANDLE(hoist a, hoist h) ! 269: | hoist x = x ! 270: ! 271: fun freevars e = ! 272: let val t = Intset.new() ! 273: val set = Intset.add t ! 274: val unset = Intset.rem t ! 275: val done = Intset.mem t ! 276: val free : int list ref = ref [] ! 277: val rec mak = ! 278: fn VAR w => if done w then () else (set w; free := w :: !free) ! 279: | FN (w,b) => (set w; mak b; unset w) ! 280: | FIX (vl,el,b) => (app set vl; app mak (b::el); app unset vl) ! 281: | APP (f,a) => (mak f; mak a) ! 282: | SWITCH(e,l,d) => ! 283: (mak e; ! 284: app (fn (DATAcon(DATACON{rep=(VARIABLE(PATH p)),...}),e) => ! 285: (mak(VAR(root p)); mak e) ! 286: | (c,e) => mak e) ! 287: l; ! 288: case d of NONE => () | SOME a => mak a) ! 289: | RECORD l => app mak l ! 290: | SELECT (i,e) => mak e ! 291: | HANDLE (a,h) => (mak a; mak h) ! 292: | RAISE e => mak e ! 293: | INT _ => () ! 294: | REAL _ => () ! 295: | STRING _ => () ! 296: | PRIM _ => () ! 297: in mak e; !free ! 298: end ! 299: ! 300: local val save = (!saveLvarNames before saveLvarNames := true) ! 301: in ! 302: val boot_zero = namedLvar(Symbol.symbol "boot_zero") (* receives unit *) ! 303: val boot_one = namedLvar(Symbol.symbol "boot_one") (* traverses free list *) ! 304: val boot_two = namedLvar(Symbol.symbol "boot_two") (* final bogus arg *) ! 305: ! 306: val (lookLvar, indexerLvar) = ! 307: (saveLvarNames := save; ! 308: (namedLvar(Symbol.symbol "lookup"), ! 309: namedLvar(Symbol.symbol "indexer")) ! 310: ) ! 311: end ! 312: ! 313: fun closestr(lookup: int->string, e:lexp, extras : int list) : lexp = ! 314: let val fv = extras @ freevars e ! 315: val names = map lookup fv ! 316: in if !ErrorMsg.debugging ! 317: then app (fn s => (print s; print " ")) names ! 318: else (); ! 319: FN(dupLvar boot_zero, ! 320: RECORD ! 321: [fold (fn (v,f) => ! 322: let val w = dupLvar boot_one ! 323: in FN(w,APP(FN(v,APP(f,SELECT(1,(VAR w)))), ! 324: SELECT(0,(VAR w)))) ! 325: end) ! 326: fv ! 327: (FN(dupLvar boot_two,e)), ! 328: fold (fn (s,f) => RECORD[STRING s, f]) ! 329: names ! 330: (RECORD [])]) ! 331: end ! 332: ! 333: fun remove(v :: vs: int list, from: int list) = ! 334: let ! 335: fun removeV(x :: xs) = if x=v then xs else x :: removeV xs ! 336: | removeV [] = [] ! 337: in ! 338: remove(vs, removeV from) ! 339: end ! 340: | remove([], from) = from ! 341: ! 342: fun bareCloseTop{lambda, looker, extras, keepFree} = ! 343: let ! 344: val fv = extras @ freevars lambda (* Free vars plus extras *) ! 345: val fv' = remove(keepFree, fv) (* The ones we actually abstract *) ! 346: in ! 347: FN(looker, ! 348: fold (fn (v, f) => APP(FN(v, f), APP(VAR looker, INT v))) ! 349: fv' lambda ! 350: ) ! 351: end ! 352: ! 353: (*** ! 354: val bareCloseTop = ! 355: fn (args as {lambda, looker, extras, keepFree}) => ! 356: (print(implode ["bareCloseTop: looker=", ! 357: Integer.makestring looker, ! 358: ", extras=[ ", ! 359: fold (fn (i, s) => makestring i ^ " " ^ s) extras "]", ! 360: ", keepFree=[ ", ! 361: fold (fn (i, s) => makestring i ^ " " ^ s) keepFree "]", ! 362: ", lambda:\n" ! 363: ] ! 364: ); ! 365: MCprint.printLexp lambda; ! 366: print ".\n"; ! 367: let val resultLamb = bareCloseTop args ! 368: in ! 369: print "bareCloseTop: result:\n"; ! 370: MCprint.printLexp resultLamb; ! 371: print ".\n"; ! 372: resultLamb ! 373: end ! 374: ) ! 375: ***) ! 376: ! 377: fun closetop(e: lexp, extras: int list): lexp = ! 378: bareCloseTop{lambda=e, looker=dupLvar lookLvar, extras=extras, keepFree=[]} ! 379: ! 380: fun closeModDecl(lambda: lexp, slotLvars: lvar list, extras: int list): lexp = ! 381: let ! 382: val looker = dupLvar lookLvar ! 383: val indexer = dupLvar indexerLvar ! 384: val fv = extras @ freevars lambda ! 385: ! 386: fun findLvarSlot(lvar: lvar, this :: rest, n) = ! 387: if lvar = this then SOME n else findLvarSlot(lvar, rest, n+1) ! 388: | findLvarSlot(_, [], _) = NONE ! 389: ! 390: fun liftVar(freevar, lambda) = ! 391: APP(FN(freevar, lambda), ! 392: case findLvarSlot(freevar, slotLvars, 0) ! 393: of SOME slot => APP(VAR indexer, INT slot) ! 394: | NONE => APP(VAR looker, INT freevar) ! 395: ) ! 396: in ! 397: FN(looker, FN(indexer, fold liftVar fv lambda)) ! 398: end ! 399: ! 400: (* free variable analysis *) ! 401: open SortedList ! 402: ! 403: fun free e = ! 404: let val vars : lvar list Intmap.intmap = Intmap.new(32, Freevars) ! 405: val setvars = Intmap.add vars ! 406: val rec freevars = ! 407: fn PRIM _ => [] ! 408: | VAR w => [w] ! 409: | APP(FN(w,b),a) => rem(w,merge(freevars b, freevars a)) ! 410: | APP(f,a) => merge(freevars f, freevars a) ! 411: | FN(w,b) => let val z = rem(w,freevars b) ! 412: in setvars(w,z); z ! 413: end ! 414: | FIX([],_,b) => freevars b ! 415: | FIX(vl as v::_,el,b) => ! 416: let val z' = foldmerge(map (fn FN(v,a) => rem(v,freevars a)) el) ! 417: val uvl = uniq vl ! 418: val z = remove(uvl, z') ! 419: in setvars(v,z); ! 420: merge(remove(uvl, freevars b), z) ! 421: end ! 422: | SWITCH(e,l,d) => ! 423: let fun freevcon(DATAcon(DATACON{rep=(VARIABLE(Access.PATH p)), ! 424: ...})) = [root p] ! 425: | freevcon _ = [] ! 426: val zz = (case d of ! 427: NONE => freevars e ! 428: | SOME x => merge(freevars e, freevars x)) ! 429: in foldmerge(zz::map(fn(c,e')=>merge(freevcon c, freevars e')) l) ! 430: end ! 431: | RECORD l => foldmerge(map freevars l) ! 432: | SELECT(_,e) => freevars e ! 433: | HANDLE(a,h) => merge(freevars a, freevars h) ! 434: | RAISE e => freevars e ! 435: | INT _ => [] ! 436: | REAL _ => [] ! 437: | STRING _ => [] ! 438: in freevars e; ! 439: Intmap.map vars ! 440: end ! 441: ! 442: fun mix0free e = ! 443: let val vars : (lvar list * lvar list) Intmap.intmap = Intmap.new(32, Freevars) ! 444: val setvars = Intmap.add vars ! 445: val rec freevars = ! 446: fn PRIM _ => ([],[]) ! 447: | VAR w => let val f = [w] in (f,f) end ! 448: | APP(FN(w,b),e as FN(_,_)) => ! 449: let val (fe,_) = freevars e ! 450: val (fb,cb) = freevars b ! 451: in (merge(rem(w,fb),fe),rem(w,cb)) ! 452: end ! 453: | APP(FN(w,b),a) => ! 454: let val (fa,ca) = freevars a ! 455: val (fb,cb) = freevars b ! 456: in (merge(rem(w,fb),fa),merge(rem(w,cb),ca)) ! 457: end ! 458: | APP(f,a) => ! 459: let val (fa,ca) = freevars a ! 460: val (ff,cf) = freevars f ! 461: in (merge(ff,fa),merge(cf,ca)) ! 462: end ! 463: | FN(v,b) => ! 464: let val (f,c) = freevars b ! 465: val fr = (rem(v,f),rem(v,c)) ! 466: in setvars(v,fr); fr ! 467: end ! 468: | FIX([],_,b) => freevars b ! 469: | FIX(vl as v::_,el,b) => ! 470: let val fr as (f,_) = ! 471: fold (fn (x,(f,c)) => (rem(x,f),rem(x,c))) ! 472: vl ! 473: (fold (fn(FN(v,a),(f',c')) => ! 474: let val (f,c) = freevars a ! 475: in (merge(rem(v,f),f'), ! 476: merge(rem(v,c),c')) ! 477: end) ! 478: el ([],[])) ! 479: val (fb,cb) = freevars b ! 480: val uvl = uniq vl ! 481: in setvars(v,fr); (merge(remove(uvl,fb),f),remove(uvl,cb)) ! 482: end ! 483: | SWITCH(e,l,d) => ! 484: let fun freevcon(DATAcon(DATACON{rep=(VARIABLE(Access.PATH p)), ! 485: ...})) = [root p] ! 486: | freevcon _ = [] ! 487: in fold (fn ((con,e'),(f,c)) => ! 488: let val (f',c') = freevars e' ! 489: in (merge(merge(freevcon con, f'),f), ! 490: merge(merge(freevcon con,c'),c)) ! 491: end) ! 492: l ! 493: (let val (fe,ce) = freevars e ! 494: val (fd,cd) = case d of SOME x => freevars x ! 495: | NONE => ([],[]) ! 496: in (merge(fe,fd),merge(ce,cd)) ! 497: end) ! 498: end ! 499: | RECORD l => fold (fn (a,(f,c)) => ! 500: let val (f',c') = freevars a ! 501: in (merge(f,f'),merge(c,c')) ! 502: end) ! 503: l ([],[]) ! 504: | SELECT(_,e) => freevars e ! 505: | HANDLE(a,h) => ! 506: let val (fa,ca) = freevars a ! 507: val (fh,ch) = freevars h ! 508: in (merge(fa,fh),merge(ca,ch)) ! 509: end ! 510: | RAISE e => freevars e ! 511: | INT _ => ([],[]) ! 512: | REAL _ => ([],[]) ! 513: | STRING _ => ([],[]) ! 514: in freevars e; ! 515: Intmap.map vars ! 516: end ! 517: ! 518: ! 519: end (* structure Opt *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.