X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fmacros.lisp;h=283cf22954b2d87bae5c62504128286978a2cc19;hb=b7eed59f1877263e1af5ad80299e641e8276f77d;hp=9e02f62a629df635e2e08116cf364455849fa2e9;hpb=63fcb94b875a97e468d9add229e220ecceec2352;p=sbcl.git diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp index 9e02f62..283cf22 100644 --- a/src/compiler/alpha/macros.lisp +++ b/src/compiler/alpha/macros.lisp @@ -11,7 +11,7 @@ (in-package "SB!VM") -;;; a handy macro for defining top-level forms that depend on the +;;; a handy macro for defining top level forms that depend on the ;;; compile environment (defmacro expand (expr) (let ((gensym (gensym))) @@ -61,14 +61,14 @@ `(inst ldl ,reg (+ (static-symbol-offset ',symbol) (ash symbol-value-slot word-shift) - (- other-pointer-type)) + (- other-pointer-lowtag)) null-tn)) (defmacro store-symbol-value (reg symbol) `(inst stl ,reg (+ (static-symbol-offset ',symbol) (ash symbol-value-slot word-shift) - (- other-pointer-type)) + (- other-pointer-lowtag)) null-tn)) (defmacro load-type (target source &optional (offset 0)) @@ -87,8 +87,8 @@ (defmacro lisp-jump (function lip) "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn - (inst lda ,lip (- (ash sb!vm:function-code-offset sb!vm:word-shift) - sb!vm:function-pointer-type) + (inst lda ,lip (- (ash sb!vm:simple-fun-code-offset sb!vm:word-shift) + sb!vm:fun-pointer-lowtag) ,function) (move ,function code-tn) (inst jsr zero-tn ,lip 1))) @@ -97,7 +97,7 @@ "Return to RETURN-PC. LIP is an interior-reg temporary." `(progn (inst lda ,lip - (- (* (1+ ,offset) word-bytes) other-pointer-type) + (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag) ,return-pc) ,@(when frob-code `((move ,return-pc code-tn))) @@ -108,7 +108,7 @@ "Emit a return-pc header word. LABEL is the label to use for this return-pc." `(progn - (align lowtag-bits) + (align n-lowtag-bits) (emit-label ,label) (inst lra-header-word))) @@ -161,39 +161,21 @@ ;;;; storage allocation -;;; 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, Flag-Tn must be wired to NL3-OFFSET, and +;;; Do stuff to allocate an other-pointer object of fixed SIZE with a +;;; single word header having the specified WIDETAG value. The result is +;;; placed in RESULT-TN, Flag-Tn must be wired to NL3-OFFSET, 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. -(defmacro with-fixed-allocation ((result-tn temp-tn type-code size) +(defmacro with-fixed-allocation ((result-tn temp-tn widetag size) &body body) `(pseudo-atomic (:extra (pad-data-block ,size)) - (inst bis alloc-tn other-pointer-type ,result-tn) - (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn) - (storew ,temp-tn ,result-tn 0 other-pointer-type) + (inst bis alloc-tn other-pointer-lowtag ,result-tn) + (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn) + (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) ,@body)) - - -;;;; 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*)))) - +;;;; error code (eval-when (:compile-toplevel :load-toplevel :execute) (defun emit-error-break (vop kind code values) (let ((vector (gensym))) @@ -203,12 +185,12 @@ (inst gentrap ,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))) + ,@(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)) @@ -242,8 +224,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*) @@ -253,28 +234,15 @@ ,error))))) -;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic. -;;; +;;; a handy macro for making sequences look atomic (defmacro pseudo-atomic ((&key (extra 0)) &rest forms) `(progn (inst addq alloc-tn 1 alloc-tn) ,@forms (inst lda alloc-tn (1- ,extra) alloc-tn) (inst stl zero-tn 0 alloc-tn))) - - -;;;; Memory accessor vop generators - -(deftype load/store-index (scale lowtag min-offset - &optional (max-offset min-offset)) - `(integer ,(- (truncate (+ (ash 1 16) - (* min-offset word-bytes) - (- lowtag)) - scale)) - ,(truncate (- (+ (1- (ash 1 16)) lowtag) - (* max-offset word-bytes)) - scale))) +;;;; memory accessor vop generators (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate) @@ -291,7 +259,7 @@ (:result-types ,el-type) (:generator 5 (inst addq object index lip) - (inst ldl value (- (* ,offset word-bytes) ,lowtag) lip) + (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip) ,@(when (equal scs '(unsigned-reg)) '((inst mskll value 4 value))))) (define-vop (,(symbolicate name "-C")) @@ -301,18 +269,18 @@ (:args (object :scs (descriptor-reg))) (:info index) (:arg-types ,type - (:constant (load/store-index ,word-bytes ,(eval lowtag) + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) ,(eval offset)))) (:results (value :scs ,scs)) (:result-types ,el-type) (:generator 4 - (inst ldl value (- (* (+ ,offset index) word-bytes) ,lowtag) + (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object) ,@(when (equal scs '(unsigned-reg)) '((inst mskll value 4 value))))))) (defmacro define-full-setter (name type offset lowtag scs el-type - &optional translate #+gengc (remember t)) + &optional translate #!+gengc (remember t)) `(progn (define-vop (,name) ,@(when translate @@ -327,7 +295,7 @@ (:result-types ,el-type) (:generator 2 (inst addq index object lip) - (inst stl value (- (* ,offset word-bytes) ,lowtag) lip) + (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip) (move value result))) (define-vop (,(symbolicate name "-C")) ,@(when translate @@ -337,13 +305,13 @@ (value :scs ,scs)) (:info index) (:arg-types ,type - (:constant (load/store-index ,word-bytes ,(eval lowtag) + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) ,(eval offset))) ,el-type) (:results (result :scs ,scs)) (:result-types ,el-type) (:generator 1 - (inst stl value (- (* (+ ,offset index) word-bytes) ,lowtag) + (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object) (move value result))))) @@ -371,28 +339,31 @@ ,@(ecase size (:byte (if signed - `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst lda temp1 (1+ (- (* ,offset word-bytes) ,lowtag)) + (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag)) lip) (inst extqh temp temp1 temp) (inst sra temp 56 value)) - `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) lip) - (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) + `((inst ldq_u + temp + (- (* ,offset n-word-bytes) ,lowtag) + lip) + (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst extbl temp temp1 value)))) (:short (if signed - `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) + (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst extwl temp temp1 temp) (inst sll temp 48 temp) (inst sra temp 48 value)) - `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) lip) + (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst extwl temp temp1 value))))))) (define-vop (,(symbolicate name "-C")) ,@(when translate @@ -412,36 +383,36 @@ ,@(ecase size (:byte (if signed - `((inst ldq_u temp (- (+ (* ,offset word-bytes) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) - (inst lda temp1 (1+ (- (+ (* ,offset word-bytes) + (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)) object) (inst extqh temp temp1 temp) (inst sra temp 56 value)) - `((inst ldq_u temp (- (+ (* ,offset word-bytes) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) - (inst lda temp1 (- (+ (* ,offset word-bytes) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) (inst extbl temp temp1 value)))) (:short (if signed - `((inst ldq_u temp (- (+ (* ,offset word-bytes) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) - (inst lda temp1 (- (+ (* ,offset word-bytes) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) (inst extwl temp temp1 temp) (inst sll temp 48 temp) (inst sra temp 48 value)) - `((inst ldq_u temp (- (+ (* ,offset word-bytes) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) - (inst lda temp1 (- (+ (* ,offset word-bytes) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag) object) (inst extwl temp temp1 value)))))))))) @@ -470,19 +441,19 @@ '((inst addq lip index lip))) ,@(ecase size (:byte - `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip) + `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) + (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst insbl value temp temp2) (inst mskbl temp1 temp temp1) (inst bis temp1 temp2 temp1) - (inst stq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip))) + (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip))) (:short - `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip) + `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) + (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) (inst mskwl temp1 temp temp1) (inst inswl value temp temp2) (inst bis temp1 temp2 temp) - (inst stq_u temp (- (* ,offset word-bytes) ,lowtag) lip)))) + (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip)))) (move value result))) (define-vop (,(symbolicate name "-C")) ,@(when translate @@ -504,27 +475,36 @@ (:generator 5 ,@(ecase size (:byte - `((inst lda temp (- (* ,offset word-bytes) + `((inst lda temp (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object) - (inst ldq_u temp1 (- (* ,offset word-bytes) + (inst ldq_u temp1 (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object) (inst insbl value temp temp2) (inst mskbl temp1 temp temp1) (inst bis temp1 temp2 temp1) - (inst stq_u temp1 (- (* ,offset word-bytes) + (inst stq_u temp1 (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object))) (:short - `((inst lda temp (- (* ,offset word-bytes) + `((inst lda temp (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object) - (inst ldq_u temp1 (- (* ,offset word-bytes) + (inst ldq_u temp1 (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object) (inst mskwl temp1 temp temp1) (inst inswl value temp temp2) (inst bis temp1 temp2 temp) - (inst stq_u temp (- (* ,offset word-bytes) + (inst stq_u temp (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag) object)))) (move value result)))))) + +(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))