1.0.16.22: FIXED-ALLOC to use MAYBE-PSEUDO-ATOMIC on x86 and x86-64.

[sbcl.git] / src / compiler / x86-64 / macros.lisp

diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 16a7774..9393c2b 100644 (file)
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -213,26 +213,16 @@
              (inst jmp DONE))
            (values)))))
 
-#+nil
-(defun allocation (alloc-tn size &optional ignored)
-  (declare (ignore ignored))
-  (inst push size)
-  (inst lea temp-reg-tn (make-ea :qword
-                            :disp (make-fixup "alloc_tramp" :foreign)))
-  (inst call temp-reg-tn)
-  (inst pop alloc-tn)
-  (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)
+(defmacro with-fixed-allocation ((result-tn widetag size &optional inline stack-allocate-p)
                                  &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)
+  (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p))
+    `(maybe-pseudo-atomic ,stack-allocate-p
+      (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p)
       (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
               ,result-tn)
       (inst lea ,result-tn
@@ -300,9 +290,8 @@
 ;;; place and there's no logical single place to attach documentation.
 ;;; grep (mostly in src/runtime) is your friend
 
-;;; FIXME: THIS NAME IS BACKWARDS!
-(defmacro maybe-pseudo-atomic (really-p &body body)
-  `(if ,really-p
+(defmacro maybe-pseudo-atomic (not-really-p &body body)
+  `(if ,not-really-p
        (progn ,@body)
        (pseudo-atomic ,@body)))
 
@@ -529,20 +518,30 @@
          (move result value)))))
 
 ;;; helper for alien stuff.
+
 (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"
-  `(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))))
+collection."
+  (if objects
+      (let ((pins (make-gensym-list (length objects)))
+            (wpo (block-gensym "WPO")))
+        ;; BODY is stuffed in a function to preserve the lexical
+        ;; environment.
+        `(flet ((,wpo () (progn ,@body)))
+           ;; PINS are dx-allocated in case the compiler for some
+           ;; unfathomable reason decides to allocate value-cells
+           ;; for them -- since we have DX value-cells on x86oid
+           ;; platforms this still forces them on the stack.
+           (dx-let ,(mapcar #'list pins objects)
+             (multiple-value-prog1 (,wpo)
+               ;; TOUCH-OBJECT has a VOP with an empty body: compiler
+               ;; thinks we're using the argument and doesn't flush
+               ;; the variable, but we don't have to pay any extra
+               ;; beyond that -- and MULTIPLE-VALUE-PROG1 keeps them
+               ;; live till the body has finished. *whew*
+               ,@(mapcar (lambda (pin)
+                           `(touch-object ,pin))
+                         pins)))))
+      `(progn ,@body)))