X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fsparc%2Fmacros.lisp;h=70e1fbd139c8f6b59afd012d7c7e962cfa81e51b;hb=b7eed59f1877263e1af5ad80299e641e8276f77d;hp=bfe10f01809596f41b7fb988e1d6ef984a2c82e6;hpb=ea775867d48327bf1179eb570263427f28083880;p=sbcl.git diff --git a/src/compiler/sparc/macros.lisp b/src/compiler/sparc/macros.lisp index bfe10f0..70e1fbd 100644 --- a/src/compiler/sparc/macros.lisp +++ b/src/compiler/sparc/macros.lisp @@ -100,12 +100,9 @@ -;;;; Stack TN's +;;;; 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)) @@ -122,9 +119,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) @@ -139,7 +133,6 @@ ;;;; Storage allocation: - (defmacro with-fixed-allocation ((result-tn temp-tn type-code size) &body body) "Do stuff to allocate an other-pointer object of fixed Size with a single @@ -157,21 +150,6 @@ ;;;; 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))) @@ -220,8 +198,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*) @@ -229,8 +206,6 @@ (emit-label ,error) (cerror-call ,vop ,continue ,error-code ,@values) ,error))))) - - ;;; a handy macro for making sequences look atomic (defmacro pseudo-atomic ((&key (extra 0)) &rest forms) @@ -250,197 +225,12 @@ ;; The C code needs to process this correctly and fixup alloc-tn. (inst t :ne pseudo-atomic-trap))))) -;;; FIXME: test typing macros. Should(?) be in type-vops.lisp, except -;;; that they're also used in subprim.lisp - -(defun cost-to-test-types (type-codes) - (+ (* 2 (length type-codes)) - (if (> (apply #'max type-codes) lowtag-limit) 7 2))) - -(defparameter *immediate-types* - (list base-char-widetag unbound-marker-widetag)) - -(defparameter *fun-header-widetags* - (list funcallable-instance-header-widetag - simple-fun-header-widetag - closure-fun-header-widetag - closure-header-widetag)) - -(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 cmp reg test) - (if last - (inst b equal target) - (inst b :eq 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 cmp reg end) - (if last - (inst b less-or-equal target) - (inst b :le label))) - ((= end max) - (inst cmp reg start) - (if last - (inst b greater-or-equal target) - (inst b :ge label))) - (t - (inst cmp reg start) - (inst b :lt (if not-p target not-target)) - (inst cmp reg end) - (if last - (inst b less-or-equal target) - (inst b :le 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 - fun-pointer-lowtag - other-pointer-lowtag)) - (hdrs (sort (copy-list hdrs) #'<)) - (immed (sort (copy-list immed) #'<))) - (append - (when immed - `((inst and ,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 andcc zero-tn ,reg fixnum-tag-mask) - ,(if (or lowtags hdrs) - `(if (member :sparc-v9 *backend-subfeatures*) - (inst b :eq ,(if not-p not-target target) ,(if not-p :pn :pt)) - (inst b :eq ,(if not-p not-target target))) - `(if (member :sparc-v9 *backend-subfeatures*) - (inst b ,(if not-p :ne :eq) ,target ,(if not-p :pn :pt)) - (inst b ,(if not-p :ne :eq) ,target))))) - (when (or lowtags hdrs) - `((inst and ,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 cmp ,temp ,lowtag) - (if (member :sparc-v9 *backend-subfeatures*) - (inst b :ne ,(if not-p target not-target) ,(if not-p :pn :pt)) - (inst b :ne ,(if not-p target not-target))) - (inst nop) - (load-type ,temp ,reg (- ,lowtag)) - ,@(gen-other-immediate-test temp target not-target not-p hdrs)))))) -(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-TYPE 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-TYPE supersedes the use of ~S" immediates) - (setf immediates nil)) - (when (intersection headers *fun-header-widetags*) - (unless (subsetp headers *fun-header-widetags*) - (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))))) - (inst nop) - (emit-label ,not-target))))) +(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body) + "Arrange with the garbage collector that the pages occupied by +OBJECTS will not be moved in memory for the duration of BODY. +Useful for e.g. foreign calls where another thread may trigger +garbage collection. This is currently implemented by disabling GC" + (declare (ignore objects)) ;should we eval these for side-effect? + `(without-gcing + ,@body))