,@body)))
\f
-;;;; Type testing noise.
-
-;;; GEN-RANGE-TEST -- internal
-;;;
-;;; Generate code that branches to TARGET iff REG contains one of VALUES.
-;;; If NOT-P is true, invert the test. Jumping to NOT-TARGET is the same
-;;; as falling out the bottom.
-;;;
-
-#|
-(defun gen-range-test (reg target not-target not-p min seperation max values)
- (let ((tests nil)
- (start nil)
- (end nil)
- (insts nil))
- (multiple-value-bind (equal less-or-equal greater-or-equal label)
- (if not-p
- (values :ne :gt :lt not-target)
- (values :eq :le :ge target))
- (flet ((emit-test ()
- (if (= start end)
- (push start tests)
- (push (cons start end) tests))))
- (dolist (value values)
- (cond ((< value min)
- (error "~S is less than the specified minimum of ~S"
- value min))
- ((> value max)
- (error "~S is greater than the specified maximum of ~S"
- value max))
- ((not (zerop (rem (- value min) seperation)))
- (error "~S isn't an even multiple of ~S from ~S"
- value seperation min))
- ((null start)
- (setf start value))
- ((> value (+ end seperation))
- (emit-test)
- (setf start value)))
- (setf end value))
- (emit-test))
- (macrolet ((inst (name &rest args)
- `(push (list 'inst ',name ,@args) insts)))
- (do ((remaining (nreverse tests) (cdr remaining)))
- ((null remaining))
- (let ((test (car remaining))
- (last (null (cdr remaining))))
- (if (atom test)
- (progn
- (inst cmpwi reg test)
- (if last
- (inst b? equal target)
- (inst beq label)))
- (let ((start (car test))
- (end (cdr test)))
- (cond ((and (= start min) (= end max))
- (warn "The values ~S cover the entire range from ~
- ~S to ~S [step ~S]."
- values min max seperation)
- (push `(unless ,not-p (inst b ,target)) insts))
- ((= start min)
- (inst cmpwi reg end)
- (if last
- (inst b? less-or-equal target)
- (inst ble label)))
- ((= end max)
- (inst cmpwi reg start)
- (if last
- (inst b? greater-or-equal target)
- (inst bge label)))
- (t
- (inst cmpwi reg start)
- (inst blt (if not-p target not-target))
- (inst cmpwi reg end)
- (if last
- (inst b? less-or-equal target)
- (inst ble label))))))))))
- (nreverse insts)))
-
-(defun gen-other-immediate-test (reg target not-target not-p values)
- (gen-range-test reg target not-target not-p
- (+ other-immediate-0-lowtag lowtag-limit)
- (- other-immediate-1-lowtag other-immediate-0-lowtag)
- (ash 1 n-widetag-bits)
- values))
-
-
-(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
- function-p)
- (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql)
- (member odd-fixnum-lowtag lowtags :test #'eql)))
- (lowtags (sort (if fixnump
- (delete even-fixnum-lowtag
- (remove odd-fixnum-lowtag lowtags
- :test #'eql)
- :test #'eql)
- (copy-list lowtags))
- #'<))
- (lowtag (if function-p
- sb!vm:fun-pointer-lowtag
- sb!vm:other-pointer-lowtag))
- (hdrs (sort (copy-list hdrs) #'<))
- (immed (sort (copy-list immed) #'<)))
- (append
- (when immed
- `((inst andi. ,temp ,reg widetag-mask)
- ,@(if (or fixnump lowtags hdrs)
- (let ((fall-through (gensym)))
- `((let (,fall-through (gen-label))
- ,@(gen-other-immediate-test
- temp (if not-p not-target target)
- fall-through nil immed)
- (emit-label ,fall-through))))
- (gen-other-immediate-test temp target not-target not-p immed))))
- (when fixnump
- `((inst andi. ,temp ,reg 3)
- ,(if (or lowtags hdrs)
- `(inst beq ,(if not-p not-target target))
- `(inst b? ,(if not-p :ne :eq) ,target))))
- (when (or lowtags hdrs)
- `((inst andi. ,temp ,reg lowtag-mask)))
- (when lowtags
- (if hdrs
- (let ((fall-through (gensym)))
- `((let ((,fall-through (gen-label)))
- ,@(gen-range-test temp (if not-p not-target target)
- fall-through nil
- 0 1 (1- lowtag-limit) lowtags)
- (emit-label ,fall-through))))
- (gen-range-test temp target not-target not-p 0 1
- (1- lowtag-limit) lowtags)))
- (when hdrs
- `((inst cmpwi ,temp ,lowtag)
- (inst bne ,(if not-p target not-target))
- (load-type ,temp ,reg (- ,lowtag))
- ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
-
-(defparameter immediate-types
- (list base-char-widetag unbound-marker-widetag))
-
-(defparameter function-subtypes
- (list funcallable-instance-header-widetag
- simple-fun-header-widetag closure-fun-header-widetag
- closure-header-widetag))
-
-(defmacro test-type (register temp target not-p &rest type-codes)
- (let* ((type-codes (mapcar #'eval type-codes))
- (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 nil))
- (unless type-codes
- (error "Must supply at least on type for test-type."))
- (when (and headers (member other-pointer-lowtag lowtags))
- (warn "OTHER-POINTER-LOWTAG supersedes the use of ~S" headers)
- (setf headers nil))
- (when (and immediates
- (or (member other-immediate-0-lowtag lowtags)
- (member other-immediate-1-lowtag lowtags)))
- (warn "OTHER-IMMEDIATE-n-LOWTAG supersedes the use of ~S" immediates)
- (setf immediates nil))
- (when (intersection headers function-subtypes)
- (unless (subsetp headers function-subtypes)
- (error "Can't test for mix of function subtypes and normal ~
- header types."))
- (setq function-p t))
-
- (let ((n-reg (gensym))
- (n-temp (gensym))
- (n-target (gensym))
- (not-target (gensym)))
- `(let ((,n-reg ,register)
- (,n-temp ,temp)
- (,n-target ,target)
- (,not-target (gen-label)))
- (declare (ignorable ,n-temp))
- ,@(if (constantp not-p)
- (test-type-aux n-reg n-temp n-target not-target
- (eval not-p) lowtags immediates headers
- function-p)
- `((cond (,not-p
- ,@(test-type-aux n-reg n-temp n-target not-target t
- lowtags immediates headers
- function-p))
- (t
- ,@(test-type-aux n-reg n-temp n-target not-target nil
- lowtags immediates headers
- function-p)))))
- (emit-label ,not-target)))))
-|#
-\f
;;;; Error Code
(defvar *adjustable-vectors* nil)
projects / sbcl.git / blobdiff