;;; 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
+;;; addition someday (except see below).
(defun allocation-dynamic-extent (alloc-tn size)
(inst sub esp-tn size)
(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 (extern-alien-name
- (concatenate 'string
+ (inst call (make-fixup (concatenate 'string
"alloc_" size-text
- "to_" tn-text))
+ "to_" tn-text)
:foreign))))
(defun allocation-inline (alloc-tn size)
(free-pointer
(make-ea :dword :disp
#!+sb-thread (* n-word-bytes thread-alloc-region-slot)
- #!-sb-thread (make-fixup (extern-alien-name "boxed_region")
- :foreign)
+ #!-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 (extern-alien-name "boxed_region")
- :foreign 4)
+ #!-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))
(#.ebx-offset "alloc_overflow_ebx")
(#.esi-offset "alloc_overflow_esi")
(#.edi-offset "alloc_overflow_edi"))))
- (inst call (make-fixup (extern-alien-name dst) :foreign)))
+ (inst call (make-fixup dst :foreign)))
(emit-label ok)
#!+sb-thread (inst fs-segment-prefix)
(inst xchg free-pointer alloc-tn))
(defun allocation (alloc-tn size &optional inline dynamic-extent)
(cond
(dynamic-extent (allocation-dynamic-extent alloc-tn size))
- ((or (null inline) (policy inline (>= speed space)))
+ ;; 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))
;;; 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 (#-sb-xc :compile-toplevel :load-toplevel :execute)
;;; 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
-(defvar *dynamic-extent* nil)
+(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)
- `(if *dynamic-extent* ; I will burn in hell
- (progn ,@forms)
- (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)) 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)))))
+ `(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))))
#!-sb-thread
(defmacro pseudo-atomic (&rest forms)
(with-unique-names (label)
- `(if *dynamic-extent*
- (progn ,@forms)
- (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)))))
+ `(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))))
\f
;;;; indexed references
projects / sbcl.git / blobdiff