Dear CFFI developers!
Recently we have migrated one of our largest projects from our home-grown
foreign-function interface implementation to CFFI.
The project is almost 1M LOC with almost 1K of foreign-functions.
Previously, we have inlined all of our foreign-function stubs. We also use
FTYPEs through the code for type-safety and optimization.
Having CFFI functions inlined and FTYPEs generated would spare us from
writing those declarations on our own.
The attached patch contains a proposal that we would like to share.
Please, let us know about any modification necessary that would make this
patch useful for a larger community.
FYI: We have tested the patch against about a hundredth open-source Lisp
projects.
Kindly,
--
Andrzej Walczak
(Google/ITA Software Engineer)
Added FTYPE declarations for DEFCFUN functions. Added INLINE for DEFCFUN in optimized mode.
--- a/src/cffi-sbcl.lisp
+++ b/src/cffi-sbcl.lisp
@@ -46,6 +46,7 @@
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-funcall-pointer
+ #:%inlinep
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
@@ -315,6 +316,10 @@
`(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
(alien-funcall ,function ,@fargs)))))
+(defun %inlinep (&optional (env (and (boundp 'sb-c::*lexenv*) sb-c::*lexenv*)))
+ "True if DEFCFUN can be inlined in lexical environment ENV."
+ (sb-c:policy (or env sb-c::*policy*) (< debug 2 speed)))
+
;;;# Callbacks
;;; The *CALLBACKS* hash table contains a direct mapping of CFFI
--- a/src/early-types.lisp
+++ b/src/early-types.lisp
@@ -161,6 +161,14 @@
(:documentation
"Unparse FOREIGN-TYPE to a type specification (symbol or list)."))
+(defgeneric lisp-parameter-type (foreign-type)
+ (:documentation "Lisp type corresponding to FOREIGN-TYPE")
+ (:method (type) t))
+
+(defgeneric lisp-value-type (foreign-type)
+ (:documentation "Lisp type for returning value corresponding to FOREIGN-TYPE")
+ (:method (type) `(values ,(lisp-parameter-type type) &optional)))
+
;;;# Foreign Types
(defclass foreign-type ()
@@ -194,6 +202,9 @@
(defmethod unparse-type ((type named-foreign-type))
(name type))
+(defmethod lisp-parameter-type ((type named-foreign-type))
+ (lisp-parameter-type (unparse-type type)))
+
;;;# Built-In Foreign Types
(defclass foreign-built-in-type (foreign-type)
@@ -224,6 +235,12 @@
"Returns the symbolic representation of a built-in type."
(type-keyword type))
+(defmethod lisp-parameter-type ((type foreign-built-in-type))
+ (lisp-parameter-type (type-keyword type)))
+
+(defmethod lisp-value-type ((type foreign-built-in-type))
+ (lisp-value-type (type-keyword type)))
+
(defmethod print-object ((type foreign-built-in-type) stream)
"Print a FOREIGN-TYPE instance to STREAM unreadably."
(print-unreadable-object (type stream :type t :identity nil)
@@ -364,6 +381,9 @@
"Return the size in bytes of a foreign typedef."
(foreign-type-size (actual-type type)))
+(defmethod lisp-parameter-type ((type foreign-type-alias))
+ (lisp-parameter-type (actual-type type)))
+
(defclass foreign-typedef (foreign-type-alias named-foreign-type)
())
@@ -396,6 +416,12 @@
foreign-type-alias)
((unparsed-type :accessor unparsed-type)))
+;;;
+;;; The CFFI type can be translated to any type.
+;;; Do not assume any dependency on the actual type.
+(defmethod lisp-parameter-type ((type translatable-foreign-type)) 't)
+(defmethod lisp-value-type ((type translatable-foreign-type)) '*)
+
;;; If actual-type isn't parsed already, let's parse it. This way we
;;; don't have to export PARSE-TYPE and users don't have to worry
;;; about this in DEFINE-FOREIGN-TYPE or DEFINE-PARSE-METHOD.
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -214,21 +214,46 @@
(list rettype))
,@options)))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (fboundp '%inlinep)
+ (defun %inlinep (&optional env)
+ "True if DEFCFUN can be inlined in lexical environment ENV."
+ (declare (ignore env))
+ nil)))
+
(defun %defcfun (lisp-name foreign-name return-type args options docstring)
(let* ((arg-names (mapcar #'first args))
(arg-types (mapcar #'second args))
- (syms (make-gensym-list (length args)))
- (call-by-value (fn-call-by-value-p arg-types return-type)))
+ (syms (make-gensym-list (length (the list args))))
+ (call-by-value (fn-call-by-value-p arg-types return-type))
+ (inline
+ (destructuring-bind
+ (&key (inline (%inlinep) inlinep) &allow-other-keys) options
+ (when inlinep
+ (setf options (copy-list options))
+ (remf options :inline))
+ (and inline `((inline ,lisp-name)))))
+ (parsed-arg-types (mapcar #'parse-type arg-types))
+ (parsed-return-type (parse-type return-type))
+ (lisp-arg-types (mapcar #'lisp-parameter-type parsed-arg-types))
+ (lisp-value-type (lisp-value-type parsed-return-type))
+ (ftype `(function ,lisp-arg-types ,lisp-value-type))
+ (declarations
+ (remove t (mapcar (lambda (arg type) `(type ,type ,arg))
+ arg-names lisp-arg-types)
+ :key #'second)))
(multiple-value-bind (prelude caller)
(if call-by-value
(values nil nil)
(defcfun-helper-forms
- foreign-name lisp-name (canonicalize-foreign-type return-type)
- syms (mapcar #'canonicalize-foreign-type arg-types) options))
+ foreign-name lisp-name (canonicalize parsed-return-type)
+ syms (mapcar #'canonicalize parsed-arg-types) options))
`(progn
- ,prelude
+ ,@(when prelude `(,prelude))
+ (declaim (ftype ,ftype ,lisp-name) ,@inline)
(defun ,lisp-name ,arg-names
,@(ensure-list docstring)
+ ,@(when declarations `((declare ,@declarations)))
,(if call-by-value
`(foreign-funcall
,(cons foreign-name options)
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -171,6 +171,8 @@
#:expand-to-foreign
#:expand-from-foreign
#:expand-into-foreign-memory
+ #:lisp-parameter-type
+ #:lisp-value-type
;; Foreign globals.
#:defcvar
--- a/src/strings.lisp
+++ b/src/strings.lisp
@@ -262,6 +262,11 @@
(print-unreadable-object (type stream :type t)
(format stream "~S" (fst-encoding type))))
+(defmethod lisp-parameter-type ((type foreign-string-type))
+ '(or foreign-pointer string))
+(defmethod lisp-value-type ((type foreign-string-type))
+ '(values (or null string) &optional))
+
(defmethod translate-to-foreign ((s string) (type foreign-string-type))
(values (foreign-string-alloc s :encoding (fst-encoding type))
(fst-free-to-foreign-p type)))
@@ -303,3 +308,8 @@
(defmethod translate-from-foreign (value (type foreign-string+ptr-type))
(list (call-next-method) value))
+
+(deftype foreign-string+ptr () '(cons (or null string) (cons foreign-pointer)))
+
+(defmethod lisp-value-type ((type foreign-string+ptr-type))
+ '(values foreign-string+ptr &optional))
--- a/src/types.lisp
+++ b/src/types.lisp
@@ -1047,3 +1047,28 @@
(:uintptr . :pointer))
(:unsigned-char :unsigned-short :unsigned-int :unsigned-long
:unsigned-long-long))))
+
+;; Declare the Lisp type of built-in foreign-types.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmethod lisp-parameter-type ((type (eql :float))) 'single-float)
+ (defmethod lisp-parameter-type ((type (eql :double))) 'float)
+ (defmethod lisp-value-type ((type (eql :double)))
+ '(values double-float &optional))
+ (defmethod lisp-parameter-type ((type (eql :string))) 'string)
+ (defmethod lisp-parameter-type ((type (eql :pointer))) 'foreign-pointer)
+ (defmethod lisp-parameter-type ((type foreign-boolean-type)) t)
+ (defmethod lisp-value-type ((type foreign-boolean-type))
+ '(values boolean &optional))
+ (defmethod lisp-value-type ((type (eql :void)))
+ '(values &optional))
+ (macrolet
+ ((define (bytes types)
+ `(progn
+ ,@(loop :for key :in types :collect
+ `(defmethod lisp-parameter-type ((type (eql ,key)))
+ '(,bytes ,(* (foreign-type-size key) 8)))))))
+ (define signed-byte
+ (:char :short :int :long :long-long))
+ (define unsigned-byte
+ (:unsigned-char :unsigned-short :unsigned-int
+ :unsigned-long :unsigned-long-long))))
