X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fhppa%2Ftype-vops.lisp;h=7953a332724999ba0fa3d380353a35a0ada5e662;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=cf5de08ce88b67682fe0f3b148c4679195fc5be7;hpb=45c05300d987de3278a713b9929f2716b257f082;p=sbcl.git diff --git a/src/compiler/hppa/type-vops.lisp b/src/compiler/hppa/type-vops.lisp index cf5de08..7953a33 100644 --- a/src/compiler/hppa/type-vops.lisp +++ b/src/compiler/hppa/type-vops.lisp @@ -24,61 +24,52 @@ (inst extru value 31 2 zero-tn :<>) (inst b (if not-p drop-through target) :nullify t)) (%test-headers value target not-p nil headers - :drop-through drop-through :temp temp))) + :drop-through drop-through :temp temp))) (defun %test-immediate (value target not-p immediate &key temp) (assemble () (inst extru value 31 8 temp) (inst bci := not-p immediate temp target))) -(defun %test-lowtag (value target not-p lowtag - &key temp temp-loaded) +(defun %test-lowtag (value target not-p lowtag &key temp temp-loaded) (assemble () (unless temp-loaded (inst extru value 31 3 temp)) (inst bci := not-p lowtag temp target))) -(defun %test-lowtag-and-headers (value target not-p lowtag - function-p headers &key temp) - (let ((drop-through (gen-label))) - (%test-lowtag value (if not-p drop-through target) nil lowtag - :temp temp) - (%test-headers value target not-p function-p headers - :drop-through drop-through :temp temp :temp-loaded t))) - (defun %test-headers (value target not-p function-p headers - &key temp (drop-through (gen-label)) temp-loaded) + &key temp (drop-through (gen-label)) temp-loaded) (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) (multiple-value-bind - (equal greater-or-equal when-true when-false) - ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to - ;; TARGET. WHEN-TRUE and WHEN-FALSE are the labels to branch to when - ;; we know it's true and when we know it's false respectively. - (if not-p - (values :<> :< drop-through target) - (values := :>= target drop-through)) + (equal greater-or-equal when-true when-false) + ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to + ;; TARGET. WHEN-TRUE and WHEN-FALSE are the labels to branch to when + ;; we know it's true and when we know it's false respectively. + (if not-p + (values :<> :< drop-through target) + (values := :>= target drop-through)) (assemble () - (%test-lowtag value when-false t lowtag - :temp temp :temp-loaded temp-loaded) - (inst ldb (- 3 lowtag) value temp) - (do ((remaining headers (cdr remaining))) - ((null remaining)) - (let ((header (car remaining)) - (last (null (cdr remaining)))) - (cond - ((atom header) - (if last - (inst bci equal nil header temp target) - (inst bci := nil header temp when-true))) - (t - (let ((start (car header)) - (end (cdr header))) - (unless (= start bignum-widetag) - (inst bci :> nil start temp when-false)) - (if last - (inst bci greater-or-equal nil end temp target) - (inst bci :>= nil end temp when-true))))))) - (emit-label drop-through))))) + (%test-lowtag value when-false t lowtag + :temp temp :temp-loaded temp-loaded) + (inst ldb (- 3 lowtag) value temp) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (if last + (inst bci equal nil header temp target) + (inst bci := nil header temp when-true))) + (t + (let ((start (car header)) + (end (cdr header))) + (unless (= start bignum-widetag) + (inst bci :> nil start temp when-false)) + (if last + (inst bci greater-or-equal nil end temp target) + (inst bci :>= nil end temp when-true))))))) + (emit-label drop-through))))) ;;;; Type checking and testing: @@ -101,36 +92,35 @@ (if (> (apply #'max type-codes) lowtag-limit) 7 2))) (defmacro !define-type-vops (pred-name check-name ptype error-code - (&rest type-codes) - &key &allow-other-keys) + (&rest type-codes) + &key &allow-other-keys) (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) `(progn ,@(when pred-name - `((define-vop (,pred-name type-predicate) - (:translate ,pred-name) - (:generator ,cost - (test-type value target not-p (,@type-codes) :temp temp))))) + `((define-vop (,pred-name type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value target not-p (,@type-codes) :temp temp))))) ,@(when check-name - `((define-vop (,check-name check-type) - (:generator ,cost - (let ((err-lab - (generate-error-code vop ,error-code value))) - (test-type value err-lab t (,@type-codes) :temp temp) - (move value result)))))) + `((define-vop (,check-name check-type) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value err-lab t (,@type-codes) :temp temp) + (move value result)))))) ,@(when ptype - `((primitive-type-vop ,check-name (:check) ,ptype)))))) + `((primitive-type-vop ,check-name (:check) ,ptype)))))) ;;;; Other integer ranges. ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with ;;; exactly one digit. - (defun signed-byte-32-test (value temp not-p target not-target) (multiple-value-bind (yep nope) (if not-p - (values not-target target) - (values target not-target)) + (values not-target target) + (values target not-target)) (assemble () (inst extru value 31 2 zero-tn :<>) (inst b yep :nullify t) @@ -149,7 +139,7 @@ (define-vop (check-signed-byte-32 check-type) (:generator 45 (let ((loose (generate-error-code vop object-not-signed-byte-32-error - value))) + value))) (signed-byte-32-test value temp t loose okay)) OKAY (move value result))) @@ -157,14 +147,13 @@ ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a ;;; bignum with exactly one positive digit, or a bignum with exactly two digits ;;; and the second digit all zeros. - (defun unsigned-byte-32-test (value temp not-p target not-target) (let ((nope (if not-p target not-target))) (assemble () ;; Is it a fixnum? (inst extru value 31 2 zero-tn :<>) (inst b fixnum) - (inst move value temp) + (move value temp t) ;; If not, is it an other pointer? (inst extru value 31 3 temp) @@ -178,9 +167,11 @@ ;; Get the second digit. (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag) ;; All zeros, its an (unsigned-byte 32). - (inst comb (if not-p := :<>) temp zero-tn not-target :nullify t) - (inst b target :nullify t) - + ;; Dont nullify comb here, because we cant guarantee target is forward + (inst comb (if not-p := :<>) temp zero-tn not-target) + (inst nop) + (inst b target) + SINGLE-WORD ;; Get the single digit. (loadw temp value bignum-digits-offset other-pointer-lowtag) @@ -199,14 +190,14 @@ (define-vop (check-unsigned-byte-32 check-type) (:generator 45 (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error - value))) + value))) (unsigned-byte-32-test value temp t loose okay)) OKAY (move value result))) ;;;; List/symbol types: -;;; +;;; ;;; symbolp (or symbol (eq nil)) ;;; consp (and list (not (eq nil))) @@ -224,7 +215,7 @@ (test-type value error t (symbol-header-widetag) :temp temp)) DROP-THRU (move value result))) - + (define-vop (consp type-predicate) (:translate consp) (:generator 8