with-alien struct initialization

doc/manual/ffi.texinfo

@@ -534,6 +534,21 @@ contain named structure or union types with the slots specified.
 Within the lexical scope of the binding specifiers and body, a locally
 defined foreign structure type @var{foo} can be referenced by its name
 using @code{(struct @var{foo})}.
+
+When a foreign function returns a structure by value, using
+@code{alien-funcall} as the @var{initial-value} allows the returned
+struct to be stack-allocated directly into the local variable's
+storage, avoiding heap allocation:
+
+@lisp
+(with-alien ((result (struct point)
+                     (alien-funcall
+                      (extern-alien "make_point"
+                                    (function (struct point) double double))
+                      1.0d0 2.0d0)))
+  (values (slot result 'x) (slot result 'y)))
+@end lisp
+
 @end defmac
 
 @node  External Foreign Variables

src/code/target-alieneval.lisp

@@ -120,6 +120,20 @@ This is SETFable."
      (let ((sb-c:*alien-stack-pointer* sb-c:*alien-stack-pointer*))
        ,@body)))
 
+#+(or x86-64 arm64)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun maybe-extract-alien-funcall-into (form alien-type var env)
+    "Transform (alien-funcall func args...) to (alien-funcall-into func sap args...).
+   Returns transformed form or NIL if not applicable."
+    (declare (ignore env))
+    ;; Form must be (alien-funcall func-expr args...)
+    (when (and (consp form)
+               (eq (car form) 'alien-funcall)
+               (alien-record-type-p alien-type))
+      (let ((func-expr (second form))
+            (args (cddr form)))
+        `(alien-funcall-into ,func-expr ,var ,@args)))))
+
 (defmacro with-alien (bindings &body body &environment env)
   "Establish some local alien variables. Each BINDING is of the form:
      VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ]
@@ -174,16 +188,28 @@ This is SETFable."
                            ,@body)))
                       (:local
                        (let* ((var (gensym "VAR"))
-                              (initval (if initial-value (gensym "INITVAL")))
                               (info (make-local-alien-info :type alien-type))
+                              ;; Try to optimize alien-funcall initializer
+                              (funcall-into-form
+                               #+(or x86-64 arm64)
+                               (and initial-value
+                                    (maybe-extract-alien-funcall-into
+                                     initial-value alien-type var env))
+                               #-(or x86-64 arm64)
+                               nil)
+                              (initval (if (and initial-value (not funcall-into-form))
+                                           (gensym "INITVAL")))
                               (inner-body
                                 `((note-local-alien-type ',info ,var)
                                   (symbol-macrolet ((,symbol (local-alien ',info ,var)))
-                                    ,@(when initial-value
-                                        `((setq ,symbol ,initval)))
-                                    ,@body)))
+                                    ,@(cond
+                                        (funcall-into-form
+                                         `(,funcall-into-form ,@body))
+                                        (initial-value
+                                         `((setq ,symbol ,initval) ,@body))
+                                        (t body)))))
                               (body-forms
-                                (if initial-value
+                                (if initval
                                     `((let ((,initval ,initial-value))
                                         ,@inner-body))
                                     inner-body)))

tests/alien-struct-by-value.impure.lisp

@@ -696,7 +696,8 @@
 ;;;; alien-funcall-into writes struct return values directly to a
 ;;;; caller-provided buffer instead of heap-allocating.
 
-(with-test (:name :alien-funcall-into)
+(with-test (:name :alien-funcall-into
+            :skipped-on (and :sb-fasteval (not :sb-eval)))
   ;; Small struct returned in registers
   (with-alien ((result (struct tiny-align-8)))
     (alien-funcall-into
@@ -749,5 +750,17 @@
         (alien-funcall-into f (alien-sap (addr result)) 99)
         (assert (= (slot result 'm0) 99))))))
 
+;;;; Test that (with-alien ((s type (alien-funcall ...)) body))
+;;;; is optimized to use alien-funcall-into.
+(with-test (:name :with-alien-funcall-init-into
+            :skipped-on (and :sb-fasteval (not :sb-eval)))
+  (with-alien ((result (struct two-doubles)
+                (alien-funcall
+                 (extern-alien "two_doubles_return"
+                               (function (struct two-doubles) double double))
+                 1.5d0 2.5d0)))
+    (assert (= (slot result 'd0) 1.5d0))
+    (assert (= (slot result 'd1) 2.5d0))))
+
 ;;; Clean up
 #-win32 (ignore-errors (delete-file *soname*))