X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=4321c3174ba69099d534c5917eba053834626003;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=3635cb4c16437a247eca371451bb0180502a816d;hpb=70c6facc145eaf5ca368528b04df63f730746b1f;p=sbcl.git

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 3635cb4..4321c31 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -190,6 +190,8 @@
          (abort-ir1-transform "too many indices for pointer deref: ~W"
                               (length indices)))
        (let ((element-type (alien-pointer-type-to alien-type)))
+         (unless element-type
+           (give-up-ir1-transform "unable to open code deref of wild pointer type"))
          (if indices
              (let ((bits (alien-type-bits element-type))
                    (alignment (alien-type-alignment element-type)))
@@ -621,14 +623,16 @@
 (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)))
+  (declare #-sb-xc-host (muffle-conditions compiler-note)
+           (optimize (speed 3)))
+  (let* ((fp-and-pc (cons (%caller-frame)
+                          (sap-int (%caller-pc)))))
+    (declare (truly-dynamic-extent fp-and-pc))
+    (let ((*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 *saved-fp-and-pcs*))
+      (funcall fn))))
 
 (defun find-saved-fp-and-pc (fp)
   (when (boundp '*saved-fp-and-pcs*)
@@ -640,7 +644,7 @@
              (int-sap (get-lisp-obj-address (car x))) fp)
         (return (values (car x) (cdr x)))))))
 
-(deftransform alien-funcall ((function &rest args) * * :important t)
+(deftransform alien-funcall ((function &rest args) * * :node node :important t)
   (let ((type (lvar-type function)))
     (unless (alien-type-type-p type)
       (give-up-ir1-transform "can't tell function type at compile time"))
@@ -698,7 +702,8 @@
             ;; 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)))
+            (when (policy node (<= speed debug))
+              (setf body `(invoke-with-saved-fp-and-pc (lambda () ,body))))
             (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
             `(lambda (function ,@(params))
                ,body)))))))
@@ -712,7 +717,8 @@
       (error "Something is broken."))
     (values-specifier-type
      (compute-alien-rep-type
-      (alien-fun-type-result-type type)))))
+      (alien-fun-type-result-type type)
+      :result))))
 
 (defoptimizer (%alien-funcall ltn-annotate)
               ((function type &rest args) node ltn-policy)