From e5360ef5398575cfcffa66b26e41e8491381c8cb Mon Sep 17 00:00:00 2001 From: CSRG Date: Mon, 25 Apr 1988 20:50:43 -0800 Subject: [PATCH] BSD 4_4 development Work on file usr/src/old/lisp/liszt/fixnum.l Synthesized-from: CSRG/cd3/4.4 --- usr/src/old/lisp/liszt/fixnum.l | 543 ++++++++++++++++++++++++++++++++ 1 file changed, 543 insertions(+) create mode 100644 usr/src/old/lisp/liszt/fixnum.l diff --git a/usr/src/old/lisp/liszt/fixnum.l b/usr/src/old/lisp/liszt/fixnum.l new file mode 100644 index 0000000000..53df64c49b --- /dev/null +++ b/usr/src/old/lisp/liszt/fixnum.l @@ -0,0 +1,543 @@ +(include-if (null (get 'chead 'version)) "../chead.l") +(Liszt-file fixnum + "$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 +; fixnum way. +; 2] the result must be a fixnum, and is left in r5 unboxed. +; +(defun d-fixnumexp (x) + (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. +; +(defun c-fixnumop nil + (d-fixnumexp v-form) + (d-fixnumbox)) + +;--- d-fixnumbox :: rebox a fixnum in r5 +; +#+(or for-vax for-tahoe) +(defun d-fixnumbox () + (let (x) + (e-write3 'moval (concat "*$5120[" '#.fixnum-reg "]") 'r0) + (e-sub3 '($ 1024) '#.fixnum-reg 'r1) + (e-write2 'blssu (setq x (d-genlab))) + (e-call-qnewint) + (e-writel x) + (d-clearreg))) + +#+for-68k +(defun d-fixnumbox () + (let (x) + (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-sub '($ 1024) 'd1) + (e-write2 'jcs (setq x (d-genlab))) ;branch carry set + (e-call-qnewint) + (e-writel x) + (d-clearreg))) + +;--- 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, +; likewise for / +(defun d-fixexpand (x) + (prog nil + (setq x (d-macroexpand x)) + loop + (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)))) + else (setq x + (cons (car x) + (cons (cadr x) + (d-collapse (cddr x) (car x)))))) + (if (null (cdr x)) + then ; (- or +) => 0 (* or /) => 1 + (setq x + (cdr (assq (car x) + '((+ . 0) (- . 0) + (* . 1) (/ . 1))))) + (go loop) + elseif (null (cddr x)) then + ; (+ n) => n, (- n) => (- 0 n), (* n) => n, + ; (/ n) => (/ 1 n) + (setq x + (if (memq (car x) '(* +)) + then (cadr x) + elseif (eq (car x) '-) + then `(- 0 ,(cadr x)) + elseif (eq (car x) '/) + then `(/ 1 ,(cadr x)) + else (comp-err + "Internal fixexpand error "))) + (go loop))) + (return x))) + +;--- 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)) + else 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) + (let (const res conlist) + ; generate list of constants (conlist) and non constants (res) + (do ((xx form (cdr xx))) + ((null xx)) + (if (numberp (car xx)) + then (if (fixp (car xx)) + then (setq conlist (cons (car xx) conlist)) + else (comp-err "Illegal operand in fixnum op " + (car xx))) + 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 + ; at the end. + + (if (null conlist) + then form ; no change + else (setq res (nreverse + (cons (apply (cond ((or (eq op '/) (eq op '*)) 'times) + (t 'plus)) + (cons (cond ((or (eq op '/) (eq op '*)) 1) + (t 0)) + conlist)) + res)))))) + + +;---- d-fixnumcode :: emit code for prescanned fixnum expression +; expr - a expression which should return an unboxed fixnum value +; in r5. +; 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 +; and put it in r5. +; +#+(or for-vax for-tahoe) +(defun d-fixnumcode (expr) + (let ((operator (and (dtpr expr) + (symbolp (car expr)) + (get (car expr) 'fixop))) + (g-ret nil) + tmp) + ; the existance of a fixop property on a function says that it is a + ; special fixnum only operation. + (if (null operator) + 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)) + ((null xx)) + (setq opnd (car xx)) + (if (fixp opnd) + then (setq rop `(immed ,opnd)) + elseif (and (symbolp opnd) + (setq rop (d-simple `(cdr ,opnd)))) + thenret + else (if (and lop (not (eq lop '#.unCstack))) + then (C-push (e-cvt lop)) + (setq lop '#.unCstack)) + (d-fixnumcode (d-fixexpand opnd)) + (setq rop 'r5)) + (if (null lop) + then (if (cdr xx) + then (setq lop rop) + else (e-move (e-cvt rop) 'r5)) + else (if (cdr xx) + then (setq res '#.Cstack) + else (setq res 'r5)) + (if (setq tmp (d-shiftcheck operator rop)) + then (e-write4 #+for-vax 'ashl + #+for-tahoe 'shal + (e-cvt (list 'immed tmp)) + (e-cvt lop) + (e-cvt res)) + else (e-write4 operator (e-cvt rop) + (e-cvt lop) + (e-cvt res))) + (if (cdr xx) + then (setq lop '#.unCstack) + else (setq lop "r5"))))))) + +#+for-68k +(defun d-fixnumcode (expr) + (let ((operator (and (dtpr expr) + (symbolp (car expr)) + (get (car expr) 'fixop))) + (g-ret nil) + tmp) + ; the existance of a fixop property on a function says that it is a + ; special fixnum only operation. + (makecomment `(d-fixnumcode ,expr)) + (if (null operator) + 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)) + ((null xx)) + (setq opnd (car xx)) + (if (fixp opnd) + then (setq rop `(immed ,opnd)) + elseif (and (symbolp opnd) + (setq rop (d-simple `(cdr ,opnd)))) + thenret + else (if (and lop (not (eq lop '#.unCstack))) + then (C-push (e-cvt lop)) + (setq lop '#.unCstack)) + (d-fixnumcode (d-fixexpand opnd)) + (setq rop '#.fixnum-reg)) + (if (null lop) + then (if (cdr xx) + then (setq lop rop) + else (e-move + (e-cvt rop) + '#.fixnum-reg)) + else (if (cdr xx) + 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))) + (if (cdr xx) + 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 + #+for-68k 'mull3) + (dtpr operand) + (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 +; _qnewint +; +#+(or for-vax for-tahoe) +(defun cc-oneplus nil + (if (null g-loc) + then (if (car g-cc) then (e-goto (car g-cc))) + else (let ((argloc (d-simple (cadr v-form))) + (lab1 (d-genlab)) + (lab2 (d-genlab))) + (if (null argloc) + then (let ((g-loc 'r0) g-cc g-ret) + (d-exp (cadr v-form))) + (setq argloc 'reg)) + (e-cmp (e-cvt argloc) '($ #.(+ 5120 (* 4 1022)))) + (e-write2 'jleq lab1) + (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)) + (if (car g-cc) + then (e-goto (car g-cc)) + else (e-goto lab2)) + (e-label lab1) + (e-add3 '($ 4) (e-cvt argloc) (e-cvt g-loc)) + (if (car g-cc) then (e-goto (car g-cc))) + (e-label lab2)))) + +#+for-68k +(defun cc-oneplus nil + (if (null g-loc) + then (if (car g-cc) then (e-goto (car g-cc))) + else (let ((argloc (d-simple (cadr v-form))) + (lab1 (d-genlab)) + (lab2 (d-genlab))) + (if (null argloc) + then (let ((g-loc 'areg) g-cc g-ret) + (d-exp (cadr v-form))) + (setq argloc 'areg)) + ; ($ (+ Fixzero (* 4 1022)) + (d-cmp argloc '(fixnum 1022)) + (e-write2 'jle lab1) + (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 (car g-cc) + then (e-goto (car g-cc)) + else (e-goto lab2)) + (e-label lab1) + (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))) + (e-label lab2)))) + + + +;--- 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+). +; +#+(or for-vax for-tahoe) +(defun cc-oneminus nil + (if (null g-loc) + then (if (car g-cc) then (e-goto (car g-cc))) + else (let ((argloc (d-simple (cadr v-form))) + (lab1 (d-genlab)) + (lab2 (d-genlab)) + (lab3 (d-genlab))) + (if (null argloc) + then (let ((g-loc 'r0) g-cc) + (d-exp (cadr v-form))) + (setq argloc 'reg)) + (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. + (e-label lab1) + (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)) + (if (car g-cc) + then (e-goto (car g-cc)) + else (e-goto lab3)) + (e-label lab2) + ; 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))) + (e-label lab3)))) + +#+for-68k +(defun cc-oneminus nil + (if (null g-loc) + then (if (car g-cc) then (e-goto (car g-cc))) + else (let ((argloc (d-simple (cadr v-form))) + (lab1 (d-genlab)) + (lab2 (d-genlab)) + (lab3 (d-genlab))) + (if (null argloc) + then (let ((g-loc 'areg) g-cc) + (d-exp (cadr v-form))) + (setq argloc 'areg)) + ; ($ (- 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. + (e-label lab1) + (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)) + (if (car g-cc) + then (e-goto (car g-cc)) + else (e-goto lab3)) + (e-label lab2) + ; 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)) + (e-sub '($ 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))) + (e-label lab3)))) + +;--- 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 +; the way eq expects it. + +(defun cm-< nil + (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 + ; a fixnum. + ; + (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)))) + +;--- c-<& :: fixnum < +; +; 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 +; the way eq expects it. + +(defun cc-<& nil + (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))))) + (cc-eq))) + +;--- 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 +; the way eq expects it. +(defun cm-> nil + (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 + ; a fixnum. + ; + (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 +; the way eq expects it. +(defun cc->& nil + (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))))) + (cc-eq))) + +;--- 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. +; +(defun cm-= nil + (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)))) + +;--- cm-=& +; +; if the number is within the small fixnum range, we can just +; do pointer comparisons. +; +(defun cm-=& nil + (if (or (and (fixp (cadr v-form)) + (< (cadr v-form) 1024) + (> (cadr v-form) -1025)) + (and (fixp (caddr v-form)) + (< (caddr v-form) 1024) + (> (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 +#+(or for-vax for-tahoe) +(defun c-\\ nil + (d-fixop 'ediv 'remainder)) + +#+(or for-vax for-tahoe) +(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) + op2 (caddr v-form)) + (if (fixp op1) + then (setq rop1 `($ ,op1) ; simple int + simpleop1 t) + else (if (setq rop1 (d-simple `(cdr ,op1))) + then (setq rop1 (e-cvt rop1)) + else (let ((g-loc 'reg) g-cc g-ret) + (d-exp op1)) + (setq rop1 '(0 r0)))) + (if (fixp op2) + then (setq rop2 `($ ,op2)) + else (if (setq rop2 (d-simple `(cdr ,op2))) + then (setq rop2 (e-cvt rop2)) + else (C-push rop1) + (setq rop1 '#.unCstack) + (let ((g-loc 'reg) + g-cc g-ret) + (d-exp op2)) + (setq rop2 '(0 r0)))) + (if (eq opcode 'ediv) + then (if (not simpleop1) + then #+for-vax (progn (e-move rop1 'r2) ;need quad + (e-write4 'ashq '$-32 'r1 'r1)) + #+for-tahoe (let ((x (d-genlab))) + (e-write2 'clrl 'r2) + (e-move rop1 'r3) + (e-write2 'jgeq x) + (e-write3 'mnegl '($ 1) 'r2) + (e-writel x)) + (setq rop1 #+for-vax 'r1 #+for-tahoe 'r2)) + ; word div. + (e-write5 'ediv rop2 rop1 'r0 'r5) + else (e-write4 opcode rop2 rop1 'r5)) + (d-fixnumbox) + (d-clearreg)))) -- 2.20.1