![[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.