diff --git a/compiler/x86/type-vops.lisp b/compiler/x86/type-vops.lisp index 94aa2a295ea388ec054da74029bd354d8f7d1de6..52d426251889559ab4e905379de8f15e9932abab 100644 --- a/compiler/x86/type-vops.lisp +++ b/compiler/x86/type-vops.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.6 1997/11/15 04:39:03 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.7 1997/12/20 19:29:20 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -117,13 +117,36 @@ ); eval-when (compile eval) +;;; Emit the most compact form of the test immediate instruction, +;;; using an 8 bit test when the immediate is only 8 bits and the +;;; value is one of the four low registers (eax, ebx, ecx, edx) or the +;;; control-stack. +;;; +(defun maybe-byte-test (value immed) + (let ((offset (tn-offset value))) + (cond ((> immed #xff) + (inst test value 3)) + ((and (sc-is value any-reg descriptor-reg) + (or (= offset eax-offset) (= offset ebx-offset) + (= offset ecx-offset) (= offset edx-offset))) + (inst test (make-random-tn :kind :normal + :sc (sc-or-lose 'byte-reg) + :offset offset) + immed)) + ((sc-is value control-stack) + (inst test (make-ea :byte :base ebp-tn + :disp (- (* (1+ offset) vm:word-bytes))) + immed)) + (t + (inst test value 3))))) + (defun %test-fixnum (value target not-p) - (inst test value 3) + (maybe-byte-test value 3) (inst jmp (if not-p :nz :z) target)) (defun %test-fixnum-and-headers (value target not-p headers) (let ((drop-through (gen-label))) - (inst test value 3) + (maybe-byte-test value 3) (inst jmp :z (if not-p drop-through target)) (%test-headers value target not-p nil headers drop-through))) @@ -242,6 +265,21 @@ (:info target not-p) (:policy :fast-safe)) +;;; Simpler VOP that don't need a temporary register. +(define-vop (simple-check-type) + (:args (value :target result :scs (any-reg descriptor-reg))) + (:results (result :scs (any-reg descriptor-reg) + :load-if (not (and (sc-is value any-reg descriptor-reg) + (sc-is result control-stack))))) + (:vop-var vop) + (:save-p :compute-only)) + +(define-vop (simple-type-predicate) + (:args (value :scs (any-reg descriptor-reg control-stack))) + (:conditional) + (:info target not-p) + (:policy :fast-safe)) + (eval-when (compile eval) (defun cost-to-test-types (type-codes) @@ -267,9 +305,28 @@ ,@(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) + (: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)))))) + ); eval-when (compile eval) -(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error +(def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error even-fixnum-type odd-fixnum-type) (def-type-vops functionp check-function function @@ -519,7 +576,7 @@ (if not-p (values not-target target) (values target not-target)) - (inst test value #x3) + (maybe-byte-test value 3) (inst jmp :e yep) (move eax-tn value) (inst and al-tn lowtag-mask) @@ -535,7 +592,7 @@ (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))) - (inst test value #x3) + (maybe-byte-test value 3) (inst jmp :e yep) (move eax-tn value) (inst and al-tn lowtag-mask) @@ -563,7 +620,7 @@ (values not-target target) (values target not-target)) ;; Is it a fixnum? - (inst test value 3) + (maybe-byte-test value 3) (move eax-tn value) (inst jmp :e fixnum) @@ -606,7 +663,7 @@ (single-word (gen-label))) ;; Is it a fixnum? - (inst test value 3) + (maybe-byte-test value 3) (move eax-tn value) (inst jmp :e fixnum)