1.0.15.36: fix bug 423

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

diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 10540ca..71440fc 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -46,6 +46,12 @@
     `(unless (location= ,n-dst ,n-src)
        (inst mov ,n-dst ,n-src))))
 
+(defmacro align-stack-pointer (tn)
+  #!-darwin (declare (ignore tn))
+  #!+darwin
+  ;; 16 byte alignment.
+  `(inst and ,tn #xfffffff0))
+
 (defmacro make-ea-for-object-slot (ptr slot lowtag &optional (size :dword))
   `(make-ea ,size :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
 
@@ -154,7 +160,8 @@
               (make-ea :byte :base ,n-source :disp ,n-offset)))
       (:big-endian
        `(inst mov ,n-target
-              (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
+              (make-ea :byte :base ,n-source
+                             :disp (+ ,n-offset (1- n-word-bytes))))))))
 \f
 ;;;; allocation helpers
 
@@ -273,13 +280,13 @@
 ;;; 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
@@ -541,24 +548,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
-                 ;; There is no race here wrt to gc, because at every
-                 ;; point during the execution there is a reference to
-                 ;; P on the stack or in a register.
-                 `(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)))