projects / unix-history / blame
| Commit | Line | Data |
|---|---|---|
| c7103161 TL |
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 | \f | |
| 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 | \f | |
| 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 | \f | |
| 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 | \f | |
| 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 | \f | |
| 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 | \f | |
| 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 | \f | |
| 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 | \f | |
| 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 | \f | |
| 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) |