X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=3635cb4c16437a247eca371451bb0180502a816d;hb=07ab1e4811ab16f95a9a5e8d767426a0787f22c0;hp=bc5b11a2ac8117e7aa3d42f8e09c28454b9049a1;hpb=60053af56e69de2fd251cde8fcdb2ea7f01d0b01;p=sbcl.git

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index bc5b11a..3635cb4 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -349,28 +349,26 @@
     (/noshow (local-alien-info-force-to-memory-p info))
     (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
     (if (local-alien-info-force-to-memory-p info)
-      #!+(or x86 x86-64)
-      `(truly-the system-area-pointer
-                  (%primitive alloc-alien-stack-space
-                              ,(ceiling (alien-type-bits alien-type)
-                                        sb!vm:n-byte-bits)))
-      #!-(or x86 x86-64)
-      `(truly-the system-area-pointer
-                  (%primitive alloc-number-stack-space
-                              ,(ceiling (alien-type-bits alien-type)
-                                        sb!vm:n-byte-bits)))
-      (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
-             (alien-rep-type (specifier-type alien-rep-type-spec)))
-        (cond ((csubtypep (specifier-type 'system-area-pointer)
-                          alien-rep-type)
-               '(int-sap 0))
-              ((ctypep 0 alien-rep-type) 0)
-              ((ctypep 0.0f0 alien-rep-type) 0.0f0)
-              ((ctypep 0.0d0 alien-rep-type) 0.0d0)
-              (t
-               (compiler-error
-                "Aliens of type ~S cannot be represented immediately."
-                (unparse-alien-type alien-type))))))))
+        #!+(or x86 x86-64)
+        `(%primitive alloc-alien-stack-space
+                     ,(ceiling (alien-type-bits alien-type)
+                               sb!vm:n-byte-bits))
+        #!-(or x86 x86-64)
+        `(%primitive alloc-number-stack-space
+                     ,(ceiling (alien-type-bits alien-type)
+                               sb!vm:n-byte-bits))
+        (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
+               (alien-rep-type (specifier-type alien-rep-type-spec)))
+          (cond ((csubtypep (specifier-type 'system-area-pointer)
+                            alien-rep-type)
+                 '(int-sap 0))
+                ((ctypep 0 alien-rep-type) 0)
+                ((ctypep 0.0f0 alien-rep-type) 0.0f0)
+                ((ctypep 0.0d0 alien-rep-type) 0.0d0)
+                (t
+                 (compiler-error
+                  "Aliens of type ~S cannot be represented immediately."
+                  (unparse-alien-type alien-type))))))))
 
 (deftransform note-local-alien-type ((info var) * * :important t)
   ;; FIXME: This test and error occur about a zillion times. They
@@ -615,6 +613,33 @@
     `(lambda (function ,@names)
        (alien-funcall (deref function) ,@names))))
 
+;;; Frame pointer, program counter conses. In each thread it's bound
+;;; locally or not bound at all.
+(defvar *saved-fp-and-pcs*)
+
+#!+:c-stack-is-control-stack
+(declaim (inline invoke-with-saved-fp-and-pc))
+#!+:c-stack-is-control-stack
+(defun invoke-with-saved-fp-and-pc (fn)
+  (let* ((fp-and-pc (multiple-value-bind (fp pc)
+                        (%caller-frame-and-pc)
+                      (cons fp pc)))
+         (*saved-fp-and-pcs* (if (boundp '*saved-fp-and-pcs*)
+                                 (cons fp-and-pc *saved-fp-and-pcs*)
+                                 (list fp-and-pc))))
+    (declare (truly-dynamic-extent fp-and-pc *saved-fp-and-pcs*))
+    (funcall fn)))
+
+(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
+             sap>
+             #!-:stack-grows-downward-not-upward
+             sap<
+             (int-sap (get-lisp-obj-address (car x))) fp)
+        (return (values (car x) (cdr x)))))))
+
 (deftransform alien-funcall ((function &rest args) * * :important t)
   (let ((type (lvar-type function)))
     (unless (alien-type-type-p type)
@@ -669,6 +694,11 @@
                         `(multiple-value-bind ,(temps) ,body
                            (values ,@(results)))))
                 (setf body `(naturalize ,body ',return-type)))
+            ;; 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
+            (setf body `(invoke-with-saved-fp-and-pc (lambda () ,body)))
             (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
             `(lambda (function ,@(params))
                ,body)))))))