From faa0ea92986f4c2b361c9378c69a540e42a70c62 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 10 Sep 2002 12:47:39 +0000 Subject: [PATCH] 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) --- src/compiler/generic/early-type-vops.lisp | 23 ++++++++++++++++------- src/compiler/x86/type-vops.lisp | 16 ++++++---------- version.lisp-expr | 2 +- 3 files changed, 23 insertions(+), 18 deletions(-) diff --git a/src/compiler/generic/early-type-vops.lisp b/src/compiler/generic/early-type-vops.lisp index d3572d6..4aa4fa3 100644 --- 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 --- 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 --- 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" -- 1.7.10.4