![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to generic.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 generic.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / cps |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: functor CPSgen(M: CMACHINE) : ! 3: sig structure CPS : CPS ! 4: val codegen : (((CPS.lvar * CPS.lvar list * CPS.cexp) * bool) list ! 5: * (CPS.lvar -> CPS.const) ! 6: * (CPS.lvar -> bool)) ! 7: -> unit ! 8: end = ! 9: struct ! 10: ! 11: structure CPS = CPS ! 12: open CPS M System.Tags Access ! 13: ! 14: datatype frag = STANDARD of (lvar * lvar list * cexp) option ref ! 15: | KNOWN of (lvar list * cexp) * EA list option ref ! 16: | CONSTfrag of const ! 17: ! 18: val standardformals2 = [standardcont, standardarg] ! 19: val standardformals3 = [standardclosure,standardarg,standardcont] ! 20: val notastandardformal::_ = miscregs ! 21: val any = notastandardformal ! 22: ! 23: fun isreg' r = case isreg r of NONE => false | _ => true ! 24: ! 25: val maxConceivableRegs = 50 ! 26: val knowngen = System.Control.CG.knowngen ! 27: val stdgen = System.Control.CG.stdgen ! 28: ! 29: local ! 30: val allregs = standardformals3 @ miscregs ! 31: val num2reg = array(maxConceivableRegs, hd allregs) ! 32: val _ = app (fn r => case isreg r of SOME i => update(num2reg,i,r)) allregs ! 33: val allregs' = map (fn r => case isreg r of SOME i => i) allregs ! 34: val okreg = array(maxConceivableRegs, false) ! 35: fun mark b = (fn r => case isreg r of (SOME i) => update(okreg,i,b) | _ => ()) ! 36: val _ = app (mark true) allregs ! 37: ! 38: in ! 39: exception Getscratch ! 40: fun getscratch(preferred, prohibited) = ! 41: let fun f(x::a) = if okreg sub x then num2reg sub x else f a ! 42: | f nil = raise Getscratch ! 43: in app (mark false) prohibited; ! 44: (case isreg preferred ! 45: of SOME i => (if okreg sub i then preferred else f allregs') ! 46: | _ => f allregs') ! 47: before app (mark true) prohibited ! 48: handle e => (app (mark true) prohibited; raise e) ! 49: end ! 50: end ! 51: ! 52: fun split pred nil = (nil,nil) ! 53: | split pred (a::r) = let val (x,y) = split pred r ! 54: in if pred a then (a::x, y) else (x, a::y) ! 55: end ! 56: ! 57: fun codegen(funs : ((lvar * lvar list * cexp) * bool) list, ! 58: ctable : lvar -> const, isconstant : lvar -> bool) = ! 59: (* isconstant means either constant or label *) ! 60: let ! 61: exception Regbind ! 62: val regbindtable : EA Intmap.intmap = Intmap.new(32, Regbind) ! 63: val addbinding = Intmap.add regbindtable ! 64: ! 65: exception Know ! 66: val knowtable : frag Intmap.intmap = Intmap.new(32, Know) ! 67: val addknow = Intmap.add knowtable ! 68: val know = Intmap.map knowtable ! 69: ! 70: exception Freemap ! 71: val freemaptable : lvar list Intmap.intmap = Intmap.new(32, Freemap) ! 72: val freemap = Intmap.map freemaptable ! 73: ! 74: fun makefrag ((f,vl,e),known) = ! 75: (addknow(f, if known then (inc knowngen; KNOWN((vl,e),ref NONE)) ! 76: else (inc stdgen; STANDARD(ref(SOME(f,vl,e))))); ! 77: addbinding(f,newlabel()); ! 78: FreeMap.freemap isconstant (Intmap.add freemaptable) e; ! 79: f) ! 80: ! 81: val frags = ref(map makefrag funs) ! 82: fun addfrag f = frags := f :: !frags ! 83: ! 84: fun regbind v = ! 85: Intmap.map regbindtable v ! 86: handle Regbind => ! 87: (case ctable v of ! 88: INTconst i => (immed(i+i+1) handle Overflow => ! 89: ErrorMsg.impossible "Overflow in cps/generic.sml") ! 90: | f => let val lab = newlabel() ! 91: in addbinding(v,lab); addknow(v, CONSTfrag f); addfrag v; lab ! 92: end) ! 93: ! 94: fun root(RECORD(_,_,e)) = root e ! 95: | root(SELECT(_,_,_,e)) = root e ! 96: | root(OFFSET(_,_,_,e)) = root e ! 97: | root(SWITCH(_,e::_)) = root e ! 98: | root(PRIMOP(_,_,_,e::_)) = root e ! 99: | root(e as APP _) = e ! 100: ! 101: val root1 = ref(APP(0,[])) ! 102: ! 103: fun alloc(v,cexp,default,continue) = ! 104: let val APP(f,wl) = !root1 ! 105: val proh = map regbind (freemap v) ! 106: fun delete (z,nil) = nil ! 107: | delete (z, a::r) = if eqreg a z then r else a::delete(z,r) ! 108: fun get(good,bad) = ! 109: let val r = getscratch(good,bad@proh) ! 110: handle Getscratch => getscratch(default,proh) ! 111: in addbinding(v,r); continue r ! 112: end ! 113: fun find fmls = ! 114: let fun g(w::wl, r::rl) = if w=v then get(r, delete(r,fmls)) ! 115: else g(wl,rl) ! 116: | g(nil,nil) = get(default, fmls) ! 117: | g _ = ErrorMsg.impossible "cps vax 33" ! 118: in g(wl,fmls) ! 119: end ! 120: in if v=f then get(default,standardformals3) ! 121: else ! 122: case (know f handle Know => STANDARD(ref NONE)) ! 123: of KNOWN(_,ref(SOME fmls)) => find fmls ! 124: | KNOWN(_,ref NONE) => get(default,nil) ! 125: | STANDARD _ => case length wl ! 126: of 2 => find standardformals2 ! 127: | 3 => find standardformals3 ! 128: | _ => ErrorMsg.impossible "cps vax 44" ! 129: end ! 130: ! 131: fun shuffle(func, args,formals) = ! 132: let val (fv,used,args,formals) = ! 133: let val fv = regbind func ! 134: in if exists (eqreg fv) formals ! 135: then let val x = getscratch(any, args@formals) ! 136: in move(fv,x); addbinding(func,x); ! 137: (x,[x],args,formals) ! 138: end ! 139: handle Getscratch => ! 140: (addbinding(func,notastandardformal); ! 141: (notastandardformal, nil, fv::args, notastandardformal::formals)) ! 142: else (fv,[fv],args,formals) ! 143: end ! 144: fun mate(a::al, b::bl)= (a,b)::mate(al,bl) ! 145: | mate _ = nil ! 146: val (inreg,notinreg) = split (isreg' o #1) (mate(args,formals)) ! 147: val (matched, notmatched) = split (fn(x,y)=>eqreg x y) inreg ! 148: ! 149: fun f(nil, used) = () ! 150: | f (pairs,used) = ! 151: let val u' = map #1 pairs @ used ! 152: fun movable (a, b) = not (exists (eqreg b) u') ! 153: in case split movable pairs ! 154: of (nil,(a,b)::r) => ! 155: let val x = getscratch(any,u') ! 156: in move(a,x); f((x,b)::r, used) ! 157: end ! 158: | (m,m') => (app move m; f(m', (map #2 m) @ used)) ! 159: end ! 160: in f(notmatched, (map #1 matched) @ used); ! 161: app move notinreg; ! 162: jmp fv ! 163: end ! 164: ! 165: fun allocparams(args,formals) = ! 166: let fun f(already,a::ar,b::br) = ! 167: let val z = getscratch(a, already@ar) ! 168: in addbinding(b,z); ! 169: if eqreg a z then () else move(a,z); ! 170: f(z::already,ar,br) ! 171: end ! 172: | f(l,nil,nil) = rev l ! 173: in f(nil,args,formals) ! 174: end ! 175: ! 176: (* Compute the maximum amount of allocation done by this function (in bytes). *) ! 177: fun sumAlloc exp = let ! 178: fun sum (RECORD (fields, _, exp'), max) = sum (exp', max+(length fields)+1) ! 179: | sum (SELECT (_, _, _, exp'), max) = sum (exp', max) ! 180: | sum (OFFSET (_, _, _, exp'), max) = sum (exp', max) ! 181: | sum (APP _, max) = max ! 182: | sum (SWITCH (_, lst), max) = max + lstMax(lst, 0) ! 183: | sum (PRIMOP (P.makeref, _, _, [exp']), max) = sum (exp', max+2) ! 184: | sum (PRIMOP (P.delay, _, _, [exp']), max) = sum (exp', max+2) ! 185: | sum (PRIMOP (P.update, _, _, [exp']), max) = sum (exp', max+4) ! 186: | sum (PRIMOP (P.:=, _, _, [exp']), max) = sum (exp', max+4) ! 187: | sum (PRIMOP (P.fadd, _, _, [exp']), max) = sum (exp', max+3) ! 188: | sum (PRIMOP (P.fsub, _, _, [exp']), max) = sum (exp', max+3) ! 189: | sum (PRIMOP (P.fmul, _, _, [exp']), max) = sum (exp', max+3) ! 190: | sum (PRIMOP (P.fdiv, _, _, [exp']), max) = sum (exp', max+3) ! 191: | sum (PRIMOP (P.fneg, _, _, [exp']), max) = sum (exp', max+3) ! 192: | sum (PRIMOP (_, _, _, [exp']), max) = sum (exp', max) ! 193: | sum (PRIMOP (_, _, _, lst), max) = max + lstMax(lst, 0) ! 194: and lstMax (nil, max) = max ! 195: |lstMax (e::rest, max) = let val m = sum (e, 0) ! 196: in ! 197: if m > max then lstMax(rest, m) else lstMax(rest, max) ! 198: end ! 199: in ! 200: (sum (exp, 0)) * 4 ! 201: end ! 202: ! 203: fun genfrag f = case (regbind f, know f) ! 204: of (_, STANDARD(ref NONE)) => () ! 205: | (lab, STANDARD(r as ref (SOME(fname,[f,a,c],e)))) => ! 206: (r := NONE; ! 207: List2.app2 addbinding ([f,a,c],standardformals3); ! 208: align(); mark(); ! 209: comment(Access.lvarName fname ^ ":\n"); ! 210: genFun(lab, e, SOME standardclosure)) ! 211: | (lab, STANDARD(r as ref (SOME(fname,[f,a],e)))) => ! 212: (r := NONE; ! 213: List2.app2 addbinding ([f,a],standardformals2); ! 214: align(); mark(); ! 215: comment(Access.lvarName fname ^ ":\n"); ! 216: genFun(lab, e, SOME standardcont)) ! 217: | (_, STANDARD _) => ErrorMsg.impossible "standard with wrong args" ! 218: | (_, KNOWN _) => () ! 219: | (lab, CONSTfrag(REALconst r)) => ! 220: (align(); mark(); emitlong(8 * power_tags + tag_embedded); ! 221: define lab; comment("# real constant " ^ r ^ "\n"); ! 222: realconst r) ! 223: | (lab, CONSTfrag(STRINGconst s)) => ! 224: (align(); mark(); ! 225: emitlong(size s * power_tags + tag_embedded); ! 226: define lab; emitstring s; align()) ! 227: ! 228: (* generate a new code label *) ! 229: and genlab(lab, cexp) = (root1 := root cexp; define lab; gen cexp) ! 230: ! 231: (* generate a new function header *) ! 232: and genFun (lab, cexp, closure) = let ! 233: val maxAllocSz = sumAlloc cexp ! 234: in ! 235: root1 := root cexp; ! 236: define lab; ! 237: if (maxAllocSz > 0) (** Won't support "true" concurrency **) ! 238: then checkLimit (maxAllocSz) else (); ! 239: case closure of SOME reg => beginStdFn(reg, lab) | _ => (); ! 240: gen cexp ! 241: end ! 242: ! 243: and gen cexp = ! 244: case cexp ! 245: of RECORD(vl,w,e) => ! 246: alloc(w, e,any, fn w' => ! 247: (record((immed(16*(length vl)+1),OFFp 0) :: ! 248: map (fn(x,p)=>(regbind x, p)) vl, ! 249: w'); ! 250: gen e)) ! 251: | SELECT(i,v,w,e) => ! 252: alloc(w, e,any, fn w' => (select(i,regbind v,w'); gen e)) ! 253: | OFFSET(i,v,w,e) => ! 254: let val v' = regbind v ! 255: in alloc(w, e,v', fn w' => (offset(i,v',w'); gen e)) ! 256: end ! 257: | APP(f,args) => ! 258: (case (map regbind args, ! 259: know f handle Know => STANDARD(ref NONE)) ! 260: of (args',KNOWN(_,ref(SOME formals))) => ! 261: shuffle(f, args', formals) ! 262: | (args', KNOWN((vl,cexp), r as ref(NONE))) => let ! 263: val lab = newlabel(); ! 264: in ! 265: r := SOME(allocparams(args',vl)); ! 266: (* replace fall-through with a jump to insure a mark ! 267: * at the beginning of every function. ! 268: *) ! 269: jmp lab; align(); mark(); define lab; ! 270: comment(Access.lvarName f ^ ":\n"); ! 271: genFun (regbind f, cexp, NONE) ! 272: end ! 273: | (args' as [_,_], STANDARD (ref NONE)) => ! 274: shuffle(f, args',standardformals2) ! 275: | (args' as [_,_,_], STANDARD (ref NONE)) => ! 276: shuffle(f, args',standardformals3) ! 277: | (args' as [_,_], STANDARD(ref(SOME _))) => ! 278: (shuffle(f, args',standardformals2); genfrag f) ! 279: | (args' as [_,_,_], STANDARD(ref(SOME _))) => ! 280: (shuffle(f, args',standardformals3); genfrag f)) ! 281: | SWITCH(v,l) => ! 282: let val lab = newlabel() ! 283: val labs = map (fn _ => newlabel()) l; ! 284: fun f(i, s::r) = (emitlab(i, s); f(i+4, r)) ! 285: | f(_, nil) = () ! 286: fun h(lab::labs, e::es) = (genlab(lab, e); h(labs,es)) ! 287: | h(nil,nil) = () ! 288: in fetchindexl(lab, arithtemp, regbind v); ! 289: jmpindexb lab; ! 290: (* align(); temporarily removed so 68020 will work. *) ! 291: define lab; ! 292: f (0, labs); ! 293: h(labs,l) ! 294: end ! 295: ! 296: | PRIMOP (i,vl,wl,el) => primops i (vl,wl,el) ! 297: ! 298: (* warning: on three-address instructions, be careful about ! 299: non-pointers in registers. On some machines, ! 300: addl3(a,b,c) is translated to: mov(b,c); add(a,c); ! 301: and it's dangerous when b is a non-pointer. In such a case, ! 302: usually a is "safe", so that addl3(b,a,c) works better. ! 303: The rule is, therefore: if the destination is a pointer register, ! 304: then b must also be a tagged value *) ! 305: ! 306: and arithprof i = () (* profile(Profile.ARITHOVH+i,2) *) ! 307: and compare(branch,test) ([v,w],[],[d,e]) = ! 308: let val lab = newlabel() ! 309: in branch(test,regbind v, regbind w, lab); ! 310: gen d; genlab(lab, e) ! 311: end ! 312: and primops p = ! 313: case p of ! 314: P.+ => (fn ([v,w],[x],[e]) => ! 315: let val v' = regbind v and w' = regbind w ! 316: in case (isimmed v', isimmed w') of ! 317: (SOME k, _) => ! 318: (arithprof 0; alloc(x,e,w', fn x' => addl3t(immed(k-1),w',x'))) ! 319: (* the next case must be done (by all machines) with v and x in ! 320: root registers (for offset computations in "boot") *) ! 321: | (_, SOME k) => ! 322: (arithprof 0; alloc(x,e,v', fn x' => addl3t(immed(k-1),v',x'))) ! 323: | _ => alloc(x,e,w',fn x' => (arithprof 1; ! 324: subl3(immed 1,v',arithtemp); ! 325: addl3t(arithtemp, w', x'))); ! 326: gen e ! 327: end) ! 328: | P.orb => (fn ([v,w],[x],[e]) => ! 329: let val w' = regbind w ! 330: in alloc(x,e,w', fn x' => (orb(regbind v, w', x'); gen e)) ! 331: end) ! 332: | P.andb => (fn ([v,w],[x],[e]) => ! 333: let val w' = regbind w ! 334: in alloc(x,e,w', fn x' => (andb(regbind v, w', x'); gen e)) ! 335: end) ! 336: | P.xorb => (fn ([v,w],[x],[e]) => ! 337: let val v' = regbind v and w' = regbind w ! 338: in alloc(x,e,any,fn x' => (case (isimmed v', isimmed w') of ! 339: (SOME k,_) => xorb(immed(k-1), w', arithtemp) ! 340: | (_,SOME k) => xorb(v', immed(k-1), arithtemp) ! 341: | _ => (xorb(v', w', arithtemp); orb(immed 1, arithtemp, x')); ! 342: gen e)) ! 343: end) ! 344: | P.notb => (fn ([v],[x],[e]) => ! 345: alloc(x,e,regbind v, fn x' => ! 346: (notb(regbind v, x'); ! 347: orb(immed 1, x', x'); ! 348: gen e))) ! 349: | P.lshift => (fn ([v,w],[x],[e]) => ! 350: let val v' = regbind v and w' = regbind w ! 351: in alloc(x,e,any, fn x' => ! 352: (case (isimmed v', isimmed w') of ! 353: (SOME k,_) => ! 354: (ashr(immed 1,w',arithtemp); ashl(arithtemp,immed(k-1), x')) ! 355: | (_,SOME k) => ! 356: (addl3(immed(~1),v',arithtemp); ! 357: ashl(immed(Bits.rshift(k,1)), arithtemp, x')) ! 358: | _ => ! 359: (ashr(immed 1, w',arithtemp); ! 360: addl3(immed(~1),v',arithtemp2); ! 361: ashl(arithtemp, arithtemp2, x')); ! 362: orb(immed 1, x', x'); ! 363: gen e)) ! 364: end) ! 365: | P.rshift => (fn ([v,w],[x],[e]) => ! 366: let val v' = regbind v and w' = regbind w ! 367: in alloc(x,e,v', fn x' => ! 368: (case isimmed w' of ! 369: SOME k => ashr(immed(Bits.rshift(k,1)), v', x') ! 370: | _ => (ashr(immed 1, w',arithtemp); ashr(arithtemp, v', x')); ! 371: orb(immed 1, x', x'); ! 372: gen e)) ! 373: end) ! 374: | P.- => (fn ([v,w],[x],[e]) => ! 375: let val v' = regbind v and w' = regbind w ! 376: in case (isimmed v', isimmed w') of ! 377: (SOME k, _) => (arithprof 0; alloc(x,e,w', fn x' => ! 378: subl3t(w', immed(k+1), x'))) ! 379: | (_, SOME k) => (arithprof 0; alloc(x,e,v', fn x' => ! 380: subl3t(immed(k-1),v',x'))) ! 381: | _ => alloc(x, e,v',fn x' => (arithprof 1; ! 382: subl3(immed 1,w',arithtemp); ! 383: subl3t(arithtemp, v', x'))); ! 384: gen e ! 385: end) ! 386: | P.* => (fn ([v,w],[x],[e]) => ! 387: let val v' = regbind v and w' = regbind w ! 388: in alloc(x,e,any,fn x' => ! 389: (arithprof 3; ! 390: case (isimmed v', isimmed w') of ! 391: (SOME k,_) => (ashr(immed 1, w', arithtemp); ! 392: mull2t(immed(k-1),arithtemp)) ! 393: | (_,SOME k) => (ashr(immed 1, v', arithtemp); ! 394: mull2t(immed(k-1),arithtemp)) ! 395: | _ => (ashr(immed 1, v', arithtemp); ! 396: subl3(immed 1, w', arithtemp2); ! 397: mull2t(arithtemp2,arithtemp)); ! 398: orb(immed 1,arithtemp,x'); ! 399: gen e)) ! 400: end) ! 401: | P.div => (fn ([v,w],[x],[e]) => ! 402: let val v' = regbind v and w' = regbind w ! 403: in alloc(x, e,any, fn x' => ! 404: (arithprof 4; ! 405: case (isimmed v', isimmed w') of ! 406: (SOME k,_) => ! 407: (move(immed(Bits.rshift(k,1)),arithtemp); ! 408: ashr(immed 1, w', arithtemp2); ! 409: divl2(arithtemp2,arithtemp)) ! 410: | (_,SOME k) => ! 411: (ashr(immed 1, v', arithtemp); ! 412: divl2(immed(Bits.rshift(k,1)),arithtemp)) ! 413: | _ => ! 414: (ashr(immed 1, v', arithtemp); ! 415: ashr(immed 1, w', arithtemp2); ! 416: divl2(arithtemp2,arithtemp)); ! 417: addl3(arithtemp, arithtemp, arithtemp); ! 418: orb(immed 1, arithtemp,x'); ! 419: gen e)) ! 420: end) ! 421: | P.! => (fn ([v],[w],[e]) => gen(SELECT(0,v,w,e))) ! 422: | P.:= => (fn ([v,w],[],[e]) => ! 423: let val v' = regbind v ! 424: in record([(immed(16*3+1),OFFp 0), (v', OFFp 0), ! 425: (immed 1, OFFp 0), (storeptr, OFFp 0)], storeptr); ! 426: storeindexl(regbind w, v', immed 1); ! 427: gen e ! 428: end) ! 429: | P.unboxedassign => (fn ([v,w],[],[e]) => ! 430: (storeindexl(regbind w, regbind v, immed 1); gen e)) ! 431: | P.~ => (fn ([v],[w],[e]) => ! 432: alloc(w,e,any,fn w' => (arithprof 0;subl3t(regbind v,immed 2,w');gen e))) ! 433: | P.makeref => ! 434: (fn ([v],[w],[e]) => ! 435: alloc(w, e,any, fn w' => ! 436: (if !CGoptions.profile then profile(Profile.REFCELLS,2) else (); ! 437: record([(immed(power_tags+tag_array),OFFp 0), ! 438: (regbind v, OFFp 0)], w'); ! 439: gen e))) ! 440: | P.delay => ! 441: (fn ([i,v],[w],[e]) => ! 442: alloc(w, e,any, fn w' => ! 443: (if !CGoptions.profile then profile(Profile.REFCELLS,2) else (); ! 444: record([(regbind i, OFFp 0),(regbind v, OFFp 0)], w'); ! 445: gen e))) ! 446: | P.ieql => compare(ibranch,NEQ) ! 447: | P.ineq => compare(ibranch,EQL) ! 448: | P.> => compare(ibranch,LEQ) ! 449: | P.>= => compare(ibranch,LSS) ! 450: | P.< => compare(ibranch,GEQ) ! 451: | P.<= => compare(ibranch,GTR) ! 452: | P.subscript => (fn ([v,w],[x],[e]) => ! 453: alloc(x, e,any, fn x' => ! 454: (arithprof 1; ! 455: fetchindexl(regbind v, x', regbind w); ! 456: gen e))) ! 457: | P.update => (fn ([a, i, v], [], [e]) => ! 458: let val a' = regbind a and i' = regbind i ! 459: in arithprof 1; ! 460: record([(immed(16*3+1),OFFp 0), (a',OFFp 0), ! 461: (i', OFFp 0), (storeptr, OFFp 0)], storeptr); ! 462: storeindexl(regbind v, a', i'); ! 463: gen e ! 464: end) ! 465: | P.unboxedupdate => (fn ([a, i, v], [], [e]) => ! 466: (arithprof 1; ! 467: storeindexl(regbind v, regbind a, regbind i); ! 468: gen e)) ! 469: | P.alength => (fn ([a], [w], [e]) => ! 470: alloc(w, e,any, fn w' => ! 471: (arithprof 1; ! 472: select(~1, regbind a, arithtemp); ! 473: ashr(immed(width_tags-1),arithtemp, arithtemp); ! 474: (* orb(immed 1, arithtemp, w'); ! 475: this didn't work on the mc68020, dammit! *) ! 476: orb(immed 1, arithtemp, arithtemp); ! 477: move(arithtemp,w'); ! 478: gen e))) ! 479: | P.slength => (fn ([a], [w], [e]) => ! 480: alloc(w, e,any, fn w' => ! 481: let val a' = regbind a ! 482: in if isreg' a' ! 483: then select(~1,a',arithtemp) ! 484: else (move(a',w'); select(~1,w',arithtemp)); ! 485: ashr(immed(width_tags-1), arithtemp, arithtemp); ! 486: (* orb(immed 1, arithtemp, w'); ! 487: this didn't work on the mc68020, dammit! *) ! 488: arithprof 1; ! 489: orb(immed 1, arithtemp, arithtemp); ! 490: move(arithtemp,w'); ! 491: gen e ! 492: end)) ! 493: | P.store => (fn ([s,i,v], [], [e]) => ! 494: (arithprof 2; ! 495: ashr(immed 1, regbind i, arithtemp); ! 496: ashr(immed 1, regbind v, arithtemp2); ! 497: storeindexb(arithtemp2, regbind s); ! 498: gen e)) ! 499: | P.ordof => (fn ([s,i], [v], [e]) => ! 500: alloc(v, e,any, fn v' => ! 501: let val s' = regbind s ! 502: in arithprof 3; ! 503: ashr(immed 1, regbind i, arithtemp); ! 504: if isreg' s' then fetchindexb(s', arithtemp2) ! 505: else (move(s',v'); fetchindexb(v',arithtemp2)); ! 506: addl3(arithtemp2,arithtemp2,arithtemp2); ! 507: orb(immed 1, arithtemp2, v'); ! 508: gen e ! 509: end)) ! 510: | P.fneg => (fn ([x], [y], [e]) => ! 511: alloc(y, e,any, fn y' => (mnegg(regbind x, y'); gen e))) ! 512: | P.profile => (fn ([index,incr],[],[c]) => ! 513: (case (isimmed(regbind index), isimmed(regbind incr)) ! 514: of (SOME i, SOME v) => profile(i div 2,(v div 2)*2); ! 515: gen c)) ! 516: | P.boxed => (fn ([x],[],[a,b]) => ! 517: let val lab = newlabel() ! 518: in bbs(immed 0, regbind x, lab); gen a; genlab(lab, b) ! 519: end) ! 520: | P.gethdlr => (fn ([],[x],[e]) => ! 521: alloc(x, e,any, fn x' => (move(exnptr,x'); gen e))) ! 522: | P.sethdlr => (fn ([x],[],[e]) => (move(regbind x, exnptr); gen e)) ! 523: | P.fmul => (fn ([x,y], [z], [e]) => ! 524: alloc(z, e,any, fn z' => ! 525: (mulg3(regbind x, regbind y, z'); gen e))) ! 526: | P.fdiv => (fn ([x,y], [z], [e]) => ! 527: alloc(z, e,any, fn z' => ! 528: (divg3(regbind x, regbind y, z'); gen e))) ! 529: | P.fadd => (fn ([x,y], [z], [e]) => ! 530: alloc(z, e,any, fn z' => ! 531: (addg3(regbind x, regbind y, z'); gen e))) ! 532: | P.fsub => (fn ([x,y], [z], [e]) => ! 533: alloc(z, e,any, fn z' => ! 534: (subg3(regbind x, regbind y, z'); gen e))) ! 535: | P.feql => compare(gbranch,NEQ) ! 536: | P.fneq => compare(gbranch,EQL) ! 537: | P.fgt => compare(gbranch,LEQ) ! 538: | P.flt => compare(gbranch,GEQ) ! 539: | P.fge => compare(gbranch,LSS) ! 540: | P.fle => compare(gbranch,GTR) ! 541: ! 542: in emitlong 1; (* Bogus tag for spacing, boot_v. *) ! 543: let fun loop nil = () ! 544: | loop (frag::r) = (frags := r; genfrag frag; loop(!frags)) ! 545: in loop(!frags) ! 546: end ! 547: (* before print "Done!\n" *) ! 548: end ! 549: ! 550: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.