- (+ (static-symbol-offset ',symbol)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag))
- null-tn
- ,reg))
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag))
+ null-tn
+ ,reg))
(defmacro store-symbol-value (reg symbol)
`(inst stw ,reg (+ (static-symbol-offset ',symbol)
(defmacro store-symbol-value (reg symbol)
`(inst stw ,reg (+ (static-symbol-offset ',symbol)
(defmacro load-type (target source &optional (offset 0))
"Loads the type bits of a pointer into target independent of
(defmacro load-type (target source &optional (offset 0))
"Loads the type bits of a pointer into target independent of
(:little-endian
`(inst ldb ,offset ,source ,target))
(:big-endian
(:little-endian
`(inst ldb ,offset ,source ,target))
(:big-endian
- `(inst ldb (+ ,offset 3) ,source ,target))))
+ `(inst ldb (+ ,offset (1- n-word-bytes)) ,source ,target))))
(defmacro lisp-jump (function)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
(inst addi
(defmacro lisp-jump (function)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
(inst addi
(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)
(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)
- (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))))))))
"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."
"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."
`(pseudo-atomic (:extra (pad-data-block ,size))
(inst move alloc-tn ,result-tn)
(inst dep other-pointer-lowtag 31 3 ,result-tn)
`(pseudo-atomic (:extra (pad-data-block ,size))
(inst move alloc-tn ,result-tn)
(inst dep other-pointer-lowtag 31 3 ,result-tn)
- (when vop
- (note-this-location vop :internal-error)))
- (inst break ,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 break ,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
(defmacro error-call (vop error-code &rest values)
"Cause an error. ERROR-CODE is the error to cause."
(cons 'progn
- (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)))))
- (* min-offset n-word-bytes)
- (- lowtag))
- scale))
- ,(truncate (- (+ (1- (ash 1 14)) lowtag)
- (* max-offset n-word-bytes))
- scale)))
+ (* min-offset n-word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 14)) lowtag)
+ (* max-offset n-word-bytes))
+ scale)))
(:arg-types ,type tagged-num)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 5
(:arg-types ,type tagged-num)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 5
- (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
- (inst ldwx temp object value)))
+ (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
+ (inst ldwx temp object value)))
(:arg-types ,type tagged-num ,el-type)
(:temporary (:scs (interior-reg)) lip)
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 2
(:arg-types ,type tagged-num ,el-type)
(:temporary (:scs (interior-reg)) lip)
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 2
- (inst add object index lip)
- (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
- (move value result)))
+ (inst add object index lip)
+ (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
+ (move value result)))
- (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
- (move value result)))))
+ (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
+ (move value result)))))
- ,@(when translate
- `((:translate ,translate)))
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg)))
- (:arg-types ,type positive-fixnum)
- (:results (value :scs ,scs))
- (:result-types ,el-type)
- (:temporary (:scs (interior-reg)) lip)
- (:generator 5
- (inst ,(ecase size (:byte 'add) (:short 'sh1add))
- index object lip)
- (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
- (- (* ,offset n-word-bytes) ,lowtag) lip value)
- ,@(when signed
- `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 5
+ (inst ,(ecase size (:byte 'add) (:short 'sh1add))
+ index object lip)
+ (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
+ (- (* ,offset n-word-bytes) ,lowtag) lip value)
+ ,@(when signed
+ `((inst extrs value 31 ,(* scale n-byte-bits) 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)
- (:generator 5
- (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
- (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
- object value)
- ,@(when signed
- `((inst extrs value 31 ,(* scale n-byte-bits) 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)
+ (:generator 5
+ (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
+ object value)
+ ,@(when signed
+ `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
- ,@(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)
- (:results (result :scs ,scs))
- (:result-types ,el-type)
- (:generator 5
- (inst ,(ecase size (:byte 'add) (:short 'sh1add))
- index object lip)
- (inst ,(ecase size (:byte 'stb) (:short 'sth))
- value (- (* ,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)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size (:byte 'add) (:short 'sh1add))
+ index object lip)
+ (inst ,(ecase size (:byte 'stb) (:short 'sth))
+ value (- (* ,offset n-word-bytes) ,lowtag) lip)
+ (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)
- (:results (result :scs ,scs))
- (:result-types ,el-type)
- (:generator 5
- (inst ,(ecase size (:byte 'stb) (:short 'sth))
- value
- (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
- object)
- (move value result))))))
-
-
-(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
+ ,@(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)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size (:byte 'stb) (:short 'sth))
+ value
+ (- (+ (* ,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"
"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"