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

Ensure that the downcalls in the inline expansion are evaluated correctly

Browse source
This commit is contained in:
Joshua Suskalo 2021-10-13 15:28:34 -05:00
parent 39d0cd854f
commit a620752f2c
1 changed files with 94 additions and 92 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -252,105 +252,107 @@
[downcall arg-types ret-type] [downcall arg-types ret-type]
(let [const-ret? (s/valid? ::mem/type ret-type) (let [const-ret? (s/valid? ::mem/type ret-type)
primitive-ret? (mem/primitive? ret-type) primitive-ret? (mem/primitive? ret-type)
scope (gensym "scope")] scope (gensym "scope")
(if-not (seqable? arg-types) downcall-sym (gensym "downcall")]
(let [args (gensym "args") `(let [~downcall-sym ~downcall]
ret (gensym "ret") ~(if-not (seqable? arg-types)
serialized-args `(map (fn [arg# type#] (mem/serialize arg# type# ~scope)) ~args ~arg-types) (let [args (gensym "args")
prim-call `(apply ~downcall ~serialized-args) ret (gensym "ret")
non-prim-call `(apply ~downcall (mem/scope-allocator ~scope) ~serialized-args)] serialized-args `(map (fn [arg# type#] (mem/serialize arg# type# ~scope)) ~args ~arg-types)
(cond prim-call `(apply ~downcall-sym ~serialized-args)
(and const-ret? non-prim-call `(apply ~downcall-sym (mem/scope-allocator ~scope) ~serialized-args)]
primitive-ret?) (cond
`(fn ~'native-fn (and const-ret?
[~'& ~args] primitive-ret?)
(with-open [~scope (mem/stack-scope)] `(fn ~'native-fn
~prim-call)) [~'& ~args]
(with-open [~scope (mem/stack-scope)]
~prim-call))
const-ret? const-ret?
`(let [~ret ~ret-type] `(let [~ret ~ret-type]
(fn ~'native-fn (fn ~'native-fn
[~'& ~args] [~'& ~args]
(with-open [~scope (mem/stack-scopee)] (with-open [~scope (mem/stack-scopee)]
~(if (mem/primitive-type ret-type) ~(if (mem/primitive-type ret-type)
`(mem/deserialize* ~prim-call ~ret) `(mem/deserialize* ~prim-call ~ret)
`(mem/deserialize-from ~non-prim-call ~ret))))) `(mem/deserialize-from ~non-prim-call ~ret)))))
:else :else
`(let [~ret ~ret-type] `(let [~ret ~ret-type]
(if (mem/primitive-type ~ret) (if (mem/primitive-type ~ret)
(fn ~'native-fn (fn ~'native-fn
[~'& ~args] [~'& ~args]
(with-open [~scope mem/stack-scope] (with-open [~scope (mem/stack-scope)]
(mem/deserialize* ~prim-call ~ret))) (mem/deserialize* ~prim-call ~ret)))
(fn ~'native-fn (fn ~'native-fn
[~'& ~args] [~'& ~args]
(with-open [~scope mem/stack-scope] (with-open [~scope (mem/stack-scope)]
(mem/deserialize-from ~non-prim-call ~ret))))))) (mem/deserialize-from ~non-prim-call ~ret)))))))
(let [arg-syms (repeatedly (count arg-types) #(gensym "arg")) (let [arg-syms (repeatedly (count arg-types) #(gensym "arg"))
ret (gensym "ret") ret (gensym "ret")
serialize-args (map (fn [sym type] serialize-args (map (fn [sym type]
(if (s/valid? ::mem/type type) (if (s/valid? ::mem/type type)
(if-not (mem/primitive? type) (if-not (mem/primitive? type)
(list sym (list sym
(if (mem/primitive-type type) (if (mem/primitive-type type)
`(mem/serialize* ~sym ~type ~scope) `(mem/serialize* ~sym ~type ~scope)
`(let [alloc# (mem/alloc-instance ~type ~scope)] `(let [alloc# (mem/alloc-instance ~type ~scope)]
(mem/serialize-into ~sym ~type alloc# ~scope) (mem/serialize-into ~sym ~type alloc# ~scope)
alloc#))) alloc#)))
(if (primitive-cast-sym type) (if (primitive-cast-sym type)
(list sym (list (primitive-cast-sym type) sym)) (list sym (list (primitive-cast-sym type) sym))
nil)) nil))
(list sym `(mem/serialize ~sym ~type ~scope)))) (list sym `(mem/serialize ~sym ~type ~scope))))
arg-syms arg-types) arg-syms arg-types)
wrap-serialize (fn [expr] wrap-serialize (fn [expr]
`(with-open [~scope (mem/stack-scope)] `(with-open [~scope (mem/stack-scope)]
(let [~@(mapcat identity serialize-args)] (let [~@(mapcat identity serialize-args)]
~expr))) ~expr)))
native-fn (fn [expr] native-fn (fn [expr]
`(fn ~'native-fn [~@arg-syms] `(fn ~'native-fn [~@arg-syms]
~expr)) ~expr))
none-to-serialize? (zero? (count (filter some? serialize-args)))] none-to-serialize? (zero? (count (filter some? serialize-args)))]
(cond (cond
(and none-to-serialize? (and none-to-serialize?
primitive-ret?) primitive-ret?)
downcall downcall-sym
primitive-ret? primitive-ret?
(-> (cons downcall arg-syms) (-> (cons downcall-sym arg-syms)
wrap-serialize wrap-serialize
native-fn) native-fn)
:else :else
`(let [~ret ~ret-type] `(let [~ret ~ret-type]
~(let [call (cons downcall arg-syms) ~(let [call (cons downcall-sym arg-syms)
prim-call `(mem/deserialize* ~call ~ret) prim-call `(mem/deserialize* ~call ~ret)
non-prim-call `(mem/deserialize-from ~(list* (first call) non-prim-call `(mem/deserialize-from ~(list* (first call)
`(mem/scope-allocator ~scope) `(mem/scope-allocator ~scope)
(rest call)) (rest call))
~ret)] ~ret)]
(cond (cond
(and none-to-serialize? (and none-to-serialize?
const-ret?) const-ret?)
(native-fn (if (mem/primitive-type ret-type) (native-fn (if (mem/primitive-type ret-type)
prim-call prim-call
non-prim-call)) non-prim-call))
none-to-serialize? none-to-serialize?
(if (mem/primitive-type ~ret) (if (mem/primitive-type ~ret)
~(native-fn prim-call) ~(native-fn prim-call)
~(native-fn non-prim-call)) ~(native-fn non-prim-call))
const-ret? const-ret?
(native-fn (wrap-serialize (native-fn (wrap-serialize
(if (mem/primitive-type ret-type) (if (mem/primitive-type ret-type)
prim-call prim-call
non-prim-call))) non-prim-call)))
:else :else
`(if (mem/primitive-type ~ret) `(if (mem/primitive-type ~ret)
~(native-fn (wrap-serialize prim-call)) ~(native-fn (wrap-serialize prim-call))
~(native-fn (wrap-serialize non-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