X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fmacros.lisp;h=230bde16554e994e6bb04817c24b7514ec191940;hb=670010e3f3dcd62efaf23f61abdc73950edb88c6;hp=fa66c78b805f3ca64bb38d3f003a36e024f6c4e3;hpb=cab2c71bb1bb8a575d9eebdae335e731daa64183;p=sbcl.git diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp index fa66c78..230bde1 100644 --- a/src/compiler/ppc/macros.lisp +++ b/src/compiler/ppc/macros.lisp @@ -1,7 +1,15 @@ -;;; +;;;; a bunch of handy macros for the PPC -(in-package "SB!VM") +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. +(in-package "SB!VM") ;;; Instruction-like macros. @@ -94,10 +102,7 @@ ;;;; Stack TN's -;;; Load-Stack-TN, Store-Stack-TN -- Interface -;;; -;;; Move a stack TN to a register and vice-versa. -;;; +;;; Move a stack TN to a register and vice-versa. (defmacro load-stack-tn (reg stack) `(let ((reg ,reg) (stack ,stack)) @@ -105,7 +110,6 @@ (sc-case stack ((control-stack) (loadw reg cfp-tn offset)))))) - (defmacro store-stack-tn (stack reg) `(let ((stack ,stack) (reg ,reg)) @@ -114,9 +118,6 @@ ((control-stack) (storew reg cfp-tn offset)))))) - -;;; MAYBE-LOAD-STACK-TN -- Interface -;;; (defmacro maybe-load-stack-tn (reg reg-or-stack) "Move the TN Reg-Or-Stack into Reg if it isn't already there." (once-only ((n-reg reg) @@ -131,7 +132,6 @@ ;;;; Storage allocation: - (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) &body body) "Do stuff to allocate an other-pointer object of fixed Size with a single @@ -148,211 +148,7 @@ ,@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) - -(defmacro with-adjustable-vector ((var) &rest body) - `(let ((,var (or (pop *adjustable-vectors*) - (make-array 16 - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t)))) - (setf (fill-pointer ,var) 0) - (unwind-protect - (progn - ,@body) - (push ,var *adjustable-vectors*)))) - (eval-when (:compile-toplevel :load-toplevel :execute) (defun emit-error-break (vop kind code values) (let ((vector (gensym))) @@ -401,8 +197,7 @@ Emit code for a continuable error with the specified Error-Code and context Values. If the error is continued, execution resumes after the GENERATE-CERROR-CODE form." - (let ((continue (gensym "CONTINUE-LABEL-")) - (error (gensym "ERROR-LABEL-"))) + (with-unique-names (continue error) `(let ((,continue (gen-label))) (emit-label ,continue) (assemble (*elsewhere*) @@ -410,18 +205,17 @@ (emit-label ,error) (cerror-call ,vop ,continue ,error-code ,@values) ,error))))) - - -;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. +;;;; PSEUDO-ATOMIC + +;;; handy macro for making sequences look atomic ;;; -;;; flag-tn must be wired to NL3. If a deferred interrupt happens -;;; while we have the low bits of alloc-tn set, we add a "large" -;;; constant to flag-tn. On exit, we add flag-tn to alloc-tn -;;; which (a) aligns alloc-tn again and (b) makes alloc-tn go -;;; negative. We then trap if alloc-tn's negative (handling the -;;; deferred interrupt) and using flag-tn - minus the large constant - -;;; to correct alloc-tn. +;;; FLAG-TN must be wired to NL3. If a deferred interrupt happens +;;; while we have the low bits of ALLOC-TN set, we add a "large" +;;; constant to FLAG-TN. On exit, we add FLAG-TN to ALLOC-TN which (a) +;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then +;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and +;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN. (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms) (let ((n-extra (gensym))) `(let ((,n-extra ,extra))