Call variadic foreign functions through a variadic function type

docs/fli-notes.md

@@ -48,6 +48,7 @@ A quote of [Dr. Christian E. Schafmeister][], [drmeister][] on Github, the ceato
     * II.1 [Source Code](#id-ii.1)
         * II.1.1 [Source Code Files](#id-ii.1.1)
     * II.2 [Source Code Rules & Conventions](#id-ii.2)
+    * II.3 [Calling Variadic Foreign Functions](#id-ii.3)
 
 * * * * *
 
@@ -153,3 +154,61 @@ Integration with the main development branch of [drmeister's repository, branch
 The following rules and conventions have been used to implement the FLI:
 
 1. All FLI Lisp functions and macros are prefixed with a % sign - indicating that these macros and functions are meant to not be used directly by a user of the FLI, except when implementing low level access to Clasp's FLI on purpose.
+
+* * * * *
+
+<div id="id-ii.3">
+## II.3 Calling Variadic Foreign Functions ##
+
+A variadic callee -- `printf`, `open`, `fcntl`, `shm_open` -- must be called through a
+*variadic* function type that names how many of its parameters are fixed. Calling it through
+an ordinary function type is undefined behaviour in C, and the two are not interchangeable in
+practice:
+
+* On **x86-64 SysV** variadic arguments are passed in the same registers as fixed ones, so the
+  mistake is invisible.
+* On **Darwin arm64** variadic arguments are passed on the **stack**. A call lowered as
+  non-variadic leaves them in registers, the callee reads an unwritten stack slot, and every
+  variadic argument arrives as **zero**.
+
+The usual symptom is a mode or flag that silently does nothing. `shm_open(name, flags, 0600)`
+creates its object with `st_mode` `0`, which cannot then be reopened; `fcntl(fd, F_SETFD,
+FD_CLOEXEC)` returns success without setting the flag.
+
+### API
+
+    (clasp-ffi:%foreign-funcall-varargs NAME FIXED-COUNT &rest ARGUMENTS)
+    (clasp-ffi:%foreign-funcall-pointer-varargs PTR FIXED-COUNT &rest ARGUMENTS)
+
+`ARGUMENTS` alternate type and value and end with the return type, exactly as for
+`%FOREIGN-FUNCALL`. `FIXED-COUNT` is how many of them are the callee's **fixed** parameters;
+the rest are variadic. It must be a literal integer, because it selects the fixed prefix when
+the function type is built at compile time, and it is validated at macroexpansion.
+
+    ;; int fcntl(int fd, int cmd, ...);  -- two fixed parameters
+    (clasp-ffi:%foreign-funcall-varargs "fcntl" 2 :int fd :int f-setfd :int fd-cloexec :int)
+
+`%FOREIGN-FUNCALL` is unchanged and still builds a non-variadic type, which is correct for the
+overwhelming majority of callees. Only reach for the variadic forms when the C declaration has
+an ellipsis.
+
+### Implementation
+
+`CMP:FUNCTION-TYPE-CREATE-ON-THE-FLY` accepts the foreign-type list in two shapes:
+
+    (return-type (arg-types ...))                 ; non-variadic
+    (return-type (arg-types ...) fixed-count)     ; variadic
+
+The third element is optional, so the representation is backward compatible: the BIR
+instruction, the translator and the foreign-caller cache all treat the signature as opaque data
+and needed no change.
+
+### CFFI
+
+CFFI already carries the fixed/variadic split down to the backend, and falls back to appending
+the two lists -- discarding the distinction -- when the backend does not define
+`%FOREIGN-FUNCALL-VARARGS`. Clasp's backend defines it, so
+
+    (cffi:foreign-funcall-varargs "shm_open" (:string name :int flags) :int #o600 :int)
+
+passes the mode correctly.

src/lisp/kernel/cmp/codegen-special-form.lisp

@@ -110,9 +110,16 @@
 
 ;;; FOREIGN-CALL, FOREIGN-CALL-POINTER
 
+;;; FOREIGN-TYPES is (return-type (arg-types...)) or, for a variadic callee,
+;;; (return-type (arg-types...) fixed-count). The distinction is not cosmetic: on
+;;; Darwin arm64 variadic arguments are passed on the stack, so lowering a
+;;; variadic call as non-variadic puts them in registers and the callee reads
+;;; whatever the stack happened to hold -- usually zero.
 (defun function-type-create-on-the-fly (foreign-types)
-  (let ((arg-types (mapcar (lambda (type)
-                             (clasp-ffi::safe-translator-type type))
-                           (second foreign-types)))
-        (varargs nil))
+  (let* ((all-arg-types (mapcar (lambda (type)
+                                  (clasp-ffi::safe-translator-type type))
+                                (second foreign-types)))
+         (fixed-count (third foreign-types))
+         (varargs (and fixed-count t))
+         (arg-types (if varargs (subseq all-arg-types 0 fixed-count) all-arg-types)))
     (llvm-sys:function-type-get (clasp-ffi::safe-translator-type (first foreign-types)) arg-types varargs)))

src/lisp/kernel/lsp/fli.lisp

@@ -218,6 +218,16 @@
        (right '() (if (endp (rest list)) right (list* (second list) right))))
       ((endp list) (list (nreverse left) (nreverse right)))))
 
+(defun check-fixed-count (fixed-count arg-types context)
+  "Signal at macroexpansion if FIXED-COUNT cannot name a prefix of ARG-TYPES."
+  (unless (integerp fixed-count)
+    (error "~a: the fixed-argument count must be a literal integer, got ~s.~@
+            It selects the callee's fixed parameters at compile time and cannot be computed at runtime."
+           context fixed-count))
+  (unless (<= 0 fixed-count (length arg-types))
+    (error "~a: fixed-argument count ~s is out of range; the call passes ~s argument~:p."
+           context fixed-count (length arg-types))))
+
 (defun extract-signature (arguments)
   "Converts (:float 16.0 :int 3 :float) -> (values '(:float (:float :int)) (16.0 3))"
   (let* ((types-args (clasp-ffi::split-list arguments))
@@ -238,6 +248,32 @@
       (extract-signature arguments)
     `(core:foreign-call-pointer ,signature (ensure-core-pointer ,ptr "%foreign-funcall-pointer" ,ptr) ,@args)))
 
+;;; A variadic callee must be called through a variadic function type, naming how
+;;; many arguments are fixed. Passing everything as fixed works by accident on
+;;; x86-64 SysV, where variadic arguments use the same registers, and fails on
+;;; Darwin arm64, where they are passed on the stack: the callee then reads an
+;;; unwritten slot, so the argument arrives as zero.
+(defmacro %foreign-funcall-varargs (name fixed-count &rest arguments)
+  "Call the variadic foreign function NAME. ARGUMENTS alternate type and value and
+end with the return type, as for %FOREIGN-FUNCALL; the first FIXED-COUNT of them
+are the callee's fixed parameters and the rest are variadic."
+  (multiple-value-bind (signature args)
+      (extract-signature arguments)
+    (check-fixed-count fixed-count (second signature) '%FOREIGN-FUNCALL-VARARGS)
+    `(core:foreign-call-pointer ,(append signature (list fixed-count))
+                                (ensure-core-pointer (core:dlsym :rtld-default ,name)
+                                                     "%foreign-funcall-varargs" ,name)
+                                ,@args)))
+
+(defmacro %foreign-funcall-pointer-varargs (ptr fixed-count &rest arguments)
+  "As %FOREIGN-FUNCALL-VARARGS, but calls the function at PTR."
+  (multiple-value-bind (signature args)
+      (extract-signature arguments)
+    (check-fixed-count fixed-count (second signature) '%FOREIGN-FUNCALL-POINTER-VARARGS)
+    `(core:foreign-call-pointer ,(append signature (list fixed-count))
+                                (ensure-core-pointer ,ptr "%foreign-funcall-pointer-varargs" ,ptr)
+                                ,@args)))
+
 ;;; We'd like for the bytecode to be able to handle foreign calls, but it
 ;;; doesn't make sense for it to handle them directly. So, we provide a
 ;;; %%foreign-funcall function, and a definition of foreign-call-pointer
@@ -481,6 +517,8 @@
             %mem-set
             %foreign-funcall
             %foreign-funcall-pointer
+            %foreign-funcall-varargs
+            %foreign-funcall-pointer-varargs
             %load-foreign-library
             %close-foreign-library
             %foreign-symbol-pointer

src/lisp/regression-tests/defcallback-native.lisp

@@ -34,3 +34,29 @@
                      collect (clasp-ffi:%mem-ref array :int (* i intsize))))
           (clasp-ffi:%foreign-free array)))
       ((1 2 3 4 5 6 7 8 9 10)))
+
+;;; fcntl(int fd, int cmd, ...) has a variadic third argument. Calling it through
+;;; a non-variadic function type is undefined behaviour that happens to work on
+;;; x86-64 SysV, where variadic arguments use the same registers as fixed ones,
+;;; and loses the argument on Darwin arm64, where they are passed on the stack:
+;;; the callee reads an unwritten slot and sees zero. shm_open's mode is the
+;;; usual casualty. F_GETFD=1, F_SETFD=2 and FD_CLOEXEC=1 on both Linux and macOS.
+(test-true foreign-funcall-varargs-passes-variadic-argument
+           (multiple-value-bind (r w) (core:pipe)
+             (declare (ignore w))
+             (clasp-ffi:%foreign-funcall-varargs "fcntl" 2 :int r :int 2 :int 1 :int)
+             (eql 1 (clasp-ffi:%foreign-funcall "fcntl" :int r :int 1 :int))))
+
+(test-true foreign-funcall-pointer-varargs-passes-variadic-argument
+           (multiple-value-bind (r w) (core:pipe)
+             (declare (ignore w))
+             (let ((fcntl (core:dlsym :rtld-default "fcntl")))
+               (clasp-ffi:%foreign-funcall-pointer-varargs fcntl 2 :int r :int 2 :int 1 :int)
+               (eql 1 (clasp-ffi:%foreign-funcall "fcntl" :int r :int 1 :int)))))
+
+;;; A call with no variadic arguments must be unaffected: it still builds a
+;;; non-variadic function type and must succeed rather than return -1.
+(test-true foreign-funcall-fixed-args-unaffected
+           (multiple-value-bind (r w) (core:pipe)
+             (declare (ignore w))
+             (>= (clasp-ffi:%foreign-funcall "fcntl" :int r :int 1 :int) 0)))