![[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] / 42BSD / ucb / lisp / liszt|
Return to fixnum.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file fixnum
3: "$Header: fixnum.l,v 1.14 83/08/28 17:13:38 layer 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: #+for-vax
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: #+for-vax
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 'ashl
194: (e-cvt (list 'immed tmp))
195: (e-cvt lop)
196: (e-cvt res))
197: else (e-write4 operator (e-cvt rop)
198: (e-cvt lop)
199: (e-cvt res)))
200: (if (cdr xx)
201: then (setq lop '#.unCstack)
202: else (setq lop "r5")))))))
203:
204: #+for-68k
205: (defun d-fixnumcode (expr)
206: (let ((operator (and (dtpr expr)
207: (symbolp (car expr))
208: (get (car expr) 'fixop)))
209: (g-ret nil)
210: tmp)
211: ; the existance of a fixop property on a function says that it is a
212: ; special fixnum only operation.
213: (makecomment `(d-fixnumcode ,expr))
214: (if (null operator)
215: then (let ((g-loc '#.fixnum-reg) g-cc) ; non fixnum op, do normal
216: (d-exp `(cdr ,expr))) ; eval to get unboxed number
217: (d-regused '#.fixnum-reg)
218: else (do ((xx (cdr expr) (cdr xx)) ; fixnum op, scan all args
219: (lop) (rop) (res) (opnd))
220: ((null xx))
221: (setq opnd (car xx))
222: (if (fixp opnd)
223: then (setq rop `(immed ,opnd))
224: elseif (and (symbolp opnd)
225: (setq rop (d-simple `(cdr ,opnd))))
226: thenret
227: else (if (and lop (not (eq lop '#.unCstack)))
228: then (C-push (e-cvt lop))
229: (setq lop '#.unCstack))
230: (d-fixnumcode (d-fixexpand opnd))
231: (setq rop '#.fixnum-reg))
232: (if (null lop)
233: then (if (cdr xx)
234: then (setq lop rop)
235: else (e-move
236: (e-cvt rop)
237: '#.fixnum-reg))
238: else (if (cdr xx)
239: then (setq res '#.Cstack)
240: else (setq res '#.fixnum-reg))
241: (if (setq tmp (d-shiftcheck operator rop))
242: then (d-asll tmp (e-cvt lop) (e-cvt res))
243: else (e-move (e-cvt lop) 'd0)
244: (e-write3 operator (e-cvt rop) 'd0)
245: (e-move 'd0 (e-cvt res)))
246: (if (cdr xx)
247: then (setq lop '#.unCstack)
248: else (setq lop '#.fixnum-reg)))))
249: (makecomment '(d-fixnumcode done))))
250:
251: ;--- d-shiftcheck :: check if we can shift instead of multiply
252: ; return t if the operator is a multiply and the operand is an
253: ; immediate whose value is a power of two.
254: (defun d-shiftcheck (operator operand)
255: (and (eq operator #+for-vax 'lmul
256: #+for-68k 'mull3)
257: (dtpr operand)
258: (eq (car operand) 'immed)
259: (cdr (assoc (cadr operand) arithequiv))))
260:
261: ; this table is incomplete
262: ;
263: (setq arithequiv '((1 . 0) (2 . 1) (4 . 2) (8 . 3) (16 . 4) (32 . 5)
264: (64 . 6) (128 . 7) (256 . 8) (512 . 9) (1024 . 10)
265: (2048 . 11) (4096 . 12) (8192 . 13) (16384 . 14)
266: (32768 . 15) (65536 . 16) (131072 . 17)))
267:
268:
269: ;--- cc-oneplus :: compile 1+ form = cc-oneplus =
270: ; 1+ increments a fixnum only. We generate code to check if the number
271: ; to be incremented is a small fixnum less than or equal to 1022. This
272: ; check is done by checking the address of the fixnum's box. If the
273: ; number is in that range, we just increment the box pointer by 4.
274: ; otherwise we call we call _qoneplus which does the add and calls
275: ; _qnewint
276: ;
277: #+for-vax
278: (defun cc-oneplus nil
279: (if (null g-loc)
280: then (if (car g-cc) then (e-goto (car g-cc)))
281: else (let ((argloc (d-simple (cadr v-form)))
282: (lab1 (d-genlab))
283: (lab2 (d-genlab)))
284: (if (null argloc)
285: then (let ((g-loc 'r0) g-cc g-ret)
286: (d-exp (cadr v-form)))
287: (setq argloc 'reg))
288: (e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1022))))
289: (e-write2 'jleq lab1)
290: (if (not (eq argloc 'r0)) then (d-move argloc 'reg))
291: (e-quick-call '_qoneplus)
292: (if (and g-loc (not (eq g-loc 'reg)))
293: then (d-move 'reg g-loc))
294: (if (car g-cc)
295: then (e-goto (car g-cc))
296: else (e-goto lab2))
297: (e-label lab1)
298: (e-add3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
299: (if (car g-cc) then (e-goto (car g-cc)))
300: (e-label lab2))))
301:
302: #+for-68k
303: (defun cc-oneplus nil
304: (if (null g-loc)
305: then (if (car g-cc) then (e-goto (car g-cc)))
306: else (let ((argloc (d-simple (cadr v-form)))
307: (lab1 (d-genlab))
308: (lab2 (d-genlab)))
309: (if (null argloc)
310: then (let ((g-loc 'areg) g-cc g-ret)
311: (d-exp (cadr v-form)))
312: (setq argloc 'areg))
313: ; ($ (+ Fixzero (* 4 1022))
314: (d-cmp argloc '(fixnum 1022))
315: (e-write2 'jle lab1)
316: (if (not (eq argloc 'areg)) then (d-move argloc 'areg))
317: (e-quick-call '_qoneplus)
318: (if (and g-loc (not (eq g-loc 'reg)))
319: then (d-move 'reg g-loc))
320: (if (car g-cc)
321: then (e-goto (car g-cc))
322: else (e-goto lab2))
323: (e-label lab1)
324: (if (not (eq argloc 'reg))
325: then (d-move argloc 'reg))
326: (e-write3 'addql "#4" 'd0)
327: (if (and g-loc (not (eq g-loc 'reg)))
328: then (d-move 'reg g-loc))
329: (if (car g-cc) then (e-goto (car g-cc)))
330: (e-label lab2))))
331:
332:
333:
334: ;--- cc-oneminus :: compile the 1- form
335: ; just like 1+ we check to see if we are decrementing an small fixnum.
336: ; and if we are we just decrement the pointer to the fixnum and save
337: ; a call to qinewint. The valid range of fixnums we can decrement are
338: ; 1023 to -1023. This requires two range checks (as opposed to one for 1+).
339: ;
340: #+for-vax
341: (defun cc-oneminus nil
342: (if (null g-loc)
343: then (if (car g-cc) then (e-goto (car g-cc)))
344: else (let ((argloc (d-simple (cadr v-form)))
345: (lab1 (d-genlab))
346: (lab2 (d-genlab))
347: (lab3 (d-genlab)))
348: (if (null argloc)
349: then (let ((g-loc 'r0) g-cc)
350: (d-exp (cadr v-form)))
351: (setq argloc 'reg))
352: (e-cmp (e-cvt argloc) '($ #.(- 5120 (* 4 1024))))
353: (e-write2 'jleq lab1) ; not within range
354: (e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1023))))
355: (e-write2 'jleq lab2) ; within range
356: ; not within range, must do it the hard way.
357: (e-label lab1)
358: (if (not (eq argloc 'r0)) then (d-move argloc 'reg))
359: (e-quick-call '_qoneminus)
360: (if (and g-loc (not (eq g-loc 'reg)))
361: then (d-move 'reg g-loc))
362: (if (car g-cc)
363: then (e-goto (car g-cc))
364: else (e-goto lab3))
365: (e-label lab2)
366: ; we are within range, just decrement the pointer by the
367: ; size of a word (4 bytes).
368: (e-sub3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
369: (if (car g-cc) then (e-goto (car g-cc)))
370: (e-label lab3))))
371:
372: #+for-68k
373: (defun cc-oneminus nil
374: (if (null g-loc)
375: then (if (car g-cc) then (e-goto (car g-cc)))
376: else (let ((argloc (d-simple (cadr v-form)))
377: (lab1 (d-genlab))
378: (lab2 (d-genlab))
379: (lab3 (d-genlab)))
380: (if (null argloc)
381: then (let ((g-loc 'areg) g-cc)
382: (d-exp (cadr v-form)))
383: (setq argloc 'areg))
384: ; ($ (- Fixzero (* 4 1024)))
385: (d-cmp argloc '(fixnum -1024))
386: (e-write2 'jle lab1) ; not within range
387: (d-cmp argloc '(fixnum 1023))
388: (e-write2 'jle lab2) ; within range
389: ; not within range, must do it the hard way.
390: (e-label lab1)
391: (if (not (eq argloc 'areg)) then (d-move argloc 'areg))
392: (e-quick-call '_qoneminus)
393: (if (and g-loc (not (eq g-loc 'reg)))
394: then (d-move 'reg g-loc))
395: (if (car g-cc)
396: then (e-goto (car g-cc))
397: else (e-goto lab3))
398: (e-label lab2)
399: ; we are within range, just decrement the pointer by the
400: ; size of a word (4 bytes).
401: (if (not (eq argloc 'reg))
402: then (d-move argloc 'reg))
403: (e-sub '($ 4) 'd0)
404: (if (and g-loc (not (eq g-loc 'reg)))
405: then (d-move 'reg g-loc))
406: (if (car g-cc) then (e-goto (car g-cc)))
407: (e-label lab3))))
408:
409: ;--- cm-< :: compile a < expression
410: ;
411: ; the operands to this form can either be fixnum or flonums but they
412: ; must be of the same type.
413: ;
414: ; We can compile the form just like an eq form since all we want is
415: ; a compare and a jump. The comparisons are inverted since that is
416: ; the way eq expects it.
417:
418: (defun cm-< nil
419: (if (not (= 2 (length (cdr v-form))))
420: then (comp-err "incorrect number of arguments to < " v-form))
421: ; only can do fixnum stuff if we know that one of the args is
422: ; a fixnum.
423: ;
424: (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
425: then `(<& ,(cadr v-form) ,(caddr v-form))
426: else `(lessp ,(cadr v-form) ,(caddr v-form))))
427:
428: ;--- c-<& :: fixnum <
429: ;
430: ; We can compile the form just like an eq form since all we want is
431: ; a compare and a jump. The comparisons are inverted since that is
432: ; the way eq expects it.
433:
434: (defun cc-<& nil
435: (let ((g-trueop #+for-vax 'jgeq #+for-68k 'jpl)
436: (g-falseop #+for-vax 'jlss #+for-68k 'jmi)
437: (v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
438: (cc-eq)))
439:
440: ;--- cm-> :: compile a > expression
441: ;
442: ; the operands to this form can either be fixnum or flonums but they
443: ; must be of the same type.
444: ; We can compile the form just like an eq form since all we want is
445: ; a compare and a jump. The comparisons are inverted since that is
446: ; the way eq expects it.
447: (defun cm-> nil
448: (if (not (= 2 (length (cdr v-form))))
449: then (comp-err "incorrect number of arguments to > " v-form))
450: ; only can do fixnum stuff if we know that one of the args is
451: ; a fixnum.
452: ;
453: (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
454: then `(>& ,(cadr v-form) ,(caddr v-form))
455: else `(greaterp ,(cadr v-form) ,(caddr v-form))))
456:
457: ;--- cc->& :: compile a fixnum > function
458: ;
459: ; We can compile the form just like an eq form since all we want is
460: ; a compare and a jump. The comparisons are inverted since that is
461: ; the way eq expects it.
462: (defun cc->& nil
463: (let ((g-trueop #+for-vax 'jleq #+for-68k 'jle)
464: (g-falseop #+for-vax 'jgtr #+for-68k 'jgt)
465: (v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
466: (cc-eq)))
467:
468: ;--- cm-= : compile an = expression
469: ; The = function is a strange one. It can compare two fixnums or two
470: ; flonums which is fine on a pdp-10 where they are the same size, but
471: ; is a real pain on a vax where they are different sizes.
472: ; We thus can see if one of the arguments is a fixnum and assume that
473: ; the other one is and then call =&, the fixnum equal code.
474: ;
475: (defun cm-= nil
476: (if (not (= 2 (length (cdr v-form))))
477: then (comp-err "incorrect number of arguments to = : " v-form))
478: (if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
479: then `(=& ,(cadr v-form) ,(caddr v-form))
480: else `(equal ,(cadr v-form) ,(caddr v-form))))
481:
482: ;--- cm-=&
483: ;
484: ; if the number is within the small fixnum range, we can just
485: ; do pointer comparisons.
486: ;
487: (defun cm-=& nil
488: (if (or (and (fixp (cadr v-form))
489: (< (cadr v-form) 1024)
490: (> (cadr v-form) -1025))
491: (and (fixp (caddr v-form))
492: (< (caddr v-form) 1024)
493: (> (caddr v-form) -1025)))
494: then `(eq ,(cadr v-form) ,(caddr v-form))
495: else `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
496:
497: ; this should be converted
498: #+for-vax
499: (defun c-\\ nil
500: (d-fixop 'ediv 'remainder))
501:
502: #+for-vax
503: (defun d-fixop (opcode lispopcode)
504: (prog (op1 op2 rop1 rop2 simpleop1)
505: (if (not (eq 3 (length v-form))) ; only handle two ops for now
506: then (d-callbig lispopcode (cdr v-form) nil)
507: else (setq op1 (cadr v-form)
508: op2 (caddr v-form))
509: (if (fixp op1)
510: then (setq rop1 `($ ,op1) ; simple int
511: simpleop1 t)
512: else (if (setq rop1 (d-simple `(cdr ,op1)))
513: then (setq rop1 (e-cvt rop1))
514: else (let ((g-loc 'reg) g-cc g-ret)
515: (d-exp op1))
516: (setq rop1 '(0 r0))))
517: (if (fixp op2)
518: then (setq rop2 `($ ,op2))
519: else (if (setq rop2 (d-simple `(cdr ,op2)))
520: then (setq rop2 (e-cvt rop2))
521: else (C-push rop1)
522: (setq rop1 '#.unCstack)
523: (let ((g-loc 'reg)
524: g-cc g-ret)
525: (d-exp op2))
526: (setq rop2 '(0 r0))))
527: (if (eq opcode 'ediv)
528: then (if (not simpleop1)
529: then (e-move rop1 'r2) ; need quad
530: (e-write4 'ashq '$-32 'r1 'r1)
531: (setq rop1 'r1)) ; word div.
532: (e-write5 'ediv rop2 rop1 'r0 'r5)
533: else (e-write4 opcode rop2 rop1 'r5))
534: (d-fixnumbox)
535: (d-clearreg))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.