![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to complrd.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / liszt|
Return to complrd.l CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / liszt |
1.1 ! root 1: ;--- file: complrd.l ! 2: (include "compmacs.l") ! 3: ! 4: (def e-bind ! 5: (lambda (v-v v-n) ! 6: (setq k-bind (cons (cons v-v v-n) k-bind)))) ! 7: ! 8: (def e-reg ! 9: (lambda (v-r v-t) ! 10: (prog (v-v) ! 11: (cond ((setq v-v (get v-r x-reg)) (return v-v))) ! 12: (setq v-v ! 13: (cond (v-t) ! 14: ((prog (v-e v-l) ! 15: (setq v-e '(4 5 2 3 1 0)) ! 16: next ! 17: (setq v-l k-regs) ! 18: loop ! 19: (cond ((null v-l) (return (car v-e))) ! 20: ((not (equal (cdar v-l) (car v-e))) ! 21: (setq v-l (cdr v-l)) ! 22: (go loop)) ! 23: ((setq v-e (cdr v-e)) (go next))))) ! 24: (t (cdar (nth k-regs -1))))) ! 25: (f-make v-r v-v) ! 26: (return v-v)))) ! 27: ;--- e-addr - v-v : s-exp ! 28: ; v-r : ? ! 29: ; v-t : ? ! 30: ; return the address in assembler format of the s-exp in v-v. ! 31: ; If the s-exp is a list or number then it must be on the ! 32: ; alist, else we look for it on the local variable stack. ! 33: ; ! 34: (def e-addr ! 35: (lambda (v-v v-r v-t) ! 36: (cond ((not (atom v-v)) (cdr (e-alist (cadr v-v)))) ; (quote arg) ! 37: ((numberp v-v) (cdr (e-alist v-v))) ;number ! 38: ((prog (v-l) ! 39: (cond ((setq v-l (assoc v-v k-bind)) ! 40: (return ! 41: (cond ((ifflag v-v x-spec) ! 42: (e-alist v-v)) ! 43: (t `(,(times 4 (cdr v-l)) ! 44: ,lpar ! 45: ,olbot-reg ! 46: ,rpar)))))))) ! 47: ((symbolp v-v) (e-alist v-v)) ! 48: ; how is this reachable ?? ! 49: (t (emit3 'movl ! 50: (list '$ v-v) ! 51: (cond (v-t (list 'r r-xv)) ! 52: ((equal v-r r-xv) (list 'r r-xv+1)) ! 53: (t (emit3 'movl (list 'r v-r) 'r0) ! 54: (list 'r r-xv+1)))))))) ! 55: ! 56: ;--- e-alist - v-v : s-exp to look for on the alist ! 57: ; returns an assembler address of the s-exp as an offset off the ! 58: ; link register ln-reg. If the given s-exp is not on the alist yet, ! 59: ; it is added to it, thus this routine never fails ! 60: ; ! 61: (def e-alist ! 62: (lambda (v-v) ! 63: (prog (v-x) ! 64: (setq v-x ! 65: (cond ((cadr (assoc v-v k-ptrs))) ! 66: (t (setq k-ptrs ! 67: (cons (list v-v (setq k-disp (add k-disp 4))) ! 68: k-ptrs)) ! 69: k-disp))) ! 70: (return (cond ((zerop v-x) `(* (,ln-reg))) ! 71: (t `(* ,v-x (,ln-reg)))))))) ! 72: ! 73: ! 74: ;--- e-have - v-e : name of value (how generated?) ! 75: ; returns the register which contains this value, else nil if ! 76: ; this value is not in a register ! 77: ; ! 78: (def e-have ! 79: (lambda (v-e) ! 80: (cond ((setq v-e (assoc v-e k-regs)) (cdr v-e))))) ! 81: ! 82: ;--- e-note - v-r : register name ! 83: ; v-e : name of value ! 84: ; returns v-r ! 85: ; This makes us remember that register v-r contains value v-e ! 86: ; by placing it in the k-regs assoc list ! 87: ; ! 88: (def e-note ! 89: (lambda (v-r v-e) ! 90: (setq k-regs (cons (cons v-e v-r) k-regs)) ! 91: v-r)) ! 92: ! 93: ;--- e-lose - v-r : register name ! 94: ; returns v-r ! 95: ; This says that register v-r is clobbered and no longer contains ! 96: ; any known value. ! 97: ; ! 98: (def e-lose ! 99: (lambda (v-r) ! 100: (setq k-regs (e-drop k-regs v-r)) ! 101: v-r)) ! 102: ! 103: ;--- e-drop - v-r : register name (in general, anything) ! 104: ; v-l : list of registers (in general, any assoc list) ! 105: ; returns v-l with all entries with v-r as cadr removed. ! 106: ; ! 107: (def e-drop ! 108: (lambda (v-l v-r) ! 109: (cond ((null v-l) nil) ! 110: ((equal (cdar v-l) v-r) (e-drop (cdr v-l) v-r)) ! 111: (t (rplacd v-l (e-drop (cdr v-l) v-r)))))) ! 112: ! 113: ! 114: ;--- e-type - v-r : register containing a lispval ! 115: ; emits instructions which replace that register with the type ! 116: ; number of the lispval it contained. ! 117: ; ! 118: (def e-type ! 119: (lambda (v-r) ! 120: (setq v-r (list 'r v-r)) ! 121: (emit4 'ashl '$-9 v-r v-r) ! 122: (emit3 'cvtbl (list '"_typetable+1[r" (cadr v-r) '"]") v-r))) ! 123: ! 124: (putprop 'get 'e-get 'x-emit) ! 125: ! 126: (def e-get ! 127: (lambda (v-r v-v) ! 128: (prog (v-cou) ! 129: (setq v-cou (get v-r 'x-count)) ! 130: ! 131: (cond ((null v-cou) ! 132: (comp-warn " value lost " (or v-v) " from reg " (or v-r) ! 133: " plist " (plist v-r) N)) ! 134: ((and (eq 'used v-cou) ; if only used once ! 135: (eq (cadar k-code) v-r) ! 136: (or (eq 'set (caar k-code)) ! 137: (eq 'push (caar k-code)))) ! 138: (cond ((eq 'set (caar k-code)) ! 139: (e-setnoreg v-v)) ! 140: (t (e-pushnoreg v-v)))) ! 141: (t (setq v-cou (e-have v-v)) ! 142: ! 143: (cond ((equal v-cou (setq v-r (e-reg v-r v-cou))) ! 144: (return t)) ! 145: ((null v-v) (emit2 'clrl (list 'r v-r))) ! 146: ((setq v-cou (e-addr v-v v-r t)) ! 147: (emit3 'movl v-cou (list 'r v-r)))) ! 148: (e-note (e-lose v-r) v-v)))))) ! 149: ! 150: ;--- e-setnoreg - v-fromv : value want to set ! 151: ; This is used to shorcut the setting of a value. We bypass teh ! 152: ; pseudo register. the set instruction is in the car of k-code. ! 153: ; ! 154: (def e-setnoreg ! 155: (lambda (v-fromv) ! 156: (prog (v-tov v-toadr v-floc) ! 157: (setq v-tov (caddar k-code) ; get loc to set to ! 158: v-toadr (e-addr v-tov nil nil) ;loc of it ! 159: v-floc (e-have v-fromv) ; reg location if exists ! 160: k-code (cdr k-code)) ! 161: ! 162: (cond ((null v-fromv) (emit2 'clrl v-toadr)) ! 163: (t (cond (v-floc (emit3 'movl `(r ,v-floc) v-toadr)) ! 164: (t (emit3 'movl (e-addr v-fromv nil nil) ! 165: v-toadr))))) ! 166: ! 167: loop ; remove alloc occuraces of v-v from the registers ! 168: (cond ((null (setq v-toadr (e-have v-tov))) ! 169: (return nil)) ! 170: (t (e-lose v-toadr))) ! 171: (go loop)))) ! 172: (putprop 'set 'e-set 'x-emit) ! 173: ;--- e-set - v-r : (actrnum) register number with value in it ! 174: ; - v-v : (actvname) name whose value will be replaced ! 175: ; emits an instruction to replace the value of v-v with ! 176: ; the value in v-r. Then we remove all mention of v-v ! 177: ; in the registers since we have changed the value. ! 178: ; Finally we note that the value is stored in v-r since ! 179: ; that is where it came from ! 180: ; ! 181: (def e-set ! 182: (lambda (v-r v-v) ! 183: (prog (v-t) ! 184: (setq v-t (e-addr v-v v-r nil)) ! 185: (cond (v-t (emit3 'movl (list 'r v-r) v-t)) ! 186: (t (return))) ! 187: loop ! 188: (cond ((setq v-t (e-have v-v)) ! 189: (e-lose v-t) ! 190: (go loop))) ! 191: (e-note v-r v-v)))) ! 192: ! 193: (putprop 'push 'e-push 'x-emit) ! 194: ! 195: ! 196: ;--- e-push - v-r : register number ! 197: ; emits an instruction to push the value in the given register ! 198: ; on the name stack ! 199: (def e-push ! 200: (lambda (v-r) ! 201: (emit3 'movl ! 202: (list 'r v-r) push-np) ! 203: (setq k-stak (add1 k-stak)))) ! 204: ! 205: ! 206: ;--- e-pushnoreg - v-fromv : value we wish to stack ! 207: ; we stack a value without going through a intermediate register. ! 208: ; ! 209: (def e-pushnoreg ! 210: (lambda (v-fromv) ! 211: (prog (v-floc) ! 212: (setq v-floc (e-have v-fromv) ; see if from is in regis ! 213: k-code (cdr k-code)) ! 214: ! 215: (cond ((null v-fromv) (emit2 'clrl push-np)) ! 216: (v-floc (emit3 'movl `(r ,v-floc) push-np)) ! 217: (t (emit3 'movl (e-addr v-fromv nil nil) ! 218: push-np))) ! 219: (setq k-stak (add1 k-stak))))) ! 220: ! 221: ! 222: (putprop 'fpush 'e-fpush 'x-emit) ! 223: ! 224: (def e-fpush ! 225: (lambda (v-r) ! 226: (emit3 'movl (list 8 '"(" v-r '")") push-np))) ! 227: ! 228: (putprop 'gpush 'e-gpush 'x-emit) ! 229: ! 230: (def e-gpush ! 231: (lambda (v-r v-v) ! 232: (prog (v-t) ! 233: (setq v-t (e-have v-v)) ! 234: (cond ((null v-v) (emit2 i-clr push-np)) ! 235: ((equal v-t (setq v-r (e-reg v-r v-t))) ! 236: (emit3 i-mov (list 'r v-r) push-np)) ! 237: ((setq v-t (e-addr v-v v-r t)) ! 238: (emit3 i-mov v-t push-np)) ! 239: ((zerop v-r)) ! 240: (t (emit3 i-mov 'r0 push-np))) ! 241: (setq k-nargs (add1 k-nargs)) ! 242: (setq k-stak (add1 k-stak))))) ! 243: ! 244: (putprop 'gfpush 'e-gfpush 'x-emit) ! 245: ! 246: (def e-gfpush ! 247: (lambda (v-r v-v) ! 248: (prog (v-t) ! 249: (setq v-t (e-have v-v)) ! 250: (cond ((null v-v) (emit2 i-clr push-np)) ! 251: ((equal v-t (setq v-r (e-reg v-r v-t))) ! 252: (emit3 i-mov (list 'r v-r) push-np)) ! 253: ((setq v-t (cdr (e-addr v-v v-r t))) ! 254: ; mod by jkf, new calling seq, push atom addr ! 255: ; on stack, let qfuncl look 8 beyond ! 256: (emit3 i-mov v-t push-np) ! 257: ;(emit3 'movl v-t (list 'r v-r)) ! 258: ;(emit3 i-mov (list 8 '"(r" v-r '")") push-np) ! 259: ) ! 260: ((zerop v-r)) ! 261: (t (emit3 i-mov '"8(r0)" push-np))) ! 262: (setq k-nargs (add1 k-nargs)) ! 263: (setq k-stak (add1 k-stak))))) ! 264: ! 265: ! 266: (putprop 'mark 'e-mark 'x-emit) ! 267: ;--- e-mark - ! 268: ; emit instructions to begin to call a function. This involves ! 269: ; setting lbot in Opus30, and saving the old lbot in Opus 20. ! 270: ; Also, some global variables are set. ! 271: ; details: In opus 30, np points to the next free loc, we set ! 272: ; lbot to one beyond that since where np points we will place ! 273: ; the address of the function to call. If we adopt a xfer ! 274: ; table scheme for calling, this would be different since ! 275: ; we wouldn't stack the address of the function. ! 276: ; ! 277: (def e-mark ! 278: (lambda nil ! 279: nil)) ; no-op ! 280: ! 281: (putprop 'call 'e-call 'x-emit) ! 282: ! 283: ;--- e-call - v-r : register where result will go, this will always be 0 ! 284: ; - v-a : nil if calling throught the oblist, non nil then ! 285: ; this is the address of a system function to call ! 286: ; Calls a routine, eithere system or through the oblist. ! 287: ; In the former case, we have only stacked the args, in the ! 288: ; latter case, lbot points to the function code to call. ! 289: ; If we are calling a non system function with 4 or less args ! 290: ; we do not set up lbot, instead we enter qfuncl at a special ! 291: ; entry point which does the set up. ! 292: ; ! 293: (def e-call ! 294: (lambda (v-r v-a v-nargs) ! 295: (prog (v-temp) ! 296: (setq k-stak (difference k-stak v-nargs)) ! 297: (setq k-regs nil) ! 298: (cond ((or v-a (null (setq v-temp (get 'qfs (sub1 v-nargs))))) ! 299: (emit3 'movab `(- ,(times 4 v-nargs) ,lpar ,np-reg ,rpar) ! 300: lbot-reg))) ; set up lbot ! 301: (cond (v-a (emit3 'calls '$0 v-a)) ; system fcn ! 302: (v-temp (emit2 'jsb v-temp)) ! 303: (t (emit2 'jsb qfuncl))) ; else non sys fcn ! 304: (cond (v-a (emit3 'movl lbot-reg np-reg)))))) ; fix up lbot if sys ! 305: ! 306: (putprop 'minus 'e-minus 'x-emit) ! 307: ! 308: (def e-minus ! 309: (lambda (v-r v-v) ! 310: (cond ((eq (caar k-code) 'get) ! 311: (prog (v-i v-b) ! 312: (setq v-i (cdar k-code)) ! 313: (setq v-b (e-reg (car v-i) nil)) ! 314: (setq k-code (cdr k-code)) ! 315: (e-lose v-b) ! 316: (cond ((equal v-r v-b) ! 317: (setq v-r (e-reg (Gensym nil) nil)) ! 318: (cond ((equal v-r v-b) ! 319: (setq v-r (remainder (add1 v-r) 6) ))) ! 320: (emit3 'movl ! 321: (list 'r v-b) ! 322: (list 'r (e-lose v-r))) ! 323: (e-note v-r (Gensym nil)))) ! 324: (cond ((null (cadr v-i)) (emit2 'clrl (list 'r v-b))) ! 325: (t (emit3 'movl ! 326: (e-addr (cadr v-i) v-b t) ! 327: (list 'r v-b))))))) ! 328: (cond ((null v-v) (emit2 'tstl (list 'r v-r))) ! 329: (t (emit3 'cmpl (e-addr v-v v-r t) (list 'r v-r)))))) ! 330: ! 331: (putprop 'true 'e-true 'x-emit) ! 332: ! 333: (def e-true ! 334: (lambda (v-l v-dv) ! 335: (emit2 'jneq v-l))) ! 336: ! 337: (putprop 'false 'e-false 'x-emit) ! 338: ! 339: (def e-false ! 340: (lambda (v-l v-dv) ! 341: (emit2 'jeql v-l))) ! 342: ! 343: (putprop 'go 'e-go 'x-emit) ! 344: ! 345: (def e-go ! 346: (lambda (v-l) ! 347: (emit2 'jbr v-l))) ! 348: ! 349: (putprop 'skip 'e-skip 'x-emit) ! 350: ! 351: (def e-skip ! 352: (lambda (v-r v-l) ! 353: (prog (v-x) ! 354: (e-lose v-r) ! 355: (setq v-x (Gensym nil)) ! 356: (emit3 'movab v-x (list 'r v-r)) ! 357: (emit2 'jbr v-l) ! 358: (emit1 (list v-x ':))))) ! 359: ! 360: (putprop 'return 'e-rtn 'x-emit) ! 361: ! 362: (putprop 'bind 'e-xbind 'x-emit) ! 363: ! 364: ;--- e-xbind - v-v : act varname to bind ! 365: ; Emits instrutions to bind v-v to the current top of stack. ! 366: ; it is possible for v-v to be nil, this means we should ignore ! 367: ; this value on the stack (but we remember that it is still on ! 368: ; the stack). ! 369: ; ! 370: (def e-xbind ! 371: (lambda (v-vrbl) ! 372: (prog (v-loc) ! 373: (cond ((null v-vrbl)) ; ignore if nil ! 374: ((ifflag v-vrbl x-spec) ! 375: ; if first bound, get val of bnp in bnp-reg ! 376: (cond ((zerop k-regf) (emit3 'movl bnp-val bnp-reg))) ! 377: ! 378: ! 379: (setq k-regf (add1 k-regf) ; count specials bound ! 380: v-loc (e-alist v-vrbl)) ; addr of vars value ! 381: (emit3 'movl v-loc '"(r11)+") ; stack value ! 382: (emit3 'movl (cdr v-loc) '"(r11)+") ; now addr ! 383: (emit3 'movl bnp-reg bnp-val) ; keep current ! 384: (emit3 'movl `(,(times 4 k-stak) ,lpar ,olbot-reg ,rpar) ! 385: v-loc)) ! 386: (t (e-bind v-vrbl k-stak))) ; update k-bind ! 387: (setq k-stak (add1 k-stak))))) ! 388: ! 389: ! 390: ! 391: (putprop 'label 'e-label 'x-emit) ! 392: ! 393: (def e-label ! 394: (lambda (v-l) ! 395: (put v-l x-lab 1) ! 396: (emit1 (list v-l ':)) ! 397: (setq k-regs nil))) ! 398: ! 399: (putprop 'entry 'e-entry 'x-emit) ! 400: ! 401: (def e-entry ! 402: (lambda (type) ! 403: (setq k-bind nil) ! 404: (setq k-stak 0) ! 405: (emit2 '".word" '"0xdc0") ; save 11,10,8,7,6 ! 406: (emit3 'movab '"linker" ln-reg) ! 407: (cond ((eq type 'lexpr) ! 408: (emit4 'subl3 '$4 lbot-reg `"-(sp)") ; stack num of args ! 409: (emit3 'movl np-reg olbot-reg) ; np is top ! 410: (emit4 'subl3 lbot-reg np-reg 'r0) ; stack numb of args ! 411: (emit3 'movab '"0x400(r0)" `(,lpar ,np-reg ,rpar +)) ! 412: (emit3 'movl `(,lpar ,olbot-reg ,rpar) '"-(sp)")) ! 413: (t ! 414: (emit3 'movl `( ,lbot-reg) `( ,olbot-reg)))) ! 415: (setq k-name (Gensym nil)) ! 416: (emit1 (list k-name ':)))) ! 417: ! 418: (putprop 'repeat 'e-repeat 'x-emit) ! 419: ! 420: (def e-repeat ! 421: (lambda nil ! 422: (emit2 'jbr k-name))) ! 423: ! 424: (putprop 'begin 'e-begin 'x-emit) ! 425: ! 426: (def e-begin ! 427: (lambda (v-nargs) ! 428: (setq k-stak (difference k-stak v-nargs)) ; make up for stacked args ! 429: (e-save) ! 430: (setq k-prog (Gensym nil)) ! 431: (setq k-regf 0))) ; counts specials bound ! 432: ! 433: (putprop 'end 'e-end 'x-emit) ! 434: ! 435: (def e-end ! 436: (lambda (v-lab) ! 437: (cond (v-lab (emit1 `(,v-lab :)))) ; if label, put out ! 438: ! 439: (cond ((not (zerop k-regf)) ; see of special to unbind ! 440: (emit3 'movl bnp-val bnp-reg) ! 441: (do ((i k-regf (sub1 i))) ! 442: ((zerop i) (emit3 'movl bnp-reg bnp-val)) ! 443: (emit3 'movl ! 444: `(-8 ,lpar ,bnp-reg ,rpar) ! 445: `(*-4 ,lpar ,bnp-reg ,rpar)) ! 446: (emit3 'subl2 '$8 bnp-reg)))) ! 447: ! 448: ; fix up np-reg to reflect poping off of local variables if ! 449: ; we are not at the end of the function and there are some to ! 450: ; pop off ! 451: (cond ((and (not (eq (caar k-code) 'fini)) ! 452: (not (zerop (difference k-stak (cadr k-save))))) ! 453: (emit3 'subl2 `($ ,(times 4 (difference k-stak (cadr k-save)))) ! 454: np-reg))) ! 455: (e-unsave))) ! 456: ! 457: (putprop 'unbind 'e-unbind 'x-emit) ! 458: ! 459: ;--- e-unbind - levnum : number of contexts to unbind through ! 460: ; this is used to unbind specials when you don't want to ! 461: ; go to then end of the current context to do so. this ! 462: ; is used, for example, to handle non-local returns ! 463: ; ! 464: (def e-unbind ! 465: (lambda (v-n) ! 466: (do ((numb k-regf) ; number of specials to unbind ! 467: (ll k-save (car ll)) ; stack of info ! 468: (count v-n (sub1 count))) ; index vrbl ! 469: ((zerop count) ! 470: ; if any specials were bound in the contexts, emit ! 471: ; the proper instructions to unbind them ! 472: (cond ((greaterp numb 0) ! 473: (emit3 'movl bnp-val bnp-reg) ! 474: (do ((cnt numb (sub1 cnt))) ! 475: ((zerop cnt) ! 476: (emit3 'movl bnp-reg bnp-val)) ! 477: (emit3 'movl ! 478: `(-8 ,lpar ,bnp-reg ,rpar) ! 479: `(*-4 ,lpar ,bnp-reg ,rpar)) ! 480: (emit3 'subl2 '$8 bnp-reg)))) ! 481: ; pop off the namestack ! 482: (cond ((not (zerop (setq ll (difference k-stak (cadr ll))))) ! 483: (emit3 'subl2 `($ ,(times 4 ll)) np-reg)))) ! 484: (setq numb (plus numb (caddr ll)))))) ; total k-regf ! 485: ! 486: ;--- e-unsave : restore the state variables. Occurs when we leave one ! 487: ; frame and pop off to the next one ! 488: ; ! 489: (def e-unsave ! 490: (lambda nil ! 491: (prog (tem) ! 492: (setq tem k-save ! 493: k-save (car tem) tem (cdr tem) ! 494: k-stak (car tem) tem (cdr tem) ! 495: k-regf (car tem) tem (cdr tem) ! 496: k-bind (car tem))))) ! 497: ! 498: (def e-save ! 499: (lambda nil ! 500: (setq k-save `(,k-save ,k-stak ,k-regf ,k-bind)))) ! 501: ! 502: ! 503: (def e-eq ! 504: (lambda (v-r1 v-r2) ! 505: (cond ((eq (caar k-code) 'get) ! 506: (prog (v-i v-b) ! 507: (setq v-i (cdar k-code)) ! 508: (setq v-b (e-reg (car v-i) nil)) ! 509: (e-lose v-b) ! 510: (setq k-code (cdr k-code)) ! 511: (cond ((null (cadr v-i)) (emit2 'clrl (list 'r v-b))) ! 512: (t (emit3 'movl (e-addr (cadr v-i) v-b t) ! 513: (list 'r v-b))))))) ! 514: (cond ((eq (caar k-code) 'false) ! 515: (rplaca (car k-code) 'true)) ! 516: ((eq (caar k-code) 'true) ! 517: (rplaca (car k-code) 'false))) ! 518: (emit3 'cmpl v-r1 v-r2))) ! 519: ! 520: (putprop 'eqs 'e-eqs 'x-emit) ! 521: ! 522: ;--- e-eqs ! 523: ; emits instructions to compare the top two items on the stack. ! 524: ; note that it updates np first before poping the items from ! 525: ; the stack so if an interrupt occured here the top two values ! 526: ; would be clobbered, this must be fixed. ! 527: ; ! 528: (def e-eqs ! 529: (lambda nil ! 530: (setq k-stak (difference k-stak 2)) ! 531: (emit3 'subl2 '"$8" ! 532: np-reg) ! 533: (e-eq `(,lpar ,np-reg ,rpar) ; compare top two times (above stack) ! 534: `(4 ,lpar ,np-reg ,rpar)))) ! 535: ! 536: (putprop 'eqv 'e-eqv 'x-emit) ! 537: ! 538: (def e-eqv ! 539: (lambda (v-r1 v-r2) ! 540: (e-eq (e-addr v-r1 nil t) (e-addr v-r2 nil t)))) ! 541: ! 542: (putprop 'fixup 'e-fixup 'x-emit) ! 543: ! 544: ! 545: ! 546: ! 547: (putprop 'seta 'e-seta 'x-emit) ! 548: ! 549: ;--- e-seta - v-r1 : dtpr lispval ! 550: ; v-r2 : lispval ! 551: ; emits an instruction to replace the car of v-r1 with v-r2 ! 552: ; ! 553: (def e-seta ! 554: (lambda (v-r1 v-r2) ! 555: (emit3 'movl ! 556: (list 'r (e-reg v-r2 nil)) ! 557: (list 4 '"(r" (e-reg v-r1 nil) '")")))) ! 558: ! 559: (putprop 'setas 'e-setas 'x-emit) ! 560: ! 561: ;--- e-setas - v-r : result register ! 562: ; top-of-stack: lispval ! 563: ; top-of-stack - 1 : dtpr lispval ! 564: ; emits instructions to replace the car of the top-of-stack -1 lispval ! 565: ; with the top-of-stack lispval, then pops the stack of those two ! 566: ; lispval as put the top-of-stack - 1 lispval in v-r. ! 567: ; note: here again we pop np too soon which could result in big ! 568: ; problem if an interrupt occured in the middle of the instruction ! 569: ; sequence. ! 570: ; ! 571: (def e-setas ! 572: (lambda (v-r) ! 573: (setq v-r (e-reg v-r nil)) ! 574: (setq k-stak (difference k-stak 2)) ! 575: (emit3 'subl2 '"$8" ! 576: np-reg) ! 577: (emit3 'movl `(,lpar ,np-reg ,rpar) (list 'r v-r)) ! 578: (emit3 'movl `( 4 ,lpar ,np-reg ,rpar) ! 579: (list 4 '"(r" v-r '")")))) ! 580: ! 581: (putprop 'setd 'e-setd 'x-emit) ! 582: ! 583: ;--- e-setd - v-r1 : dtpr lispval ! 584: ; v-r2 : lispval ! 585: ; emits instructions to replace the car of v-r1 with v-r2 ! 586: ; ! 587: (def e-setd ! 588: (lambda (v-r1 v-r2) ! 589: (emit3 'movl ! 590: (list 'r (e-reg v-r2 nil)) ! 591: (list '"(r" (e-reg v-r1 nil) '")")))) ! 592: ! 593: (putprop 'setds 'e-setds 'x-emit) ! 594: ! 595: ;--- e-setds - v-r : result register ! 596: ; top-of-stack : lispval ! 597: ; top-of-stack - 1 : dtpr lisval ! 598: ; emits instructions to replace the cdr of the top-of-stack -1 ! 599: ; lispval with the top of stack lispval. The result is placed ! 600: ; in v-r ! 601: (def e-setds ! 602: (lambda (v-r) ! 603: (setq v-r (e-reg v-r nil)) ! 604: (setq k-stak (difference k-stak 2)) ! 605: (emit3 'subl2 '"$8" np-reg) ! 606: (emit3 'movl `(,lpar ,np-reg ,rpar) (list 'r v-r)) ! 607: (emit3 'movl `( 4 ,lpar ,np-reg ,rpar) ! 608: (list '"(r" v-r '")")))) ! 609: ! 610: ! 611: ! 612: ! 613: (putprop 'dopop 'e-dopop 'x-emit) ! 614: ! 615: (def e-dopop ! 616: (lambda (v-l) ! 617: (mapc '(lambda (v-x) ! 618: (emit3 'movl `( - ,lpar ,np-reg ,rpar) ! 619: (e-addr v-x nil t)) ! 620: (setq k-stak (sub1 k-stak))) ! 621: (reverse v-l)))) ! 622: ! 623: (putprop 'list 'e-list 'x-emit) ! 624: ! 625: (def e-list (lambda nil nil)) ! 626: ! 627: (putprop 'chain 'e-chain 'x-emit) ! 628: ! 629: ;--- e-chain - v-r : result lispval ! 630: ; v-e : dtpr lispval ! 631: ; v-b : an atom of the form cxxr where the x's are a's and d's ! 632: ; emits instructions to put the cxxr of v-e in v-r ! 633: ; ! 634: (def e-chain ! 635: (lambda (v-r v-e v-b) ! 636: (setq v-r (e-reg v-r nil)) ! 637: (setq v-e (e-reg v-e nil)) ! 638: (cond ((setq v-b (cdr (reverse (cdr (explode v-b))))) ! 639: (e-lose v-e) ! 640: (e-note (e-lose v-r) (Gensym nil)) ! 641: (setq v-r (concat 'r v-r)) ! 642: (setq v-e (concat 'r v-e)) ! 643: (prog (op) ! 644: ! 645: loop ! 646: (cond ((null v-b) (return))) ! 647: (cond ((eq (car v-b) 'd) ! 648: (setq op (list '"(" v-e '")" ))) ! 649: (t (setq op (list 4 '"(" v-e '")" )))) ! 650: (setq v-b (cdr v-b)) ! 651: (cond ((and (not (null v-b)) (eq (car v-b) 'd)) ! 652: (setq v-b (cdr v-b)) ! 653: (setq op (cons '* op)))) ! 654: (emit3 'movl op v-r) ! 655: (setq v-e v-r) ! 656: (go loop))) ! 657: ! 658: ((equal v-r v-e)) ! 659: ! 660: (t (emit3 'movl (list 'r v-e) (list 'r v-r)))))) ! 661: ! 662: ! 663: (putprop 'getype 'e-getype 'x-emit) ! 664: ! 665: (def e-getype ! 666: (lambda (v-r v-n) ! 667: (prog (v-i v-b v-x v-x1) ! 668: (setq v-r (e-reg v-r nil)) ! 669: (setq v-x1 (setq v-x (list 'r v-r))) ! 670: (cond ((eq (caar k-code) 'get) ! 671: (setq v-i (cdar k-code)) ! 672: (setq k-code (cdr k-code)) ! 673: (e-type v-r) ! 674: (cond ((equal (e-note (e-lose ! 675: (setq v-b ! 676: (e-reg (car v-i) nil))) ! 677: (setq v-i (cadr v-i))) ! 678: v-r) ! 679: (emit2 'pushl v-x) ! 680: (setq v-x '"(sp)") ! 681: (setq v-x1 '"(sp)+"))) ! 682: (cond ((null v-i) (emit2 'clrl (list 'r v-b))) ! 683: (t (emit3 'movl (e-addr v-i v-b t) ! 684: (list 'r v-b))))) ! 685: (t (e-type v-r))) ! 686: (e-lose v-r) ! 687: (cond ((eq v-n 'name) ! 688: (emit3 'movl (list '"_tynames+4[r" v-r '"]") ! 689: (list 'r v-r)) ! 690: (emit3 'movl (list '"(r" v-r '")") (list 'r v-r))) ! 691: ((atom v-n) (emit3 'cmpl (list '$ v-n) v-x1) ! 692: (cond ((eq (caar k-code) 'false) ! 693: (rplaca (car k-code) 'true)) ! 694: ((eq (caar k-code) 'true) ! 695: (rplaca (car k-code) 'false)))) ! 696: (t (prog nil ! 697: (emit4 'ashl v-x '$1 v-x) ! 698: (setq v-i 0) ! 699: loop ! 700: (cond ((null v-n) (go out))) ! 701: (setq v-i (mylogor v-i (leftshift 1 (car v-n)))) ! 702: (setq v-n (cdr v-n)) ! 703: (go loop) ! 704: out ! 705: (emit3 'bitw (list '$ v-i) v-x1))))))) ! 706: ! 707: ! 708: ! 709: (putprop 'catchent 'e-catchent 'x-emit) ! 710: ! 711: ;--- e-catchent - v-l : label throw should go to ! 712: ; - v-t : tag to be caught ! 713: ; - v-f : if non nil reg which contains flag to store in frame ! 714: ; We create a catch frame, the form is this: ! 715: ; --------------- ! 716: ; | return addr | ! 717: ; --------------- ! 718: ; | reg r13 (fp) | ! 719: ; --------------- ! 720: ; | reg r10 | ! 721: ; --------------- ! 722: ; | reg r8 | ^ ! 723: ; --------------- | high addresses, bottom of stack ! 724: ; | reg r6 | ! 725: ; --------------- ! 726: ; | Saved | ! 727: ; | (return) | (10 words) (kls CROCK fix) ! 728: ; | dope | ! 729: ; --------------- ! 730: ; | bnp | ! 731: ; --------------- ! 732: ; | tag | ! 733: ; --------------- ! 734: ; | flag | ! 735: ; --------------- ! 736: ; | link | <-- errp points here ! 737: ; --------------- ! 738: ; ! 739: ; due to bad operation of e-addr (which returns addr of list or number, ! 740: ; and value of atom), we must carefully check v-t ! 741: ; ! 742: (def e-catchent ! 743: (lambda (v-l v-t v-f) ! 744: (emit2 'pushab v-l) ! 745: (emit2 'pushr '"$0x2540") ; register save mask ! 746: ; (emit2 'subl2 '"$40,sp") ! 747: ; (emit2 'movc3 '"$40,_setsav,(sp)") ; this won't work since lisp ! 748: ; may user register 0 - 5 ! 749: ; the whole thing is a crock anyhow ! 750: ! 751: (emit2 'jsb '_svkludg) ! 752: (emit2 'pushl bnp-val) ; push value of bnp ! 753: (cond ((or (numberp v-t) (not (atom v-t))) ! 754: (emit2 'pushl (e-addr v-t nil nil))) ! 755: (v-t (emit2 'pushl `(r ,(e-reg v-t nil)))) ! 756: (t (emit2 'clrl '"-(sp)"))) ; tag is nil ! 757: (cond (v-f (setq v-f (e-reg v-f nil)) ; if flag, find loc ! 758: (emit2 'pushl `(r ,v-f))) ! 759: (t (emit2 'pushl '$1))) ; non flag, assume true ! 760: (emit2 'pushl '_errp) ; sav current errp value ! 761: (emit3 'movl 'sp '_errp))) ! 762: ! 763: (putprop 'catchexit 'e-catchexit 'x-emit) ! 764: ! 765: ;--- e-catchexit - do catchexit stuff. This code is hit if we exit ! 766: ; a catch by just falling through, instead of via a throw. ! 767: ; ! 768: (def e-catchexit ! 769: (lambda nil ! 770: (emit3 'movl '"(sp)" '_errp) ; unstack error frame ! 771: (emit3 'addl2 '$76 'sp))) ; pop off 9 entries ! 772: ; + 10 for (return) context ! 773: ! 774: ! 775: (putprop '*throw 'e-*throw 'x-emit) ! 776: ! 777: ;--- e-*throw - v-r : pseudo reg containing value to throw ! 778: ; - v-nr : pseudo reg containing tag to throw ! 779: ; ! 780: (def e-*throw ! 781: (lambda (v-r v-nr) ! 782: (setq v-r (e-reg v-r nil) ; get real regis ! 783: v-nr (e-reg v-nr nil)) ! 784: (emit2 'pushl `(r ,v-r)) ! 785: (emit2 'pushl `(r ,v-nr)) ! 786: (emit3 'calls '$0 '_Idothrow) ! 787: (emit2 'clrl '"-(sp)") ! 788: (emit2 'pushab '__erthrow) ! 789: (emit3 'calls '$2 '_error))) ! 790: (putprop 'pushnil 'e-pushnil 'x-emit) ! 791: ;--- e-pushnil - v-num : number of nils to push ! 792: ; pushs nils on the np stack in the most efficient way possible ! 793: ; ! 794: (def e-pushnil ! 795: (lambda (v-num) ! 796: (do ((i v-num (difference i 2))) ! 797: ((lessp i 2) (cond ((equal i 1) (emit2 'clrl push-np)))) ! 798: ! 799: (emit2 'clrq push-np)) ! 800: ! 801: (setq k-stak (plus k-stak v-num)))) ! 802: ! 803: (putprop 'fini 'e-fini 'x-emit) ! 804: ! 805: ;--- e-fini ! 806: ; called at the end of a function, just emits a ret ! 807: ; ! 808: (def e-fini ! 809: (lambda nil ! 810: (emit1 'ret))) ! 811: ! 812: (putprop 'arg 'e-arg 'x-emit) ! 813: ! 814: ;--- e-arg ! 815: ; form is (arg psreg) ! 816: ; ! 817: (def e-arg ! 818: (lambda (v-r) ! 819: (prog (tmp tmp2) ! 820: (setq v-r (e-reg v-r nil)) ! 821: (emit3 'movl `(,lpar r ,v-r ,rpar) `(r ,v-r)) ! 822: (emit2 'jeql (setq tmp (Gensym nil))) ! 823: (emit3 'movl `("*-4(fp)[r" ,v-r "]") `(r ,v-r)) ! 824: (emit2 'jmp (setq tmp2 (Gensym nil))) ! 825: (emit1 `(,tmp :)) ! 826: (emit3 'movl '"-8(fp)" `(r ,v-r)) ! 827: (emit1 `(,tmp2 :)) ! 828: (e-lose v-r)))) ! 829: ! 830: ! 831: ! 832: ;; special system functions ! 833: ! 834: (defsysf 'minus '_Lminus) ! 835: (defsysf 'add1 '_Ladd1) ! 836: (defsysf 'sub1 '_Lsub1) ! 837: (defsysf 'plist '_Lplist) ! 838: (defsysf 'cons '_Lcons) ! 839: (defsysf 'putprop '_Lputprop) ! 840: (defsysf 'print '_Lprint) ! 841: (defsysf 'patom '_Lpatom) ! 842: (defsysf 'read '_Lread) ! 843: (defsysf 'concat '_Lconcat) ! 844: (defsysf 'get '_Lget) ! 845: (defsysf 'mapc '_Lmapc) ! 846: (defsysf 'mapcan '_Lmapcan) ! 847: (defsysf 'list '_Llist) ! 848: (defsysf 'add '_Ladd) ! 849: (defsysf 'plus '_Ladd) ! 850: (defsysf '> '_Lgreaterp) ! 851: (defsysf '= '_Lequal) ! 852: (defsysf 'times '_Ltimes) ! 853: (defsysf 'difference '_Lsub) ! 854: ! 855: (flag 'set 'x-asg) ! 856: (flag 'push 'x-asg) ! 857: (flag 'minus 'x-asg) ! 858: (flag 'skip 'x-asg) ! 859: (flag 'set 'x-dont) ! 860: (flag 'setq 'x-dont) ! 861: (flag 'prog 'x-dont) ! 862: (flag 'lambda 'x-dont) ! 863: (flag 'go 'x-dont) ! 864: (flag 'return 'x-dont) ! 865: (put 'go 'x-leap 'go) ! 866: (put 'return 'x-leap 'return) ! 867: (put 'label 'x-leap 'go) ! 868: (setq x-spf 'x-spf) ! 869: (setq x-spfq 'x-spfq) ! 870: (setq x-spfn 'x-spfn) ! 871: (setq x-spfh 'x-spfh) ! 872: (setq x-con 'x-con) ! 873: (setq x-leap 'x-leap) ! 874: (setq x-reg 'x-reg) ! 875: (setq x-indx 'x-indx) ! 876: (setq x-opt 'x-opt) ! 877: (setq x-emit 'x-emit) ! 878: (setq x-asg 'x-asg) ! 879: (setq x-lab 'x-lab) ! 880: (setq x-dont 'x-dont) ! 881: (setq g-xv 'xv) ! 882: (setq g-xv+1 'xv+1) ! 883: (setq g-xv+2 'xv+2) ! 884: (setq k-regf nil) ! 885: (setq k-free 'nil) ! 886: (setq k-nargs nil) ! 887: (setq k-cnargs nil) ! 888: (setq k-stak 'nil) ! 889: (setq k-cstk 'nil) ! 890: (setq k-prog 'nil) ! 891: (setq k-undo 'nil) ! 892: (setq k-bind 'nil) ! 893: (setq k-back 'nil) ! 894: (setq k-save 'nil) ! 895: (setq k-code 'nil) ! 896: (setq k-name 'nil) ! 897: (setq k-args 'nil) ! 898: (setq k-regs 'nil) ! 899: (setq push-np '"(r6)+") ! 900: (setq r-xv 0) ! 901: (setq r-xv+1 'r1) ! 902: (put 'xv 'x-reg 0) ! 903: (putprop 'xv 'force 'x-count) ! 904: (put 'xv+1 'x-reg 1) ! 905: (put 'xv+2 'x-reg 2) ! 906: ! 907: (setq $gccount$ 0) ; incase auxfns0 is old ! 908: ; macros are not compiled by default ! 909: (setq macros nil)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.