X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fmacros.lisp;h=513f9e243ebe1527c43d46ab383e892022a21aba;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=96eb1882db93328c5ce5e063277e25dcfbc4e5aa;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp index 96eb188..513f9e2 100644 --- a/src/compiler/alpha/macros.lisp +++ b/src/compiler/alpha/macros.lisp @@ -16,8 +16,8 @@ (defmacro expand (expr) (let ((gensym (gensym))) `(macrolet - ((,gensym () - ,expr)) + ((,gensym () + ,expr)) (,gensym)))) ;;; instruction-like macros @@ -59,27 +59,27 @@ (defmacro load-symbol-value (reg symbol) `(inst ldl ,reg - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag)) - null-tn)) + (+ (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- 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-lowtag)) - null-tn)) + (+ (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag)) + null-tn)) (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)) `(progn - (inst ldl ,n-target ,n-offset ,n-source) - (inst and ,n-target #xff ,n-target)))) + (inst ldl ,n-target ,n-offset ,n-source) + (inst and ,n-target #xff ,n-target)))) ;;; macros to handle the fact that we cannot use the machine native ;;; call and return instructions @@ -87,20 +87,20 @@ (defmacro lisp-jump (function lip) "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn - (inst lda ,lip (- (ash sb!vm:simple-fun-code-offset sb!vm:word-shift) - sb!vm:fun-pointer-lowtag) - ,function) + (inst lda ,lip (- (ash simple-fun-code-offset word-shift) + fun-pointer-lowtag) + ,function) (move ,function code-tn) (inst jsr zero-tn ,lip 1))) (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) "Return to RETURN-PC. LIP is an interior-reg temporary." `(progn - (inst lda ,lip - (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag) - ,return-pc) + (inst lda ,lip + (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag) + ,return-pc) ,@(when frob-code - `((move ,return-pc code-tn))) + `((move ,return-pc code-tn))) (inst ret zero-tn ,lip 1))) @@ -108,7 +108,7 @@ "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))) @@ -119,45 +119,45 @@ ;;; 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)))))) ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there. (defmacro maybe-load-stack-tn (reg reg-or-stack) (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-stack ,n-reg)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-stack ,n-reg)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there. (defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp) (once-only ((n-reg reg) - (n-stack reg-or-stack)) + (n-stack reg-or-stack)) `(when ,reg - (sc-case ,n-reg - ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-stack ,n-reg)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)) - (inst mskll nsp-tn 0 ,temp) - (inst bis ,temp ,n-reg ,n-reg)))))))) + (sc-case ,n-reg + ((any-reg descriptor-reg) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-stack ,n-reg)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)) + (inst mskll nsp-tn 0 ,temp) + (inst bis ,temp ,n-reg ,n-reg)))))))) ;;;; storage allocation @@ -168,54 +168,51 @@ ;;; the body.) The body is placed inside the PSEUDO-ATOMIC, and ;;; presumably initializes the object. (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-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)) + &body body) + (unless body + (bug "empty &body in WITH-FIXED-ALLOCATION")) + (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size)) + `(pseudo-atomic (:extra (pad-data-block ,size)) + (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))) + +(defun align-csp (temp) + ;; is used for stack allocation of dynamic-extent objects + (let ((aligned (gen-label))) + (inst and csp-tn lowtag-mask temp) + (inst beq temp aligned) + (inst addq csp-tn n-word-bytes csp-tn) + (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)))) - (setf (fill-pointer ,var) 0) - (unwind-protect - (progn - ,@body) - (push ,var *adjustable-vectors*)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) +(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 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))) - 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 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))) + 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) @@ -239,292 +236,293 @@ 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))))) -;;; 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 n-word-bytes) - (- lowtag)) - scale)) - ,(truncate (- (+ (1- (ash 1 16)) lowtag) - (* max-offset n-word-bytes)) - scale))) +;;;; memory accessor vop generators (defmacro define-full-reffer (name type offset lowtag scs el-type - &optional translate) + &optional translate) `(progn (define-vop (,name) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types ,type tagged-num) (:temporary (:scs (interior-reg)) lip) (:results (value :scs ,scs)) (:result-types ,el-type) (:generator 5 - (inst addq object index lip) - (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip) - ,@(when (equal scs '(unsigned-reg)) - '((inst mskll value 4 value))))) + (inst addq object index 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")) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg))) (:info index) (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset)))) + (: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) n-word-bytes) ,lowtag) - object) - ,@(when (equal scs '(unsigned-reg)) - '((inst mskll value 4 value))))))) + (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 - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs ,scs :target result)) + (index :scs (any-reg)) + (value :scs ,scs :target result)) (:arg-types ,type tagged-num ,el-type) (:temporary (:scs (interior-reg)) lip) (:results (result :scs ,scs)) (:result-types ,el-type) (:generator 2 - (inst addq index object lip) - (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip) - (move value result))) + (inst addq index object lip) + (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip) + (move value result))) (define-vop (,(symbolicate name "-C")) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (value :scs ,scs)) + (value :scs ,scs)) (:info index) (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset))) - ,el-type) + (: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) n-word-bytes) ,lowtag) - object) - (move value result))))) + (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) + object) + (move value result))))) (defmacro define-partial-reffer (name type size signed offset lowtag scs - el-type &optional translate) + el-type &optional translate) (let ((scale (ecase size (:byte 1) (:short 2)))) `(progn (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:generator 5 - (inst addq object index lip) - ,@(when (eq size :short) - '((inst addq index lip lip))) - ,@(ecase size - (:byte - (if signed - `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) - lip) - (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 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 n-word-bytes) ,lowtag) - lip) - (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 n-word-bytes) ,lowtag) - lip) - (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst extwl temp temp1 value))))))) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:generator 5 + (inst addq object index lip) + ,@(when (eq size :short) + '((inst addq index lip lip))) + ,@(ecase size + (:byte + (if signed + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) + lip) + (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 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 n-word-bytes) ,lowtag) + lip) + (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 n-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 - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:generator 5 - ,@(ecase size - (:byte - (if signed - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (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 n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst extbl temp temp1 value)))) - (:short - (if signed - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (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 n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst extwl temp temp1 value)))))))))) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset)))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:generator 4 + ,@(ecase size + (:byte + (if signed + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (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 n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst extbl temp temp1 value)))) + (:short + (if signed + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (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 n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst extwl temp temp1 value)))))))))) (defmacro define-partial-setter (name type size offset lowtag scs el-type - &optional translate) + &optional translate) (let ((scale (ecase size (:byte 1) (:short 2)))) `(progn (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type positive-fixnum ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:temporary (:sc non-descriptor-reg) temp2) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst addq object index lip) - ,@(when (eq size :short) - '((inst addq lip index lip))) - ,@(ecase size - (:byte - `((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 n-word-bytes) ,lowtag) lip))) - (:short - `((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 n-word-bytes) ,lowtag) lip)))) - (move value result))) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type positive-fixnum ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:temporary (:sc non-descriptor-reg) temp2) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst addq object index lip) + ,@(when (eq size :short) + '((inst addq lip index lip))) + ,@(ecase size + (:byte + `((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 n-word-bytes) ,lowtag) lip))) + (:short + `((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 n-word-bytes) ,lowtag) lip)))) + (move value result))) (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs :target result)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:temporary (:sc non-descriptor-reg) temp2) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - ,@(ecase size - (:byte - `((inst lda temp (- (* ,offset n-word-bytes) - (* index ,scale) ,lowtag) - object) - (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 n-word-bytes) - (* index ,scale) ,lowtag) object))) - (:short - `((inst lda temp (- (* ,offset n-word-bytes) - (* index ,scale) ,lowtag) - object) - (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 n-word-bytes) - (* index ,scale) ,lowtag) object)))) - (move value result)))))) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs :target result)) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset))) + ,el-type) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:temporary (:sc non-descriptor-reg) temp2) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 4 + ,@(ecase size + (:byte + `((inst lda temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) + object) + (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 n-word-bytes) + (* index ,scale)) + ,lowtag) object))) + (:short + `((inst lda temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) + object) + (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 n-word-bytes) + (* index ,scale)) + ,lowtag) object)))) + (move value result)))))) + +(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))