(include-if (null (get 'chead 'version)) "../chead.l")
"$Header: /usr/src/local/franz/liszt/RCS/fixnum.l,v 1.16 88/04/26 11:50:18 sklower Exp $")
;;; ---- f i x n u m fixnum compilation
;;; -[Fri Aug 26 14:07:53 1983 by layer]-
; There are a few functions in lisp which are only permitted to take
; fixnum operands and produce fixnum results. The compiler recognizes
; these functions and open codes them.
;--- d-fixnumexp :: compute a fixnum from an expression
; x - a lisp expression which must return a fixnum
; This is an almost equivalent to d-exp, except that
; 1] it will do clever things if the expression can be open coded in a
; 2] the result must be a fixnum, and is left in r5 unboxed.
(d-fixnumcode (d-fixexpand x)))
;--- c-fixnumop :: compute a fixnum result
; This is the extry point into this code from d-exp. The form to evaluate
; is in v-form. The only way we could get here is if the car of v-form
; is a function which we've stated is a fixnum returning function.
;--- d-fixnumbox :: rebox a fixnum in r5
(e-write3 'moval (concat "*$5120[" '#.fixnum-reg "]") 'r0)
(e-sub3 '($ 1024) '#.fixnum-reg 'r1)
(e-write2 'blssu (setq x (d-genlab)))
(d-regused '#.fixnum-reg)
(e-move '#.fixnum-reg 'd0)
(e-write3 'asll '($ 2) 'd0)
; add onto the base of the fixnums
(e-add (e-cvt '(fixnum 0)) 'd0)
(e-move '#.fixnum-reg 'd1)
(e-write2 'jcs (setq x (d-genlab))) ;branch carry set
;--- d-fixexpand :: pass over a fixnum expression doing local optimizations
; This code gets the first look at the operands of a fixnum expression.
; It handles the strange cases, like (+) or (/ 3), and it also insures
; that constants are folded (or collapsed as we call it here).
; things to watch out for:
; (+ x y z) we can fold x,y,z , likewise in the case of *
; (- x y z) we can only fold y and z since they are negated but x is not,
(setq x (d-macroexpand x))
(if (and (dtpr x) (symbolp (car x)) (get (car x) 'fixop))
then (if (memq (car x) '(+ *))
then (setq x (cons (car x)
(d-collapse (cdr x) (car x))))
(d-collapse (cddr x) (car x))))))
then ; (- or +) => 0 (* or /) => 1
elseif (null (cddr x)) then
; (+ n) => n, (- n) => (- 0 n), (* n) => n,
(if (memq (car x) '(* +))
"Internal fixexpand error ")))
;--- d-toplevmacroexpand :: expand top level form if macro
; a singe level of macro expansion is done. this is a nice general
; routine and should be used by d-exp.
;**** out of date **** will be removed soon
(defun d-toplevmacroexpand (x)
(let ((fnbnd (and (dtpr x) (symbolp (car x)) (getd (car x)))))
(if (and fnbnd (or (and (bcdp fnbnd) (eq (getdisc fnbnd) 'macro))
(and (dtpr fnbnd) (eq (car fnbnd) 'macro))))
then (d-toplevmacroexpand (apply fnbnd x))
;--- d-collapse :: collapse (fold) constants
; this is used to reduce the number of operations. since we know that
; fixnum operations are commutative.
(defun d-collapse (form op)
; generate list of constants (conlist) and non constants (res)
then (setq conlist (cons (car xx) conlist))
else (comp-err "Illegal operand in fixnum op "
else (setq res (cons (car xx) res))))
; if no constants found thats ok, but if we found some,
; then collapse and return the form with the collapsed constant
(cons (apply (cond ((or (eq op '/) (eq op '*)) 'times)
(cons (cond ((or (eq op '/) (eq op '*)) 1)
;---- d-fixnumcode :: emit code for prescanned fixnum expression
; expr - a expression which should return an unboxed fixnum value
; This function checks if the expression is indeed a guaranteed fixnum
; arithmetic expression, and if so , generates code for the operation.
; If the expression is not a fixnum operation, then a normal evaluation
; of the cdr of the expression is done, which will grab the fixnum value
(defun d-fixnumcode (expr)
(let ((operator (and (dtpr expr)
(get (car expr) 'fixop)))
; the existance of a fixop property on a function says that it is a
; special fixnum only operation.
then (let ((g-loc '#.fixnum-reg) g-cc) ; non fixnum op, do normal
(d-exp `(cdr ,expr))) ; eval to get unboxed number
else (do ((xx (cdr expr) (cdr xx)) ; fixnum op, scan all args
(lop) (rop) (res) (opnd))
then (setq rop `(immed ,opnd))
elseif (and (symbolp opnd)
(setq rop (d-simple `(cdr ,opnd))))
else (if (and lop (not (eq lop '#.unCstack)))
then (C-push (e-cvt lop))
(d-fixnumcode (d-fixexpand opnd))
else (e-move (e-cvt rop) 'r5))
then (setq res '#.Cstack)
(if (setq tmp (d-shiftcheck operator rop))
then (e-write4 #+for-vax 'ashl
(e-cvt (list 'immed tmp))
else (e-write4 operator (e-cvt rop)
then (setq lop '#.unCstack)
else (setq lop "r5")))))))
(defun d-fixnumcode (expr)
(let ((operator (and (dtpr expr)
(get (car expr) 'fixop)))
; the existance of a fixop property on a function says that it is a
; special fixnum only operation.
(makecomment `(d-fixnumcode ,expr))
then (let ((g-loc '#.fixnum-reg) g-cc) ; non fixnum op, do normal
(d-exp `(cdr ,expr))) ; eval to get unboxed number
(d-regused '#.fixnum-reg)
else (do ((xx (cdr expr) (cdr xx)) ; fixnum op, scan all args
(lop) (rop) (res) (opnd))
then (setq rop `(immed ,opnd))
elseif (and (symbolp opnd)
(setq rop (d-simple `(cdr ,opnd))))
else (if (and lop (not (eq lop '#.unCstack)))
then (C-push (e-cvt lop))
(d-fixnumcode (d-fixexpand opnd))
(setq rop '#.fixnum-reg))
then (setq res '#.Cstack)
else (setq res '#.fixnum-reg))
(if (setq tmp (d-shiftcheck operator rop))
then (d-asll tmp (e-cvt lop) (e-cvt res))
else (e-move (e-cvt lop) 'd0)
(e-write3 operator (e-cvt rop) 'd0)
(e-move 'd0 (e-cvt res)))
then (setq lop '#.unCstack)
else (setq lop '#.fixnum-reg)))))
(makecomment '(d-fixnumcode done))))
;--- d-shiftcheck :: check if we can shift instead of multiply
; return t if the operator is a multiply and the operand is an
; immediate whose value is a power of two.
(defun d-shiftcheck (operator operand)
(and (eq operator #+(or for-vax for-tahoe) 'lmul
(eq (car operand) 'immed)
(cdr (assoc (cadr operand) arithequiv))))
; this table is incomplete
(setq arithequiv '((1 . 0) (2 . 1) (4 . 2) (8 . 3) (16 . 4) (32 . 5)
(64 . 6) (128 . 7) (256 . 8) (512 . 9) (1024 . 10)
(2048 . 11) (4096 . 12) (8192 . 13) (16384 . 14)
(32768 . 15) (65536 . 16) (131072 . 17)))
;--- cc-oneplus :: compile 1+ form = cc-oneplus =
; 1+ increments a fixnum only. We generate code to check if the number
; to be incremented is a small fixnum less than or equal to 1022. This
; check is done by checking the address of the fixnum's box. If the
; number is in that range, we just increment the box pointer by 4.
; otherwise we call we call _qoneplus which does the add and calls
then (if (car g-cc) then (e-goto (car g-cc)))
else (let ((argloc (d-simple (cadr v-form)))
then (let ((g-loc 'r0) g-cc g-ret)
(e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1022))))
(if (not (eq argloc 'r0)) then (d-move argloc 'reg))
(e-quick-call '_qoneplus)
(if (and g-loc (not (eq g-loc 'reg)))
then (d-move 'reg g-loc))
(e-add3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
(if (car g-cc) then (e-goto (car g-cc)))
then (if (car g-cc) then (e-goto (car g-cc)))
else (let ((argloc (d-simple (cadr v-form)))
then (let ((g-loc 'areg) g-cc g-ret)
; ($ (+ Fixzero (* 4 1022))
(d-cmp argloc '(fixnum 1022))
(if (not (eq argloc 'areg)) then (d-move argloc 'areg))
(e-quick-call '_qoneplus)
(if (and g-loc (not (eq g-loc 'reg)))
then (d-move 'reg g-loc))
(if (not (eq argloc 'reg))
then (d-move argloc 'reg))
(e-write3 'addql "#4" 'd0)
(if (and g-loc (not (eq g-loc 'reg)))
then (d-move 'reg g-loc))
(if (car g-cc) then (e-goto (car g-cc)))
;--- cc-oneminus :: compile the 1- form
; just like 1+ we check to see if we are decrementing an small fixnum.
; and if we are we just decrement the pointer to the fixnum and save
; a call to qinewint. The valid range of fixnums we can decrement are
; 1023 to -1023. This requires two range checks (as opposed to one for 1+).
then (if (car g-cc) then (e-goto (car g-cc)))
else (let ((argloc (d-simple (cadr v-form)))
then (let ((g-loc 'r0) g-cc)
(e-cmp (e-cvt argloc) '($ #.(- 5120 (* 4 1024))))
(e-write2 'jleq lab1) ; not within range
(e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1023))))
(e-write2 'jleq lab2) ; within range
; not within range, must do it the hard way.
(if (not (eq argloc 'r0)) then (d-move argloc 'reg))
(e-quick-call '_qoneminus)
(if (and g-loc (not (eq g-loc 'reg)))
then (d-move 'reg g-loc))
; we are within range, just decrement the pointer by the
; size of a word (4 bytes).
(e-sub3 '($ 4) (e-cvt argloc) (e-cvt g-loc))
(if (car g-cc) then (e-goto (car g-cc)))
then (if (car g-cc) then (e-goto (car g-cc)))
else (let ((argloc (d-simple (cadr v-form)))
then (let ((g-loc 'areg) g-cc)
; ($ (- Fixzero (* 4 1024)))
(d-cmp argloc '(fixnum -1024))
(e-write2 'jle lab1) ; not within range
(d-cmp argloc '(fixnum 1023))
(e-write2 'jle lab2) ; within range
; not within range, must do it the hard way.
(if (not (eq argloc 'areg)) then (d-move argloc 'areg))
(e-quick-call '_qoneminus)
(if (and g-loc (not (eq g-loc 'reg)))
then (d-move 'reg g-loc))
; we are within range, just decrement the pointer by the
; size of a word (4 bytes).
(if (not (eq argloc 'reg))
then (d-move argloc 'reg))
(if (and g-loc (not (eq g-loc 'reg)))
then (d-move 'reg g-loc))
(if (car g-cc) then (e-goto (car g-cc)))
;--- cm-< :: compile a < expression
; the operands to this form can either be fixnum or flonums but they
; must be of the same type.
; We can compile the form just like an eq form since all we want is
; a compare and a jump. The comparisons are inverted since that is
(if (not (= 2 (length (cdr v-form))))
then (comp-err "incorrect number of arguments to < " v-form))
; only can do fixnum stuff if we know that one of the args is
(if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
then `(<& ,(cadr v-form) ,(caddr v-form))
else `(lessp ,(cadr v-form) ,(caddr v-form))))
; We can compile the form just like an eq form since all we want is
; a compare and a jump. The comparisons are inverted since that is
(let ((g-trueop #+(or for-vax for-tahoe) 'jgeq #+for-68k 'jpl)
(g-falseop #+(or for-vax for-tahoe) 'jlss #+for-68k 'jmi)
(v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
;--- cm-> :: compile a > expression
; the operands to this form can either be fixnum or flonums but they
; must be of the same type.
; We can compile the form just like an eq form since all we want is
; a compare and a jump. The comparisons are inverted since that is
(if (not (= 2 (length (cdr v-form))))
then (comp-err "incorrect number of arguments to > " v-form))
; only can do fixnum stuff if we know that one of the args is
(if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
then `(>& ,(cadr v-form) ,(caddr v-form))
else `(greaterp ,(cadr v-form) ,(caddr v-form))))
;--- cc->& :: compile a fixnum > function
; We can compile the form just like an eq form since all we want is
; a compare and a jump. The comparisons are inverted since that is
(let ((g-trueop #+(or for-vax for-tahoe) 'jleq #+for-68k 'jle)
(g-falseop #+(or for-vax for-tahoe) 'jgtr #+for-68k 'jgt)
(v-form `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
;--- cm-= : compile an = expression
; The = function is a strange one. It can compare two fixnums or two
; flonums which is fine on a pdp-10 where they are the same size, but
; is a real pain on a vax where they are different sizes.
; We thus can see if one of the arguments is a fixnum and assume that
; the other one is and then call =&, the fixnum equal code.
(if (not (= 2 (length (cdr v-form))))
then (comp-err "incorrect number of arguments to = : " v-form))
(if (or (fixp (cadr v-form)) (fixp (caddr v-form)))
then `(=& ,(cadr v-form) ,(caddr v-form))
else `(equal ,(cadr v-form) ,(caddr v-form))))
; if the number is within the small fixnum range, we can just
; do pointer comparisons.
(if (or (and (fixp (cadr v-form))
(and (fixp (caddr v-form))
(> (caddr v-form) -1025)))
then `(eq ,(cadr v-form) ,(caddr v-form))
else `(eq (cdr ,(cadr v-form)) (cdr ,(caddr v-form)))))
; this should be converted
(d-fixop 'ediv 'remainder))
(defun d-fixop (opcode lispopcode)
(prog (op1 op2 rop1 rop2 simpleop1)
(if (not (eq 3 (length v-form))) ; only handle two ops for now
then (d-callbig lispopcode (cdr v-form) nil)
else (setq op1 (cadr v-form)
then (setq rop1 `($ ,op1) ; simple int
else (if (setq rop1 (d-simple `(cdr ,op1)))
then (setq rop1 (e-cvt rop1))
else (let ((g-loc 'reg) g-cc g-ret)
then (setq rop2 `($ ,op2))
else (if (setq rop2 (d-simple `(cdr ,op2)))
then (setq rop2 (e-cvt rop2))
then #+for-vax (progn (e-move rop1 'r2) ;need quad
(e-write4 'ashq '$-32 'r1 'r1))
#+for-tahoe (let ((x (d-genlab)))
(e-write3 'mnegl '($ 1) 'r2)
(setq rop1 #+for-vax 'r1 #+for-tahoe 'r2))
(e-write5 'ediv rop2 rop1 'r0 'r5)
else (e-write4 opcode rop2 rop1 'r5))