From: Christophe Rhodes Date: Mon, 9 Sep 2002 18:09:33 +0000 (+0000) Subject: 0.7.7.20-backend-cleanup-1.3: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=760b572425ddd9ffeec81566999c862b3812be83;p=sbcl.git 0.7.7.20-backend-cleanup-1.3: New !DEFINE-TYPE-VOPS interface, replacing DEF-TYPE-VOPS and DEF-SIMPLE-TYPE-VOPS ... define an x86 version ... use it in the generic code (still won't work on non-x86, for obvious reasons) --- diff --git a/src/compiler/generic/late-type-vops.lisp b/src/compiler/generic/late-type-vops.lisp index 86d2c85..1d4d29a 100644 --- a/src/compiler/generic/late-type-vops.lisp +++ b/src/compiler/generic/late-type-vops.lisp @@ -1,197 +1,223 @@ (in-package "SB!VM") -(def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error - even-fixnum-lowtag odd-fixnum-lowtag) +(!define-type-vops fixnump check-fixnum fixnum object-not-fixnum-error + (even-fixnum-lowtag odd-fixnum-lowtag) + ;; we can save a register on the x86. + :variant simple) -(def-type-vops functionp check-fun function - object-not-fun-error fun-pointer-lowtag) +(!define-type-vops functionp check-fun function object-not-fun-error + (fun-pointer-lowtag)) -(def-type-vops listp check-list list object-not-list-error - list-pointer-lowtag) +(!define-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) +(!define-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) +(!define-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) +(!define-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) +(!define-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) +(!define-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) +(!define-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) +(!define-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) +(!define-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) +(!define-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) +(!define-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) +(!define-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) +(!define-type-vops long-float-p check-long-float long-float + object-not-long-float-error + (long-float-widetag)) + +(!define-type-vops simple-string-p check-simple-string simple-string + object-not-simple-string-error + (simple-string-widetag)) + +(!define-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector + object-not-simple-bit-vector-error + (simple-bit-vector-widetag)) + +(!define-type-vops simple-vector-p check-simple-vector simple-vector + object-not-simple-vector-error + (simple-vector-widetag)) + +(!define-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)) + +(!define-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)) + +(!define-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)) + +(!define-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)) + +(!define-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)) + +(!define-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)) + +(!define-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)) + +(!define-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)) + +(!define-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)) + +(!define-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)) + +(!define-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) +(!define-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)) + +(!define-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)) + +(!define-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) - -(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) - -(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) +(!define-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)) + +(!define-type-vops base-char-p check-base-char base-char + object-not-base-char-error + (base-char-widetag)) + +(!define-type-vops system-area-pointer-p check-system-area-pointer + system-area-pointer + object-not-sap-error + (sap-widetag)) + +(!define-type-vops weak-pointer-p check-weak-pointer weak-pointer + object-not-weak-pointer-error + (weak-pointer-widetag)) + +(!define-type-vops code-component-p nil nil nil + (code-header-widetag)) + +(!define-type-vops lra-p nil nil nil + (return-pc-header-widetag)) + +(!define-type-vops fdefn-p nil nil nil + (fdefn-widetag)) + +(!define-type-vops funcallable-instance-p nil nil nil + (funcallable-instance-header-widetag)) + +(!define-type-vops array-header-p nil nil nil + (simple-array-widetag complex-string-widetag complex-bit-vector-widetag + complex-vector-widetag complex-array-widetag)) + +(!define-type-vops stringp check-string nil object-not-string-error + (simple-string-widetag complex-string-widetag)) + +(!define-type-vops bit-vector-p check-bit-vector nil + object-not-bit-vector-error + (simple-bit-vector-widetag complex-bit-vector-widetag)) + +(!define-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)) ;;; Note that this "type VOP" is sort of an oddball; it doesn't so ;;; much test for a Lisp-level type as just expose a low-level type @@ -203,53 +229,84 @@ ;;; type.) Thus, there's no point in building up the full machinery of ;;; associated backend type predicates and so forth as we do for ;;; ordinary type VOPs. -(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) +(!define-type-vops complex-vector-p check-complex-vector nil + object-not-complex-vector-error + (complex-vector-widetag)) + +(!define-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)) + +(!define-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)) + +(!define-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)) + +(!define-type-vops rationalp check-rational nil object-not-rational-error + (even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag)) + +(!define-type-vops integerp check-integer nil object-not-integer-error + (even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag)) + +(!define-type-vops floatp check-float nil object-not-float-error + (single-float-widetag double-float-widetag #!+long-float long-float-widetag)) + +(!define-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)) diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index 1dc2594..ca114cf 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -147,36 +147,23 @@ (+ (* 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) - (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) +(defmacro !define-type-vops (pred-name check-name ptype error-code + (&rest type-codes) + &key (variant nil variant-p)) + ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the + ;; expansion? + (let* ((cost (cost-to-test-types (mapcar #'eval type-codes))) + (prefix (if variant-p + (concatenate 'string (string variant) "-") + ""))) `(progn ,@(when pred-name - `((define-vop (,pred-name type-predicate) + `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE"))) (:translate ,pred-name) (:generator ,cost (test-type value 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) - (move result value)))))) - ,@(when ptype - `((primitive-type-vop ,check-name (:check) ,ptype)))))) - -(defmacro def-simple-type-vops (pred-name check-name ptype error-code - &rest type-codes) - (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) - `(progn - ,@(when pred-name - `((define-vop (,pred-name simple-type-predicate) - (:translate ,pred-name) - (:generator ,cost - (test-type value target not-p ,@type-codes))))) - ,@(when check-name - `((define-vop (,check-name simple-check-type) + `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE"))) (:generator ,cost (let ((err-lab (generate-error-code vop ,error-code value))) diff --git a/version.lisp-expr b/version.lisp-expr index a3238b9..1090b94 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.2" +"0.7.7.20-backend-cleanup-1.3"