![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fixnum.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / liszt|
Return to fixnum.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file fixnum
3: "$Header: /usr/src/local/franz/liszt/RCS/fixnum.l,v 1.16 88/04/26 11:50:18 sklower Exp $")
4:
5: ;;; ---- f i x n u m fixnum compilation
6: ;;;
7: ;;; -[Fri Aug 26 14:07:53 1983 by layer]-
8:
9: ; There are a few functions in lisp which are only permitted to take
10: ; fixnum operands and produce fixnum results. The compiler recognizes
11: ; these functions and open codes them.
12: ;
13:
14: ;--- d-fixnumexp :: compute a fixnum from an expression
15: ; x - a lisp expression which must return a fixnum
16: ;
17: ; This is an almost equivalent to d-exp, except that
18: ; 1] it will do clever things if the expression can be open coded in a
19: ; fixnum way.
20: ; 2] the result must be a fixnum, and is left in r5 unboxed.
21: ;
22: (defun d-fixnumexp (x)
23: (d-fixnumcode (d-fixexpand x)))
24:
25:
26: ;--- c-fixnumop :: compute a fixnum result
27: ; This is the extry point into this code from d-exp. The form to evaluate
28: ; is in v-form. The only way we could get here is if the car of v-form
29: ; is a function which we've stated is a fixnum returning function.
30: ;
31: (defun c-fixnumop nil
32: (d-fixnumexp v-form)
33: (d-fixnumbox))
34:
35: ;--- d-fixnumbox :: rebox a fixnum in r5
36: ;
37: #+(or for-vax for-tahoe)
38: (defun d-fixnumbox ()
39: (let (x)
40: (e-write3 'moval (concat "*$5120[" '#.fixnum-reg "]") 'r0)
41: (e-sub3 '($ 1024) '#.fixnum-reg 'r1)
42: (e-write2 'blssu (setq x (d-genlab)))
43: (e-call-qnewint)
44: (e-writel x)
45: (d-clearreg)))
46:
47: #+for-68k
48: (defun d-fixnumbox ()
49: (let (x)
50: (d-regused '#.fixnum-reg)
51: (e-move '#.fixnum-reg 'd0)
52: (e-write3 'asll '($ 2) 'd0)
53: ; add onto the base of the fixnums
54: (e-add (e-cvt '(fixnum 0)) 'd0)
55: (e-move '#.fixnum-reg 'd1)
56: (e-sub '($ 1024) 'd1)
57: (e-write2 'jcs (setq x (d-genlab))) ;branch carry set
58: (e-call-qnewint)
59: (e-writel x)
60: (d-clearreg)))
61:
62: ;--- d-fixexpand :: pass over a fixnum expression doing local optimizations
63: ;
64: ; This code gets the first look at the operands of a fixnum expression.
65: ; It handles the strange cases, like (+) or (/ 3), and it also insures
66: ; that constants are folded (or collapsed as we call it here).
67: ;
68: ; things to watch out for:
69: ; (+ x y z) we can fold x,y,z , likewise in the case of *
70: ; (- x y z) we can only fold y and z since they are negated but x is not,
71: ; likewise for /
72: (defun d-fixexpand (x)
73: (prog nil
74: (setq x (d-macroexpand x))
75: loop
76: (if (and (dtpr x) (symbolp (car x)) (get (car x) 'fixop))
77: then (if (memq (car x) '(+ *))
78: then (setq x (cons (car x)
79: (d-collapse (cdr x) (car x))))
80: else (setq x
81: (cons (car x)
82: (cons (cadr x)
83: (d-collapse (cddr x) (car x))))))
84: (if (null (cdr x))
85: then ; (- or +) => 0 (* or /) => 1
86: (setq x
87: (cdr (assq (car x)
88: '((+ . 0) (- . 0)
89: (* . 1) (/ . 1)))))
90: (go loop)
91: elseif (null (cddr x)) then
92: ; (+ n) => n, (- n) => (- 0 n), (* n) => n,
93: ; (/ n) => (/ 1 n)
94: (setq x
95: (if (memq (car x) '(* +))
96: then (cadr x)
97: elseif (eq (car x) '-)
98: then `(- 0 ,(cadr x))
99: elseif (eq (car x) '/)
100: then `(/ 1 ,(cadr x))
101: else (comp-err
102: "Internal fixexpand error ")))
103: (go loop)))
104: (return x)))
105:
106: ;--- d-toplevmacroexpand :: expand top level form if macro
107: ; a singe level of macro expansion is done. this is a nice general
108: ; routine and should be used by d-exp.
109: ;**** out of date **** will be removed soon
110: (defun d-toplevmacroexpand (x)
111: (let ((fnbnd (and (dtpr x) (symbolp (car x)) (getd (car x)))))
112: (if (and fnbnd (or (and (bcdp fnbnd) (eq (getdisc fnbnd) 'macro))
113: (and (dtpr fnbnd) (eq (car fnbnd) 'macro))))
114: then (d-toplevmacroexpand (apply fnbnd x))
115: else x)))
116:
117:
118: ;--- d-collapse :: collapse (fold) constants
119: ;
120: ; this is used to reduce the number of operations. since we know that
121: ; fixnum operations are commutative.
122: ;
123: (defun d-collapse (form op)
124: (let (const res conlist)
125: ; generate list of constants (conlist) and non constants (res)
126: (do ((xx form (cdr xx)))
127: ((null xx))
128: (if (numberp (car xx))
129: then (if (fixp (car xx))
130: then (setq conlist (cons (car xx) conlist))
131: else (comp-err "Illegal operand in fixnum op "
132: (car xx)))
133: else (setq res (cons (car xx) res))))
134:
135: ; if no constants found thats ok, but if we found some,
136: ; then collapse and return the form with the collapsed constant
137: ; at the end.
138:
139: (if (null conlist)
140: then form ; no change
141: else (setq res (nreverse
142: (cons (apply (cond ((or (eq op '/) (eq op '*)) 'times)
143: (t 'plus))
144: (cons (cond ((or (eq op '/) (eq op '*)) 1)
145: (t 0))
146: conlist))
147: res))))))
148:
149:
150: ;---- d-fixnumcode :: emit code for prescanned fixnum expression
151: ; expr - a expression which should return an unboxed fixnum value
152: ; in r5.
153: ; This function checks if the expression is indeed a guaranteed fixnum
154: ; arithmetic expression, and if so , generates code for the operation.
155: ; If the expression is not a fixnum operation, then a normal evaluation
156: ; of the cdr of the expression is done, which will grab the fixnum value
157: ; and put it in r5.
158: ;
159: #+(or for-vax for-tahoe)
160: (defun d-fixnumcode (expr)
161: (let ((operator (and (dtpr expr)
162: (symbolp (car expr))
163: (get (car expr) 'fixop)))
164: (g-ret nil)
165: tmp)
166: ; the existance of a fixop property on a function says that it is a
167: ; special fixnum only operation.
168: (if (null operator)
169: then (let ((g-loc '#.fixnum-reg) g-cc) ; non fixnum op, do normal
170: (d-exp `(cdr ,expr))) ; eval to get unboxed number
171: else (do ((xx (cdr expr) (cdr xx)) ; fixnum op, scan all args
172: (lop) (rop) (res) (opnd))
173: ((null xx))
174: (setq opnd (car xx))
175: (if (fixp opnd)
176: then (setq rop `(immed ,opnd))
177: elseif (and (symbolp opnd)
178: (setq rop (d-simple `(cdr ,opnd))))
179: thenret
180: else (if (and lop (not (eq lop '#.unCstack)))
181: then (C-push (e-cvt lop))
182: (setq lop '#.unCstack))
183: (d-fixnumcode (d-fixexpand opnd))
184: (setq rop 'r5))
185: (if (null lop)
186: then (if (cdr xx)
187: then (setq lop rop)
188: else (e-move (e-cvt rop) 'r5))
189: else (if (cdr xx)
190: then (setq res '#.Cstack)
191: else (setq res 'r5))
192: (if (setq tmp (d-shiftcheck operator rop))
193: then (e-write4 #+for-vax 'ashl
194: #+for-tahoe 'shal
195: (e-cvt (list 'immed tmp))
196: (e-cvt lop)
197: (e-cvt res))
198: else (e-write4 operator (e-cvt rop)
199: (e-cvt lop)
200: (e-cvt res)))
201: (if (cdr xx)
202: then (setq lop '#.unCstack)
203: else (setq lop "r5")))))))
204:
205: #+for-68k
206: (defun d-fixnumcode (expr)
207: (let ((operator (and (dtpr expr)
208: (symbolp (car expr))
209: (get (car expr) 'fixop)))
210: (g-ret nil)
211: tmp)
212: ; the existance of a fixop property on a function says that it is a
213: ; special fixnum only operation.
214: (makecomment `(d-fixnumcode ,expr))
215: (if (null operator)
216: then (let ((g-loc '#.fixnum-reg) g-cc) ; non fixnum op, do normal
217: (d-exp `(cdr ,expr))) ; eval to get unboxed number
218: (d-regused '#.fixnum-reg)
219: else (do ((xx (cdr expr) (cdr xx)) ; fixnum op, scan all args
220: (lop) (rop) (res) (opnd))
221: ((null xx))
222: (setq opnd (car xx))
223: (if (fixp opnd)
224: then (setq rop `(immed ,opnd))
225: elseif (and (symbolp opnd)
226: (setq rop (d-simple `(cdr ,opnd))))
227: thenret
228: else (if (and lop (not (eq lop '#.unCstack)))
229: then (C-push (e-cvt lop))
230: (setq lop '#.unCstack))
231: (d-fixnumcode (d-fixexpand opnd))
232: (setq rop '#.fixnum-reg))
233: (if (null lop)
234: then (if (cdr xx)
235: then (setq lop rop)
236: else (e-move
237: (e-cvt rop)
238: '#.fixnum-reg))
239: else (if (cdr xx)
240: then (setq res '#.Cstack)
241: else (setq res '#.fixnum-reg))
242: (if (setq tmp (d-shiftcheck operator rop))
243: then (d-asll tmp (e-cvt lop) (e-cvt res))
244: else (e-move (e-cvt lop) 'd0)
245: (e-write3 operator (e-cvt rop) 'd0)
246: (e-move 'd0 (e-cvt res)))
247: (if (cdr xx)
248: then (setq lop '#.unCstack)
249: else (setq lop '#.fixnum-reg)))))
250: (makecomment '(d-fixnumcode done))))
251:
252: ;--- d-shiftcheck :: check if we can shift instead of multiply
253: ; return t if the operator is a multiply and the operand is an
254: ; immediate whose value is a power of two.
255: (defun d-shiftcheck (operator operand)
256: (and (eq operator #+(or for-vax for-tahoe) 'lmul
257: #+for-68k 'mull3)
258: (dtpr operand)
259: (eq (car operand) 'immed)
260: (cdr (assoc (cadr operand) arithequiv))))
261:
262: ; this table is incomplete
263: ;
264: (setq arithequiv '((1 . 0) (2 . 1) (4 . 2) (8 . 3) (16 . 4) (32 . 5)
265: (64 . 6) (128 . 7) (256 . 8) (512 . 9) (1024 . 10)
266: (2048 . 11) (4096 . 12) (8192 . 13) (16384 . 14)
267: (32768 . 15) (65536 . 16) (131072 . 17)))
268:
269:
270: ;--- cc-oneplus :: compile 1+ form = cc-oneplus =
271: ; 1+ increments a fixnum only. We generate code to check if the number
272: ; to be incremented is a small fixnum less than or equal to 1022. This
273: ; check is done by checking the address of the fixnum's box. If the
274: ; number is in that range, we just increment the box pointer by 4.
275: ; otherwise we call we call _qoneplus which does the add and calls
276: ; _qnewint
277: ;
278: #+(or for-vax for-tahoe)
279: (defun cc-oneplus nil
280: (if (null g-loc)
281: then (if (car g-cc) then (e-goto (car g-cc)))
282: else (let ((argloc (d-simple (cadr v-form)))
283: (lab1 (d-genlab))
284: (lab2 (d-genlab)))
285: (if (null argloc)
286: then (let ((g-loc 'r0) g-cc g-ret)
287: (d-exp (cadr v-form)))
288: (setq argloc 'reg))
289: (e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1022))))
290: (e-write2 'jleq lab1)
291: (if (not (eq argloc 'r0)) then (d-move argloc 'reg))
292: (e-quick-call '_qoneplus)
293: (if (and g-loc (not (eq g-loc 'reg)))
294: then (d-move 'reg g-loc))
295: (if (car g-cc)
296: then (e-goto (car g-cc))
297: else (e-goto lab2))
298: (e-label lab1)
299: (e-add3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
300: (if (car g-cc) then (e-goto (car g-cc)))
301: (e-label lab2))))
302:
303: #+for-68k
304: (defun cc-oneplus nil
305: (if (null g-loc)
306: then (if (car g-cc) then (e-goto (car g-cc)))
307: else (let ((argloc (d-simple (cadr v-form)))
308: (lab1 (d-genlab))
309: (lab2 (d-genlab)))
310: (if (null argloc)
311: then (let ((g-loc 'areg) g-cc g-ret)
312: (d-exp (cadr v-form)))
313: (setq argloc 'areg))
314: ; ($ (+ Fixzero (* 4 1022))
315: (d-cmp argloc '(fixnum 1022))
316: (e-write2 'jle lab1)
317: (if (not (eq argloc 'areg)) then (d-move argloc 'areg))
318: (e-quick-call '_qoneplus)
319: (if (and g-loc (not (eq g-loc 'reg)))
320: then (d-move 'reg g-loc))
321: (if (car g-cc)
322: then (e-goto (car g-cc))
323: else (e-goto lab2))
324: (e-label lab1)
325: (if (not (eq argloc 'reg))
326: then (d-move argloc 'reg))
327: (e-write3 'addql "#4" 'd0)
328: (if (and g-loc (not (eq g-loc 'reg)))
329: then (d-move 'reg g-loc))
330: (if (car g-cc) then (e-goto (car g-cc)))
331: (e-label lab2))))
332:
333:
334:
335: ;--- cc-oneminus :: compile the 1- form
336: ; just like 1+ we check to see if we are decrementing an small fixnum.
337: ; and if we are we just decrement the pointer to the fixnum and save
338: ; a call to qinewint. The valid range of fixnums we can decrement are
339: ; 1023 to -1023. This requires two range checks (as opposed to one for 1+).
340: ;
341: #+(or for-vax for-tahoe)
342: (defun cc-oneminus nil
343: (if (null g-loc)
344: then (if (car g-cc) then (e-goto (car g-cc)))
345: else (let ((argloc (d-simple (cadr v-form)))
346: (lab1 (d-genlab))
347: (lab2 (d-genlab))
348: (lab3 (d-genlab)))
349: (if (null argloc)
350: then (let ((g-loc 'r0) g-cc)
351: (d-exp (cadr v-form)))
352: (setq argloc 'reg))
353: (e-cmp (e-cvt argloc) '($ #.(- 5120 (* 4 1024))))
354: (e-write2 'jleq lab1) ; not within range
355: (e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1023))))
356: (e-write2 'jleq lab2) ; within range
357: ; not within range, must do it the hard way.
358: (e-label lab1)
359: (if (not (eq argloc 'r0)) then (d-move argloc 'reg))
360: (e-quick-call '_qoneminus)
361: (if (and g-loc (not (eq g-loc 'reg)))
362: then (d-move 'reg g-loc))
363: (if (car g-cc)
364: then (e-goto (car g-cc))
365: else (e-goto lab3))
366: (e-label lab2)
367: ; we are within range, just decrement the pointer by the
368: ; size of a word (4 bytes).
369: (e-sub3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
370: (if (car g-cc) then (e-goto (car g-cc)))
371: (e-label lab3))))
372:
373: #+for-68k
374: (defun cc-oneminus nil
375: (if (null g-loc)
376: then (if (car g-cc) then (e-goto (car g-cc)))
377: else (let ((argloc (d-simple (cadr v-form)))
378: (lab1 (d-genlab))
379: (lab2 (d-genlab))
380: (lab3 (d-genlab)))
381: (if (null argloc)
382: then (let ((g-loc 'areg) g-cc)
383: (d-exp (cadr v-form)))
384: (setq argloc 'areg))
385: ; ($ (- Fixzero (* 4 1024)))
386: (d-cmp argloc '(fixnum -1024))
387: (e-write2 'jle lab1) ; not within range
388: (d-cmp argloc '(fixnum 1023))
389: (e-write2 'jle lab2) ; within range
390: ; not within range, must do it the hard way.
391: (e-label lab1)
392: (if (not (eq argloc 'areg)) then (d-move argloc 'areg))
393: (e-quick-call '_qoneminus)
394: (if (and g-loc (not (eq g-loc 'reg)))
395: then (d-move 'reg g-loc))
396: (if (car g-cc)
397: then (e-goto (car g-cc))
398: else (e-goto lab3))
399: (e-label lab2)
400: ; we are within range, just decrement the pointer by the
401: ; size of a word (4 bytes).
402: (if (not (eq argloc 'reg))
403: then (d-move argloc 'reg))
404: (e-sub '($ 4) 'd0)
405: (if (and g-loc (not (eq g-loc 'reg)))
406: then (d-move 'reg g-loc))
407: (if (car g-cc) then (e-goto (car g-cc)))
408: (e-label lab3))))
409:
410: ;--- cm-< :: compile a < expression
411: ;
412: ; the operands to this form can either be fixnum or flonums but they
413: ; must be of the same type.
414: ;
415: ; We can compile the form just like an eq form since all we want is
416: ; a compare and a jump. The comparisons are inverted since that is
417: ; the way eq expects it.
418:
419: (defun cm-< nil
420: (if (not (= 2 (length (cdr v-form))))
421: then (comp-err "incorrect number of arguments to < " v-form))
422: ; only can do fixnum stuff if we know that one of the args is
423: ; a fixnum.
424: ;
425: (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
426: then `(<& ,(cadr v-form) ,(caddr v-form))
427: else `(lessp ,(cadr v-form) ,(caddr v-form))))
428:
429: ;--- c-<& :: fixnum <
430: ;
431: ; We can compile the form just like an eq form since all we want is
432: ; a compare and a jump. The comparisons are inverted since that is
433: ; the way eq expects it.
434:
435: (defun cc-<& nil
436: (let ((g-trueop #+(or for-vax for-tahoe) 'jgeq #+for-68k 'jpl)
437: (g-falseop #+(or for-vax for-tahoe) 'jlss #+for-68k 'jmi)
438: (v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
439: (cc-eq)))
440:
441: ;--- cm-> :: compile a > expression
442: ;
443: ; the operands to this form can either be fixnum or flonums but they
444: ; must be of the same type.
445: ; We can compile the form just like an eq form since all we want is
446: ; a compare and a jump. The comparisons are inverted since that is
447: ; the way eq expects it.
448: (defun cm-> nil
449: (if (not (= 2 (length (cdr v-form))))
450: then (comp-err "incorrect number of arguments to > " v-form))
451: ; only can do fixnum stuff if we know that one of the args is
452: ; a fixnum.
453: ;
454: (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
455: then `(>& ,(cadr v-form) ,(caddr v-form))
456: else `(greaterp ,(cadr v-form) ,(caddr v-form))))
457:
458: ;--- cc->& :: compile a fixnum > function
459: ;
460: ; We can compile the form just like an eq form since all we want is
461: ; a compare and a jump. The comparisons are inverted since that is
462: ; the way eq expects it.
463: (defun cc->& nil
464: (let ((g-trueop #+(or for-vax for-tahoe) 'jleq #+for-68k 'jle)
465: (g-falseop #+(or for-vax for-tahoe) 'jgtr #+for-68k 'jgt)
466: (v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
467: (cc-eq)))
468:
469: ;--- cm-= : compile an = expression
470: ; The = function is a strange one. It can compare two fixnums or two
471: ; flonums which is fine on a pdp-10 where they are the same size, but
472: ; is a real pain on a vax where they are different sizes.
473: ; We thus can see if one of the arguments is a fixnum and assume that
474: ; the other one is and then call =&, the fixnum equal code.
475: ;
476: (defun cm-= nil
477: (if (not (= 2 (length (cdr v-form))))
478: then (comp-err "incorrect number of arguments to = : " v-form))
479: (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
480: then `(=& ,(cadr v-form) ,(caddr v-form))
481: else `(equal ,(cadr v-form) ,(caddr v-form))))
482:
483: ;--- cm-=&
484: ;
485: ; if the number is within the small fixnum range, we can just
486: ; do pointer comparisons.
487: ;
488: (defun cm-=& nil
489: (if (or (and (fixp (cadr v-form))
490: (< (cadr v-form) 1024)
491: (> (cadr v-form) -1025))
492: (and (fixp (caddr v-form))
493: (< (caddr v-form) 1024)
494: (> (caddr v-form) -1025)))
495: then `(eq ,(cadr v-form) ,(caddr v-form))
496: else `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
497:
498: ; this should be converted
499: #+(or for-vax for-tahoe)
500: (defun c-\\ nil
501: (d-fixop 'ediv 'remainder))
502:
503: #+(or for-vax for-tahoe)
504: (defun d-fixop (opcode lispopcode)
505: (prog (op1 op2 rop1 rop2 simpleop1)
506: (if (not (eq 3 (length v-form))) ; only handle two ops for now
507: then (d-callbig lispopcode (cdr v-form) nil)
508: else (setq op1 (cadr v-form)
509: op2 (caddr v-form))
510: (if (fixp op1)
511: then (setq rop1 `($ ,op1) ; simple int
512: simpleop1 t)
513: else (if (setq rop1 (d-simple `(cdr ,op1)))
514: then (setq rop1 (e-cvt rop1))
515: else (let ((g-loc 'reg) g-cc g-ret)
516: (d-exp op1))
517: (setq rop1 '(0 r0))))
518: (if (fixp op2)
519: then (setq rop2 `($ ,op2))
520: else (if (setq rop2 (d-simple `(cdr ,op2)))
521: then (setq rop2 (e-cvt rop2))
522: else (C-push rop1)
523: (setq rop1 '#.unCstack)
524: (let ((g-loc 'reg)
525: g-cc g-ret)
526: (d-exp op2))
527: (setq rop2 '(0 r0))))
528: (if (eq opcode 'ediv)
529: then (if (not simpleop1)
530: then #+for-vax (progn (e-move rop1 'r2) ;need quad
531: (e-write4 'ashq '$-32 'r1 'r1))
532: #+for-tahoe (let ((x (d-genlab)))
533: (e-write2 'clrl 'r2)
534: (e-move rop1 'r3)
535: (e-write2 'jgeq x)
536: (e-write3 'mnegl '($ 1) 'r2)
537: (e-writel x))
538: (setq rop1 #+for-vax 'r1 #+for-tahoe 'r2))
539: ; word div.
540: (e-write5 'ediv rop2 rop1 'r0 'r5)
541: else (e-write4 opcode rop2 rop1 'r5))
542: (d-fixnumbox)
543: (d-clearreg))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.