Allow any unsigned-reg for the check-type and type-predicate temporary.
authorCarl Shapiro <cshapiro@common-lisp.net>
Thu, 8 Aug 2013 07:19:52 +0000 (00:19 -0700)
committerCarl Shapiro <cshapiro@common-lisp.net>
Thu, 8 Aug 2013 07:19:52 +0000 (00:19 -0700)
src/compiler/x86/type-vops.lisp

index 2597c6d..95ede9d 100644 (file)
@@ -60,7 +60,7 @@
        (emit-test)))
     (results)))
 
-(defmacro test-type (value target not-p &rest type-codes)
+(defmacro test-type (value temp target not-p &rest type-codes)
   ;; Determine what interesting combinations we need to test for.
   (let* ((type-codes (mapcar #'eval type-codes))
         (fixnump (and (member even-fixnum-type type-codes)
@@ -90,7 +90,7 @@
       (when immediates
        (error "Can't mix fixnum testing with other immediates."))
       (if headers
-         `(%test-fixnum-and-headers ,value ,target ,not-p
+         `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
                                     ',(canonicalize-headers headers))
          `(%test-fixnum ,value ,target ,not-p)))
      (immediates
        (error "Can't mix testing of immediates with testing of lowtags."))
       (when (cdr immediates)
        (error "Can't test multiple immediates at the same time."))
-      `(%test-immediate ,value ,target ,not-p ,(car immediates)))
+      `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
      (lowtags
       (when (cdr lowtags)
        (error "Can't test multiple lowtags at the same time."))
       (if headers
          `(%test-lowtag-and-headers
-           ,value ,target ,not-p ,(car lowtags)
+           ,value ,temp ,target ,not-p ,(car lowtags)
            ,function-p ',(canonicalize-headers headers))
-         `(%test-lowtag ,value ,target ,not-p ,(car lowtags))))
+         `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
      (headers
-      `(%test-headers ,value ,target ,not-p ,function-p
+      `(%test-headers ,value ,temp ,target ,not-p ,function-p
                      ',(canonicalize-headers headers)))
      (t
       (error "Nothing to test?")))))
   (generate-fixnum-test value)
   (inst jmp (if not-p :nz :z) target))
 
-(defun %test-fixnum-and-headers (value target not-p headers)
+(defun %test-fixnum-and-headers (value temp target not-p headers)
   (let ((drop-through (gen-label)))
     (generate-fixnum-test value)
     (inst jmp :z (if not-p drop-through target))
-    (%test-headers value target not-p nil headers drop-through)))
+    (%test-headers value temp target not-p nil headers drop-through)))
 
-(defun %test-immediate (value target not-p immediate)
+(defun %test-immediate (value temp target not-p immediate)
   ;; Code a single instruction byte test if possible.
   (let ((offset (tn-offset value)))
     (cond ((and (sc-is value any-reg descriptor-reg)
                                     :offset offset)
                 immediate))
          (t
-          (move eax-tn value)
-          (inst cmp al-tn immediate))))
+          (move temp value)
+          (inst and temp type-mask)
+          (inst cmp temp immediate))))
   (inst jmp (if not-p :ne :e) target))
 
-(defun %test-lowtag (value target not-p lowtag &optional al-loaded)
-  (unless al-loaded
-    (move eax-tn value)
-    (inst and al-tn lowtag-mask))
-  (inst cmp al-tn lowtag)
+(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded)
+  (unless temp-loaded
+    (move temp value)
+    (inst and temp lowtag-mask))
+  (inst cmp temp lowtag)
   (inst jmp (if not-p :ne :e) target))
 
-(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers)
+(defun %test-lowtag-and-headers (value temp target not-p lowtag
+                                      function-p headers)
   (let ((drop-through (gen-label)))
-    (%test-lowtag value (if not-p drop-through target) nil lowtag)
-    (%test-headers value target not-p function-p headers drop-through t)))
+    (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
+    (%test-headers value temp target not-p function-p headers drop-through t)))
 
 
-(defun %test-headers (value target not-p function-p headers
-                           &optional (drop-through (gen-label)) al-loaded)
+(defun %test-headers (value temp target not-p function-p headers
+                           &optional (drop-through (gen-label)) temp-loaded)
   (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
     (multiple-value-bind
        (equal less-or-equal when-true when-false)
        (if not-p
            (values :ne :a drop-through target)
            (values :e :na target drop-through))
-      (%test-lowtag value when-false t lowtag al-loaded)
-      (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+      (%test-lowtag value temp when-false t lowtag temp-loaded)
+      (load-type temp value (- lowtag))
       (do ((remaining headers (cdr remaining)))
          ((null remaining))
        (let ((header (car remaining))
              (last (null (cdr remaining))))
          (cond
           ((atom header)
-           (inst cmp al-tn header)
+           (inst cmp temp header)
            (if last
                (inst jmp equal target)
                (inst jmp :e when-true)))
             (let ((start (car header))
                   (end (cdr header)))
               (unless (= start bignum-type)
-                (inst cmp al-tn start)
+                (inst cmp temp start)
                 (inst jmp :b when-false)) ; was :l
-              (inst cmp al-tn end)
+              (inst cmp temp end)
               (if last
                   (inst jmp less-or-equal target)
                   (inst jmp :be when-true))))))) ; was :le
 ;; both cmp and sub take 2 cycles so maybe its a wash
 #+nil
 (defun %test-headers (value target not-p function-p headers
-                           &optional (drop-through (gen-label)) al-loaded)
+                           &optional (drop-through (gen-label)) temp-loaded)
   (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
     (multiple-value-bind
        (equal less-or-equal when-true when-false)
        (if not-p
            (values :ne :a drop-through target)
            (values :e :na target drop-through))
-      (%test-lowtag value when-false t lowtag al-loaded)
-      (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+      (%test-lowtag value when-false t lowtag temp-loaded)
+      (load-type temp value (- lowtag))
       (let ((delta 0))
        (do ((remaining headers (cdr remaining)))
            ((null remaining))
                (last (null (cdr remaining))))
            (cond
              ((atom header)
-              (inst sub al-tn (- header delta))
+              (inst sub temp (- header delta))
               (setf delta header)
               (if last
                   (inst jmp equal target)
               (let ((start (car header))
                     (end (cdr header)))
                 (unless (= start bignum-type)
-                  (inst sub al-tn (- start delta))
+                  (inst sub temp (- start delta))
                   (setf delta start)
                   (inst jmp :l when-false))
-                (inst sub al-tn (- end delta))
+                (inst sub temp (- end delta))
                 (setf delta end)
                 (if last
                     (inst jmp less-or-equal target)
 (define-vop (check-type)
   (:args (value :target result :scs (any-reg descriptor-reg)))
   (:results (result :scs (any-reg descriptor-reg)))
-  (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
-  (:ignore eax)
+  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
   (:vop-var vop)
   (:save-p :compute-only))
 
 (define-vop (type-predicate)
   (:args (value :scs (any-reg descriptor-reg)))
-  (:temporary (:sc unsigned-reg :offset eax-offset) eax)
-  (:ignore eax)
+  (:temporary (:scs (unsigned-reg)) temp)
   (:conditional)
   (:info target not-p)
   (:policy :fast-safe))
           `((define-vop (,pred-name type-predicate)
               (:translate ,pred-name)
               (:generator ,cost
-                (test-type value target not-p ,@type-codes)))))
+                (test-type value temp target not-p ,@type-codes)))))
        ,@(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)
+                  (test-type value temp err-lab t ,@type-codes)
                   (move result value))))))
        ,@(when ptype
           `((primitive-type-vop ,check-name (:check) ,ptype))))))
           `((define-vop (,pred-name simple-type-predicate)
               (:translate ,pred-name)
               (:generator ,cost
-                (test-type value target not-p ,@type-codes)))))
+                (test-type value temp target not-p ,@type-codes)))))
        ,@(when check-name
           `((define-vop (,check-name simple-check-type)
               (:generator ,cost
                 (let ((err-lab
                        (generate-error-code vop ,error-code value)))
-                  (test-type value err-lab t ,@type-codes)
+                  (test-type value temp err-lab t ,@type-codes)
                   (move result value))))))
        ,@(when ptype
           `((primitive-type-vop ,check-name (:check) ,ptype))))))
            (values target not-target))
       (generate-fixnum-test value)
       (inst jmp :e yep)
-      (move eax-tn value)
-      (inst and al-tn lowtag-mask)
-      (inst cmp al-tn other-pointer-type)
+      (move temp value)
+      (inst and temp lowtag-mask)
+      (inst cmp temp other-pointer-type)
       (inst jmp :ne nope)
-      (loadw eax-tn value 0 other-pointer-type)
-      (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+      (loadw temp value 0 other-pointer-type)
+      (inst cmp temp (+ (ash 1 type-bits) bignum-type))
       (inst jmp (if not-p :ne :e) target))
     NOT-TARGET))
 
                                     value)))
       (generate-fixnum-test value)
       (inst jmp :e yep)
-      (move eax-tn value)
-      (inst and al-tn lowtag-mask)
-      (inst cmp al-tn other-pointer-type)
+      (move temp value)
+      (inst and temp lowtag-mask)
+      (inst cmp temp other-pointer-type)
       (inst jmp :ne nope)
-      (loadw eax-tn value 0 other-pointer-type)
-      (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+      (loadw temp value 0 other-pointer-type)
+      (inst cmp temp (+ (ash 1 type-bits) bignum-type))
       (inst jmp :ne nope))
     YEP
     (move result value)))
              (values target not-target))
        ;; Is it a fixnum?
        (generate-fixnum-test value)
-       (move eax-tn value)
+       (move temp value)
        (inst jmp :e fixnum)
 
        ;; If not, is it an other pointer?
-       (inst and al-tn lowtag-mask)
-       (inst cmp al-tn other-pointer-type)
+       (inst and temp lowtag-mask)
+       (inst cmp temp other-pointer-type)
        (inst jmp :ne nope)
        ;; Get the header.
-       (loadw eax-tn value 0 other-pointer-type)
+       (loadw temp value 0 other-pointer-type)
        ;; Is it one?
-       (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+       (inst cmp temp (+ (ash 1 type-bits) bignum-type))
        (inst jmp :e single-word)
        ;; If it's other than two, we can't be an (unsigned-byte 32)
-       (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
+       (inst cmp temp (+ (ash 2 type-bits) bignum-type))
        (inst jmp :ne nope)
        ;; Get the second digit.
-       (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+       (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
        ;; All zeros, its an (unsigned-byte 32).
-       (inst or eax-tn eax-tn)
+       (inst test temp temp)
        (inst jmp :z yep)
        (inst jmp nope)
        
        (emit-label single-word)
        ;; Get the single digit.
-       (loadw eax-tn value bignum-digits-offset other-pointer-type)
+       (loadw temp value bignum-digits-offset other-pointer-type)
 
        ;; positive implies (unsigned-byte 32).
        (emit-label fixnum)
-       (inst or eax-tn eax-tn)
+       (inst test temp temp)
        (inst jmp (if not-p :s :ns) target)
 
        (emit-label not-target)))))
 
       ;; Is it a fixnum?
       (generate-fixnum-test value)
-      (move eax-tn value)
+      (move temp value)
       (inst jmp :e fixnum)
 
       ;; If not, is it an other pointer?
-      (inst and al-tn lowtag-mask)
-      (inst cmp al-tn other-pointer-type)
+      (inst and temp lowtag-mask)
+      (inst cmp temp other-pointer-type)
       (inst jmp :ne nope)
       ;; Get the header.
-      (loadw eax-tn value 0 other-pointer-type)
+      (loadw temp value 0 other-pointer-type)
       ;; Is it one?
-      (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+      (inst cmp temp (+ (ash 1 type-bits) bignum-type))
       (inst jmp :e single-word)
       ;; If it's other than two, we can't be an (unsigned-byte 32)
-      (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
+      (inst cmp temp (+ (ash 2 type-bits) bignum-type))
       (inst jmp :ne nope)
       ;; Get the second digit.
-      (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+      (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
       ;; All zeros, its an (unsigned-byte 32).
-      (inst or eax-tn eax-tn)
+      (inst or temp temp)
       (inst jmp :z yep)
       (inst jmp nope)
        
       (emit-label single-word)
       ;; Get the single digit.
-      (loadw eax-tn value bignum-digits-offset other-pointer-type)
+      (loadw temp value bignum-digits-offset other-pointer-type)
 
       ;; positive implies (unsigned-byte 32).
       (emit-label fixnum)
-      (inst or eax-tn eax-tn)
+      (inst or temp temp)
       (inst jmp :s nope)
 
       (emit-label yep)
     (let ((is-symbol-label (if not-p drop-thru target)))
       (inst cmp value nil-value)
       (inst jmp :e is-symbol-label)
-      (test-type value target not-p symbol-header-type))
+      (test-type value temp target not-p symbol-header-type))
     DROP-THRU))
 
 (define-vop (check-symbol check-type)
     (let ((error (generate-error-code vop object-not-symbol-error value)))
       (inst cmp value nil-value)
       (inst jmp :e drop-thru)
-      (test-type value error t symbol-header-type))
+      (test-type value temp error t symbol-header-type))
     DROP-THRU
     (move result value)))
   
     (let ((is-not-cons-label (if not-p target drop-thru)))
       (inst cmp value nil-value)
       (inst jmp :e is-not-cons-label)
-      (test-type value target not-p list-pointer-type))
+      (test-type value temp target not-p list-pointer-type))
     DROP-THRU))
 
 (define-vop (check-cons check-type)
     (let ((error (generate-error-code vop object-not-cons-error value)))
       (inst cmp value nil-value)
       (inst jmp :e error)
-      (test-type value error t list-pointer-type)
+      (test-type value temp error t list-pointer-type)
       (move result value))))