X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fmacros.lisp;h=513f9e243ebe1527c43d46ab383e892022a21aba;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=fcb878f66df8fe15795a5e9a3dfd79dd18debae4;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp index fcb878f..513f9e2 100644 --- a/src/compiler/alpha/macros.lisp +++ b/src/compiler/alpha/macros.lisp @@ -1,34 +1,26 @@ -;;; -*- Package: ALPHA; Log: C.Log -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; - -;;; -;;; ********************************************************************** -;;; -;;; This file contains various useful macros for generating Alpha code. -;;; -;;; Written by William Lott and Christopher Hoover. -;;; Alpha conversion by Sean Hallgren. -;;; - -(in-package "SB!VM") +;;;; various useful macros for generating Alpha code +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. -;;; Handy macro for defining top-level forms that depend on the compile -;;; environment. +(in-package "SB!VM") +;;; a handy macro for defining top level forms that depend on the +;;; compile environment (defmacro expand (expr) (let ((gensym (gensym))) `(macrolet - ((,gensym () - ,expr)) + ((,gensym () + ,expr)) (,gensym)))) - -;;; Instruction-like macros. +;;; instruction-like macros ;;; c.f. x86 backend: ;;(defmacro move (dst src) @@ -39,7 +31,6 @@ ;; `(unless (location= ,n-dst ,n-src) ;; (inst mov ,n-dst ,n-src)))) - (defmacro move (src dst) "Move SRC into DST unless they are location=." (once-only ((n-src src) (n-dst dst)) @@ -68,48 +59,48 @@ (defmacro load-symbol-value (reg symbol) `(inst ldl ,reg - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-type)) - 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-type)) - 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. +;;; macros to handle the fact that we cannot use the machine native +;;; call and return instructions (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) - ,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) word-bytes) other-pointer-type) - ,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))) @@ -117,127 +108,111 @@ "Emit a return-pc header word. LABEL is the label to use for this return-pc." `(progn - (align 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. -;;; (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 -;;; +;;; Move the TN Reg-Or-Stack into Reg if it isn't already there. (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-stack ,n-reg)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) - -;;; MAYBE-LOAD-STACK-NFP-TN -- Interface -;;; + (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) - "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)) `(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: - -(defmacro with-fixed-allocation ((result-tn temp-tn type-code size) - &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, 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." - `(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) - ,@body)) - - +;;;; storage allocation + +;;; 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 widetag size) + &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) +;;;; 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 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) @@ -261,289 +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 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) + &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 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 ,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) 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 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 ,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) 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 word-bytes) ,lowtag) - lip) - (inst lda temp1 (1+ (- (* ,offset 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) - lip) - (inst extbl temp temp1 value)))) - (:short - (if signed - `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) - lip) - (inst lda temp1 (- (* ,offset 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) - lip) - (inst lda temp1 (- (* ,offset 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 word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (1+ (- (+ (* ,offset word-bytes) - (* index ,scale)) ,lowtag)) - object) - (inst extqh temp temp1 temp) - (inst sra temp 56 value)) - `((inst ldq_u temp (- (+ (* ,offset word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst extbl temp temp1 value)))) - (:short - (if signed - `((inst ldq_u temp (- (+ (* ,offset word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset 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) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset 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 word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset 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))) - (:short - `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset 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)))) - (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 word-bytes) - (* index ,scale) ,lowtag) - object) - (inst ldq_u temp1 (- (* ,offset 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) - (* index ,scale) ,lowtag) object))) - (:short - `((inst lda temp (- (* ,offset word-bytes) - (* index ,scale) ,lowtag) - object) - (inst ldq_u temp1 (- (* ,offset 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) - (* 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))