X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Faliencomp.lisp;h=36226af6afeae31291c8b07bb21abe0ce604e2e0;hb=77ae1e21c9418325b78e639a37634213b7222789;hp=7cd63584c60ba68a95df7bfba1a834f44d9b7687;hpb=a6c61ba848e9ed11118b6fb579fe237d0b1cf9c6;p=sbcl.git

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 7cd6358..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)))
@@ -332,13 +334,17 @@
 (deftransform %heap-alien-addr ((info) * * :important t)
   (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
     (/noshow "in DEFTRANSFORM %HEAP-ALIEN-ADDR, creating %SAP-ALIEN")
-    `(%sap-alien ,sap ',type)))
+    `(%sap-alien ,sap ',(make-alien-pointer-type :to type))))
+
 
 ;;;; 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)))
@@ -348,34 +354,29 @@
     (/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
-  ;; 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))
@@ -390,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)
@@ -401,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)
@@ -423,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")
@@ -433,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)
@@ -527,7 +523,7 @@
          (count-low-order-zeros (lvar-uses thing))))
     (combination
      (case (let ((name (lvar-fun-name (combination-fun thing))))
-             (or (modular-version-info name :unsigned) name))
+             (or (modular-version-info name :untagged nil) name))
        ((+ -)
         (let ((min most-positive-fixnum)
               (itype (specifier-type 'integer)))
@@ -584,7 +580,7 @@
       (give-up-ir1-transform))
     (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
       (multiple-value-bind (prototype width)
-          (modular-version-info inside-fun-name :unsigned)
+          (modular-version-info inside-fun-name :untagged nil)
         (unless (eq (or prototype inside-fun-name) 'ash)
           (give-up-ir1-transform))
         (when (and width (not (constant-lvar-p amount)))
@@ -614,7 +610,36 @@
     `(lambda (function ,@names)
        (alien-funcall (deref function) ,@names))))
 
-(deftransform alien-funcall ((function &rest args) * * :important t)
+;;; 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)
+  (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*)
+    (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) * * :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"))
@@ -668,8 +693,15 @@
                         `(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
+            (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))
@@ -681,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)