![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to convert.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 convert.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / cps |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: (* notes: ! 3: OFFSET should not be generated by this module ! 4: RECORD fields should contain only empty paths (pure variables) ! 5: *) ! 6: ! 7: (* xgrep '[^a-z]n[^a-z]' cps/convert.sml *) ! 8: structure Convert = ! 9: struct ! 10: ! 11: open CPS Access ! 12: fun sublist test = ! 13: let fun subl(a::r) = if test a then a::(subl r) else subl r ! 14: | subl x = x ! 15: in subl ! 16: end ! 17: ! 18: local open Lambda Basics ! 19: in ! 20: fun translatepath [v] = VAR v ! 21: | translatepath (x::p) = SELECT(x,translatepath p) ! 22: | translatepath nil = ErrorMsg.impossible "convert.translatepath nil" ! 23: ! 24: fun isboxedRep(CONSTANT _) = false ! 25: | isboxedRep(TRANSU) = false ! 26: | isboxedRep(_) = true ! 27: ! 28: fun isboxed (DATAcon(DATACON{rep,...})) = isboxedRep(rep) ! 29: | isboxed (REALcon _) = true ! 30: | isboxed (STRINGcon s) = (size s <> 1) ! 31: | isboxed _ = false ! 32: end ! 33: ! 34: fun mk f = f (mkLvar()) ! 35: ! 36: val sortcases = Sort.sort (fn ((i:int,_),(j,_)) => i>j) ! 37: ! 38: val calling = ! 39: fn P.boxed => (1,0,2) ! 40: | P.< => (2,0,2) ! 41: | P.<= => (2,0,2) ! 42: | P.> => (2,0,2) ! 43: | P.>= => (2,0,2) ! 44: | P.ieql => (2,0,2) ! 45: | P.ineq => (2,0,2) ! 46: | P.feql => (2,0,2) ! 47: | P.fge => (2,0,2) ! 48: | P.fgt => (2,0,2) ! 49: | P.fle => (2,0,2) ! 50: | P.flt => (2,0,2) ! 51: | P.fneq => (2,0,2) ! 52: | P.gethdlr => (0,1,1) ! 53: | P.* => (2,1,1) ! 54: | P.+ => (2,1,1) ! 55: | P.- => (2,1,1) ! 56: | P.div => (2,1,1) ! 57: | P.orb => (2,1,1) ! 58: | P.andb => (2,1,1) ! 59: | P.xorb => (2,1,1) ! 60: | P.rshift => (2,1,1) ! 61: | P.lshift => (2,1,1) ! 62: | P.fadd => (2,1,1) ! 63: | P.fdiv => (2,1,1) ! 64: | P.fmul => (2,1,1) ! 65: | P.fsub => (2,1,1) ! 66: | P.subscript => (2,1,1) ! 67: | P.ordof => (2,1,1) ! 68: | P.! => (1,1,1) ! 69: | P.alength => (1,1,1) ! 70: | P.fneg => (1,1,1) ! 71: | P.makeref => (1,1,1) ! 72: | P.delay => (2,1,1) ! 73: | P.slength => (1,1,1) ! 74: | P.~ => (1,1,1) ! 75: | P.notb => (1,1,1) ! 76: | P.sethdlr => (1,0,1) ! 77: | P.:= => (2,0,1) ! 78: | P.unboxedassign => (2,0,1) ! 79: | P.store => (3,0,1) ! 80: | P.unboxedupdate => (3,0,1) ! 81: | P.update => (3,0,1) ! 82: | _ => ErrorMsg.impossible "calling with bad primop" ! 83: ! 84: fun nthcdr(l, 0) = l ! 85: | nthcdr(a::r, n) = nthcdr(r, n-1) ! 86: | nthcdr _ = ErrorMsg.impossible "nthcdr in convert" ! 87: ! 88: fun count test = ! 89: let fun subl acc (a::r) = subl(if test a then 1+acc else acc) r ! 90: | subl acc nil = acc ! 91: in subl 0 ! 92: end ! 93: ! 94: fun convert lexp = ! 95: let ! 96: local open Intmap ! 97: val m : const intmap = new(32, Ctable) ! 98: val enter = add m ! 99: in fun bindconst(c,cont) = mk(fn v => (enter(v,c); cont v)) ! 100: val ctable = m ! 101: end ! 102: ! 103: local open Intmap ! 104: exception Rename ! 105: val m : lvar intmap = new(32, Rename) ! 106: val rename = map m ! 107: in fun ren v = rename v handle Rename => v ! 108: val newname = add m ! 109: end ! 110: ! 111: fun switch1(e : lvar, cases : (int*cexp) list, d : lvar, (lo,hi)) = ! 112: let val delta = 2 ! 113: fun collapse (l as (li,ui,ni,xi)::(lj,uj,nj,xj)::r ) = ! 114: if ((ni+nj) * delta > ui-lj) ! 115: then collapse((lj,ui,ni+nj,xj)::r) ! 116: else l ! 117: | collapse l = l ! 118: fun f (z, x as (i,_)::r) = f(collapse((i,i,1,x)::z), r) ! 119: | f (z, nil) = z ! 120: fun tackon (stuff as (l,u,n,x)::r) = ! 121: if n*delta > u-l andalso n>4 andalso hi>u ! 122: then tackon((l,u+1,n+1,x@[(u+1,APP(d,nil))])::r) ! 123: else stuff ! 124: fun separate((z as (l,u,n,x))::r) = ! 125: if n<4 andalso n>1 ! 126: then let val ix as (i,_) = nth(x, (n-1)) ! 127: in (i,i,1,[ix])::separate((l,l,n-1,x)::r) ! 128: end ! 129: else z :: separate r ! 130: | separate nil = nil ! 131: val chunks = rev (separate (tackon (f (nil,cases)))) ! 132: fun g(1,(l,h,1,(i,b)::_)::_,(lo,hi)) = ! 133: if lo=i andalso hi=i then b ! 134: else bindconst(INTconst i, fn i' => ! 135: PRIMOP(P.ineq,[e, i'], nil, [APP(d,nil), b])) ! 136: | g(1,(l,h,n,x)::_,(lo,hi)) = ! 137: let fun f(0,_,_) = nil ! 138: | f(n,i,l as (j,b)::r) = ! 139: if i+lo = j then b::f(n-1,i+1,r) ! 140: else (APP(d,nil))::f(n,i+1,l) ! 141: val list = f(n,0,x) ! 142: val body = if lo=0 then SWITCH(e,list) ! 143: else bindconst(INTconst lo, fn lo' => ! 144: mk(fn e' => ! 145: PRIMOP(P.-,[e, lo'], [e'], ! 146: [SWITCH(e', list)]))) ! 147: val a = if (lo<l) ! 148: then bindconst(INTconst l, fn l' => ! 149: PRIMOP(P.<,[e, l'], nil, [APP(d,nil), body])) ! 150: else body ! 151: val b = if (hi > h) ! 152: then bindconst(INTconst h, fn h' => ! 153: PRIMOP(P.>,[e, h'], nil, [APP(d,nil), a])) ! 154: else a ! 155: in b ! 156: end ! 157: | g(n,cases,(lo,hi)) = ! 158: let val n2 = n div 2 ! 159: val c2 as (l,_,_,_)::r = nthcdr(cases, n2) ! 160: in bindconst(INTconst l, fn l' => ! 161: PRIMOP(P.<,[e,l'],nil, [g(n2,cases,(lo,l-1)), ! 162: g(n-n2,c2,(l,hi))])) ! 163: end ! 164: in g (length chunks, chunks, (lo, hi)) ! 165: end ! 166: ! 167: fun switch(e, l, d, inrange) = ! 168: let val len = List.length l ! 169: val d' = case d of SOME d' => d' | NONE => mkLvar() ! 170: fun ifelse nil = APP(d',nil) ! 171: | ifelse ((i,b)::r) = ! 172: bindconst(INTconst i, fn v => ! 173: PRIMOP(P.ineq,[v, e], nil, [ifelse r, b])) ! 174: fun ifelseN [(i,b)] = b ! 175: | ifelseN ((i,b)::r) = ! 176: bindconst(INTconst i, fn v => ! 177: PRIMOP(P.ineq,[v, e], nil, [ifelseN r, b])) ! 178: | ifelseN _ = ErrorMsg.impossible "convert.224" ! 179: val l = sortcases l ! 180: in case (len<4, inrange) ! 181: of (true, NONE) => ifelse l ! 182: | (true, SOME n) => if n+1=len then ifelseN l else ifelse l ! 183: | (false, NONE) => ! 184: let fun last [x] = x | last (_::r) = last r ! 185: val (hi,_) = last l and (low,_)::r = l ! 186: in bindconst(INTconst low, fn low' => ! 187: bindconst(INTconst hi, fn hi' => ! 188: PRIMOP(P.>,[low', e], nil, [APP(d',[]), ! 189: PRIMOP(P.<,[hi', e], nil, [APP(d',[]), ! 190: switch1(e, l, d', (low,hi))])]))) ! 191: end ! 192: | (false, SOME n) => switch1(e, l, d', (0,n)) ! 193: end ! 194: ! 195: val zero = bindconst(INTconst 0, fn x => x) ! 196: val one = bindconst(INTconst 1, fn x => x) ! 197: val neg1 = bindconst(INTconst ~1, fn x => x) ! 198: val unevaled = bindconst(INTconst (System.Tags.tag_suspension div 2), fn x => x) ! 199: val evaled = bindconst(INTconst((System.Tags.tag_suspension ! 200: +System.Tags.power_tags)div 2), fn x => x) ! 201: ! 202: fun convlist (el,c) = ! 203: let fun f(le::r, vl) = conv(le, fn v => f(r,v::vl)) ! 204: | f(nil, vl) = c (rev vl) ! 205: in f (el,nil) ! 206: end ! 207: ! 208: and getargs(1,a,g) = conv(a, fn z => g[z]) ! 209: | getargs(n,Lambda.RECORD l,g) = convlist(l,g) ! 210: | getargs(n, a, g) = conv(a, fn v => ! 211: let fun f (j,wl) = if j=n ! 212: then g(rev wl) ! 213: else mk(fn w => SELECT(j,v,w,f(j+1,w::wl))) ! 214: in f(0,nil) ! 215: end) ! 216: ! 217: and conv (le, c) = ! 218: case le of ! 219: Lambda.APP(Lambda.PRIM P.callcc, f) => ! 220: let val k = mkLvar() and k' = mkLvar() and k'' = mkLvar() ! 221: and x = mkLvar() and y = mkLvar() and h = mkLvar() ! 222: in FIX([(k,[x],c x)], ! 223: PRIMOP(P.gethdlr,[],[h], ! 224: [FIX([(k',[y,k''],PRIMOP(P.sethdlr,[h],[],[APP(k,[y])]))], ! 225: conv(f, fn vf => APP(vf,[k',k])))])) ! 226: end ! 227: | Lambda.APP(Lambda.PRIM P.throw, k) => conv(k,c) ! 228: | Lambda.APP(Lambda.PRIM P.cast, k) => conv(k,c) ! 229: | Lambda.APP(Lambda.PRIM P.force, k) => ! 230: let val c0=mkLvar() and c0v=mkLvar() and w=mkLvar() and x=mkLvar() ! 231: and y=mkLvar() and c1=mkLvar() and c1v=mkLvar() ! 232: in conv(k, fn v => ! 233: FIX([(c0,[c0v],c c0v)], ! 234: PRIMOP(P.boxed,[v],[],[PRIMOP(P.subscript,[v,neg1],[w],[ ! 235: PRIMOP(P.ieql,[w,evaled],[],[PRIMOP(P.!,[v],[x],[APP(c0,[x])]), ! 236: PRIMOP(P.ineq,[w,unevaled],[],[APP(c0,[v]), ! 237: FIX([(c1,[c1v], ! 238: PRIMOP(P.:=,[v,c1v],[],[ ! 239: PRIMOP(P.update,[v,neg1,evaled],[],[ ! 240: APP(c0,[c1v])])]))], ! 241: PRIMOP(P.!,[v],[y],[APP(y,[zero,c1])]))])])]), ! 242: APP(c0,[v])]))) ! 243: end ! 244: | Lambda.APP(Lambda.PRIM i, a) => ! 245: (case calling i of ! 246: (n,1,1) => getargs(n,a,fn vl => mk(fn w => PRIMOP(i,vl,[w],[c w]))) ! 247: | (n,0,1) => getargs(n,a,fn vl => PRIMOP(i,vl,[],[c zero])) ! 248: | (n,0,2) => getargs(n,a,fn vl => ! 249: let val cv = mkLvar() and v = mkLvar() ! 250: in FIX([(cv,[v],c v)],PRIMOP(i,vl,[],[APP(cv,[one]),APP(cv,[zero])])) ! 251: end)) ! 252: | Lambda.PRIM i => mk(fn v => conv(Lambda.FN(v,Lambda.APP(le,Lambda.VAR v)),c)) ! 253: | Lambda.VAR v => c (ren v) ! 254: | Lambda.APP(Lambda.FN(v,e),a) => ! 255: conv(a, fn w => (newname(v,w);Access.sameName(v,w); conv(e, c))) ! 256: | Lambda.FN (v,e) => let val f = mkLvar() and w = mkLvar() ! 257: in FIX([(f,[v,w],conv(e, fn z => APP(w,[z])))], c f) ! 258: end ! 259: | Lambda.APP (f,a) => ! 260: let val fc = mkLvar() and x = mkLvar() ! 261: in FIX([(fc,[x],c x)], conv(f,fn vf => conv(a,fn va => APP(vf,[va,fc])))) ! 262: end ! 263: | Lambda.FIX (fl, el, body) => ! 264: let fun g(f::fl, Lambda.FN(v,b)::el) = ! 265: mk(fn w => (f,[v,w], conv(b, fn z => APP(w,[z])))) :: g(fl,el) ! 266: | g(nil,nil) = nil ! 267: in FIX(g(fl,el), conv(body,c)) ! 268: end ! 269: | Lambda.INT i => ! 270: ((i+i; bindconst(INTconst i, c)) ! 271: handle Overflow => ! 272: let open Lambda ! 273: in conv(APP(PRIM P.+, RECORD[INT(i div 2), INT(i - i div 2)]),c) ! 274: end) ! 275: | Lambda.REAL i => bindconst(REALconst i, c) ! 276: | Lambda.STRING i => (case size i ! 277: of 1 => bindconst(INTconst(ord i),c) ! 278: | _ => bindconst(STRINGconst i, c)) ! 279: | Lambda.RECORD nil => c zero ! 280: | Lambda.RECORD l => convlist(l,fn vl => mk(fn x => RECORD(recordpath vl,x,c x))) ! 281: | Lambda.SELECT(i, e) => mk(fn w => conv(e, fn v => SELECT(i, v, w, c w))) ! 282: | Lambda.SWITCH(e,l as (Lambda.DATAcon(Basics.DATACON{ ! 283: rep=Basics.VARIABLE _,...}), _)::_, SOME d) => ! 284: let val cf = mkLvar() and vf = mkLvar() ! 285: in FIX([(cf, [vf], c vf)], ! 286: conv(Lambda.SELECT(1,e), fn w => ! 287: let fun g((Lambda.DATAcon(Basics.DATACON{ ! 288: rep=Basics.VARIABLE(Access.PATH p),const=true,...}), x)::r) = ! 289: conv(translatepath(1::p), fn v => ! 290: PRIMOP(P.ineq, [w,v], [], [g r, conv(x, fn z => APP(cf,[z]))])) ! 291: | g((Lambda.DATAcon(Basics.DATACON{ ! 292: rep=Basics.VARIABLE(Access.PATH p),...}), x)::r) = ! 293: conv(translatepath p, fn v => ! 294: PRIMOP(P.ineq, [w,v], [], [g r, conv(x, fn z => APP(cf,[z]))])) ! 295: | g nil = conv(d, fn z => APP(cf,[z])) ! 296: | g _ = ErrorMsg.impossible "convert.21" ! 297: in g l ! 298: end)) ! 299: end ! 300: | Lambda.SWITCH(e,l as (Lambda.REALcon _, _)::_, SOME d) => ! 301: let val cf = mkLvar() and vf = mkLvar() ! 302: in FIX([(cf, [vf], c vf)], ! 303: conv(e, fn w => ! 304: let fun g((Lambda.REALcon rval, x)::r) = ! 305: bindconst(REALconst rval, fn v => ! 306: PRIMOP(P.fneq, [w,v],[], [g r, conv(x,fn z => APP(cf,[z]))])) ! 307: | g nil = conv(d, fn z => APP(cf,[z])) ! 308: | g _ = ErrorMsg.impossible "convert.81" ! 309: in g l ! 310: end)) ! 311: end ! 312: | Lambda.SWITCH(e,l as (Lambda.INTcon _, _)::_, SOME d) => ! 313: let val cf = mkLvar() and vf = mkLvar() and df = mkLvar() ! 314: in FIX([(cf, [vf], c vf), (df, [], conv(d, fn z => APP(cf,[z])))], ! 315: conv(e, fn w => ! 316: let fun g (Lambda.INTcon j, a) = (j,conv(a, fn z => APP(cf,[z]))) ! 317: in switch(w, map g l, SOME df, NONE) ! 318: end)) ! 319: end ! 320: | Lambda.SWITCH(e,l as (Lambda.STRINGcon _, _)::_, SOME d) => ! 321: let val cf = mkLvar() and vf = mkLvar() and df = mkLvar() and vd = mkLvar() ! 322: val cont = fn z => APP(cf,[z]) ! 323: fun isboxed (Lambda.STRINGcon s, _) = size s <> 1 ! 324: val b = sublist isboxed l ! 325: val u = sublist (not o isboxed) l ! 326: fun g(Lambda.STRINGcon j, e) = (ord j, conv(e,cont)) ! 327: val z = map g u ! 328: val [p1,p2] = !CoreInfo.stringequalPath ! 329: in FIX([(cf, [vf], c vf), (df, [], conv(d, cont))], ! 330: conv(e, fn w => ! 331: let val genu = switch(w, z, SOME df, NONE) ! 332: fun genb [] = APP(df,[]) ! 333: | genb cases = ! 334: let val len1 = mkLvar() ! 335: fun g((Lambda.STRINGcon s, x)::r) = ! 336: let val ssize = size s ! 337: val k = mkLvar() and seq = mkLvar() and pair = mkLvar() ! 338: and c2 = mkLvar() and ans = mkLvar() ! 339: in FIX((k,[], g r):: ! 340: if ssize=0 then [] ! 341: else [(c2,[ans],PRIMOP(P.ieql,[ans,zero],[], ! 342: [APP(k,[]), conv(x,cont)]))], ! 343: bindconst(STRINGconst s, fn v => ! 344: bindconst(INTconst ssize, fn len0 => ! 345: bindconst(INTconst((ssize + 3) div 4 - 1), fn len0' => ! 346: PRIMOP(P.ineq,[len0,len1],[], ! 347: [APP(k,[]), ! 348: if ssize=0 then conv(x,cont) ! 349: else SELECT(p1,ren p2,seq, ! 350: RECORD([(w,OFFp 0),(v,OFFp 0)], ! 351: pair, APP(seq,[pair,c2])))]))))) ! 352: end ! 353: | g nil = APP(df, []) ! 354: in PRIMOP(P.slength,[w],[len1], [g cases]) ! 355: end ! 356: in PRIMOP(P.boxed,[w],[],[genb b, genu]) ! 357: end)) ! 358: end ! 359: | Lambda.SWITCH ! 360: (x as (Lambda.APP(Lambda.PRIM i, args), ! 361: [(Lambda.DATAcon(Basics.DATACON{rep=(Basics.CONSTANT c1),...}),e1), ! 362: (Lambda.DATAcon(Basics.DATACON{rep=(Basics.CONSTANT c2),...}),e2)], ! 363: NONE)) => ! 364: let fun g(n,a,b) = ! 365: let val cf = mkLvar() and v = mkLvar() ! 366: val cont = (fn w => APP(cf,[w])) ! 367: in FIX([(cf,[v],c v)], ! 368: getargs(n,args,fn vl => PRIMOP(i,vl,[],[conv(a,cont),conv(b,cont)]))) ! 369: end ! 370: in case (calling i, c1, c2) of ! 371: ((n,0,2), 1, 0) => g(n,e1,e2) ! 372: | ((n,0,2), 0, 1) => g(n,e2,e1) ! 373: | _ => genswitch(x,c) ! 374: end ! 375: | Lambda.SWITCH x => genswitch(x,c) ! 376: | Lambda.RAISE(e) => ! 377: conv(e,fn w => mk(fn h => PRIMOP(P.gethdlr,[],[h],[APP(h,[w])]))) ! 378: | Lambda.HANDLE(a,b) => ! 379: let val h = mkLvar() and vb = mkLvar() and vc = mkLvar() ! 380: and x = mkLvar() and v = mkLvar () ! 381: in FIX([(vc,[x],c x)], ! 382: PRIMOP(P.gethdlr,[],[h], ! 383: [FIX([(vb,[v],PRIMOP(P.sethdlr,[h],[],[conv(b,fn f => APP(f,[v,vc]))]))], ! 384: PRIMOP(P.sethdlr,[vb],[], ! 385: [conv(a, fn va => PRIMOP(P.sethdlr,[h],[], [APP(vc,[va])]))]))])) ! 386: end ! 387: ! 388: and genswitch ((e, l as (Lambda.DATAcon(Basics.DATACON{sign,...}),_)::_, d),c) = ! 389: let val cf = mkLvar() and cv = mkLvar() and df = mkLvar() ! 390: val cont = fn z => APP(cf,[z]) ! 391: val boxed = sublist (isboxed o #1) l ! 392: val unboxed = sublist (not o isboxed o #1) l ! 393: val w = mkLvar() and t = mkLvar() ! 394: fun tag (Lambda.DATAcon(Basics.DATACON{rep=Basics.CONSTANT i,...}), e) = ! 395: (i, conv(e,cont)) ! 396: | tag (Lambda.DATAcon(Basics.DATACON{rep=Basics.TAGGED i,...}), e) = ! 397: (i, conv(e,cont)) ! 398: | tag (c,e) = (0, conv(e,cont)) ! 399: in FIX((cf,[cv],c cv) :: ! 400: case d of NONE => [] | SOME d' => [(df,[],conv(d',cont))], ! 401: conv(e, fn w => ! 402: case (count isboxedRep sign, count (not o isboxedRep) sign) ! 403: of (0, n) => switch(w, map tag l, SOME df, SOME(n-1)) ! 404: | (n, 0) => SELECT(1, w, t, switch(t, map tag l, SOME df, SOME(n-1))) ! 405: | (1, nu) => ! 406: PRIMOP(P.boxed, [w], [], ! 407: [switch(zero, map tag boxed, SOME df, SOME 0), ! 408: switch(w, map tag unboxed, SOME df, SOME(nu-1))]) ! 409: | (nb,nu) => ! 410: PRIMOP(P.boxed, [w], [], ! 411: [SELECT(1,w,t, switch(t, map tag boxed, SOME df, SOME(nb-1))), ! 412: switch(w, map tag unboxed, SOME df, SOME(nu-1))]))) ! 413: end ! 414: val v = mkLvar() and x = mkLvar() and f = mkLvar() ! 415: in ((f, [v,x], conv(lexp, fn w => APP(w,[v,x]))), ctable) ! 416: end ! 417: ! 418: end ! 419:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.