X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fearly-type-vops.lisp;h=b84493d75ae508c9a951d032894a820ae681ecfb;hb=711f75f20284c41f53485fda882fc7cc9e8e930f;hp=8c854fb09547708f4be2a0b2e8dd799e2684c11d;hpb=63817d29028c8551cda23f432a3328acd7fdd62f;p=sbcl.git diff --git a/src/compiler/generic/early-type-vops.lisp b/src/compiler/generic/early-type-vops.lisp index 8c854fb..b84493d 100644 --- a/src/compiler/generic/early-type-vops.lisp +++ b/src/compiler/generic/early-type-vops.lisp @@ -11,92 +11,113 @@ (in-package "SB!VM") (defparameter *immediate-types* - (list unbound-marker-widetag character-widetag)) + (list* unbound-marker-widetag character-widetag + (when (= sb!vm::n-word-bits 64) + (list single-float-widetag)))) (defparameter *fun-header-widetags* (list funcallable-instance-header-widetag - simple-fun-header-widetag - closure-header-widetag)) + simple-fun-header-widetag + closure-header-widetag)) (defun canonicalize-headers (headers) (collect ((results)) (let ((start nil) - (prev nil) - (delta (- other-immediate-1-lowtag other-immediate-0-lowtag))) + (prev nil) + (delta (- other-immediate-1-lowtag other-immediate-0-lowtag))) (flet ((emit-test () - (results (if (= start prev) - start - (cons start prev))))) - (dolist (header (sort headers #'<)) - (cond ((null start) - (setf start header) - (setf prev header)) - ((= header (+ prev delta)) - (setf prev header)) - (t - (emit-test) - (setf start header) - (setf prev header)))) - (emit-test))) + (results (if (= start prev) + start + (cons start prev))))) + (dolist (header (sort headers #'<)) + (cond ((null start) + (setf start header) + (setf prev header)) + ((= header (+ prev delta)) + (setf prev header)) + (t + (emit-test) + (setf start header) + (setf prev header)))) + (emit-test))) (results))) (defmacro test-type (value target not-p - (&rest type-codes) - &rest other-args - &key &allow-other-keys) + (&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) - (member odd-fixnum-lowtag type-codes) - t)) - (lowtags (remove lowtag-limit type-codes :test #'<)) - (extended (remove lowtag-limit type-codes :test #'>)) - (immediates (intersection extended *immediate-types* :test #'eql)) - (headers (set-difference extended *immediate-types* :test #'eql)) - (function-p (if (intersection headers *fun-header-widetags*) - (if (subsetp headers *fun-header-widetags*) - t - (error "can't test for mix of function subtypes ~ + (fixnump (and (every (lambda (lowtag) + (member lowtag type-codes)) + '#.(mapcar #'symbol-value fixnum-lowtags)) + t)) + (lowtags (remove lowtag-limit type-codes :test #'<)) + (extended (remove lowtag-limit type-codes :test #'>)) + (immediates (intersection extended *immediate-types* :test #'eql)) + (headers (set-difference extended *immediate-types* :test #'eql)) + (function-p (if (intersection headers *fun-header-widetags*) + (if (subsetp headers *fun-header-widetags*) + t + (error "can't test for mix of function subtypes ~ and normal header types")) - nil))) + nil))) (unless type-codes (error "At least one type must be supplied for TEST-TYPE.")) (cond (fixnump (when (remove-if (lambda (x) - (or (= x even-fixnum-lowtag) - (= x odd-fixnum-lowtag))) - lowtags) - (error "can't mix fixnum testing with other lowtags")) + (member x '#.(mapcar #'symbol-value fixnum-lowtags))) + lowtags) + (error "can't mix fixnum testing with other lowtags")) (when function-p - (error "can't mix fixnum testing with function subtype testing")) - (when immediates - (error "can't mix fixnum testing with other immediates")) - (if headers - `(%test-fixnum-and-headers ,value ,target ,not-p - ',(canonicalize-headers headers) - ,@other-args) - `(%test-fixnum ,value ,target ,not-p - ,@other-args))) + (error "can't mix fixnum testing with function subtype testing")) + (cond + ((and (= sb!vm:n-word-bits 64) immediates headers) + `(%test-fixnum-immediate-and-headers ,value ,target ,not-p + ,(car immediates) + ',(canonicalize-headers + headers) + ,@other-args)) + (immediates + (if (= sb!vm:n-word-bits 64) + `(%test-fixnum-and-immediate ,value ,target ,not-p + ,(car immediates) + ,@other-args) + (error "can't mix fixnum testing with other immediates"))) + (headers + `(%test-fixnum-and-headers ,value ,target ,not-p + ',(canonicalize-headers headers) + ,@other-args)) + (t + `(%test-fixnum ,value ,target ,not-p + ,@other-args)))) (immediates - (when headers - (error "can't mix testing of immediates with testing of headers")) - (when lowtags - (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) - ,@other-args)) + (cond + (headers + (if (= sb!vm:n-word-bits 64) + `(%test-immediate-and-headers ,value ,target ,not-p + ,(car immediates) + ',(canonicalize-headers headers) + ,@other-args) + (error "can't mix testing of immediates with testing of headers"))) + (lowtags + (error "can't mix testing of immediates with testing of lowtags")) + ((cdr immediates) + (error "can't test multiple immediates at the same time")) + (t + `(%test-immediate ,value ,target ,not-p ,(car immediates) + ,@other-args)))) (lowtags (when (cdr lowtags) - (error "can't test multiple lowtags at the same time")) + (error "can't test multiple lowtags at the same time")) (when headers - (error "can't test non-fixnum lowtags and headers at the same time")) + (error "can't test non-fixnum lowtags and headers at the same time")) `(%test-lowtag ,value ,target ,not-p ,(car lowtags) ,@other-args)) (headers `(%test-headers ,value ,target ,not-p ,function-p - ',(canonicalize-headers headers) - ,@other-args)) + ',(canonicalize-headers headers) + ,@other-args)) (t (error "nothing to test?")))))