X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsparc%2Fmacros.lisp;h=5136a42481c42c8a73e2dbb66ff05cfdb6fdc81d;hb=56c7428e2bcb149dac575142d5d17e0b297f8670;hp=dc0e1f51c1fdee91725d87d0ea50b9baecb0c0df;hpb=369029d73f198b59135c6c005b7a70ae5a753650;p=sbcl.git diff --git a/src/compiler/sparc/macros.lisp b/src/compiler/sparc/macros.lisp index dc0e1f5..5136a42 100644 --- a/src/compiler/sparc/macros.lisp +++ b/src/compiler/sparc/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 move ,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 ld word-shift) - (frob storew st word-shift)) + `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))))) + (def loadw ld word-shift) + (def storew st word-shift)) (defmacro load-symbol (reg symbol) `(inst add ,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 ld ,reg null-tn - (+ (static-symbol-offset ',symbol) - (ash ,',offset word-shift) - (- other-pointer-lowtag)))) - (defmacro ,storer (reg symbol) - `(inst st ,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 ld ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-lowtag)))) + (defmacro ,storer (reg symbol) + `(inst st ,reg null-tn + (+ (static-symbol-offset ',symbol) + (ash ,',offset word-shift) + (- other-pointer-lowtag)))))))) (frob value) (frob function)) @@ -62,142 +62,131 @@ "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)) ;; FIXME: although I don't understand entirely, I'm going to do ;; what whn does in x86/macros.lisp -- Christophe (ecase *backend-byte-order* (:little-endian `(inst ldub ,n-target ,n-source ,n-offset)) (:big-endian - `(inst ldub ,n-target ,n-source (+ ,n-offset 3)))))) + `(inst ldub ,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 (fun) "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn (inst j ,fun - (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)) + (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)) (move code-tn ,fun))) (defmacro lisp-return (return-pc &key (offset 0) (frob-code t)) "Return to RETURN-PC." `(progn (inst j ,return-pc - (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)) + (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)) ,(if frob-code - `(move code-tn ,return-pc) - '(inst nop)))) + `(move code-tn ,return-pc) + '(inst nop)))) (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))) -;;;; 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)) + (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 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) - (type-code type-code) (size size)) + (type-code type-code) (size size)) `(pseudo-atomic (:extra (pad-data-block ,size)) (inst or ,result-tn alloc-tn other-pointer-lowtag) (inst li ,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) + (let ((aligned (gen-label))) + ;; FIXME: why use a TEMP? Why not just ZERO-TN? + (inst andcc temp csp-tn lowtag-mask) + (if (member :sparc-v9 *backend-subfeatures*) + (inst b :eq aligned :pt) + (inst b :eq aligned)) + (storew zero-tn csp-tn 0) ; sneaky use of delay slot + (inst add csp-tn csp-tn n-word-bytes) + (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))))) + (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)))) + (emit-alignment 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) @@ -221,17 +210,14 @@ 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*) - (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))))) ;;; a handy macro for making sequences look atomic (defmacro pseudo-atomic ((&key (extra 0)) &rest forms) @@ -239,15 +225,24 @@ `(let ((,n-extra ,extra)) ;; Set the pseudo-atomic flag. (without-scheduling () - (inst add alloc-tn 4)) + (inst add alloc-tn 4)) ,@forms ;; Reset the pseudo-atomic flag. (without-scheduling () - #+nil (inst taddcctv alloc-tn (- ,n-extra 4)) - ;; Remove the pseudo-atomic flag. - (inst add alloc-tn (- ,n-extra 4)) - ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1). - (inst andcc zero-tn alloc-tn 3) - ;; The C code needs to process this correctly and fixup alloc-tn. - (inst t :ne pseudo-atomic-trap))))) - + #+nil (inst taddcctv alloc-tn (- ,n-extra 4)) + ;; Remove the pseudo-atomic flag. + (inst add alloc-tn (- ,n-extra 4)) + ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1). + (inst andcc zero-tn alloc-tn 3) + ;; The C code needs to process this correctly and fixup alloc-tn. + (inst t :ne pseudo-atomic-trap))))) + + +(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" + (declare (ignore objects)) ;should we eval these for side-effect? + `(without-gcing + ,@body))