MAKE-ALIEN improvements

 * Move more of the bytes-calculation to macroexpansion time.

 * Change %MAKE-ALIEN to take bytes instead of bits, so that --in theory at
   least-- chunks upto ARRAY-DIMENSION-LIMIT-1 bytes can be allocated.

 * Use ALIEN-FUNCALL-SAVES-FP-AND-PC 0.

 * Detect malloc() failure and signal a storage-condition for it.  Fixes
   lp#891268.

diff --git a/NEWS b/NEWS
index 2f27a07..24ee1fa 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,8 @@ changes relative to sbcl-1.0.54:
     ** --arch option can be used to specify the architecture to build for.
        (Mainly useful for building 32-bit SBCL's on x86-64 hosts, not
        full-blows cross-compilation.)
+  * enhancement: MAKE-ALIEN signals a storage-condition instead of returning a
+    null alien when malloc() fails. (lp#891268)
   * optimization: the compiler is smarter about representation selection for
     floating point constants used in full calls.
   * bug fix: deadlock detection could report the same deadlock twice, for

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index e95abe3..aa7922f 100644 (file)
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -295,18 +295,28 @@ Examples:
         ;; 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))
+           ;; FIXME: Do we really need the ASH/+7 here after ALIGN-OFFSET?
+           (%sap-alien (%make-alien (* ,(ash (+ 7 (align-offset bits alignment)) -3)
+                                       (the index ,size-expr)))
                        ',(make-alien-pointer-type :to alien-type)))))))
 
+(defun malloc-error (bytes errno)
+  (error 'simple-storage-condition
+         :format-control "~A: malloc() of ~S bytes failed."
+         :format-arguments (list (strerror errno) bytes)))
+
 ;;; Allocate a block of memory at least BITS bits long and return a
 ;;; system area pointer to it.
 #!-sb-fluid (declaim (inline %make-alien))
-(defun %make-alien (bits)
-  (declare (type index bits))
-  (alien-funcall (extern-alien "malloc"
-                               (function system-area-pointer unsigned))
-                 (ash (the index (+ bits 7)) -3)))
+(defun %make-alien (bytes)
+  (declare (type index bytes)
+           (optimize (sb!c:alien-funcall-saves-fp-and-pc 0)))
+  (let ((sap (alien-funcall (extern-alien "malloc"
+                                          (function system-area-pointer size-t))
+                            bytes)))
+    (if (and (not (eql 0 bytes)) (eql 0 (sap-int sap)))
+        (malloc-error bytes (get-errno))
+        sap)))
 
 #!-sb-fluid (declaim (inline free-alien))
 (defun free-alien (alien)
@@ -329,7 +339,7 @@ allocated by MAKE-ALIEN, MAKE-ALIEN-STRING or malloc(3)."
                                    :external-format external-format
                                    :null-terminate null-terminate))
          (count (length octets))
-         (buf (%make-alien (* 8 count))))
+         (buf (%make-alien count)))
     (sb!kernel:copy-ub8-to-system-area octets 0 buf 0 count)
     buf))
 

diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index c235b63..b490961 100644 (file)
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -324,4 +324,11 @@
     (assert (equal "This comes from lisp!" (cast alien c-string)))
     (free-alien alien)))
 
+(with-test (:name :malloc-failure)
+  (assert (eq :enomem
+              (handler-case
+                  (sb-alien:make-alien char (1- array-total-size-limit))
+                (storage-condition ()
+                  :enomem)))))
+
 ;;; success