X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fx86-64%2Fmacros.lisp;h=6c53ab48288d3382a6290ffa391ec30f2d1ed57c;hb=068cf4b55af3f8f8acf2c7c06869441612261cd4;hp=5bcb03a7ccbfdb89827095a1223f257639a5292e;hpb=bbc19242c0683a6c8cb93146eab22e29aa453801;p=sbcl.git

diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 5bcb03a..6c53ab4 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -213,16 +213,6 @@
              (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.
@@ -529,22 +519,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"
+OBJECTS will not be moved in memory for the duration of BODY.
+Useful for e.g. foreign calls where another thread may trigger
+collection."
   (if objects
-      `(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)))
+      (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)))