"CHECK-SYMBOL"
;; FIXME: 32/64-bit issues
"CHECK-UNSIGNED-BYTE-32" "CHECK-UNSIGNED-BYTE-64"
- "CHECK-MOD-FIXNUM"
"CLOSURE-INIT" "CLOSURE-REF" "CLOSURE-INIT-FROM-FP"
"*CODE-COVERAGE-INFO*"
"COMPARE-AND-SWAP-SLOT"
"%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF"
"%FIND-POSITION-IF-VECTOR-MACRO" "%FIND-POSITION-IF-NOT"
"%FIND-POSITION-IF-NOT-VECTOR-MACRO"
+ "FIXNUM-MOD-P"
"%HYPOT" "%LDB" "%LOG" "%LOGB" "%LOG10"
"%LAST0"
"%LAST1"
"OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR"
"OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUN-ERROR"
"OBJECT-NOT-INSTANCE-ERROR" "OBJECT-NOT-INTEGER-ERROR"
- "OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-MOD-ERROR"
+ "OBJECT-NOT-LIST-ERROR"
#!+long-float "OBJECT-NOT-LONG-FLOAT-ERROR"
"OBJECT-NOT-NUMBER-ERROR" "OBJECT-NOT-RATIO-ERROR"
"OBJECT-NOT-RATIONAL-ERROR" "OBJECT-NOT-REAL-ERROR"
:datum object
:expected-type 'fixnum))
-(deferr object-not-mod-error (object limit)
- (error 'type-error
- :datum object
- :expected-type `(mod ,(1+ limit))))
-
(deferr object-not-vector-error (object)
(error 'type-error
:datum object
(def-type-predicate-wrapper stringp)
(def-type-predicate-wrapper vectorp)
(def-type-predicate-wrapper vector-nil-p))
+
+#!+(or x86 x86-64)
+(defun fixnum-mod-p (x limit)
+ (and (fixnump x)
+ (<= 0 x limit)))
+
\f
;;; Return the specifier for the type of object. This is not simply
;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different
(defknown (eq eql) (t t) boolean (movable foldable flushable))
(defknown (equal equalp) (t t) boolean (foldable flushable recursive))
+
+#!+(or x86 x86-64)
+(defknown fixnum-mod-p (t fixnum) boolean
+ (movable foldable flushable always-translatable))
+
\f
;;;; classes
"Object is not of type SIMPLE-STRING.")
(object-not-fixnum
"Object is not of type FIXNUM.")
- (object-not-mod
- "Object is not of type (MOD X).")
(object-not-vector
"Object is not of type VECTOR.")
(object-not-string
;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding
;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL.
-;;; The second value is T if the template needs TYPE to be passed.
(defun hairy-type-check-template-name (type)
(declare (type ctype type))
(typecase type
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((type= type (specifier-type '(unsigned-byte 64)))
'sb!c:check-unsigned-byte-64)
- #!+(or x86 x86-64) ; Not implemented yet on other platforms
- ((and (eql (numeric-type-class type) 'integer)
- (eql (numeric-type-low type) 0)
- (fixnump (numeric-type-high type)))
- (values 'sb!c:check-mod-fixnum t))
(t nil)))
(fun-type
'sb!c:check-fun)
;;; If there is any CHECK-xxx template for TYPE, then return it,
;;; otherwise return NIL.
-;;; The second value is T if the template needs TYPE to be passed
(defun type-check-template (type)
(declare (type ctype type))
(multiple-value-bind (check-ptype exact) (primitive-type type)
(if exact
(primitive-type-check check-ptype)
- (multiple-value-bind (name type-needed)
- (hairy-type-check-template-name type)
+ (let ((name (hairy-type-check-template-name type)))
(if name
- (values (template-or-lose name) type-needed)
+ (template-or-lose name)
nil)))))
;;; Emit code in BLOCK to check that VALUE is of the specified TYPE,
(defun emit-type-check (node block value result type)
(declare (type tn value result) (type node node) (type ir2-block block)
(type ctype type))
- (multiple-value-bind (template type-needed) (type-check-template type)
- (if type-needed
- (emit-load-template node block template value result (list type))
- (emit-move-template node block template value result)))
+ (emit-move-template node block (type-check-template type) value result)
(values))
;;; Allocate an indirect value cell.
((symbolp type)
``(:or ,(primitive-type-or-lose ',type)))
(t
- (ecase (first type)
+ (ecase (car type)
(:or
``(:or ,,@(mapcar (lambda (type)
`(primitive-type-or-lose ',type))
(rest type))))
(:constant
``(:constant ,#'(lambda (x)
- (sb!xc:typep x ',(second type)))
+ ;; Can't handle SATISFIES during XC
+ ,(if (and (consp (second type))
+ (eq (caadr type) 'satisfies))
+ `(,(cadadr type) x)
+ `(sb!xc:typep x ',(second type))))
,',(second type)))))))
(defun specify-operand-types (types ops more-ops)
(once-only ((n-object object))
(ecase (numeric-type-complexp type)
(:real
- `(and (typep ,n-object ',base)
- ,(transform-numeric-bound-test n-object type base)))
+ (if (and #!-(or x86 x86-64) ;; Not implemented elsewhere yet
+ nil
+ (eql (numeric-type-class type) 'integer)
+ (eql (numeric-type-low type) 0)
+ (fixnump (numeric-type-high type)))
+ `(fixnum-mod-p ,n-object ,(numeric-type-high type))
+ `(and (typep ,n-object ',base)
+ ,(transform-numeric-bound-test n-object type base))))
(:complex
`(and (complexp ,n-object)
,(once-only ((n-real `(realpart (truly-the complex ,n-object)))
(emit-label yep)
(move result value))))
-(define-vop (check-mod-fixnum check-type)
- (:info type)
- (:temporary (:sc any-reg) temp)
- (:generator 30
- (let* ((low (numeric-type-low type))
- (hi (numeric-type-high type))
- (fixnum-hi (fixnumize hi))
- (error (gen-label)))
- ;; FIXME: abstract
- (assemble (*elsewhere*)
- (emit-label error)
- ;; The general case uses the number directly,
- ;; and it will already have the number constantized
- ;; even though MOV can use 64-bit immediates,
- ;; using the same inlined constant will save space
- (if (= (logcount (1+ hi)) 1)
- (inst mov temp fixnum-hi)
- (inst mov temp (constantize fixnum-hi)))
- (emit-error-break vop error-trap
- (error-number-or-lose 'object-not-mod-error)
- (list value temp)))
- (aver (zerop low))
- (cond
- ;; Handle powers of two specially
- ;; The higher bits and the fixnum tag can be tested in one go
- ((= (logcount (1+ hi)) 1)
- (inst test value
- (constantize (lognot fixnum-hi)))
- (inst jmp :ne error))
- (t
- (generate-fixnum-test value)
- (inst jmp :ne error)
- (inst cmp value (constantize fixnum-hi))
- (inst jmp :a error)))
- (move result value))))
+(defun power-of-two-limit-p (x)
+ (and (fixnump x)
+ (= (logcount (1+ x)) 1)))
+
+(define-vop (test-fixnum-mod-power-of-two)
+ (:args (value :scs (any-reg descriptor-reg
+ unsigned-reg signed-reg
+ immediate)))
+ (:arg-types *
+ (:constant (satisfies power-of-two-limit-p)))
+ (:translate fixnum-mod-p)
+ (:conditional :e)
+ (:info hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (not (sc-is value immediate)))
+ (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
+ hi
+ (fixnumize hi))))
+ (inst test value (constantize (lognot fixnum-hi))))))
+
+(define-vop (test-fixnum-mod-tagged-unsigned)
+ (:args (value :scs (any-reg descriptor-reg
+ unsigned-reg signed-reg
+ immediate)))
+ (:arg-types (:or tagged-num unsigned-num signed-num)
+ (:constant fixnum))
+ (:translate fixnum-mod-p)
+ (:conditional :be)
+ (:info hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 5
+ (aver (not (sc-is value immediate)))
+ (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
+ hi
+ (fixnumize hi))))
+ (inst cmp value (constantize fixnum-hi)))))
+(define-vop (test-fixnum-mod-*)
+ (:args (value :scs (any-reg descriptor-reg)))
+ (:arg-types * (:constant fixnum))
+ (:translate fixnum-mod-p)
+ (:conditional)
+ (:info target not-p hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 6
+ (let* ((fixnum-hi (fixnumize hi))
+ (skip (gen-label)))
+ (generate-fixnum-test value)
+ (inst jmp :ne (if not-p target skip))
+ (inst cmp value (constantize fixnum-hi))
+ (inst jmp (if not-p :a :be) target)
+ (emit-label skip))))
\f
;;;; list/symbol types
;;;
(emit-label yep)
(move result value))))
-(define-vop (check-mod-fixnum check-type)
- (:info type)
- (:temporary (:sc any-reg) temp)
- (:generator 30
- (let* ((low (numeric-type-low type))
- (hi (numeric-type-high type))
- (fixnum-hi (fixnumize hi))
- (error (gen-label)))
- ;; FIXME: abstract
- (assemble (*elsewhere*)
- (emit-label error)
- (inst mov temp fixnum-hi)
- (emit-error-break vop error-trap
- (error-number-or-lose 'object-not-mod-error)
- (list value temp)))
- (aver (zerop low))
- (cond
- ;; Handle powers of two specially
- ;; The higher bits and the fixnum tag can be tested in one go
- ((= (logcount (1+ hi)) 1)
- (inst test value (lognot fixnum-hi))
- (inst jmp :ne error))
- (t
- (generate-fixnum-test value)
- (inst jmp :ne error)
- (inst cmp value fixnum-hi)
- (inst jmp :a error)))
- (move result value))))
+(defun power-of-two-limit-p (x)
+ (and (fixnump x)
+ (= (logcount (1+ x)) 1)))
+
+(define-vop (test-fixnum-mod-power-of-two)
+ (:args (value :scs (any-reg descriptor-reg
+ unsigned-reg signed-reg
+ immediate)))
+ (:arg-types *
+ (:constant (satisfies power-of-two-limit-p)))
+ (:translate sb!c::fixnum-mod-p)
+ (:conditional :e)
+ (:info hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 4
+ (aver (not (sc-is value immediate)))
+ (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
+ hi
+ (fixnumize hi))))
+ (inst test value (lognot fixnum-hi)))))
+
+(define-vop (test-fixnum-mod-tagged-unsigned)
+ (:args (value :scs (any-reg descriptor-reg
+ unsigned-reg signed-reg
+ immediate)))
+ (:arg-types (:or tagged-num unsigned-num signed-num)
+ (:constant fixnum))
+ (:translate sb!c::fixnum-mod-p)
+ (:conditional :be)
+ (:info hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 5
+ (aver (not (sc-is value immediate)))
+ (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
+ hi
+ (fixnumize hi))))
+ (inst cmp value fixnum-hi))))
+
+(define-vop (test-fixnum-mod-*)
+ (:args (value :scs (any-reg descriptor-reg)))
+ (:arg-types * (:constant fixnum))
+ (:translate sb!c::fixnum-mod-p)
+ (:conditional)
+ (:info target not-p hi)
+ (:save-p :compute-only)
+ (:policy :fast-safe)
+ (:generator 6
+ (let* ((fixnum-hi (fixnumize hi))
+ (skip (gen-label)))
+ (generate-fixnum-test value)
+ (inst jmp :ne (if not-p target skip))
+ (inst cmp value fixnum-hi)
+ (inst jmp (if not-p :a :be) target)
+ (emit-label skip))))
\f
;;;; list/symbol types
projects / sbcl.git / commitdiff