(: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.
(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
;;;; Storage allocation:
-(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
+
+;;; 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
+ (let ((fix-addr (gensym))
+ (inline-alloc (gensym)))
+ `(let ((,fix-addr (gen-label))
+ (,inline-alloc (gen-label)))
+ ;; Make temp-tn be the size
+ (cond ((numberp ,size)
+ (inst lr ,temp-tn ,size))
+ (t
+ (move ,temp-tn ,size)))
+
+ (inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
+ (inst lwz ,result-tn ,flag-tn 0)
+
+ ;; 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)
+ (inst lwz ,flag-tn ,flag-tn 4)
+
+ (without-scheduling ()
+ ;; CAUTION: The C code depends on the exact order of
+ ;; instructions here. In particular, three instructions before
+ ;; the TW instruction must be an ADD or ADDI instruction, so it
+ ;; can figure out the size of the desired allocation.
+ ;; 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 cmpw ,result-tn ,flag-tn)
+
+ (inst bng ,inline-alloc)
+ (inst tw :lge ,result-tn ,flag-tn))
+ (inst b ,fix-addr)
+
+ (emit-label ,inline-alloc)
+ (inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
+ (inst stw ,result-tn ,flag-tn 0)
+
+ (emit-label ,fix-addr)
+ ;; 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))
&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."
- (unless body
- (bug "empty &body in WITH-FIXED-ALLOCATION"))
(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)
+ (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)
\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)))))
+(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))))
-(defmacro error-call (vop error-code &rest values)
+(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."
- (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)))))
+ (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
;;; 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)) &body 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)))))
-
-
-
+(defmacro pseudo-atomic ((flag-tn) &body forms)
+ `(progn
+ (without-scheduling ()
+ ;; Extra debugging stuff:
+ #+debug
+ (progn
+ (inst andi. ,flag-tn alloc-tn 7)
+ (inst twi :ne ,flag-tn 0))
+ (inst ori alloc-tn alloc-tn 4))
+ ,@forms
+ (without-scheduling ()
+ (inst li ,flag-tn -5)
+ (inst and alloc-tn alloc-tn ,flag-tn)
+ ;; Now test to see if the pseudo-atomic interrupted bit is set.
+ (inst andi. ,flag-tn alloc-tn 1)
+ (inst twi :ne ,flag-tn 0))
+ #+debug
+ (progn
+ (inst andi. ,flag-tn alloc-tn 7)
+ (inst twi :ne ,flag-tn 0))))
-(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
+(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?
+ (declare (ignore objects)) ; should we eval these for side-effect?
`(without-gcing
,@body))
projects / sbcl.git / blobdiff