0.7.7.20-backend-cleanup-1.4:

	Generalize interface to TEST-TYPE to allow for different
		architectural needs
	... &REST OTHER-ARGS &KEY &ALLOW-OTHER-KEYS
	... pass the OTHER-ARGS through to
		architecture-specific %TEST-FIXNUM and friends
	(still x86-only)

diff --git a/src/compiler/generic/early-type-vops.lisp b/src/compiler/generic/early-type-vops.lisp
index d3572d6..4aa4fa3 100644 (file)
--- a/src/compiler/generic/early-type-vops.lisp
+++ b/src/compiler/generic/early-type-vops.lisp
@@ -31,7 +31,10 @@
        (emit-test)))
     (results)))
 
-(defmacro test-type (value target not-p &rest type-codes)
+(defmacro test-type (value target not-p
+                    (&rest type-codes)
+                    &rest other-args
+                    &key &allow-other-keys)
   ;; Determine what interesting combinations we need to test for.
   (let* ((type-codes (mapcar #'eval type-codes))
         (fixnump (and (member even-fixnum-lowtag type-codes)
@@ -62,8 +65,10 @@
         (error "can't mix fixnum testing with other immediates"))
        (if headers
           `(%test-fixnum-and-headers ,value ,target ,not-p
-            ',(canonicalize-headers headers))
-          `(%test-fixnum ,value ,target ,not-p)))
+            ',(canonicalize-headers headers)
+            ,@other-args)
+          `(%test-fixnum ,value ,target ,not-p
+            ,@other-args)))
       (immediates
        (when headers
         (error "can't mix testing of immediates with testing of headers"))
@@ -71,18 +76,22 @@
         (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 ,target ,not-p ,(car immediates)
+        ,@other-args))
       (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)
-            ,function-p ',(canonicalize-headers headers))
-          `(%test-lowtag ,value ,target ,not-p ,(car lowtags))))
+            ,function-p ',(canonicalize-headers headers)
+            ,@other-args)
+          `(%test-lowtag ,value ,target ,not-p ,(car lowtags)
+            ,@other-args)))
       (headers
        `(%test-headers ,value ,target ,not-p ,function-p
-        ',(canonicalize-headers headers)))
+        ',(canonicalize-headers headers)
+        ,@other-args))
       (t
        (error "nothing to test?")))))
 

diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp
index ca114cf..36f49a6 100644 (file)
--- a/src/compiler/x86/type-vops.lisp
+++ b/src/compiler/x86/type-vops.lisp
@@ -139,10 +139,6 @@
   (:info target not-p)
   (:policy :fast-safe))
 
-;;; FIXME: DEF-TYPE-VOPS and DEF-SIMPLE-TYPE-VOPS are only used in
-;;; this file, so they should be in the EVAL-WHEN above, or otherwise
-;;; tweaked so that they don't appear in the target system.
-
 (defun cost-to-test-types (type-codes)
   (+ (* 2 (length type-codes))
      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
@@ -161,13 +157,13 @@
           `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
               (:translate ,pred-name)
               (:generator ,cost
-                (test-type value target not-p ,@type-codes)))))
+                (test-type value target not-p (,@type-codes))))))
        ,@(when check-name
           `((define-vop (,check-name ,(intern (concatenate 'string prefix "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 err-lab t (,@type-codes))
                   (move result value))))))
        ,@(when ptype
           `((primitive-type-vop ,check-name (:check) ,ptype))))))
@@ -315,7 +311,7 @@
     (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-widetag))
+      (test-type value target not-p (symbol-header-widetag)))
     DROP-THRU))
 
 (define-vop (check-symbol check-type)
@@ -323,7 +319,7 @@
     (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-widetag))
+      (test-type value error t (symbol-header-widetag)))
     DROP-THRU
     (move result value)))
 
@@ -333,7 +329,7 @@
     (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-lowtag))
+      (test-type value target not-p (list-pointer-lowtag)))
     DROP-THRU))
 
 (define-vop (check-cons check-type)
@@ -341,5 +337,5 @@
     (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-lowtag)
+      (test-type value error t (list-pointer-lowtag))
       (move result value))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 1090b94..c0f339a 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.7.20-backend-cleanup-1.3"
+"0.7.7.20-backend-cleanup-1.4"