`(unless (location= ,n-dst ,n-src)
(inst mr ,n-dst ,n-src))))
(macrolet
`(unless (location= ,n-dst ,n-src)
(inst mr ,n-dst ,n-src))))
(macrolet
- `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
- (frob loadw lwz word-shift)
- (frob storew stw word-shift))
+ `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
+ (def loadw lwz word-shift)
+ (def storew stw word-shift))
(defmacro load-symbol (reg symbol)
`(inst addi ,reg null-tn (static-symbol-offset ,symbol)))
(defmacro load-symbol (reg symbol)
`(inst addi ,reg null-tn (static-symbol-offset ,symbol)))
- "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 lwz ,reg null-tn
- (+ (static-symbol-offset ',symbol)
- (ash ,',offset word-shift)
- (- other-pointer-lowtag))))
- (defmacro ,storer (reg symbol)
- `(inst stw ,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 lwz ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash ,',offset word-shift)
+ (- other-pointer-lowtag))))
+ (defmacro ,storer (reg symbol)
+ `(inst stw ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash ,',offset word-shift)
+ (- other-pointer-lowtag))))))))
(ecase *backend-byte-order*
(:little-endian
`(inst lbz ,n-target ,n-source ,n-offset))
(ecase *backend-byte-order*
(:little-endian
`(inst lbz ,n-target ,n-source ,n-offset))
`(inst lbz ,n-target ,n-source (+ ,n-offset 3))))))
;;; Macros to handle the fact that we cannot use the machine native call and
`(inst lbz ,n-target ,n-source (+ ,n-offset 3))))))
;;; Macros to handle the fact that we cannot use the machine native call and
(defmacro lisp-jump (function lip)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
(defmacro lisp-jump (function lip)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
(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-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))))))))
"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 (,flag-tn :extra (pad-data-block ,size))
(inst ori ,result-tn alloc-tn other-pointer-lowtag)
(inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
(storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
,@body)))
`(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
(inst ori ,result-tn alloc-tn other-pointer-lowtag)
(inst lr ,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)
+ ;; is used for stack allocation of dynamic-extent objects
+ (let ((aligned (gen-label)))
+ (inst andi. temp csp-tn lowtag-mask)
+ (inst beq aligned)
+ (inst addi csp-tn csp-tn n-word-bytes)
+ (storew zero-tn csp-tn -1)
+ (emit-label aligned)))
+
\f
;;;; Error Code
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
`((let ((vop ,vop))
\f
;;;; 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 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))))
+ (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)))))
;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then
;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then
;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
(let ((n-extra (gensym)))
`(let ((,n-extra ,extra))
(without-scheduling ()
(let ((n-extra (gensym)))
`(let ((,n-extra ,extra))
(without-scheduling ()
- ;; Extra debugging stuff:
- #+debug
- (progn
- (inst andi. ,flag-tn alloc-tn 7)
- (inst twi :ne ,flag-tn 0))
- (inst lr ,flag-tn (- ,n-extra 4))
- (inst addi alloc-tn alloc-tn 4))
+ ;; Extra debugging stuff:
+ #+debug
+ (progn
+ (inst andi. ,flag-tn alloc-tn 7)
+ (inst twi :ne ,flag-tn 0))
+ (inst lr ,flag-tn (- ,n-extra 4))
+ (inst addi alloc-tn alloc-tn 4))
,@forms
(without-scheduling ()
(inst add alloc-tn alloc-tn ,flag-tn)
(inst twi :lt alloc-tn 0))
#+debug
(progn
,@forms
(without-scheduling ()
(inst add alloc-tn alloc-tn ,flag-tn)
(inst twi :lt alloc-tn 0))
#+debug
(progn
- (inst andi. ,flag-tn alloc-tn 7)
- (inst twi :ne ,flag-tn 0)))))
+ (inst andi. ,flag-tn alloc-tn 7)
+ (inst twi :ne ,flag-tn 0)))))
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"
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"