X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=36226af6afeae31291c8b07bb21abe0ce604e2e0;hb=e0aff99a73d836da0dad4602e5559595fbe5ba5c;hp=3ac88bb26e3e00292bb5164c463fbc52cef42efd;hpb=3cbc1e7cfb59875d7ebec4af3c7c744cab0b76ae;p=sbcl.git

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 3ac88bb..36226af 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)))
@@ -337,9 +339,12 @@
 
 ;;;; support for local (stack or register) aliens
 
-(deftransform make-local-alien ((info) * * :important t)
+(defun alien-info-constant-or-abort (info)
   (unless (constant-lvar-p info)
-    (abort-ir1-transform "Local alien info isn't constant?"))
+    (abort-ir1-transform "Local alien info isn't constant?")))
+
+(deftransform make-local-alien ((info) * * :important t)
+  (alien-info-constant-or-abort info)
   (let* ((info (lvar-value info))
          (alien-type (local-alien-info-type info))
          (bits (alien-type-bits alien-type)))
@@ -371,10 +376,7 @@
                   (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
-  ;; could be factored into a function.
-  (unless (constant-lvar-p info)
-    (abort-ir1-transform "Local alien info isn't constant?"))
+  (alien-info-constant-or-abort info)
   (let ((info (lvar-value info)))
     (/noshow "in DEFTRANSFORM NOTE-LOCAL-ALIEN-TYPE" info)
     (/noshow (local-alien-info-force-to-memory-p info))
@@ -389,8 +391,7 @@
   nil)
 
 (deftransform local-alien ((info var) * * :important t)
-  (unless (constant-lvar-p info)
-    (abort-ir1-transform "Local alien info isn't constant?"))
+  (alien-info-constant-or-abort info)
   (let* ((info (lvar-value info))
          (alien-type (local-alien-info-type info)))
     (/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type)
@@ -400,14 +401,12 @@
         `(naturalize var ',alien-type))))
 
 (deftransform %local-alien-forced-to-memory-p ((info) * * :important t)
-  (unless (constant-lvar-p info)
-    (abort-ir1-transform "Local alien info isn't constant?"))
+  (alien-info-constant-or-abort info)
   (let ((info (lvar-value info)))
     (local-alien-info-force-to-memory-p info)))
 
 (deftransform %set-local-alien ((info var value) * * :important t)
-  (unless (constant-lvar-p info)
-    (abort-ir1-transform "Local alien info isn't constant?"))
+  (alien-info-constant-or-abort info)
   (let* ((info (lvar-value info))
          (alien-type (local-alien-info-type info)))
     (if (local-alien-info-force-to-memory-p info)
@@ -422,8 +421,7 @@
       *wild-type*))
 
 (deftransform %local-alien-addr ((info var) * * :important t)
-  (unless (constant-lvar-p info)
-    (abort-ir1-transform "Local alien info isn't constant?"))
+  (alien-info-constant-or-abort info)
   (let* ((info (lvar-value info))
          (alien-type (local-alien-info-type info)))
     (/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
@@ -432,8 +430,7 @@
         (error "This shouldn't happen."))))
 
 (deftransform dispose-local-alien ((info var) * * :important t)
-  (unless (constant-lvar-p info)
-    (abort-ir1-transform "Local alien info isn't constant?"))
+  (alien-info-constant-or-abort info)
   (let* ((info (lvar-value info))
          (alien-type (local-alien-info-type info)))
     (if (local-alien-info-force-to-memory-p info)
@@ -700,10 +697,11 @@
             ;; to it later regardless of how the foreign stack looks
             ;; like.
             #!+:c-stack-is-control-stack
-            (when (policy node (<= speed debug))
+            (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)
             `(lambda (function ,@(params))
+               (declare (optimize (let-conversion 3)))
                ,body)))))))
 
 (defoptimizer (%alien-funcall derive-type) ((function type &rest args))
@@ -715,7 +713,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)