X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fmacros.lisp;h=41df39a10183560678c12436b163d774fea9192a;hb=d319b944d934f3efbb01a2a345c46bafd40857d0;hp=230bde16554e994e6bb04817c24b7514ec191940;hpb=670010e3f3dcd62efaf23f61abdc73950edb88c6;p=sbcl.git diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp index 230bde1..41df39a 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,27 +33,27 @@ (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)) @@ -61,8 +61,8 @@ "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)) @@ -70,14 +70,14 @@ `(inst lbz ,n-target ,n-source (+ ,n-offset 3)))))) ;;; 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))) @@ -105,75 +105,86 @@ ;;; 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)))))) (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) + &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." + (unless body + (bug "empty &body in WITH-FIXED-ALLOCATION")) (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn) - (type-code type-code) (size size)) + (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) ,@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 (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))))) + (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) "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-code values))) (defmacro cerror-call (vop label error-code &rest values) @@ -201,10 +212,10 @@ `(let ((,continue (gen-label))) (emit-label ,continue) (assemble (*elsewhere*) - (let ((,error (gen-label))) - (emit-label ,error) - (cerror-call ,vop ,continue ,error-code ,@values) - ,error))))) + (let ((,error (gen-label))) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values) + ,error))))) ;;;; PSEUDO-ATOMIC @@ -216,25 +227,34 @@ ;;; 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) +(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &body 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)) + ;; 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))))) + (inst andi. ,flag-tn alloc-tn 7) + (inst twi :ne ,flag-tn 0))))) + +(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))