X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsparc%2Ftype-vops.lisp;h=3185d8e4c91b78b9ab9306d59b148467163238e6;hb=369029d73f198b59135c6c005b7a70ae5a753650;hp=e9de8dff0a5a63a6e70d6218b6d4be6a0c07af88;hpb=faa0ea92986f4c2b361c9378c69a540e42a70c62;p=sbcl.git

diff --git a/src/compiler/sparc/type-vops.lisp b/src/compiler/sparc/type-vops.lisp
index e9de8df..3185d8e 100644
--- a/src/compiler/sparc/type-vops.lisp
+++ b/src/compiler/sparc/type-vops.lisp
@@ -11,6 +11,92 @@
 
 (in-package "SB!VM")
 
+
+(defun %test-fixnum (value target not-p &key temp)
+  (declare (ignore temp))
+  (assemble ()
+    (inst andcc zero-tn value fixnum-tag-mask)
+    (if (member :sparc-v9 *backend-subfeatures*)
+	(inst b (if not-p :ne :eq) target (if not-p :pn :pt))
+	(inst b (if not-p :ne :eq) target))
+    (inst nop)))
+
+(defun %test-fixnum-and-headers (value target not-p headers
+				 &key temp)
+  (let ((drop-through (gen-label)))
+    (assemble ()
+      (inst andcc zero-tn value fixnum-tag-mask)
+      (inst b :eq (if not-p drop-through target)))
+    (%test-headers value target not-p nil headers
+		   :drop-through drop-through
+		   :temp temp)))
+
+(defun %test-immediate (value target not-p immediate &key temp)
+  (assemble ()
+    (inst and temp value widetag-mask)
+    (inst cmp temp immediate)
+    ;; FIXME: include SPARC-V9 magic
+    (inst b (if not-p :ne :eq) target)
+    (inst nop)))
+
+(defun %test-lowtag (value target not-p lowtag
+		     &key temp skip-nop)
+  (assemble ()
+    (inst and temp value lowtag-mask)
+    (inst cmp temp lowtag)
+    ;; FIXME: include SPARC-V9 magic
+    (inst b (if not-p :ne :eq) target)
+    (unless skip-nop
+      (inst nop))))
+
+(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) not-p lowtag
+		  :temp temp :skip-nop t)
+    (%test-headers value target not-p function-p headers
+		   :temp temp :drop-through drop-through)))
+
+(defun %test-headers (value target not-p function-p headers
+		      &key temp (drop-through (gen-label)))
+  (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
+    (multiple-value-bind (when-true when-false)
+	(if not-p
+	    (values drop-through target)
+	    (values target drop-through))
+      (assemble ()
+	(%test-lowtag value when-false t lowtag :temp temp)
+	(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 temp header)
+	       (if last
+		   ;; FIXME: Some SPARC-V9 magic might not go amiss
+		   ;; here, too, if I can figure out what it should
+		   ;; be.
+		   (inst b (if not-p :ne :eq) target)
+		   (inst b :eq when-true)))
+	      (t
+	       (let ((start (car header))
+		     (end (cdr header)))
+		 ;; FIXME: BIGNUM-WIDETAG here actually means (MIN
+		 ;; <widetags>).
+		 (unless (= start bignum-widetag)
+		   (inst cmp temp start)
+		   (inst b :lt when-false))
+		 ;; FIXME: conceivably, it might be worth having a
+		 ;; (MAX <widetags>) here too.
+		 (inst cmp temp end)
+		 (if last
+		     (inst b (if not-p :gt :le) target)
+		     (inst b :le when-true)))))))
+	(inst nop)
+	(emit-label drop-through)))))
+
 ;;;; Simple type checking and testing:
 ;;;
 ;;; These types are represented by a single type code, so are easily
@@ -29,342 +115,39 @@
   (:policy :fast-safe)
   (:temporary (:scs (non-descriptor-reg)) temp))
 
-;;; moved to macros. FIXME.
-;;;(defun cost-to-test-types (type-codes)
-;;;  (+ (* 2 (length type-codes))
-;;;     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
-;;;
-;;;(defparameter immediate-types
-;;;  (list base-char-type unbound-marker-type))
-;;;
-;;;(defparameter function-header-types
-;;;  (list funcallable-instance-header-type
-;;;        byte-code-function-type byte-code-closure-type
-;;;        function-header-type closure-function-header-type
-;;;        closure-header-type))
-;;;
-;; FIXME: there's a canonicalize-headers in alpha/ and x86/
+(defun cost-to-test-types (type-codes)
+  (+ (* 2 (length type-codes))
+     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 
-(defmacro def-type-vops (pred-name check-name ptype error-code
-			 &rest type-codes)
-  ;;; FIXME: #+sb-xc-host?
+(defmacro !define-type-vops (pred-name check-name ptype error-code
+			 (&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 temp target not-p ,@type-codes)))))
-       ,@(when check-name
+		 (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 temp err-lab t ,@type-codes)
+		   (test-type value err-lab t (,@type-codes)
+			      :temp temp)
 		   (move result value))))))
        ,@(when ptype
 	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
 
-;;; This is a direct translation of the code in CMUCL
-;;; compiler/sparc/macros.lisp. Don't blame me if it doesn't work.
-
-;;; moved test-type back to macros.lisp, as other bits of code use it
-;;; too. FIXME.
-
-
-
-
-  
-;; Don't use this because it uses the deprecated taddcctv instruction.
-#+ignore
-(progn
-  (def-type-vops fixnump nil nil nil even-fixnum-lowtag odd-fixnum-lowtag)
-  (define-vop (check-fixnum check-type)
-      (:ignore temp)
-    (:generator 1
-		(inst taddcctv result value zero-tn)))
-  (primitive-type-vop check-fixnum (:check) fixnum))
-  
-;; This avoids the taddcctv instruction
-(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
-	       even-fixnum-lowtag odd-fixnum-lowtag)
-(def-type-vops functionp check-fun function
-	       object-not-fun-error fun-pointer-lowtag)
-  
-  ;; The following encode the error type and register in the trap
-  ;; instruction, however this breaks on the later sparc Ultra.
-  #+ignore
-  (progn
-    (def-type-vops listp nil nil nil list-pointer-lowtag)
-    (define-vop (check-list check-type)
-	(:generator 3
-		    (inst and temp value lowtag-mask)
-		    (inst cmp temp list-pointer-lowtag)
-		    (inst t :ne (logior (ash (tn-offset value) 8) object-not-list-trap))
-		    (move result value)))
-    (primitive-type-vop check-list (:check) list)
-    
-    (def-type-vops %instancep nil nil nil instance-pointer-lowtag)
-    (define-vop (check-instance check-type)
-	(:generator 3
-		    (inst and temp value lowtag-mask)
-		    (inst cmp temp instance-pointer-lowtag)
-		    (inst t :ne (logior (ash (tn-offset value) 8) object-not-instance-trap))
-		    (move result value)))
-    (primitive-type-vop check-instance (:check) instance))
-
-  ;; These avoid the trap instruction.
-  (def-type-vops listp check-list list object-not-list-error
-  list-pointer-lowtag)
-  (def-type-vops %instancep check-instance instance object-not-instance-error
-  instance-pointer-lowtag)
-      
-  (def-type-vops bignump check-bignum bignum
-  object-not-bignum-error bignum-widetag)
-      
-  (def-type-vops ratiop check-ratio ratio
-  object-not-ratio-error ratio-widetag)
-      
-  (def-type-vops complexp check-complex complex object-not-complex-error
-  complex-widetag complex-single-float-widetag
-  complex-double-float-widetag #!+long-float complex-long-float-widetag)
-
-  (def-type-vops complex-rational-p check-complex-rational nil
-  object-not-complex-rational-error complex-widetag)
-
-  (def-type-vops complex-float-p check-complex-float nil
-  object-not-complex-float-error
-  complex-single-float-widetag complex-double-float-widetag
-  #!+long-float complex-long-float-widetag)
-
-  (def-type-vops complex-single-float-p check-complex-single-float
-  complex-single-float object-not-complex-single-float-error
-  complex-single-float-widetag)
-
-  (def-type-vops complex-double-float-p check-complex-double-float
-  complex-double-float object-not-complex-double-float-error
-  complex-double-float-widetag)
-
-  #!+long-float
-  (def-type-vops complex-long-float-p check-complex-long-float
-  complex-long-float object-not-complex-long-float-error
-  complex-long-float-widetag)
-
-  (def-type-vops single-float-p check-single-float single-float
-  object-not-single-float-error single-float-widetag)
-
-  (def-type-vops double-float-p check-double-float double-float
-  object-not-double-float-error double-float-widetag)
-
-  #!+long-float
-  (def-type-vops long-float-p check-long-float long-float
-  object-not-long-float-error long-float-widetag)
-
-  (def-type-vops simple-string-p check-simple-string simple-string
-  object-not-simple-string-error simple-string-widetag)
-
-  (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
-  object-not-simple-bit-vector-error simple-bit-vector-widetag)
-      
-  (def-type-vops simple-vector-p check-simple-vector simple-vector
-  object-not-simple-vector-error simple-vector-widetag)
-      
-  (def-type-vops simple-array-unsigned-byte-2-p
-  check-simple-array-unsigned-byte-2
-  simple-array-unsigned-byte-2
-  object-not-simple-array-unsigned-byte-2-error
-  simple-array-unsigned-byte-2-widetag)
-      
-  (def-type-vops simple-array-unsigned-byte-4-p
-  check-simple-array-unsigned-byte-4
-  simple-array-unsigned-byte-4
-  object-not-simple-array-unsigned-byte-4-error
-  simple-array-unsigned-byte-4-widetag)
-
-  (def-type-vops simple-array-unsigned-byte-8-p
-  check-simple-array-unsigned-byte-8
-  simple-array-unsigned-byte-8
-  object-not-simple-array-unsigned-byte-8-error
-  simple-array-unsigned-byte-8-widetag)
-
-  (def-type-vops simple-array-unsigned-byte-16-p
-  check-simple-array-unsigned-byte-16
-  simple-array-unsigned-byte-16
-  object-not-simple-array-unsigned-byte-16-error
-  simple-array-unsigned-byte-16-widetag)
-
-  (def-type-vops simple-array-unsigned-byte-32-p
-  check-simple-array-unsigned-byte-32
-  simple-array-unsigned-byte-32
-  object-not-simple-array-unsigned-byte-32-error
-  simple-array-unsigned-byte-32-widetag)
-
-  (def-type-vops simple-array-signed-byte-8-p
-  check-simple-array-signed-byte-8
-  simple-array-signed-byte-8
-  object-not-simple-array-signed-byte-8-error
-  simple-array-signed-byte-8-widetag)
-
-  (def-type-vops simple-array-signed-byte-16-p
-  check-simple-array-signed-byte-16
-  simple-array-signed-byte-16
-  object-not-simple-array-signed-byte-16-error
-  simple-array-signed-byte-16-widetag)
-
-  (def-type-vops simple-array-signed-byte-30-p
-  check-simple-array-signed-byte-30
-  simple-array-signed-byte-30
-  object-not-simple-array-signed-byte-30-error
-  simple-array-signed-byte-30-widetag)
-
-  (def-type-vops simple-array-signed-byte-32-p
-  check-simple-array-signed-byte-32
-  simple-array-signed-byte-32
-  object-not-simple-array-signed-byte-32-error
-  simple-array-signed-byte-32-widetag)
-      
-  (def-type-vops simple-array-single-float-p check-simple-array-single-float
-  simple-array-single-float object-not-simple-array-single-float-error
-  simple-array-single-float-widetag)
-
-  (def-type-vops simple-array-double-float-p check-simple-array-double-float
-  simple-array-double-float object-not-simple-array-double-float-error
-  simple-array-double-float-widetag)
-
-  #!+long-float
-  (def-type-vops simple-array-long-float-p check-simple-array-long-float
-  simple-array-long-float object-not-simple-array-long-float-error
-  simple-array-long-float-widetag)
-      
-  (def-type-vops simple-array-complex-single-float-p
-  check-simple-array-complex-single-float
-  simple-array-complex-single-float
-  object-not-simple-array-complex-single-float-error
-  simple-array-complex-single-float-widetag)
-      
-  (def-type-vops simple-array-complex-double-float-p
-  check-simple-array-complex-double-float
-  simple-array-complex-double-float
-  object-not-simple-array-complex-double-float-error
-  simple-array-complex-double-float-widetag)
-      
-  #!+long-float
-  (def-type-vops simple-array-complex-long-float-p
-  check-simple-array-complex-long-float
-  simple-array-complex-long-float
-  object-not-simple-array-complex-long-float-error
-  simple-array-complex-long-float-widetag)
-
-  (def-type-vops base-char-p check-base-char base-char
-  object-not-base-char-error base-char-widetag)
-      
-  (def-type-vops system-area-pointer-p check-system-area-pointer
-  system-area-pointer object-not-sap-error sap-widetag)
-      
-  (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
-  object-not-weak-pointer-error weak-pointer-widetag)
-  ;; FIXME
-#|       
-  (def-type-vops scavenger-hook-p nil nil nil
-  0)
-|#
-  (def-type-vops code-component-p nil nil nil
-  code-header-widetag)
-      
-  (def-type-vops lra-p nil nil nil
-  return-pc-header-widetag)
-
-  (def-type-vops fdefn-p nil nil nil
-  fdefn-widetag)
-
-  (def-type-vops funcallable-instance-p nil nil nil
-  funcallable-instance-header-widetag)
-      
-  (def-type-vops array-header-p nil nil nil
-  simple-array-widetag complex-string-widetag complex-bit-vector-widetag
-  complex-vector-widetag complex-array-widetag)
-
-  ;; This appears to have disappeared. FIXME -- CSR
-  (def-type-vops nil check-fun-or-symbol nil object-not-fun-or-symbol-error
-  fun-pointer-lowtag symbol-header-widetag)
-      
-  (def-type-vops stringp check-string nil object-not-string-error
-  simple-string-widetag complex-string-widetag)
-      
-  (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
-  simple-bit-vector-widetag complex-bit-vector-widetag)
-
-  (def-type-vops vectorp check-vector nil object-not-vector-error
-  simple-string-widetag simple-bit-vector-widetag simple-vector-widetag
-  simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag
-  simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag
-  simple-array-unsigned-byte-32-widetag
-  simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
-  simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
-  simple-array-single-float-widetag simple-array-double-float-widetag
-  #!+long-float simple-array-long-float-widetag
-  simple-array-complex-single-float-widetag
-  simple-array-complex-double-float-widetag
-  #!+long-float simple-array-complex-long-float-widetag
-  complex-string-widetag complex-bit-vector-widetag complex-vector-widetag)
-
-(def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error
-  complex-vector-widetag)
-
-  (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
-  simple-array-widetag simple-string-widetag simple-bit-vector-widetag
-  simple-vector-widetag simple-array-unsigned-byte-2-widetag
-  simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
-  simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
-  simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
-  simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
-  simple-array-single-float-widetag simple-array-double-float-widetag
-  #!+long-float simple-array-long-float-widetag
-  simple-array-complex-single-float-widetag
-  simple-array-complex-double-float-widetag
-  #!+long-float simple-array-complex-long-float-widetag)
-      
-  (def-type-vops arrayp check-array nil object-not-array-error
-  simple-array-widetag simple-string-widetag simple-bit-vector-widetag
-  simple-vector-widetag simple-array-unsigned-byte-2-widetag
-  simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
-  simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
-  simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
-  simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
-  simple-array-single-float-widetag simple-array-double-float-widetag
-  #!+long-float simple-array-long-float-widetag
-  simple-array-complex-single-float-widetag
-  simple-array-complex-double-float-widetag
-  #!+long-float simple-array-complex-long-float-widetag
-  complex-string-widetag complex-bit-vector-widetag complex-vector-widetag
-  complex-array-widetag)
-      
-  (def-type-vops numberp check-number nil object-not-number-error
-  even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag
-  single-float-widetag double-float-widetag #!+long-float long-float-widetag
-  complex-widetag complex-single-float-widetag complex-double-float-widetag
-  #!+long-float complex-long-float-widetag)
-      
-  (def-type-vops rationalp check-rational nil object-not-rational-error
-  even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag)
-      
-  (def-type-vops integerp check-integer nil object-not-integer-error
-  even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag)
-      
-  (def-type-vops floatp check-float nil object-not-float-error
-  single-float-widetag double-float-widetag #!+long-float long-float-widetag)
-      
-  (def-type-vops realp check-real nil object-not-real-error
-  even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag
-  single-float-widetag double-float-widetag #!+long-float long-float-widetag)
-
-  
+
 ;;;; Other integer ranges.
 
   ;; A (signed-byte 32) can be represented with either fixnum or a
   ;; bignum with exactly one digit.
 
-  (define-vop (signed-byte-32-p type-predicate)
+(define-vop (signed-byte-32-p type-predicate)
   (:translate signed-byte-32-p)
   (:generator 45
 	      (let ((not-target (gen-label)))
@@ -375,7 +158,7 @@
 			(values target not-target))
 		  (inst andcc zero-tn value #x3)
 		  (inst b :eq yep)
-		  (test-type value temp nope t other-pointer-lowtag)
+		  (test-type value nope t (other-pointer-lowtag) :temp temp)
 		  (loadw temp value 0 other-pointer-lowtag)
 		  (inst cmp temp (+ (ash 1 n-widetag-bits)
 				    bignum-widetag))
@@ -383,13 +166,13 @@
 		  (inst nop)
 		  (emit-label not-target)))))
 
-  (define-vop (check-signed-byte-32 check-type)
+(define-vop (check-signed-byte-32 check-type)
   (:generator 45
 	      (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
 		    (yep (gen-label)))
 		(inst andcc temp value #x3)
 		(inst b :eq yep)
-		(test-type value temp nope t other-pointer-lowtag)
+		(test-type value nope t (other-pointer-lowtag) :temp temp)
 		(loadw temp value 0 other-pointer-lowtag)
 		(inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 		(inst b :ne nope)
@@ -403,7 +186,7 @@
   ;; a bignum with exactly two digits and the second digit all
   ;; zeros.
 
-  (define-vop (unsigned-byte-32-p type-predicate)
+(define-vop (unsigned-byte-32-p type-predicate)
   (:translate unsigned-byte-32-p)
   (:generator 45
 	      (let ((not-target (gen-label))
@@ -420,7 +203,7 @@
 		  (inst cmp value)
 
 		  ;; If not, is it an other pointer?
-		  (test-type value temp nope t other-pointer-lowtag)
+		  (test-type value nope t (other-pointer-lowtag) :temp temp)
 		  ;; Get the header.
 		  (loadw temp value 0 other-pointer-lowtag)
 		  ;; Is it one?
@@ -452,7 +235,7 @@
 			
 		  (emit-label not-target)))))	  
 
-  (define-vop (check-unsigned-byte-32 check-type)
+(define-vop (check-unsigned-byte-32 check-type)
   (:generator 45
 	      (let ((nope
 		     (generate-error-code vop object-not-unsigned-byte-32-error value))
@@ -465,7 +248,7 @@
 		(inst cmp value)
 			
 		;; If not, is it an other pointer?
-		(test-type value temp nope t other-pointer-lowtag)
+		(test-type value nope t (other-pointer-lowtag) :temp temp)
 		;; Get the number of digits.
 		(loadw temp value 0 other-pointer-lowtag)
 		;; Is it one?
@@ -503,40 +286,40 @@
   ;; symbolp (or symbol (eq nil))
   ;; consp (and list (not (eq nil)))
       
-  (define-vop (symbolp type-predicate)
+(define-vop (symbolp type-predicate)
   (:translate symbolp)
   (:generator 12
 	      (let* ((drop-thru (gen-label))
 		     (is-symbol-label (if not-p drop-thru target)))
 		(inst cmp value null-tn)
 		(inst b :eq is-symbol-label)
-		(test-type value temp target not-p symbol-header-widetag)
+		(test-type value target not-p (symbol-header-widetag) :temp temp)
 		(emit-label drop-thru))))
       
-  (define-vop (check-symbol check-type)
+(define-vop (check-symbol check-type)
   (:generator 12
 	      (let ((drop-thru (gen-label))
 		    (error (generate-error-code vop object-not-symbol-error value)))
 		(inst cmp value null-tn)
 		(inst b :eq drop-thru)
-		(test-type value temp error t symbol-header-widetag)
+		(test-type value error t (symbol-header-widetag) :temp temp)
 		(emit-label drop-thru)
 		(move result value))))
       
-  (define-vop (consp type-predicate)
+(define-vop (consp type-predicate)
   (:translate consp)
   (:generator 8
 	      (let* ((drop-thru (gen-label))
 		     (is-not-cons-label (if not-p target drop-thru)))
 		(inst cmp value null-tn)
 		(inst b :eq is-not-cons-label)
-		(test-type value temp target not-p list-pointer-lowtag)
+		(test-type value target not-p (list-pointer-lowtag) :temp temp)
 		(emit-label drop-thru))))
       
-  (define-vop (check-cons check-type)
+(define-vop (check-cons check-type)
   (:generator 8
 	      (let ((error (generate-error-code vop object-not-cons-error value)))
 		(inst cmp value null-tn)
 		(inst b :eq error)
-		(test-type value temp error t list-pointer-lowtag)
+		(test-type value error t (list-pointer-lowtag) :temp temp)
 		(move result value))))