(defmacro move (dst src)
"Move SRC into DST unless they are location=."
(once-only ((n-dst dst)
- (n-src src))
+ (n-src src))
`(unless (location= ,n-dst ,n-src)
(inst mr ,n-dst ,n-src))))
(macrolet
- ((frob (op inst shift)
+ ((def (op inst shift)
`(defmacro ,op (object base &optional (offset 0) (lowtag 0))
- `(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)))
(macrolet
((frob (slot)
(let ((loader (intern (concatenate 'simple-string
- "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))))))))
(frob value)
- (frob function))
+ (frob function)
+
+ ;; FIXME: These are only good for static-symbols, so why not
+ ;; statically-allocate the static-symbol TLS slot indices at
+ ;; cross-compile time so we can just use a fixed offset within the
+ ;; TLS block instead of mucking about with the extra memory access
+ ;; (and temp register, for stores)?
+ #!+sb-thread
+ (defmacro load-tl-symbol-value (reg symbol)
+ `(progn
+ (inst lwz ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag)))
+ (inst lwzx ,reg thread-base-tn ,reg)))
+ #!-sb-thread
+ (defmacro load-tl-symbol-value (reg symbol)
+ `(load-symbol-value ,reg ,symbol))
+
+ #!+sb-thread
+ (defmacro store-tl-symbol-value (reg symbol temp)
+ `(progn
+ (inst lwz ,temp null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag)))
+ (inst stwx ,reg thread-base-tn ,temp)))
+ #!-sb-thread
+ (defmacro store-tl-symbol-value (reg symbol temp)
+ (declare (ignore temp))
+ `(store-symbol-value ,reg ,symbol)))
(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))
(ecase *backend-byte-order*
(:little-endian
`(inst lbz ,n-target ,n-source ,n-offset))
(:big-endian
- `(inst lbz ,n-target ,n-source (+ ,n-offset 3))))))
+ `(inst lbz ,n-target ,n-source (+ ,n-offset (1- n-word-bytes)))))))
;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions.
+;;; return instructions.
(defmacro lisp-jump (function lip)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
;; something is deeply bogus. look at this
- ;; (loadw ,lip ,function sb!vm:function-code-offset sb!vm:function-pointer-type)
- (inst addi ,lip ,function (- (* n-word-bytes sb!vm:simple-fun-code-offset) sb!vm:fun-pointer-lowtag))
+ ;; (loadw ,lip ,function function-code-offset function-pointer-type)
+ (inst addi ,lip ,function (- (* n-word-bytes simple-fun-code-offset) fun-pointer-lowtag))
(inst mtctr ,lip)
- (move code-tn ,function)
(inst bctr)))
-(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
+(defmacro lisp-return (return-pc lip &key (offset 0))
"Return to RETURN-PC."
`(progn
(inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
(inst mtlr ,lip)
- ,@(if frob-code
- `((move code-tn ,return-pc)))
(inst blr)))
(defmacro emit-return-pc (label)
"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)))
\f
;;;; Stack TN's
-;;; Load-Stack-TN, Store-Stack-TN -- Interface
-;;;
-;;; Move a stack TN to a register and vice-versa.
-;;;
+;;; 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
-;;;
(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-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))))))))
\f
;;;; Storage allocation:
-(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
- &body body)
+;;; This is the main mechanism for allocating memory in the lisp heap.
+;;;
+;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
+;;; applied. The amount of space to be allocated is SIZE bytes (which
+;;; must be a multiple of the lisp object size).
+;;;
+;;; On other platforms (Non-PPC), if STACK-P is given, then allocation
+;;; occurs on the control stack (for dynamic-extent). In this case,
+;;; you MUST also specify NODE, so that the appropriate compiler
+;;; policy can be used, and TEMP-TN, which is needed for work-space.
+;;; TEMP-TN MUST be a non-descriptor reg. FIXME: This is not yet
+;;; implemented on PPC. We should implement this and replace the
+;;; inline stack-based allocation that presently occurs in the
+;;; VOPs. The stack-p argument is ignored on PPC.
+;;;
+;;; If generational GC is enabled, you MUST supply a value for TEMP-TN
+;;; because a temp register is needed to do inline allocation.
+;;; TEMP-TN, in this case, can be any register, since it holds a
+;;; double-word aligned address (essentially a fixnum).
+(defmacro allocation (result-tn size lowtag &key stack-p node temp-tn flag-tn)
+ ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
+ ;; set. If the lowtag also has a 1 bit in the same position, we're all
+ ;; set. Otherwise, we need to zap out the lowtag from alloc-tn, and
+ ;; then or in the lowtag.
+ ;; Normal allocation to the heap.
+ (declare (ignore stack-p node)
+ #!-gencgc
+ (ignore temp-tn flag-tn))
+ #!-gencgc
+ (let ((alloc-size (gensym)))
+ `(let ((,alloc-size ,size))
+ (if (logbitp (1- n-lowtag-bits) ,lowtag)
+ (progn
+ (inst ori ,result-tn alloc-tn ,lowtag))
+ (progn
+ (inst clrrwi ,result-tn alloc-tn n-lowtag-bits)
+ (inst ori ,result-tn ,result-tn ,lowtag)))
+ (if (numberp ,alloc-size)
+ (inst addi alloc-tn alloc-tn ,alloc-size)
+ (inst add alloc-tn alloc-tn ,alloc-size))))
+ #!+gencgc
+ `(progn
+ ;; Make temp-tn be the size
+ (cond ((numberp ,size)
+ (inst lr ,temp-tn ,size))
+ (t
+ (move ,temp-tn ,size)))
+
+ #!-sb-thread
+ (inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
+ #!-sb-thread
+ (inst lwz ,result-tn ,flag-tn 0)
+ #!+sb-thread
+ (inst lwz ,result-tn thread-base-tn (* thread-alloc-region-slot
+ n-word-bytes))
+
+ ;; we can optimize this to only use one fixup here, once we get
+ ;; it working
+ ;; (inst lr ,flag-tn (make-fixup "boxed_region" :foreign 4))
+ ;; (inst lwz ,flag-tn ,flag-tn 0)
+ #!-sb-thread
+ (inst lwz ,flag-tn ,flag-tn 4)
+ #!+sb-thread
+ (inst lwz ,flag-tn thread-base-tn (* (1+ thread-alloc-region-slot)
+ n-word-bytes))
+
+ (without-scheduling ()
+ ;; CAUTION: The C code depends on the exact order of
+ ;; instructions here. In particular, immediately before the
+ ;; TW instruction must be an ADD or ADDI instruction, so it
+ ;; can figure out the size of the desired allocation and
+ ;; storing the new base pointer back to the allocation region
+ ;; must take two instructions (one on threaded targets).
+
+ ;; Now make result-tn point at the end of the object, to
+ ;; figure out if we overflowed the current region.
+ (inst add ,result-tn ,result-tn ,temp-tn)
+ ;; result-tn points to the new end of the region. Did we go past
+ ;; the actual end of the region? If so, we need a full alloc.
+ ;; The C code depends on this exact form of instruction. If
+ ;; either changes, you have to change the other appropriately!
+ (inst tw :lge ,result-tn ,flag-tn)
+
+ ;; The C code depends on this instruction sequence taking up
+ ;; #!-sb-thread three #!+sb-thread one machine instruction.
+ ;; The lr of a fixup counts as two instructions.
+ #!-sb-thread
+ (inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
+ #!-sb-thread
+ (inst stw ,result-tn ,flag-tn 0)
+ #!+sb-thread
+ (inst stw ,result-tn thread-base-tn (* thread-alloc-region-slot
+ n-word-bytes)))
+
+ ;; Should the allocation trap above have fired, the runtime
+ ;; arranges for execution to resume here, just after where we
+ ;; would have updated the free pointer in the alloc region.
+
+ ;; At this point, result-tn points at the end of the object.
+ ;; Adjust to point to the beginning.
+ (inst sub ,result-tn ,result-tn ,temp-tn)
+ ;; Set the lowtag appropriately
+ (inst ori ,result-tn ,result-tn ,lowtag)))
+
+(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size
+ &key (lowtag other-pointer-lowtag)
+ stack-allocate-p)
+ &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, 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."
(once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
- (type-code type-code) (size size))
- `(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)
+ (type-code type-code) (size size) (lowtag lowtag))
+ `(pseudo-atomic (,flag-tn)
+ (if ,stack-allocate-p
+ (progn
+ (align-csp ,temp-tn)
+ (inst ori ,result-tn csp-tn ,lowtag)
+ (inst addi csp-tn csp-tn (pad-data-block ,size)))
+ (allocation ,result-tn (pad-data-block ,size) ,lowtag
+ :temp-tn ,temp-tn
+ :flag-tn ,flag-tn))
+ (when ,type-code
+ (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
+ (storew ,temp-tn ,result-tn 0 ,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
-
-(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))))
- (declare (type (vector (unsigned-byte 8) 16) ,var))
- (setf (fill-pointer ,var) 0)
- (unwind-protect
- (progn
- ,@body)
- (push ,var *adjustable-vectors*))))
-
-(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)))))
-
-(defmacro error-call (vop error-code &rest values)
+(defun emit-error-break (vop kind code values)
+ (assemble ()
+ (when vop
+ (note-this-location vop :internal-error))
+ (inst unimp kind)
+ (with-adjustable-vector (vector)
+ (write-var-integer code vector)
+ (dolist (tn values)
+ (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
+ (or (tn-offset tn) 0))
+ vector))
+ (inst byte (length vector))
+ (dotimes (i (length vector))
+ (inst byte (aref vector i)))
+ (emit-alignment word-shift))))
+
+(defun error-call (vop error-code &rest values)
+ #!+sb-doc
"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-number-or-lose error-code) values))
-
-(defmacro cerror-call (vop label error-code &rest values)
- "Cause a continuable error. If the error is continued, execution resumes at
- LABEL."
- `(progn
- ,@(emit-error-break vop cerror-trap error-code values)
- (inst b ,label)))
-
-(defmacro generate-error-code (vop error-code &rest values)
+(defun generate-error-code (vop error-code &rest values)
+ #!+sb-doc
"Generate-Error-Code Error-code Value*
Emit code for an error with the specified Error-Code and context Values."
- `(assemble (*elsewhere*)
- (let ((start-lab (gen-label)))
- (emit-label start-lab)
- (error-call ,vop ,error-code ,@values)
- start-lab)))
-
-(defmacro generate-cerror-code (vop error-code &rest values)
- "Generate-CError-Code Error-code Value*
- 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-")))
- `(let ((,continue (gen-label)))
- (emit-label ,continue)
- (assemble (*elsewhere*)
- (let ((,error (gen-label)))
- (emit-label ,error)
- (cerror-call ,vop ,continue ,error-code ,@values)
- ,error)))))
-
-
+ (assemble (*elsewhere*)
+ (let ((start-lab (gen-label)))
+ (emit-label start-lab)
+ (emit-error-break vop error-trap (error-number-or-lose error-code) values)
+ start-lab)))
\f
-;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
-;;;
-;;; flag-tn must be wired to NL3. If a deferred interrupt happens
-;;; while we have the low bits of alloc-tn set, we add a "large"
-;;; constant to flag-tn. On exit, we add flag-tn to alloc-tn
-;;; which (a) 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.
-(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
- (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))
- ,@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)))))
-
-
+;;;; PSEUDO-ATOMIC
+;;; handy macro for making sequences look atomic
+;;;
+;;; FLAG-TN must be wired to NL3. If a deferred interrupt happens
+;;; while we have the low bits of ALLOC-TN set, we add a "large"
+;;; constant to FLAG-TN. On exit, we add FLAG-TN to ALLOC-TN which (a)
+;;; 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.
+(defmacro pseudo-atomic ((flag-tn) &body forms)
+ #!+sb-safepoint-strictly
+ `(progn ,flag-tn ,@forms (emit-safepoint))
+ #!-sb-safepoint-strictly
+ `(progn
+ (without-scheduling ()
+ ;; Extra debugging stuff:
+ #+debug
+ (progn
+ (inst andi. ,flag-tn alloc-tn lowtag-mask)
+ (inst twi :ne ,flag-tn 0))
+ (inst ori alloc-tn alloc-tn pseudo-atomic-flag))
+ ,@forms
+ (without-scheduling ()
+ (inst subi alloc-tn alloc-tn pseudo-atomic-flag)
+ ;; Now test to see if the pseudo-atomic interrupted bit is set.
+ (inst andi. ,flag-tn alloc-tn pseudo-atomic-interrupted-flag)
+ (inst twi :ne ,flag-tn 0))
+ #+debug
+ (progn
+ (inst andi. ,flag-tn alloc-tn lowtag-mask)
+ (inst twi :ne ,flag-tn 0))
+ #!+sb-safepoint
+ (emit-safepoint)))
+
+#!+sb-safepoint
+(defun emit-safepoint ()
+ (inst lwz zero-tn null-tn (- (+ 4096 4 other-pointer-lowtag))))
+
+(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"
+ #!-gencgc
+ (declare (ignore objects)) ; should we eval these for side-effect?
+ #!-gencgc
+ `(without-gcing
+ ,@body)
+ #!+gencgc
+ `(let ((*pinned-objects* (list* ,@objects *pinned-objects*)))
+ (declare (truly-dynamic-extent *pinned-objects*))
+ ,@body))
projects / sbcl.git / blobdiff