X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=2b133cd7d3373543cbbec29f6fb849762afadf5a;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=c4f4e2f227d6e3896698add91c59507fe52a5fb7;hpb=290675ccc55b43bef1c2c39f07479dbb2f20ad1f;p=sbcl.git

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index c4f4e2f..2b133cd 100644
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -216,11 +216,11 @@
 (defmacro make-alien (type &optional size &environment env)
   #!+sb-doc
   "Allocate an alien of type TYPE and return an alien pointer to it. If SIZE
-   is supplied, how it is interpreted depends on TYPE. If TYPE is an array
-   type, SIZE is used as the first dimension for the allocated array. If TYPE
-   is not an array, then SIZE is the number of elements to allocate. The
-   memory is allocated using ``malloc'', so it can be passed to foreign
-   functions which use ``free''."
+is supplied, how it is interpreted depends on TYPE. If TYPE is an array type,
+SIZE is used as the first dimension for the allocated array. If TYPE is not an
+array, then SIZE is the number of elements to allocate. The memory is
+allocated using ``malloc'', so it can be passed to foreign functions which use
+``free''."
   (let ((alien-type (if (alien-type-p type)
                         type
                         (parse-alien-type type env))))
@@ -228,18 +228,18 @@
         (if (alien-array-type-p alien-type)
             (let ((dims (alien-array-type-dimensions alien-type)))
               (cond
-               (size
-                (unless dims
-                  (error
-                   "cannot override the size of zero-dimensional arrays"))
-                (when (constantp size)
-                  (setf alien-type (copy-alien-array-type alien-type))
-                  (setf (alien-array-type-dimensions alien-type)
-                        (cons (constant-form-value size) (cdr dims)))))
-               (dims
-                (setf size (car dims)))
-               (t
-                (setf size 1)))
+                (size
+                 (unless dims
+                   (error
+                    "cannot override the size of zero-dimensional arrays"))
+                 (when (constantp size)
+                   (setf alien-type (copy-alien-array-type alien-type))
+                   (setf (alien-array-type-dimensions alien-type)
+                         (cons (constant-form-value size) (cdr dims)))))
+                (dims
+                 (setf size (car dims)))
+                (t
+                 (setf size 1)))
               (values `(* ,size ,@(cdr dims))
                       (alien-array-type-element-type alien-type)))
             (values (or size 1) alien-type))
@@ -251,9 +251,13 @@
         (unless alignment
           (error "The alignment of ~S is unknown."
                  (unparse-alien-type element-type)))
-        `(%sap-alien (%make-alien (* ,(align-offset bits alignment)
-                                     ,size-expr))
-                     ',(make-alien-pointer-type :to alien-type))))))
+        ;; This is the one place where the %SAP-ALIEN note is quite
+        ;; undesirable, in most uses of MAKE-ALIEN the %SAP-ALIEN
+        ;; cannot be optimized away.
+        `(locally (declare (muffle-conditions compiler-note))
+           (%sap-alien (%make-alien (* ,(align-offset bits alignment)
+                                       ,size-expr))
+                       ',(make-alien-pointer-type :to alien-type)))))))
 
 ;;; Allocate a block of memory at least BITS bits long and return a
 ;;; system area pointer to it.
@@ -885,8 +889,9 @@ one."
                            ,function
                            (or (gethash ',specifier *alien-callback-wrappers*)
                                (setf (gethash ',specifier *alien-callback-wrappers*)
-                                     ,(alien-callback-lisp-wrapper-lambda
-                                       specifier result-type argument-types env))))
+                                     (compile nil
+                                              ',(alien-callback-lisp-wrapper-lambda
+                                                 specifier result-type argument-types env)))))
       ',(parse-alien-type specifier env))))
 
 (defun alien-callback-p (alien)