luciano/coffi
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Rewrite the inline expansion macro

Browse source
This commit is contained in:
Joshua Suskalo 2021-10-14 18:25:06 -05:00
parent b8411d4996
commit e760a320a7
2 changed files with 132 additions and 99 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
CHANGELOG.md
View file

@ -2,6 +2,8 @@
All notable changes to this project will be documented in this file. This change log follows the conventions of [keepachangelog.com](http://keepachangelog.com/). All notable changes to this project will be documented in this file. This change log follows the conventions of [keepachangelog.com](http://keepachangelog.com/).
## [Unreleased] ## [Unreleased]
### Fixed
- Bug with the inline expansion of `make-serde-wrapper`, make it more maintainable
## [0.1.246] - 2021-10-14 ## [0.1.246] - 2021-10-14
### Fixed ### Fixed

229
src/clj/coffi/ffi.clj
View file

@ -250,112 +250,143 @@
primitive, the `downcall` is returned directly. In cases where arguments must primitive, the `downcall` is returned directly. In cases where arguments must
be serialized, a new [[mem/stack-scope]] is generated." be serialized, a new [[mem/stack-scope]] is generated."
[downcall arg-types ret-type] [downcall arg-types ret-type]
(let [const-ret? (s/valid? ::mem/type ret-type) (let [;; Complexity of types
primitive-ret? (mem/primitive? ret-type) const-args? (or (vector? arg-types) (nil? arg-types))
simple-args? (when const-args?
(every? mem/primitive? arg-types))
const-ret? (s/valid? ::mem/type ret-type)
primitive-ret? (and const-ret? (or (mem/primitive? ret-type)
(#{::mem/void} ret-type)))
simple-ret? (and const-ret? (mem/primitive-type ret-type))
no-serde? (and const-args? (empty? arg-types)
primitive-ret?)]
(if no-serde?
`(let [downcall# ~downcall]
;; NOTE(Joshua): These are here to ensure that evaluation order is
;; preserved as equivalent to a function call.
~arg-types
~ret-type
downcall#)
(let [;; All our symbols
scope (gensym "scope") scope (gensym "scope")
downcall-sym (gensym "downcall")] downcall-sym (gensym "downcall")
`(let [~downcall-sym ~downcall] args-sym (when-not const-args?
~(if-not (seqable? arg-types) (gensym "args"))
(let [args (gensym "args") args-types-sym (when-not const-args?
ret (gensym "ret") (gensym "args-types"))
serialized-args `(map (fn [arg# type#] (mem/serialize arg# type# ~scope)) ~args ~arg-types) arg-syms (when const-args?
prim-call `(apply ~downcall-sym ~serialized-args) (repeatedly (count arg-types) #(gensym "arg")))
non-prim-call `(apply ~downcall-sym (mem/scope-allocator ~scope) ~serialized-args)] arg-type-syms (when const-args?
(cond (repeatedly (count arg-types) #(gensym "arg-type")))
(and const-ret? ret-type-sym (gensym "ret-type")
primitive-ret?)
`(fn ~'native-fn
[~'& ~args]
(with-open [~scope (mem/stack-scope)]
~prim-call))
const-ret? ;; Helper Functions
`(let [~ret ~ret-type] make-serialized-binding
(fn ~'native-fn ;; Given a symbol and its type, make a partial binding to serialize and shadow it
[~'& ~args] (fn [sym type type-sym]
(with-open [~scope (mem/stack-scopee)] (some->>
~(if (mem/primitive-type ret-type) (cond
`(mem/deserialize* ~prim-call ~ret) (not (s/valid? ::mem/type type))
`(mem/deserialize-from ~non-prim-call ~ret))))) `(mem/serialize ~sym ~type-sym ~scope)
(and (mem/primitive? type)
(not (#{::mem/pointer} type)))
(list (primitive-cast-sym type) sym)
(#{::mem/pointer} type)
nil
(mem/primitive-type type)
`(mem/serialize* ~sym ~type-sym ~scope)
:else :else
`(let [~ret ~ret-type] `(let [alloc# (mem/alloc-instance ~type-sym)]
(if (mem/primitive-type ~ret) (mem/serialize-into ~sym ~type-sym alloc# ~scope)
(fn ~'native-fn alloc#))
[~'& ~args] (list sym)))
(with-open [~scope (mem/stack-scope)]
(mem/deserialize* ~prim-call ~ret))) arg-serializers
(fn ~'native-fn ;; Binding forms that rebind the arg symbols to their serialized counterparts
[~'& ~args] (when const-args?
(with-open [~scope (mem/stack-scope)] (->> (map make-serialized-binding
(mem/deserialize-from ~non-prim-call ~ret))))))) arg-syms arg-types arg-type-syms)
(let [arg-syms (repeatedly (count arg-types) #(gensym "arg")) (filter some?)))
ret (gensym "ret")
serialize-args (map (fn [sym type] wrap-serialize
(if (s/valid? ::mem/type type) ;; Wrap an expression to shadow args to their serialized counterparts
(if-not (mem/primitive? type) (fn [expr]
(list sym (cond
(if (mem/primitive-type type) (and const-args?
`(mem/serialize* ~sym ~type ~scope) (zero? (count arg-types)))
`(let [alloc# (mem/alloc-instance ~type ~scope)] expr
(mem/serialize-into ~sym ~type alloc# ~scope)
alloc#))) const-args?
(if (primitive-cast-sym type) (if (seq arg-serializers)
(list sym (list (primitive-cast-sym type) sym)) `(let [~@(mapcat identity arg-serializers)]
nil)) ~expr)
(list sym `(mem/serialize ~sym ~type ~scope)))) expr)
arg-syms arg-types)
:else
`(let [~args-sym (map (fn [obj# type#]
(mem/serialize obj# type# ~scope))
~args-sym ~args-types-sym)]
~expr)))
make-call (fn [args & {:keys [allocator?]}]
;; NOTE(Joshua): If `args` is a symbol, that means we're
;; taking restargs, and so the downcall must be applied
(-> `(~@(when (symbol? args) [`apply])
~downcall-sym
~@(when allocator? [`(mem/scope-allocator ~scope)])
~@(if (symbol? args)
[args]
args))
wrap-serialize))
deserialize-prim (fn [expr]
`(mem/deserialize* ~expr ~ret-type-sym))
deserialize-segment (fn [expr]
`(mem/deserialize-from ~expr ~ret-type-sym))
deserialize-ret (fn [expr]
(cond
(or (mem/primitive? ret-type)
(#{::mem/void} ret-type))
expr
(mem/primitive-type ret-type)
(deserialize-prim expr)
:else
(deserialize-segment expr)))
wrap-scope (fn [expr] wrap-scope (fn [expr]
`(with-open [~scope (mem/stack-scope)] `(with-open [~scope (mem/stack-scope)]
~expr)) ~expr))
wrap-serialize (fn [expr] wrap-fn (fn [call needs-scope?]
`(let [~@(mapcat identity serialize-args)] `(fn [~@(if const-args? arg-syms ['& args-sym])]
~expr)) ~(cond-> call needs-scope? wrap-scope)))]
native-fn (fn [expr] `(let [;; NOTE(Joshua): To ensure all arguments are evaluated once and
`(fn ~'native-fn [~@arg-syms] ;; in-order, they must be bound here
~expr)) ~downcall-sym ~downcall
none-to-serialize? (zero? (count (filter some? serialize-args)))] ~@(if const-args?
(cond (mapcat vector arg-type-syms arg-types)
(and none-to-serialize? [args-types-sym arg-types])
primitive-ret?) ~ret-type-sym ~ret-type]
downcall-sym ~(if const-ret?
(-> (make-call (if const-args? arg-syms args-sym)
primitive-ret? :allocator? (not (mem/primitive-type ret-type)))
(-> (cons downcall-sym arg-syms) deserialize-ret
wrap-serialize (wrap-fn (or (not simple-args?)
wrap-scope (not simple-ret?))))
native-fn) (let [prim-call (-> (make-call (if const-args? arg-syms args-sym)
:allocator? false)
:else deserialize-prim)
`(let [~ret ~ret-type] non-prim-call (-> (make-call (if const-args? arg-syms args-sym)
~(let [call (cons downcall-sym arg-syms) :allocator? true)
prim-call `(mem/deserialize* ~call ~ret) deserialize-segment)]
non-prim-call `(mem/deserialize-from ~(list* (first call) `(if (mem/primitive-type ~ret-type-sym)
`(mem/scope-allocator ~scope) ~(wrap-fn prim-call (not simple-args?))
(rest call)) ~(wrap-fn non-prim-call true)))))))))
~ret)]
(cond
(and none-to-serialize?
const-ret?)
(native-fn (if (mem/primitive-type ret-type)
prim-call
(wrap-scope non-prim-call)))
none-to-serialize?
`(if (mem/primitive-type ~ret)
~(native-fn prim-call)
~(native-fn (wrap-scope non-prim-call)))
const-ret?
(native-fn (wrap-serialize
(if (mem/primitive-type ret-type)
prim-call
non-prim-call)))
:else
`(if (mem/primitive-type ~ret)
~(native-fn (wrap-serialize prim-call))
~(native-fn (wrap-serialize non-prim-call))))))))))))
(defn make-serde-wrapper (defn make-serde-wrapper
"Constructs a wrapper function for the `downcall` which serializes the arguments "Constructs a wrapper function for the `downcall` which serializes the arguments