From 7aa33c0b1c6498fe034450c79cf96843c44d0f6b Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Sun, 10 May 2015 03:12:40 +0300
Subject: [PATCH] Do not cons when calling foreign functions.

By default, FP and PC are saved to aid debugging, but PC may turn out
to be non-fixnum and will have to be allocated, this happens all the
time on FreeBSD-x86. Instead of putting FP and PC into a dx-allocated
cons, put it into a dx-allocated word-specialized vector.
---
 src/code/debug-int.lisp       |  5 +----
 src/code/early-alieneval.lisp | 19 +++++++++++--------
 src/code/unix.lisp            |  1 +
 src/compiler/aliencomp.lisp   |  2 +-
 4 files changed, 14 insertions(+), 13 deletions(-)

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 477684a4d..14af3c586 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -632,10 +632,7 @@
   (multiple-value-bind (saved-fp saved-pc)
       (sb!alien-internals:find-saved-fp-and-pc fp)
     (when saved-fp
-      (compute-calling-frame (descriptor-sap saved-fp)
-                             (descriptor-sap saved-pc)
-                             up-frame
-                             t))))
+      (compute-calling-frame saved-fp saved-pc up-frame t))))
 
 ;;; Return the frame immediately below FRAME on the stack; or when
 ;;; FRAME is the bottom of the stack, return NIL.
diff --git a/src/code/early-alieneval.lisp b/src/code/early-alieneval.lisp
index 803d7f8bf..3778ac6ac 100644
--- a/src/code/early-alieneval.lisp
+++ b/src/code/early-alieneval.lisp
@@ -33,15 +33,17 @@
 ;;; locally or not bound at all.
 (defvar *saved-fp-and-pcs*)
 
-#!+:c-stack-is-control-stack
+#!+c-stack-is-control-stack
 (declaim (inline invoke-with-saved-fp-and-pc))
-#!+:c-stack-is-control-stack
+#!+c-stack-is-control-stack
 (defun invoke-with-saved-fp-and-pc (fn)
   (declare #-sb-xc-host (muffle-conditions compiler-note)
            (optimize (speed 3)))
-  (let* ((fp-and-pc (cons (sb!kernel:%caller-frame)
-                          (sap-int (sb!kernel:%caller-pc)))))
+  (let ((fp-and-pc (make-array 2 :element-type 'word)))
     (declare (truly-dynamic-extent fp-and-pc))
+    (setf (aref fp-and-pc 0) (sb!kernel:get-lisp-obj-address
+                              (sb!kernel:%caller-frame))
+          (aref fp-and-pc 1) (sap-int (sb!kernel:%caller-pc)))
     (let ((*saved-fp-and-pcs* (if (boundp '*saved-fp-and-pcs*)
                                   (cons fp-and-pc *saved-fp-and-pcs*)
                                   (list fp-and-pc))))
@@ -51,10 +53,11 @@
 (defun find-saved-fp-and-pc (fp)
   (when (boundp '*saved-fp-and-pcs*)
     (dolist (x *saved-fp-and-pcs*)
-      (when (#!+:stack-grows-downward-not-upward
+      (declare (type (simple-array word (2)) x))
+      (when (#!+stack-grows-downward-not-upward
              sap>
-             #!-:stack-grows-downward-not-upward
+             #!-stack-grows-downward-not-upward
              sap<
-             (int-sap (sb!kernel:get-lisp-obj-address (car x))) fp)
-        (return (values (car x) (cdr x)))))))
+             (int-sap (aref x 0)) fp)
+        (return (values (int-sap (aref x 0)) (int-sap (aref x 1))))))))
 
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 29518b098..defa8c7a9 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -947,6 +947,7 @@ avoiding atexit(3) hooks, etc. Otherwise exit(2) is called."
 
 #!-win32
 (defun nanosleep (secs nsecs)
+  (declare (optimize (sb!c:alien-funcall-saves-fp-and-pc 0)))
   (with-alien ((req (struct timespec))
                (rem (struct timespec)))
     (setf (slot req 'tv-sec) secs
diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index a24483d5c..64c54974e 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -668,7 +668,7 @@
             ;; Remember this frame to make sure that we can get back
             ;; to it later regardless of how the foreign stack looks
             ;; like.
-            #!+:c-stack-is-control-stack
+            #!+c-stack-is-control-stack
             (when (policy node (= 3 alien-funcall-saves-fp-and-pc))
               (setf body `(invoke-with-saved-fp-and-pc (lambda () ,body))))
             (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
-- 
2.11.4.GIT