X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fmacros.lisp;h=2dfb14be891c802b7396eb64f886661f418bca3f;hb=7ce4dc62a7b03590b127bb950738e771e33341a7;hp=147dfd15241b8d31592bb68cfdb995fa61f8e16a;hpb=4081f91910d6dc5dc79e2c43b8a746acaa78ecd9;p=sbcl.git diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp index 147dfd1..2dfb14b 100644 --- a/src/compiler/ppc/macros.lisp +++ b/src/compiler/ppc/macros.lisp @@ -156,197 +156,6 @@ ,@body))) -;;;; 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))))) -|# - ;;;; Error Code (defvar *adjustable-vectors* nil)