X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fmacros.lisp;h=1905a7f449377f992cef6f7357c3cc1a7311c0d0;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=2dfb14be891c802b7396eb64f886661f418bca3f;hpb=7ce4dc62a7b03590b127bb950738e771e33341a7;p=sbcl.git diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp index 2dfb14b..1905a7f 100644 --- a/src/compiler/ppc/macros.lisp +++ b/src/compiler/ppc/macros.lisp @@ -16,16 +16,16 @@ (defmacro move (dst src) "Move SRC into DST unless they are location=." (once-only ((n-dst dst) - (n-src src)) + (n-src src)) `(unless (location= ,n-dst ,n-src) (inst mr ,n-dst ,n-src)))) (macrolet - ((frob (op inst shift) + ((def (op inst shift) `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) - `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))))) - (frob loadw lwz word-shift) - (frob storew stw word-shift)) + `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))))) + (def loadw lwz word-shift) + (def storew stw word-shift)) (defmacro load-symbol (reg symbol) `(inst addi ,reg null-tn (static-symbol-offset ,symbol))) @@ -33,68 +33,95 @@ (macrolet ((frob (slot) (let ((loader (intern (concatenate 'simple-string - "LOAD-SYMBOL-" - (string slot)))) - (storer (intern (concatenate 'simple-string - "STORE-SYMBOL-" - (string slot)))) - (offset (intern (concatenate 'simple-string - "SYMBOL-" - (string slot) - "-SLOT") - (find-package "SB!VM")))) - `(progn - (defmacro ,loader (reg symbol) - `(inst lwz ,reg null-tn - (+ (static-symbol-offset ',symbol) - (ash ,',offset word-shift) - (- other-pointer-lowtag)))) - (defmacro ,storer (reg symbol) - `(inst stw ,reg null-tn - (+ (static-symbol-offset ',symbol) - (ash ,',offset word-shift) - (- other-pointer-lowtag)))))))) + "LOAD-SYMBOL-" + (string slot)))) + (storer (intern (concatenate 'simple-string + "STORE-SYMBOL-" + (string slot)))) + (offset (intern (concatenate 'simple-string + "SYMBOL-" + (string slot) + "-SLOT") + (find-package "SB!VM")))) + `(progn + (defmacro ,loader (reg symbol) + `(inst lwz ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-lowtag)))) + (defmacro ,storer (reg symbol) + `(inst stw ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-lowtag)))))))) (frob value) - (frob function)) + (frob function) + + ;; FIXME: These are only good for static-symbols, so why not + ;; statically-allocate the static-symbol TLS slot indices at + ;; cross-compile time so we can just use a fixed offset within the + ;; TLS block instead of mucking about with the extra memory access + ;; (and temp register, for stores)? + #!+sb-thread + (defmacro load-tl-symbol-value (reg symbol) + `(progn + (inst lwz ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag))) + (inst lwzx ,reg thread-base-tn ,reg))) + #!-sb-thread + (defmacro load-tl-symbol-value (reg symbol) + `(load-symbol-value ,reg ,symbol)) + + #!+sb-thread + (defmacro store-tl-symbol-value (reg symbol temp) + `(progn + (inst lwz ,temp null-tn + (+ (static-symbol-offset ',symbol) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag))) + (inst stwx ,reg thread-base-tn ,temp))) + #!-sb-thread + (defmacro store-tl-symbol-value (reg symbol temp) + (declare (ignore temp)) + `(store-symbol-value ,reg ,symbol))) (defmacro load-type (target source &optional (offset 0)) "Loads the type bits of a pointer into target independent of byte-ordering issues." (once-only ((n-target target) - (n-source source) - (n-offset offset)) + (n-source source) + (n-offset offset)) (ecase *backend-byte-order* (:little-endian `(inst lbz ,n-target ,n-source ,n-offset)) (:big-endian - `(inst lbz ,n-target ,n-source (+ ,n-offset 3)))))) + `(inst lbz ,n-target ,n-source (+ ,n-offset (1- n-word-bytes))))))) ;;; Macros to handle the fact that we cannot use the machine native call and -;;; return instructions. +;;; return instructions. (defmacro lisp-jump (function lip) "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn ;; something is deeply bogus. look at this - ;; (loadw ,lip ,function sb!vm:function-code-offset sb!vm:function-pointer-type) - (inst addi ,lip ,function (- (* n-word-bytes sb!vm:simple-fun-code-offset) sb!vm:fun-pointer-lowtag)) + ;; (loadw ,lip ,function function-code-offset function-pointer-type) + (inst addi ,lip ,function (- (* n-word-bytes simple-fun-code-offset) fun-pointer-lowtag)) (inst mtctr ,lip) - (move code-tn ,function) (inst bctr))) -(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) +(defmacro lisp-return (return-pc lip &key (offset 0)) "Return to RETURN-PC." `(progn (inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)) (inst mtlr ,lip) - ,@(if frob-code - `((move code-tn ,return-pc))) (inst blr))) (defmacro emit-return-pc (label) "Emit a return-pc header word. LABEL is the label to use for this return-pc." `(progn - (align n-lowtag-bits) + (emit-alignment n-lowtag-bits) (emit-label ,label) (inst lra-header-word))) @@ -102,165 +129,259 @@ ;;;; 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)) + (stack ,stack)) (let ((offset (tn-offset stack))) (sc-case stack - ((control-stack) - (loadw reg cfp-tn offset)))))) - + ((control-stack) + (loadw reg cfp-tn offset)))))) (defmacro store-stack-tn (stack reg) `(let ((stack ,stack) - (reg ,reg)) + (reg ,reg)) (let ((offset (tn-offset stack))) (sc-case stack - ((control-stack) - (storew reg cfp-tn offset)))))) + ((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) - (n-stack reg-or-stack)) + (n-stack reg-or-stack)) `(sc-case ,n-reg ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-reg ,n-stack)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-reg ,n-stack)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) ;;;; Storage allocation: -(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) - &body body) +;;; This is the main mechanism for allocating memory in the lisp heap. +;;; +;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG +;;; applied. The amount of space to be allocated is SIZE bytes (which +;;; must be a multiple of the lisp object size). +;;; +;;; On other platforms (Non-PPC), if STACK-P is given, then allocation +;;; occurs on the control stack (for dynamic-extent). In this case, +;;; you MUST also specify NODE, so that the appropriate compiler +;;; policy can be used, and TEMP-TN, which is needed for work-space. +;;; TEMP-TN MUST be a non-descriptor reg. FIXME: This is not yet +;;; implemented on PPC. We should implement this and replace the +;;; inline stack-based allocation that presently occurs in the +;;; VOPs. The stack-p argument is ignored on PPC. +;;; +;;; If generational GC is enabled, you MUST supply a value for TEMP-TN +;;; because a temp register is needed to do inline allocation. +;;; TEMP-TN, in this case, can be any register, since it holds a +;;; double-word aligned address (essentially a fixnum). +(defmacro allocation (result-tn size lowtag &key stack-p node temp-tn flag-tn) + ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is + ;; set. If the lowtag also has a 1 bit in the same position, we're all + ;; set. Otherwise, we need to zap out the lowtag from alloc-tn, and + ;; then or in the lowtag. + ;; Normal allocation to the heap. + (declare (ignore stack-p node) + #!-gencgc + (ignore temp-tn flag-tn)) + #!-gencgc + (let ((alloc-size (gensym))) + `(let ((,alloc-size ,size)) + (if (logbitp (1- n-lowtag-bits) ,lowtag) + (progn + (inst ori ,result-tn alloc-tn ,lowtag)) + (progn + (inst clrrwi ,result-tn alloc-tn n-lowtag-bits) + (inst ori ,result-tn ,result-tn ,lowtag))) + (if (numberp ,alloc-size) + (inst addi alloc-tn alloc-tn ,alloc-size) + (inst add alloc-tn alloc-tn ,alloc-size)))) + #!+gencgc + `(progn + ;; Make temp-tn be the size + (cond ((numberp ,size) + (inst lr ,temp-tn ,size)) + (t + (move ,temp-tn ,size))) + + #!-sb-thread + (inst lr ,flag-tn (make-fixup "boxed_region" :foreign)) + #!-sb-thread + (inst lwz ,result-tn ,flag-tn 0) + #!+sb-thread + (inst lwz ,result-tn thread-base-tn (* thread-alloc-region-slot + n-word-bytes)) + + ;; we can optimize this to only use one fixup here, once we get + ;; it working + ;; (inst lr ,flag-tn (make-fixup "boxed_region" :foreign 4)) + ;; (inst lwz ,flag-tn ,flag-tn 0) + #!-sb-thread + (inst lwz ,flag-tn ,flag-tn 4) + #!+sb-thread + (inst lwz ,flag-tn thread-base-tn (* (1+ thread-alloc-region-slot) + n-word-bytes)) + + (without-scheduling () + ;; CAUTION: The C code depends on the exact order of + ;; instructions here. In particular, immediately before the + ;; TW instruction must be an ADD or ADDI instruction, so it + ;; can figure out the size of the desired allocation and + ;; storing the new base pointer back to the allocation region + ;; must take two instructions (one on threaded targets). + + ;; Now make result-tn point at the end of the object, to + ;; figure out if we overflowed the current region. + (inst add ,result-tn ,result-tn ,temp-tn) + ;; result-tn points to the new end of the region. Did we go past + ;; the actual end of the region? If so, we need a full alloc. + ;; The C code depends on this exact form of instruction. If + ;; either changes, you have to change the other appropriately! + (inst tw :lge ,result-tn ,flag-tn) + + ;; The C code depends on this instruction sequence taking up + ;; #!-sb-thread three #!+sb-thread one machine instruction. + ;; The lr of a fixup counts as two instructions. + #!-sb-thread + (inst lr ,flag-tn (make-fixup "boxed_region" :foreign)) + #!-sb-thread + (inst stw ,result-tn ,flag-tn 0) + #!+sb-thread + (inst stw ,result-tn thread-base-tn (* thread-alloc-region-slot + n-word-bytes))) + + ;; Should the allocation trap above have fired, the runtime + ;; arranges for execution to resume here, just after where we + ;; would have updated the free pointer in the alloc region. + + ;; At this point, result-tn points at the end of the object. + ;; Adjust to point to the beginning. + (inst sub ,result-tn ,result-tn ,temp-tn) + ;; Set the lowtag appropriately + (inst ori ,result-tn ,result-tn ,lowtag))) + +(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size + &key (lowtag other-pointer-lowtag) + stack-allocate-p) + &body body) "Do stuff to allocate an other-pointer object of fixed Size with a single word header having the specified Type-Code. The result is placed in Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably initializes the object." (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn) - (type-code type-code) (size size)) - `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) - (inst ori ,result-tn alloc-tn other-pointer-lowtag) - (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) - (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) + (type-code type-code) (size size) (lowtag lowtag)) + `(pseudo-atomic (,flag-tn) + (if ,stack-allocate-p + (progn + (align-csp ,temp-tn) + (inst ori ,result-tn csp-tn ,lowtag) + (inst addi csp-tn csp-tn (pad-data-block ,size))) + (allocation ,result-tn (pad-data-block ,size) ,lowtag + :temp-tn ,temp-tn + :flag-tn ,flag-tn)) + (when ,type-code + (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 ,lowtag)) ,@body))) +(defun align-csp (temp) + ;; is used for stack allocation of dynamic-extent objects + (let ((aligned (gen-label))) + (inst andi. temp csp-tn lowtag-mask) + (inst beq aligned) + (inst addi csp-tn csp-tn n-word-bytes) + (storew zero-tn csp-tn -1) + (emit-label aligned))) + ;;;; 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)))) - (declare (type (vector (unsigned-byte 8) 16) ,var)) - (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))) - `((let ((vop ,vop)) - (when vop - (note-this-location vop :internal-error))) - (inst unimp ,kind) - (with-adjustable-vector (,vector) - (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar #'(lambda (tn) - `(let ((tn ,tn)) - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (tn-offset tn)) - ,vector))) - values) - (inst byte (length ,vector)) - (dotimes (i (length ,vector)) - (inst byte (aref ,vector i)))) - (align word-shift))))) - -(defmacro error-call (vop error-code &rest values) +(defun emit-error-break (vop kind code values) + (assemble () + (when vop + (note-this-location vop :internal-error)) + (inst unimp kind) + (with-adjustable-vector (vector) + (write-var-integer code vector) + (dolist (tn values) + (write-var-integer (make-sc-offset (sc-number (tn-sc tn)) + (or (tn-offset tn) 0)) + vector)) + (inst byte (length vector)) + (dotimes (i (length vector)) + (inst byte (aref vector i))) + (emit-alignment word-shift)))) + +(defun error-call (vop error-code &rest values) + #!+sb-doc "Cause an error. ERROR-CODE is the error to cause." - (cons 'progn - (emit-error-break vop error-trap error-code values))) + (emit-error-break vop error-trap (error-number-or-lose error-code) values)) - -(defmacro cerror-call (vop label error-code &rest values) - "Cause a continuable error. If the error is continued, execution resumes at - LABEL." - `(progn - ,@(emit-error-break vop cerror-trap error-code values) - (inst b ,label))) - -(defmacro generate-error-code (vop error-code &rest values) +(defun generate-error-code (vop error-code &rest values) + #!+sb-doc "Generate-Error-Code Error-code Value* Emit code for an error with the specified Error-Code and context Values." - `(assemble (*elsewhere*) - (let ((start-lab (gen-label))) - (emit-label start-lab) - (error-call ,vop ,error-code ,@values) - start-lab))) - -(defmacro generate-cerror-code (vop error-code &rest values) - "Generate-CError-Code Error-code Value* - 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-"))) - `(let ((,continue (gen-label))) - (emit-label ,continue) - (assemble (*elsewhere*) - (let ((,error (gen-label))) - (emit-label ,error) - (cerror-call ,vop ,continue ,error-code ,@values) - ,error))))) - - + (assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (emit-error-break vop error-trap (error-number-or-lose error-code) values) + start-lab))) -;;; 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. -(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms) - (let ((n-extra (gensym))) - `(let ((,n-extra ,extra)) - (without-scheduling () - ;; Extra debugging stuff: - #+debug - (progn - (inst andi. ,flag-tn alloc-tn 7) - (inst twi :ne ,flag-tn 0)) - (inst lr ,flag-tn (- ,n-extra 4)) - (inst addi alloc-tn alloc-tn 4)) - ,@forms - (without-scheduling () - (inst add alloc-tn alloc-tn ,flag-tn) - (inst twi :lt alloc-tn 0)) - #+debug - (progn - (inst andi. ,flag-tn alloc-tn 7) - (inst twi :ne ,flag-tn 0))))) - - +;;;; 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. +(defmacro pseudo-atomic ((flag-tn) &body forms) + #!+sb-safepoint-strictly + `(progn ,flag-tn ,@forms (emit-safepoint)) + #!-sb-safepoint-strictly + `(progn + (without-scheduling () + ;; Extra debugging stuff: + #+debug + (progn + (inst andi. ,flag-tn alloc-tn lowtag-mask) + (inst twi :ne ,flag-tn 0)) + (inst ori alloc-tn alloc-tn pseudo-atomic-flag)) + ,@forms + (inst sync) + (without-scheduling () + (inst subi alloc-tn alloc-tn pseudo-atomic-flag) + ;; Now test to see if the pseudo-atomic interrupted bit is set. + (inst andi. ,flag-tn alloc-tn pseudo-atomic-interrupted-flag) + (inst twi :ne ,flag-tn 0)) + #+debug + (progn + (inst andi. ,flag-tn alloc-tn lowtag-mask) + (inst twi :ne ,flag-tn 0)) + #!+sb-safepoint + (emit-safepoint))) + +#!+sb-safepoint +(defun emit-safepoint () + (inst lwz zero-tn null-tn (- (+ 4096 4 other-pointer-lowtag)))) + +(def!macro 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" + #!-gencgc + (declare (ignore objects)) ; should we eval these for side-effect? + #!-gencgc + `(without-gcing + ,@body) + #!+gencgc + `(let ((*pinned-objects* (list* ,@objects *pinned-objects*))) + (declare (truly-dynamic-extent *pinned-objects*)) + ,@body))