(- other-pointer-lowtag)))
,reg))
+#!+sb-thread
+(defmacro load-tl-symbol-value (reg symbol)
+ `(progn
+ (inst mov ,reg
+ (make-ea :dword
+ :disp (+ nil-value
+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
+ (inst fs-segment-prefix)
+ (inst mov ,reg (make-ea :dword :scale 1 :index ,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 mov ,temp
+ (make-ea :dword
+ :disp (+ nil-value
+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
+ (inst fs-segment-prefix)
+ (inst mov (make-ea :dword :scale 1 :index ,temp) ,reg)))
+#!-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))
#!+sb-doc
"Loads the type bits of a pointer into target independent of
\f
;;;; allocation helpers
-;;; Two allocation approaches are implemented. A call into C can be
-;;; used, and in that case special care can be taken to disable
-;;; interrupts. Alternatively with gencgc inline allocation is possible
-;;; although it isn't interrupt safe.
+;;; All allocation is done by calls to assembler routines that
+;;; eventually invoke the C alloc() function. Once upon a time
+;;; (before threads) allocation within an alloc_region could also be
+;;; done inline, with the aid of two C symbols storing the current
+;;; allocation region boundaries; however, C symbols are global.
+
+;;; C calls for allocation don't /seem/ to make an awful lot of
+;;; difference to speed. Guessing from historical context, it looks
+;;; like inline allocation was introduced before pseudo-atomic, at
+;;; which time all calls to alloc() would have needed a syscall to
+;;; mask signals for the duration. Now we have pseudoatomic there's
+;;; no need for that overhead. Still, inline alloc would be a neat
+;;; addition someday (except see below).
+
+(defun allocation-dynamic-extent (alloc-tn size)
+ (inst sub esp-tn size)
+ ;; FIXME: SIZE _should_ be double-word aligned (suggested but
+ ;; unfortunately not enforced by PAD-DATA-BLOCK and
+ ;; WITH-FIXED-ALLOCATION), so that ESP is always divisible by 8 (for
+ ;; 32-bit lispobjs). In that case, this AND instruction is
+ ;; unneccessary and could be removed. If not, explain why. -- CSR,
+ ;; 2004-03-30
+ (inst and esp-tn #.(ldb (byte 32 0) (lognot lowtag-mask)))
+ (aver (not (location= alloc-tn esp-tn)))
+ (inst mov alloc-tn esp-tn)
+ (values))
+
+(defun allocation-notinline (alloc-tn size)
+ (let* ((alloc-tn-offset (tn-offset alloc-tn))
+ ;; C call to allocate via dispatch routines. Each
+ ;; destination has a special entry point. The size may be a
+ ;; register or a constant.
+ (tn-text (ecase alloc-tn-offset
+ (#.eax-offset "eax")
+ (#.ecx-offset "ecx")
+ (#.edx-offset "edx")
+ (#.ebx-offset "ebx")
+ (#.esi-offset "esi")
+ (#.edi-offset "edi")))
+ (size-text (case size (8 "8_") (16 "16_") (t ""))))
+ (unless (or (eql size 8) (eql size 16))
+ (unless (and (tn-p size) (location= alloc-tn size))
+ (inst mov alloc-tn size)))
+ (inst call (make-fixup (concatenate 'string
+ "alloc_" size-text
+ "to_" tn-text)
+ :foreign))))
+
+(defun allocation-inline (alloc-tn size)
+ (let ((ok (gen-label))
+ (free-pointer
+ (make-ea :dword :disp
+ #!+sb-thread (* n-word-bytes thread-alloc-region-slot)
+ #!-sb-thread (make-fixup "boxed_region" :foreign)
+ :scale 1)) ; thread->alloc_region.free_pointer
+ (end-addr
+ (make-ea :dword :disp
+ #!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot))
+ #!-sb-thread (make-fixup "boxed_region" :foreign 4)
+ :scale 1))) ; thread->alloc_region.end_addr
+ (unless (and (tn-p size) (location= alloc-tn size))
+ (inst mov alloc-tn size))
+ #!+sb-thread (inst fs-segment-prefix)
+ (inst add alloc-tn free-pointer)
+ #!+sb-thread (inst fs-segment-prefix)
+ (inst cmp alloc-tn end-addr)
+ (inst jmp :be OK)
+ (let ((dst (ecase (tn-offset alloc-tn)
+ (#.eax-offset "alloc_overflow_eax")
+ (#.ecx-offset "alloc_overflow_ecx")
+ (#.edx-offset "alloc_overflow_edx")
+ (#.ebx-offset "alloc_overflow_ebx")
+ (#.esi-offset "alloc_overflow_esi")
+ (#.edi-offset "alloc_overflow_edi"))))
+ (inst call (make-fixup dst :foreign)))
+ (emit-label ok)
+ #!+sb-thread (inst fs-segment-prefix)
+ (inst xchg free-pointer alloc-tn))
+ (values))
-;;; For GENCGC it is possible to inline object allocation, to permit
-;;; this set the following variable to True.
-;;;
-;;; FIXME: The comment above says that this isn't interrupt safe. Is that
-;;; right? If so, do we want to do this? And surely we don't want to do this by
-;;; default? How much time does it save to do this? Is it any different in the
-;;; current CMU CL version instead of the one that I grabbed in 1998?
-;;; (Later observation: In order to be interrupt safe, it'd probably
-;;; have to use PSEUDO-ATOMIC, so it's probably not -- yuck. Try benchmarks
-;;; with and without inline allocation, and unless the inline allocation
-;;; wins by a whole lot, it's not likely to be worth messing with. If
-;;; we want to hack up memory allocation for performance, effort spent
-;;; on DYNAMIC-EXTENT would probably give a better payoff.)
-(defvar *maybe-use-inline-allocation* t)
;;; Emit code to allocate an object with a size in bytes given by
-;;; Size. The size may be an integer of a TN. If Inline is a VOP
+;;; SIZE. The size may be an integer or a TN. If Inline is a VOP
;;; node-var then it is used to make an appropriate speed vs size
;;; decision.
-;;;
-;;; FIXME: We call into C.. except when inline allocation is enabled..?
-;;;
-;;; FIXME: Also, calls to
-;;; ALLOCATION are always wrapped with PSEUDO-ATOMIC -- why? Is it to
-;;; make sure that no GC happens between the time of allocation and the
-;;; time that the allocated memory has its tag bits set correctly?
-;;; If so, then ALLOCATION itself might as well set the PSEUDO-ATOMIC
-;;; bits, so that the caller need only clear them. Check whether it's
-;;; true that every ALLOCATION is surrounded by PSEUDO-ATOMIC, and
-;;; that every PSEUDO-ATOMIC contains a single ALLOCATION, which is
-;;; its first instruction. If so, the connection should probably be
-;;; formalized, in documentation and in macro definition,
-;;; with the macro becoming e.g. PSEUDO-ATOMIC-ALLOCATION.
-(defun allocation (alloc-tn size &optional inline)
- (flet ((load-size (dst-tn size)
- (unless (and (tn-p size) (location= alloc-tn size))
- (inst mov dst-tn size))))
- (let ((alloc-tn-offset (tn-offset alloc-tn)))
- ;; C call to allocate via dispatch routines. Each
- ;; destination has a special entry point. The size may be a
- ;; register or a constant.
- (ecase alloc-tn-offset
- (#.eax-offset
- (case size
- (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax")
- :foreign)))
- (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax")
- :foreign)))
- (t
- (load-size eax-tn size)
- (inst call (make-fixup (extern-alien-name "alloc_to_eax")
- :foreign)))))
- (#.ecx-offset
- (case size
- (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx")
- :foreign)))
- (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx")
- :foreign)))
- (t
- (load-size ecx-tn size)
- (inst call (make-fixup (extern-alien-name "alloc_to_ecx")
- :foreign)))))
- (#.edx-offset
- (case size
- (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx")
- :foreign)))
- (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx")
- :foreign)))
- (t
- (load-size edx-tn size)
- (inst call (make-fixup (extern-alien-name "alloc_to_edx")
- :foreign)))))
- (#.ebx-offset
- (case size
- (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx")
- :foreign)))
- (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx")
- :foreign)))
- (t
- (load-size ebx-tn size)
- (inst call (make-fixup (extern-alien-name "alloc_to_ebx")
- :foreign)))))
- (#.esi-offset
- (case size
- (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi")
- :foreign)))
- (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi")
- :foreign)))
- (t
- (load-size esi-tn size)
- (inst call (make-fixup (extern-alien-name "alloc_to_esi")
- :foreign)))))
- (#.edi-offset
- (case size
- (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi")
- :foreign)))
- (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi")
- :foreign)))
- (t
- (load-size edi-tn size)
- (inst call (make-fixup (extern-alien-name "alloc_to_edi")
- :foreign))))))))
+
+;;; Allocation should only be used inside a pseudo-atomic section, which
+;;; should also cover subsequent initialization of the object.
+
+;;; (FIXME: so why aren't we asserting this?)
+
+(defun allocation (alloc-tn size &optional inline dynamic-extent)
+ (cond
+ (dynamic-extent (allocation-dynamic-extent alloc-tn size))
+ ;; FIXME: for reasons unknown, inline allocation is a speed win on
+ ;; non-P4s, and a speed loss on P4s (and probably other such
+ ;; high-spec high-cache machines). :INLINE-ALLOCATION-IS-GOOD is
+ ;; a bit of a KLUDGE, really. -- CSR, 2004-08-05 (following
+ ;; observations made by ASF and Juho Snellman)
+ ((and (member :inline-allocation-is-good *backend-subfeatures*)
+ (or (null inline) (policy inline (>= speed space))))
+ (allocation-inline alloc-tn size))
+ (t (allocation-notinline alloc-tn size)))
(values))
;;; 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.
(defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
- &rest forms)
- `(pseudo-atomic
- (allocation ,result-tn (pad-data-block ,size) ,inline)
- (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
- ,result-tn)
- (inst lea ,result-tn
- (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
- ,@forms))
+ &body forms)
+ (unless forms
+ (bug "empty &body in WITH-FIXED-ALLOCATION"))
+ (once-only ((result-tn result-tn) (size size))
+ `(pseudo-atomic
+ (allocation ,result-tn (pad-data-block ,size) ,inline)
+ (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
+ ,result-tn)
+ (inst lea ,result-tn
+ (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
+ ,@forms)))
\f
;;;; error code
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
`((inst int 3) ; i386 breakpoint instruction
(cons 'progn
(emit-error-break vop error-trap error-code values)))
-;;; not used in SBCL
-#|
-(defmacro cerror-call (vop label error-code &rest values)
- #!+sb-doc
- "Cause a continuable error. If the error is continued, execution resumes
- at LABEL."
- `(progn
- ,@(emit-error-break vop cerror-trap error-code values)
- (inst jmp ,label)))
-|#
-
(defmacro generate-error-code (vop error-code &rest values)
#!+sb-doc
"Generate-Error-Code Error-code Value*
(error-call ,vop ,error-code ,@values)
start-lab)))
-;;; not used in SBCL
-#|
-(defmacro generate-cerror-code (vop error-code &rest values)
- #!+sb-doc
- "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))
- (,error (gen-label)))
- (emit-label ,continue)
- (assemble (*elsewhere*)
- (emit-label ,error)
- (cerror-call ,vop ,continue ,error-code ,@values))
- ,error)))
-|#
\f
;;;; PSEUDO-ATOMIC
+;;; This is used to wrap operations which leave untagged memory lying
+;;; around. It's an operation which the AOP weenies would describe as
+;;; having "cross-cutting concerns", meaning it appears all over the
+;;; place and there's no logical single place to attach documentation.
+;;; grep (mostly in src/runtime) is your friend
+
;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
;;; the C flag after the shift to see whether you were interrupted.
+;;;
+;;; KLUDGE: since the stack on the x86 is treated conservatively, it
+;;; does not matter whether a signal occurs during construction of a
+;;; dynamic-extent object, as the half-finished construction of the
+;;; object will not cause any difficulty. We can therefore elide
+(defmacro maybe-pseudo-atomic (really-p &body forms)
+ `(if ,really-p
+ (progn ,@forms)
+ (pseudo-atomic ,@forms)))
+
+#!+sb-thread
+(defmacro pseudo-atomic (&rest forms)
+ (with-unique-names (label)
+ `(let ((,label (gen-label)))
+ (inst fs-segment-prefix)
+ (inst mov (make-ea :byte
+ :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
+ (inst fs-segment-prefix)
+ (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot))
+ (fixnumize 1))
+ ,@forms
+ (inst fs-segment-prefix)
+ (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0)
+ (inst fs-segment-prefix)
+ (inst cmp (make-ea :byte
+ :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
+ (inst jmp :eq ,label)
+ ;; if PAI was set, interrupts were disabled at the same
+ ;; time using the process signal mask.
+ (inst break pending-interrupt-trap)
+ (emit-label ,label))))
-;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave
-;;; untagged memory lying around, but some documentation would be nice.
+#!-sb-thread
(defmacro pseudo-atomic (&rest forms)
- (let ((label (gensym "LABEL-")))
+ (with-unique-names (label)
`(let ((,label (gen-label)))
- ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
- ;; something. (perhaps SVLB, for static variable low byte)
- (inst mov (make-ea :byte :disp (+ nil-value
- (static-symbol-offset
- '*pseudo-atomic-interrupted*)
- (ash symbol-value-slot word-shift)
- ;; FIXME: Use mask, not minus, to
- ;; take out type bits.
- (- other-pointer-lowtag)))
- 0)
- (inst mov (make-ea :byte :disp (+ nil-value
- (static-symbol-offset
- '*pseudo-atomic-atomic*)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))
- (fixnumize 1))
- ,@forms
- (inst mov (make-ea :byte :disp (+ nil-value
- (static-symbol-offset
- '*pseudo-atomic-atomic*)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))
- 0)
- ;; KLUDGE: Is there any requirement for interrupts to be
- ;; handled in order? It seems as though an interrupt coming
- ;; in at this point will be executed before any pending interrupts.
- ;; Or do incoming interrupts check to see whether any interrupts
- ;; are pending? I wish I could find the documentation for
- ;; pseudo-atomics.. -- WHN 19991130
- (inst cmp (make-ea :byte
- :disp (+ nil-value
- (static-symbol-offset
- '*pseudo-atomic-interrupted*)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))
- 0)
- (inst jmp :eq ,label)
- ;; if PAI was set, interrupts were disabled at the same time
- ;; using the process signal mask.
- (inst break pending-interrupt-trap)
- (emit-label ,label))))
+ ;; FIXME: The MAKE-EA noise should become a MACROLET macro
+ ;; or something. (perhaps SVLB, for static variable low
+ ;; byte)
+ (inst mov (make-ea :byte :disp (+ nil-value
+ (static-symbol-offset
+ '*pseudo-atomic-interrupted*)
+ (ash symbol-value-slot word-shift)
+ ;; FIXME: Use mask, not minus, to
+ ;; take out type bits.
+ (- other-pointer-lowtag)))
+ 0)
+ (inst mov (make-ea :byte :disp (+ nil-value
+ (static-symbol-offset
+ '*pseudo-atomic-atomic*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
+ (fixnumize 1))
+ ,@forms
+ (inst mov (make-ea :byte :disp (+ nil-value
+ (static-symbol-offset
+ '*pseudo-atomic-atomic*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
+ 0)
+ ;; KLUDGE: Is there any requirement for interrupts to be
+ ;; handled in order? It seems as though an interrupt coming
+ ;; in at this point will be executed before any pending
+ ;; interrupts. Or do incoming interrupts check to see
+ ;; whether any interrupts are pending? I wish I could find
+ ;; the documentation for pseudo-atomics.. -- WHN 19991130
+ (inst cmp (make-ea :byte
+ :disp (+ nil-value
+ (static-symbol-offset
+ '*pseudo-atomic-interrupted*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
+ 0)
+ (inst jmp :eq ,label)
+ ;; if PAI was set, interrupts were disabled at the same
+ ;; time using the process signal mask.
+ (inst break pending-interrupt-trap)
+ (emit-label ,label))))
\f
;;;; indexed references
value)
(move result value)))))
+;;; helper for alien stuff.
+(defmacro 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"
+ `(multiple-value-prog1
+ (progn
+ ,@(loop for p in objects
+ collect `(push-word-on-c-stack
+ (int-sap (sb!kernel:get-lisp-obj-address ,p))))
+ ,@body)
+ ;; If the body returned normally, we should restore the stack pointer
+ ;; for the benefit of any following code in the same function. If
+ ;; there's a non-local exit in the body, sp is garbage anyway and
+ ;; will get set appropriately from {a, the} frame pointer before it's
+ ;; next needed
+ (pop-words-from-c-stack ,(length objects))))
projects / sbcl.git / blobdiff