Separate memory ops into their own ns
This commit is contained in:
Joshua Suskalo
parent
c90f0e0a18
commit
5f96439432
4 changed files with 807 additions and 768 deletions
120
README.md
120
README.md
|
|
@ -42,11 +42,12 @@ In the simplest cases, the native functions you call will work exclusively with
|
|||
built-in types, for example the function `strlen` from libc.
|
||||
|
||||
```clojure
|
||||
(require '[coffi.ffi :as ffi :refer [defcfn defalias]])
|
||||
(require '[coffi.mem :as mem :refer [defalias]])
|
||||
(require '[coffi.ffi :as ffi :refer [defcfn]])
|
||||
|
||||
(defcfn strlen
|
||||
"Given a string, measures its length in bytes."
|
||||
strlen [::ffi/c-string] ::ffi/long)
|
||||
strlen [::mem/c-string] ::mem/long)
|
||||
|
||||
(strlen "hello")
|
||||
;; => 5
|
||||
|
|
@ -61,7 +62,7 @@ If you wish to use a native function as an anonymous function, it can be done
|
|||
with the `cfn` function.
|
||||
|
||||
```clojure
|
||||
((ffi/cfn "strlen" [::ffi/c-string] ::ffi/long) "hello")
|
||||
((ffi/cfn "strlen" [::mem/c-string] ::mem/long) "hello")
|
||||
;; => 5
|
||||
```
|
||||
|
||||
|
|
@ -134,7 +135,7 @@ The corresponding coffi definition is like so:
|
|||
|
||||
```clojure
|
||||
(defcfn zero-point
|
||||
"zero" [] [::ffi/struct [[:x ::ffi/float] [:y ::ffi/float]]])
|
||||
"zero" [] [::mem/struct [[:x ::mem/float] [:y ::mem/float]]])
|
||||
|
||||
(zero-point)
|
||||
;; => {:x 0.0,
|
||||
|
|
@ -146,9 +147,9 @@ macro `defalias` is used to define a struct alias.
|
|||
|
||||
```clojure
|
||||
(defalias ::point
|
||||
[::ffi/struct
|
||||
[[:x ::ffi/float]
|
||||
[:y ::ffi/float]]])
|
||||
[::mem/struct
|
||||
[[:x ::mem/float]
|
||||
[:y ::mem/float]]])
|
||||
|
||||
(defcfn zero-point
|
||||
"zero" [] ::point)
|
||||
|
|
@ -159,7 +160,7 @@ native function, but dosn't need to be read back in, the `pointer` primitive
|
|||
type can take a type argument.
|
||||
|
||||
```clojure
|
||||
[::ffi/pointer ::ffi/int]
|
||||
[::mem/pointer ::mem/int]
|
||||
```
|
||||
|
||||
Arrays are also supported via a type argument. Keep in mind that they are the
|
||||
|
|
@ -167,7 +168,7 @@ array itself, and not a pointer to the array like you might see in certain cases
|
|||
in C.
|
||||
|
||||
```clojure
|
||||
[::ffi/array ::ffi/int 3]
|
||||
[::mem/array ::mem/int 3]
|
||||
```
|
||||
|
||||
### Callbacks
|
||||
|
|
@ -175,7 +176,7 @@ In addition to these composite types, there is also support for Clojure
|
|||
functions.
|
||||
|
||||
```clojure
|
||||
[::ffi/fn [::ffi/c-string] ::ffi/int]
|
||||
[::ffi/fn [::mem/c-string] ::mem/int]
|
||||
```
|
||||
|
||||
Be aware though that if an exception is thrown out of a callback that is called
|
||||
|
|
@ -189,14 +190,14 @@ Some native functions can take any number of arguments, and in these cases coffi
|
|||
provides `vacfn-factory` (for "varargs C function factory").
|
||||
|
||||
```clojure
|
||||
(def printf-factory (ffi/vacfn-factory "printf" [::ffi/c-string] ::ffi/int))
|
||||
(def printf-factory (ffi/vacfn-factory "printf" [::mem/c-string] ::mem/int))
|
||||
```
|
||||
|
||||
This returns a function of the types of the rest of the arguments which itself
|
||||
returns a native function wrapper.
|
||||
|
||||
```clojure
|
||||
(def print-int (printf-factory ::ffi/int))
|
||||
(def print-int (printf-factory ::mem/int))
|
||||
|
||||
(print-int "Some integer: %d\n" 5)
|
||||
;; Some integer: 5
|
||||
|
|
@ -213,7 +214,7 @@ Some libraries include global variables or constants accessible through symbols.
|
|||
To start with, constant values stored in symbols can be fetched with `const`
|
||||
|
||||
```clojure
|
||||
(def some-const (ffi/const "some_const" ::ffi/int))
|
||||
(def some-const (ffi/const "some_const" ::mem/int))
|
||||
```
|
||||
|
||||
This value is fetched once when you call `const` and is turned into a Clojure
|
||||
|
|
@ -221,7 +222,7 @@ value. If you need to refer to a global variable, then `static-variable` can be
|
|||
used to create a reference to the native value.
|
||||
|
||||
```clojure
|
||||
(def some-var (ffi/static-variable "some_var" ::ffi/int))
|
||||
(def some-var (ffi/static-variable "some_var" ::mem/int))
|
||||
```
|
||||
|
||||
This variable is an `IDeref`. Each time you dereference it, the value will be
|
||||
|
|
@ -249,12 +250,12 @@ Clojure code to make this easier.
|
|||
|
||||
```clojure
|
||||
(defcfn takes-array
|
||||
"takes_array_with_count" [::ffi/pointer ::ffi/long] ::ffi/void
|
||||
"takes_array_with_count" [::mem/pointer ::mem/long] ::mem/void
|
||||
native-fn
|
||||
[ints]
|
||||
(let [arr-len (count ints)
|
||||
int-array (serialize ints [::ffi/array ::ffi/int arr-len]
|
||||
(native-fn (ffi/address-of int-array) arr-len))]))
|
||||
int-array (serialize ints [::mem/array ::mem/int arr-len]
|
||||
(native-fn (mem/address-of int-array) arr-len))]))
|
||||
```
|
||||
|
||||
The symbol `native-fn` can be any unqualified symbol, and names the native
|
||||
|
|
@ -268,17 +269,17 @@ This can be used to implement out variables often seen in native code.
|
|||
|
||||
```clojure
|
||||
(defcfn out-int
|
||||
"out_int" [::ffi/pointer] ::ffi/void
|
||||
"out_int" [::mem/pointer] ::mem/void
|
||||
native-fn
|
||||
[i]
|
||||
(let [int-ptr (serialize i [::ffi/pointer ::ffi/int])]
|
||||
(let [int-ptr (serialize i [::mem/pointer ::mem/int])]
|
||||
(native-fn int-ptr)
|
||||
(deserialize int-ptr [::ffi/pointer ::ffi/int])))
|
||||
(deserialize int-ptr [::mem/pointer ::mem/int])))
|
||||
```
|
||||
|
||||
### Scopes
|
||||
In order to serialize any non-primitive type (such as the previous
|
||||
`[::ffi/pointer ::ffi/int]`), off-heap memory needs to be allocated. When memory
|
||||
`[::mem/pointer ::mem/int]`), off-heap memory needs to be allocated. When memory
|
||||
is allocated inside the JVM, the memory is associated with a scope. Because none
|
||||
was provided here, the scope is an implicit scope, and the memory will be freed
|
||||
when the serialized object is garbage collected.
|
||||
|
|
@ -294,13 +295,13 @@ stack scope.
|
|||
|
||||
```clojure
|
||||
(defcfn out-int
|
||||
"out_int" [::ffi/pointer] ::ffi/void
|
||||
"out_int" [::mem/pointer] ::mem/void
|
||||
native-fn
|
||||
[i]
|
||||
(with-open [scope (ffi/stack-scope)]
|
||||
(let [int-ptr (ffi/serialize i [::ffi/pointer ::ffi/int] scope)]
|
||||
(with-open [scope (mem/stack-scope)]
|
||||
(let [int-ptr (mem/serialize i [::mem/pointer ::mem/int] scope)]
|
||||
(native-fn int-ptr)
|
||||
(ffi/deserialize int-ptr [::ffi/pointer ::ffi/int]))))
|
||||
(mem/deserialize int-ptr [::mem/pointer ::mem/int]))))
|
||||
```
|
||||
|
||||
This will free the pointer immediately upon leaving the function.
|
||||
|
|
@ -330,9 +331,9 @@ The multimethod `primitive-type` returns the primitive type that a given type
|
|||
serializes to. For this example, it should be a pointer.
|
||||
|
||||
```clojure
|
||||
(defmethod ffi/primitive-type ::vector
|
||||
(defmethod mem/primitive-type ::vector
|
||||
[_type]
|
||||
::ffi/pointer)
|
||||
::mem/pointer)
|
||||
```
|
||||
|
||||
For any type which doesn't serialize to a primitive, it returns nil, and
|
||||
|
|
@ -342,14 +343,14 @@ Next is `serialize*` and `deserialize*`, multimethods that work with types that
|
|||
serialize to primitives.
|
||||
|
||||
```clojure
|
||||
(defmethod ffi/serialize* ::vector
|
||||
(defmethod mem/serialize* ::vector
|
||||
[obj _type scope]
|
||||
(ffi/address-of (ffi/serialize obj [::ffi/array ::ffi/float 3] scope)))
|
||||
(mem/address-of (mem/serialize obj [::mem/array ::mem/float 3] scope)))
|
||||
|
||||
(defmethod ffi/deserialize* ::vector
|
||||
(defmethod mem/deserialize* ::vector
|
||||
[addr _type]
|
||||
(ffi/deserialize (ffi/slice-global addr (ffi/size-of [::ffi/array ::ffi/float 3]))
|
||||
[::ffi/array ::ffi/float 3]))
|
||||
(mem/deserialize (mem/slice-global addr (mem/size-of [::mem/array ::mem/float 3]))
|
||||
[::mem/array ::mem/float 3]))
|
||||
```
|
||||
|
||||
The `slice-global` function allows you to take an address without an associated
|
||||
|
|
@ -361,7 +362,7 @@ function that takes a pointer exists, we could use this:
|
|||
|
||||
```clojure
|
||||
(defcfn returns-vector
|
||||
"returns_vector" [] ::ffi/pointer
|
||||
"returns_vector" [] ::mem/pointer
|
||||
native-fn
|
||||
[scope]
|
||||
(let [ret-ptr (native-fn)]
|
||||
|
|
@ -387,7 +388,7 @@ To represent this, we can have a `tagged-union` type. For this instance of the
|
|||
result type, it may look like this:
|
||||
|
||||
```clojure
|
||||
[::tagged-union [:ok :err] {:ok ::ffi/int :err ::ffi/c-string}]
|
||||
[::tagged-union [:ok :err] {:ok ::mem/int :err ::mem/c-string}]
|
||||
```
|
||||
|
||||
The native representation of these objects is a struct of the tag and a union of
|
||||
|
|
@ -396,11 +397,11 @@ we need a representation of the native layout of the data. The `c-layout`
|
|||
multimethod provides that.
|
||||
|
||||
```clojure
|
||||
(defmethod ffi/c-layout ::tagged-union
|
||||
(defmethod mem/c-layout ::tagged-union
|
||||
[[_tagged-union tags type-map]]
|
||||
(ffi/c-layout [::ffi/struct
|
||||
[[:tag ::ffi/long]
|
||||
[:value [::ffi/union (vals type-map)]]]]))
|
||||
(mem/c-layout [::mem/struct
|
||||
[[:tag ::mem/long]
|
||||
[:value [::mem/union (vals type-map)]]]]))
|
||||
```
|
||||
|
||||
Types with type arguments are represented as vectors of the type name and any
|
||||
|
|
@ -421,13 +422,13 @@ deserialize the value into and out of memory segments. This is accomplished with
|
|||
(filter (comp #{item} second))
|
||||
(map first))))
|
||||
|
||||
(defmethod ffi/serialize-into ::tagged-union
|
||||
(defmethod mem/serialize-into ::tagged-union
|
||||
[obj [_tagged-union tags type-map] segment scope]
|
||||
(ffi/serialize-into
|
||||
(mem/serialize-into
|
||||
{:tag (item-index tags (first obj))
|
||||
:value (second obj)}
|
||||
[::ffi/struct
|
||||
[[:tag ::ffi/long]
|
||||
[::mem/struct
|
||||
[[:tag ::mem/long]
|
||||
[:value (get type-map (first obj))]]]
|
||||
segment
|
||||
scope))
|
||||
|
|
@ -438,12 +439,12 @@ a map, and serializes it as a struct, choosing the type of the value based on
|
|||
the tag.
|
||||
|
||||
```clojure
|
||||
(defmethod ffi/deserialize-from ::tagged-union
|
||||
(defmethod mem/deserialize-from ::tagged-union
|
||||
[segment [_tagged-union tags type-map]]
|
||||
(let [tag (ffi/deserialize-from segment ::ffi/long)]
|
||||
(let [tag (mem/deserialize-from segment ::mem/long)]
|
||||
[(nth tags tag)
|
||||
(ffi/deserialize-from
|
||||
(ffi/slice segment (ffi/size-of ::ffi/long))
|
||||
(mem/deserialize-from
|
||||
(mem/slice segment (mem/size-of ::mem/long))
|
||||
(get type-map tag))]))
|
||||
```
|
||||
|
||||
|
|
@ -459,11 +460,11 @@ is rather limited. It can be serialized, but not deserialized without external
|
|||
information.
|
||||
|
||||
```clojure
|
||||
[::ffi/union
|
||||
#{::ffi/float ::ffi/double}
|
||||
[::mem/union
|
||||
#{::mem/float ::mem/double}
|
||||
:dispatch #(cond
|
||||
(float? %) ::ffi/float
|
||||
(double? %) ::ffi/double)]
|
||||
(float? %) ::mem/float
|
||||
(double? %) ::mem/double)]
|
||||
```
|
||||
|
||||
This is a minimal union in coffi. If the `:dispatch` keyword argument is not
|
||||
|
|
@ -476,11 +477,11 @@ may also be provided. In the case of the value in the tagged union from before,
|
|||
it could be represented for serialization purposes like so:
|
||||
|
||||
```clojure
|
||||
[::ffi/union
|
||||
#{::ffi/int ::ffi/c-string}
|
||||
[::mem/union
|
||||
#{::mem/int ::mem/c-string}
|
||||
:dispatch #(case (first %)
|
||||
:ok ::ffi/int
|
||||
:err ::ffi/c-string)
|
||||
:ok ::mem/int
|
||||
:err ::mem/c-string)
|
||||
:extract second]
|
||||
```
|
||||
|
||||
|
|
@ -501,8 +502,8 @@ The functions `make-downcall` and `make-varargs-factory` are provided to create
|
|||
these raw handles.
|
||||
|
||||
```clojure
|
||||
(def raw-strlen (ffi/make-downcall "strlen" [::ffi/c-string] ::ffi/long))
|
||||
(raw-strlen (ffi/serialize "hello" ::ffi/c-string))
|
||||
(def raw-strlen (ffi/make-downcall "strlen" [::mem/c-string] ::mem/long))
|
||||
(raw-strlen (mem/serialize "hello" ::mem/c-string))
|
||||
;; => 5
|
||||
```
|
||||
|
||||
|
|
@ -521,7 +522,7 @@ In addition, function types can be specified as being raw, in the following
|
|||
manner:
|
||||
|
||||
```clojure
|
||||
[::ffi/fn [::ffi/int] ::ffi/int :raw-fn? true]
|
||||
[::ffi/fn [::mem/int] ::mem/int :raw-fn? true]
|
||||
```
|
||||
|
||||
Clojure functions serialized to this type will have their arguments and return
|
||||
|
|
@ -541,8 +542,8 @@ The data to represent an API is a map with the following form:
|
|||
(def strlen-libspec
|
||||
{:strlen {:type :function
|
||||
:symbol "strlen"
|
||||
:function/args [::ffi/c-string]
|
||||
:function/ret ::ffi/long}})
|
||||
:function/args [::mem/c-string]
|
||||
:function/ret ::mem/long}})
|
||||
```
|
||||
|
||||
Each key in this map represents a single symbol to be loaded. The value is a map
|
||||
|
|
@ -585,6 +586,7 @@ These features are planned for future releases.
|
|||
- Support for va_args type
|
||||
- Functions for wrapping structs in padding following various standards
|
||||
- Header parsing tool for generating a data model?
|
||||
- Generic type aliases
|
||||
|
||||
## License
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
(:require
|
||||
[clojure.java.io :as io]
|
||||
[clojure.spec.alpha :as s]
|
||||
[coffi.mem :as mem]
|
||||
[insn.core :as insn])
|
||||
(:import
|
||||
(clojure.lang
|
||||
|
|
@ -18,589 +19,9 @@
|
|||
Addressable
|
||||
CLinker
|
||||
FunctionDescriptor
|
||||
MemoryAccess
|
||||
MemoryAddress
|
||||
MemoryLayout
|
||||
MemorySegment
|
||||
ResourceScope
|
||||
SegmentAllocator)))
|
||||
|
||||
(defn stack-scope
|
||||
"Constructs a new scope for use only in this thread.
|
||||
|
||||
The memory allocated within this scope is cheap to allocate, like a native
|
||||
stack."
|
||||
^ResourceScope []
|
||||
(ResourceScope/newConfinedScope))
|
||||
|
||||
(defn shared-scope
|
||||
"Constructs a new shared scope.
|
||||
|
||||
This scope can be shared across threads and memory allocated in it will only
|
||||
be cleaned up once every thread accessing the scope closes it."
|
||||
^ResourceScope []
|
||||
(ResourceScope/newSharedScope))
|
||||
|
||||
(defn connected-scope
|
||||
"Constructs a new scope to reclaim all connected resources at once.
|
||||
|
||||
The scope may be shared across threads, and all resources created with it will
|
||||
be cleaned up at the same time, when all references have been collected.
|
||||
|
||||
This type of scope cannot be closed, and therefore should not be created in
|
||||
a [[with-open]] clause."
|
||||
^ResourceScope []
|
||||
(ResourceScope/newImplicitScope))
|
||||
|
||||
(defn global-scope
|
||||
"Constructs the global scope, which will never reclaim its resources.
|
||||
|
||||
This scope may be shared across threads, but is intended mainly in cases where
|
||||
memory is allocated with [[alloc]] but is either never freed or whose
|
||||
management is relinquished to a native library, such as when returned from a
|
||||
callback."
|
||||
^ResourceScope []
|
||||
(ResourceScope/globalScope))
|
||||
|
||||
(defn scope-allocator
|
||||
"Constructs a segment allocator from the given `scope`.
|
||||
|
||||
This is primarily used when working with unwrapped downcall functions. When a
|
||||
downcall function returns a non-primitive type, it must be provided with an
|
||||
allocator."
|
||||
^SegmentAllocator [^ResourceScope scope]
|
||||
(SegmentAllocator/ofScope scope))
|
||||
|
||||
(defn alloc
|
||||
"Allocates `size` bytes.
|
||||
|
||||
If a `scope` is provided, the allocation will be reclaimed when it is closed."
|
||||
([size] (alloc size (connected-scope)))
|
||||
([size scope] (MemorySegment/allocateNative (long size) ^ResourceScope scope)))
|
||||
|
||||
(defn alloc-with
|
||||
"Allocates `size` bytes using the `allocator`."
|
||||
([allocator size]
|
||||
(.allocate ^SegmentAllocator allocator (long size)))
|
||||
([allocator size alignment]
|
||||
(.allocate ^SegmentAllocator allocator (long size) (long alignment))))
|
||||
|
||||
(defmacro with-acquired
|
||||
"Acquires a `scope` to ensure it will not be released until the `body` completes.
|
||||
|
||||
This is only necessary to do on shared scopes, however if you are operating on
|
||||
an arbitrary passed scope, it is best practice to wrap code that interacts
|
||||
with it wrapped in this."
|
||||
[scope & body]
|
||||
`(let [scope# ~scope
|
||||
handle# (.acquire ^ResourceScope scope#)]
|
||||
(try ~@body
|
||||
(finally (.release ^ResourceScope scope# handle#)))))
|
||||
|
||||
(defn address-of
|
||||
"Gets the address of a given segment.
|
||||
|
||||
This value can be used as an argument to functions which take a pointer."
|
||||
[addressable]
|
||||
(.address ^Addressable addressable))
|
||||
|
||||
(defn null?
|
||||
"Checks if a memory address is null."
|
||||
[addr]
|
||||
(.equals (MemoryAddress/NULL) addr))
|
||||
|
||||
(defn slice-global
|
||||
"Gets a slice of the global address space.
|
||||
|
||||
Because this fetches from the global segment, it has no associated scope, and
|
||||
therefore the reference created here cannot prevent the value from being
|
||||
freed. Be careful to ensure that you are not retaining an object incorrectly."
|
||||
[address size]
|
||||
(.asSlice (MemorySegment/globalNativeSegment)
|
||||
^MemoryAddress address (long size)))
|
||||
|
||||
(defn slice
|
||||
"Get a slice over the `segment` with the given `offset`."
|
||||
([segment offset]
|
||||
(.asSlice ^MemorySegment segment (long offset)))
|
||||
([segment offset size]
|
||||
(.asSlice ^MemorySegment segment (long offset) (long size))))
|
||||
|
||||
(defn slice-into
|
||||
"Get a slice into the `segment` starting at the `address`."
|
||||
([address segment]
|
||||
(.asSlice ^MemorySegment segment ^MemoryAddress address))
|
||||
([address segment size]
|
||||
(.asSlice ^MemorySegment segment ^MemoryAddress address (long size))))
|
||||
|
||||
(defn with-offset
|
||||
"Get a new address `offset` from the old `address`."
|
||||
[address offset]
|
||||
(.addOffset ^MemoryAddress address (long offset)))
|
||||
|
||||
(defn as-segment
|
||||
"Dereferences an `address` into a memory segment associated with the `scope`.
|
||||
|
||||
If `cleanup` is provided, it is a 0-arity function run when the scope is
|
||||
closed. This can be used to register a free method for the memory, or do other
|
||||
cleanup in a way that doesn't require modifying the code at the point of
|
||||
freeing, and allows shared or garbage collected resources to be freed
|
||||
correctly."
|
||||
([address size scope]
|
||||
(.asSegment ^MemoryAddress address size scope))
|
||||
([address size scope cleanup]
|
||||
(.asSegment ^MemoryAddress address size cleanup scope)))
|
||||
|
||||
(defn add-close-action!
|
||||
"Adds a 0-arity function to be run when the `scope` closes."
|
||||
[scope action]
|
||||
(.addCloseAction ^ResourceScope scope action))
|
||||
|
||||
(defn copy-segment
|
||||
"Copies the content to `dest` from `src`"
|
||||
[dest src]
|
||||
(.copyFrom ^MemorySegment dest ^MemorySegment src))
|
||||
|
||||
(defn clone-segment
|
||||
"Clones the content of `segment` into a new segment of the same size."
|
||||
([segment] (clone-segment segment (connected-scope)))
|
||||
([segment scope]
|
||||
(doto ^MemorySegment (alloc (.byteSize ^MemorySegment segment) scope)
|
||||
(copy-segment segment))))
|
||||
|
||||
(defn slice-segments
|
||||
"Constructs a lazy seq of `size`-length memory segments, sliced from `segment`."
|
||||
[segment size]
|
||||
(let [num-segments (quot (.byteSize ^MemorySegment segment) size)]
|
||||
(map #(slice segment (* % size) size)
|
||||
(range num-segments))))
|
||||
|
||||
(def primitive-types
|
||||
"A set of keywords representing all the primitive types which may be passed to
|
||||
or returned from native functions."
|
||||
#{::byte ::short ::int ::long ::long-long
|
||||
::char
|
||||
::float ::double
|
||||
::pointer ::void})
|
||||
|
||||
(defn- type-dispatch
|
||||
"Gets a type dispatch value from a (potentially composite) type."
|
||||
[type]
|
||||
(cond
|
||||
(qualified-keyword? type) type
|
||||
(sequential? type) (keyword (first type))))
|
||||
|
||||
(defmulti primitive-type
|
||||
"Gets the primitive type that is used to pass as an argument for the `type`.
|
||||
|
||||
This is for objects which are passed to native functions as primitive types,
|
||||
but which need additional logic to be performed during serialization and
|
||||
deserialization.
|
||||
|
||||
Returns nil for any type which does not have a primitive representation."
|
||||
type-dispatch)
|
||||
|
||||
(defmethod primitive-type :default
|
||||
[type]
|
||||
(primitive-types type))
|
||||
|
||||
(defmethod primitive-type ::pointer
|
||||
[_type]
|
||||
::pointer)
|
||||
|
||||
(def c-prim-layout
|
||||
"Map of primitive type names to the [[CLinker]] types for a method handle."
|
||||
{::byte CLinker/C_CHAR
|
||||
::short CLinker/C_SHORT
|
||||
::int CLinker/C_INT
|
||||
::long CLinker/C_LONG
|
||||
::long-long CLinker/C_LONG_LONG
|
||||
::char CLinker/C_CHAR
|
||||
::float CLinker/C_FLOAT
|
||||
::double CLinker/C_DOUBLE
|
||||
::pointer CLinker/C_POINTER})
|
||||
|
||||
(defmulti c-layout
|
||||
"Gets the layout object for a given `type`.
|
||||
|
||||
If a type is primitive it will return the appropriate primitive
|
||||
layout (see [[c-prim-layout]]).
|
||||
|
||||
Otherwise, it should return a [[GroupLayout]] for the given type."
|
||||
type-dispatch)
|
||||
|
||||
(defmethod c-layout :default
|
||||
[type]
|
||||
(c-prim-layout (or (primitive-type type) type)))
|
||||
|
||||
(def java-prim-layout
|
||||
"Map of primitive type names to the Java types for a method handle."
|
||||
{::byte Byte/TYPE
|
||||
::short Short/TYPE
|
||||
::int Integer/TYPE
|
||||
::long Long/TYPE
|
||||
::long-long Long/TYPE
|
||||
::char Byte/TYPE
|
||||
::float Float/TYPE
|
||||
::double Double/TYPE
|
||||
::pointer MemoryAddress
|
||||
::void Void/TYPE})
|
||||
|
||||
(defn java-layout
|
||||
"Gets the Java class to an argument of this type for a method handle.
|
||||
|
||||
If a type serializes to a primitive it returns return a Java primitive type.
|
||||
Otherwise, it returns [[MemorySegment]]."
|
||||
[type]
|
||||
(java-prim-layout (or (primitive-type type) type) MemorySegment))
|
||||
|
||||
(defn size-of
|
||||
"The size in bytes of the given `type`."
|
||||
[type]
|
||||
(.byteSize ^MemoryLayout (c-layout type)))
|
||||
|
||||
(defn alloc-instance
|
||||
"Allocates a memory segment for the given `type`."
|
||||
([type] (alloc-instance type (connected-scope)))
|
||||
([type scope] (MemorySegment/allocateNative (long (size-of type)) ^ResourceScope scope)))
|
||||
|
||||
(declare serialize serialize-into)
|
||||
|
||||
(defmulti serialize*
|
||||
"Constructs a serialized version of the `obj` and returns it.
|
||||
|
||||
Any new allocations made during the serialization should be tied to the given
|
||||
`scope`, except in extenuating circumstances.
|
||||
|
||||
This method should only be implemented for types that serialize to primitives."
|
||||
(fn
|
||||
#_{:clj-kondo/ignore [:unused-binding]}
|
||||
[obj type scope]
|
||||
(type-dispatch type)))
|
||||
|
||||
(def ^:private primitive-cast
|
||||
"Map from primitive type names to the function to cast it to a primitive."
|
||||
{::byte byte
|
||||
::short short
|
||||
::int int
|
||||
::long long
|
||||
::long-long long
|
||||
::char char
|
||||
::float float
|
||||
::double double})
|
||||
|
||||
(defmethod serialize* :default
|
||||
[obj type _scope]
|
||||
(if-let [prim (primitive-type type)]
|
||||
((primitive-cast prim) obj)
|
||||
(throw (ex-info "Attempted to serialize a non-primitive type with primitive methods"
|
||||
{:type type
|
||||
:object obj}))))
|
||||
|
||||
(defmethod serialize* ::pointer
|
||||
[obj type scope]
|
||||
(when-not (null? obj)
|
||||
(if (sequential? type)
|
||||
(let [segment (alloc-instance (second type) scope)]
|
||||
(serialize-into obj (second type) segment scope)
|
||||
(address-of segment))
|
||||
obj)))
|
||||
|
||||
(defmulti serialize-into
|
||||
"Writes a serialized version of the `obj` to the given `segment`.
|
||||
|
||||
Any new allocations made during the serialization should be tied to the given
|
||||
`scope`, except in extenuating circumstances.
|
||||
|
||||
This method should be implemented for any type which does not
|
||||
override [[c-layout]].
|
||||
|
||||
For any other type, this will serialize it as [[serialize*]] before writing
|
||||
the result value into the `segment`."
|
||||
(fn
|
||||
#_{:clj-kondo/ignore [:unused-binding]}
|
||||
[obj type segment scope]
|
||||
(type-dispatch type)))
|
||||
|
||||
(defmethod serialize-into :default
|
||||
[obj type segment scope]
|
||||
(if-some [prim-layout (primitive-type type)]
|
||||
(serialize-into (serialize* obj type scope) prim-layout segment scope)
|
||||
(throw (ex-info "Attempted to serialize an object to a type that has not been overriden"
|
||||
{:type type
|
||||
:object obj}))))
|
||||
|
||||
(defmethod serialize-into ::byte
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setByte segment (byte obj)))
|
||||
|
||||
(defmethod serialize-into ::short
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setShort segment (short obj)))
|
||||
|
||||
(defmethod serialize-into ::int
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setInt segment (int obj)))
|
||||
|
||||
(defmethod serialize-into ::long
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setLong segment (long obj)))
|
||||
|
||||
(defmethod serialize-into ::long-long
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setLong segment (long obj)))
|
||||
|
||||
(defmethod serialize-into ::char
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setChar segment (char obj)))
|
||||
|
||||
(defmethod serialize-into ::float
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setFloat segment (float obj)))
|
||||
|
||||
(defmethod serialize-into ::double
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setDouble segment (double obj)))
|
||||
|
||||
(defmethod serialize-into ::pointer
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setAddress segment obj))
|
||||
|
||||
(defn serialize
|
||||
"Serializes an arbitrary type.
|
||||
|
||||
For types which have a primitive representation, this serializes into that
|
||||
representation. For types which do not, it allocates a new segment and
|
||||
serializes into that."
|
||||
([obj type] (serialize obj type (connected-scope)))
|
||||
([obj type scope]
|
||||
(if (primitive-type type)
|
||||
(serialize* obj type scope)
|
||||
(let [segment (alloc-instance type scope)]
|
||||
(serialize-into obj type segment scope)
|
||||
segment))))
|
||||
|
||||
(declare deserialize deserialize*)
|
||||
|
||||
(defmulti deserialize-from
|
||||
"Deserializes the given segment into a Clojure data structure.
|
||||
|
||||
For types that serialize to primitives, a default implementation will
|
||||
deserialize the primitive before calling [[deserialize*]]."
|
||||
(fn
|
||||
#_{:clj-kondo/ignore [:unused-binding]}
|
||||
[segment type]
|
||||
(type-dispatch type)))
|
||||
|
||||
(defmethod deserialize-from :default
|
||||
[segment type]
|
||||
(if-some [prim (primitive-type type)]
|
||||
(-> segment
|
||||
(deserialize-from prim)
|
||||
(deserialize* type))
|
||||
(throw (ex-info "Attempted to deserialize a non-primitive type that has not been overriden"
|
||||
{:type type
|
||||
:segment segment}))))
|
||||
|
||||
(defmethod deserialize-from ::byte
|
||||
[segment _type]
|
||||
(MemoryAccess/getByte segment))
|
||||
|
||||
(defmethod deserialize-from ::short
|
||||
[segment _type]
|
||||
(MemoryAccess/getShort segment))
|
||||
|
||||
(defmethod deserialize-from ::int
|
||||
[segment _type]
|
||||
(MemoryAccess/getInt segment))
|
||||
|
||||
(defmethod deserialize-from ::long
|
||||
[segment _type]
|
||||
(MemoryAccess/getLong segment))
|
||||
|
||||
(defmethod deserialize-from ::long-long
|
||||
[segment _type]
|
||||
(MemoryAccess/getLong segment))
|
||||
|
||||
(defmethod deserialize-from ::char
|
||||
[segment _type]
|
||||
(MemoryAccess/getChar segment))
|
||||
|
||||
(defmethod deserialize-from ::float
|
||||
[segment _type]
|
||||
(MemoryAccess/getFloat segment))
|
||||
|
||||
(defmethod deserialize-from ::double
|
||||
[segment _type]
|
||||
(MemoryAccess/getDouble segment))
|
||||
|
||||
(defmethod deserialize-from ::pointer
|
||||
[segment type]
|
||||
(cond-> (MemoryAccess/getAddress segment)
|
||||
(sequential? type) (deserialize* type)))
|
||||
|
||||
(defmulti deserialize*
|
||||
"Deserializes a primitive object into a Clojure data structure.
|
||||
|
||||
This is intended for use with types that are returned as a primitive but which
|
||||
need additional processing before they can be returned."
|
||||
(fn
|
||||
#_{:clj-kondo/ignore [:unused-binding]}
|
||||
[obj type]
|
||||
(type-dispatch type)))
|
||||
|
||||
(defmethod deserialize* :default
|
||||
[obj type]
|
||||
(if (primitive-type type)
|
||||
obj
|
||||
(throw (ex-info "Attempted to deserialize a non-primitive type with primitive methods"
|
||||
{:type type
|
||||
:segment obj}))))
|
||||
|
||||
(defmethod deserialize* ::pointer
|
||||
[addr type]
|
||||
(when-not (null? addr)
|
||||
(if (sequential? type)
|
||||
(deserialize-from (slice-global addr (size-of (second type)))
|
||||
(second type))
|
||||
addr)))
|
||||
|
||||
(defn deserialize
|
||||
"Deserializes an arbitrary type.
|
||||
|
||||
For types which have a primitive representation, this deserializes the
|
||||
primitive representation. For types which do not, this deserializes out of
|
||||
a segment."
|
||||
[obj type]
|
||||
(when-not (identical? ::void type)
|
||||
((if (primitive-type type)
|
||||
deserialize*
|
||||
deserialize-from)
|
||||
obj type)))
|
||||
|
||||
(defn seq-of
|
||||
"Constructs a lazy sequence of `type` elements deserialized from `segment`."
|
||||
[type segment]
|
||||
(map #(deserialize % type) (slice-segments segment (size-of type))))
|
||||
|
||||
;;; C String type
|
||||
|
||||
(defmethod primitive-type ::c-string
|
||||
[_type]
|
||||
::pointer)
|
||||
|
||||
(defmethod serialize* ::c-string
|
||||
[obj _type scope]
|
||||
(if obj
|
||||
(address-of (CLinker/toCString ^String obj ^ResourceScope scope))
|
||||
(MemoryAddress/NULL)))
|
||||
|
||||
(defmethod deserialize* ::c-string
|
||||
[addr _type]
|
||||
(when-not (null? addr)
|
||||
(CLinker/toJavaString ^MemoryAddress addr)))
|
||||
|
||||
;;; Union types
|
||||
|
||||
(defmethod c-layout ::union
|
||||
[[_union types & {:as _opts} :as _type]]
|
||||
(let [items (map c-layout types)]
|
||||
(MemoryLayout/unionLayout
|
||||
(into-array MemoryLayout items))))
|
||||
|
||||
(defmethod serialize-into ::union
|
||||
[obj [_union _types & {:keys [dispatch extract]} :as type] segment scope]
|
||||
(when-not dispatch
|
||||
(throw (ex-info "Attempted to serialize a union with no dispatch function"
|
||||
{:type type
|
||||
:value obj})))
|
||||
(let [type (dispatch obj)]
|
||||
(serialize-into
|
||||
(if extract
|
||||
(extract type obj)
|
||||
obj)
|
||||
type
|
||||
segment
|
||||
scope)))
|
||||
|
||||
(defmethod deserialize-from ::union
|
||||
[segment type]
|
||||
(clone-segment (slice segment 0 (size-of type))))
|
||||
|
||||
;;; Struct types
|
||||
|
||||
(defmethod c-layout ::struct
|
||||
[[_struct fields]]
|
||||
(let [fields (for [[field-name field] fields]
|
||||
(.withName ^MemoryLayout (c-layout field)
|
||||
(name field-name)))]
|
||||
(MemoryLayout/structLayout
|
||||
(into-array MemoryLayout fields))))
|
||||
|
||||
(defmethod serialize-into ::struct
|
||||
[obj [_struct fields] segment scope]
|
||||
(loop [offset 0
|
||||
fields fields]
|
||||
(when (seq fields)
|
||||
(let [[field type] (first fields)
|
||||
size (size-of type)]
|
||||
(serialize-into
|
||||
(get obj field) type
|
||||
(slice segment offset size) scope)
|
||||
(recur (long (+ offset size)) (rest fields))))))
|
||||
|
||||
(defmethod deserialize-from ::struct
|
||||
[segment [_struct fields]]
|
||||
(loop [offset 0
|
||||
fields fields
|
||||
obj {}]
|
||||
(if (seq fields)
|
||||
(let [[field type] (first fields)
|
||||
size (size-of type)]
|
||||
(recur
|
||||
(long (+ offset size))
|
||||
(rest fields)
|
||||
(assoc obj field (deserialize-from
|
||||
(slice segment offset size)
|
||||
type))))
|
||||
obj)))
|
||||
|
||||
;;; Padding type
|
||||
|
||||
(defmethod c-layout ::padding
|
||||
[[_padding size]]
|
||||
(MemoryLayout/paddingLayout (* 8 size)))
|
||||
|
||||
(defmethod serialize-into ::padding
|
||||
[_obj [_padding _size] _segment _scope]
|
||||
nil)
|
||||
|
||||
(defmethod deserialize-from ::padding
|
||||
[_segment [_padding _size]]
|
||||
nil)
|
||||
|
||||
;;; Array types
|
||||
|
||||
(defmethod c-layout ::array
|
||||
[[_array type count]]
|
||||
(MemoryLayout/sequenceLayout
|
||||
count
|
||||
(c-layout type)))
|
||||
|
||||
(defmethod serialize-into ::array
|
||||
[obj [_array type count] segment scope]
|
||||
(dorun
|
||||
(map #(serialize-into %1 type %2 scope)
|
||||
obj
|
||||
(slice-segments (slice segment 0 (* count (size-of type)))
|
||||
(size-of type)))))
|
||||
|
||||
(defmethod deserialize-from ::array
|
||||
[segment [_array type count]]
|
||||
(map #(deserialize-from % type)
|
||||
(slice-segments (slice segment 0 (* count (size-of type)))
|
||||
(size-of type))))
|
||||
|
||||
;;; FFI Code loading and function access
|
||||
|
||||
(defn load-system-library
|
||||
|
|
@ -621,20 +42,20 @@
|
|||
|
||||
(defn- method-type
|
||||
"Gets the [[MethodType]] for a set of `args` and `ret` types."
|
||||
([args] (method-type args ::void))
|
||||
([args] (method-type args ::mem/void))
|
||||
([args ret]
|
||||
(MethodType/methodType
|
||||
^Class (java-layout ret)
|
||||
^"[Ljava.lang.Class;" (into-array Class (map java-layout args)))))
|
||||
^Class (mem/java-layout ret)
|
||||
^"[Ljava.lang.Class;" (into-array Class (map mem/java-layout args)))))
|
||||
|
||||
(defn- function-descriptor
|
||||
"Gets the [[FunctionDescriptor]] for a set of `args` and `ret` types."
|
||||
([args] (function-descriptor args ::void))
|
||||
([args] (function-descriptor args ::mem/void))
|
||||
([args ret]
|
||||
(let [args-arr (into-array MemoryLayout (map c-layout args))]
|
||||
(if-not (identical? ret ::void)
|
||||
(let [args-arr (into-array MemoryLayout (map mem/c-layout args))]
|
||||
(if-not (identical? ret ::mem/void)
|
||||
(FunctionDescriptor/of
|
||||
(c-layout ret)
|
||||
(mem/c-layout ret)
|
||||
args-arr)
|
||||
(FunctionDescriptor/ofVoid
|
||||
args-arr)))))
|
||||
|
|
@ -646,26 +67,26 @@
|
|||
|
||||
(def ^:private load-instructions
|
||||
"Mapping from primitive types to the instruction used to load them onto the stack."
|
||||
{::byte :bload
|
||||
::short :sload
|
||||
::int :iload
|
||||
::long :lload
|
||||
::long-long :lload
|
||||
::char :cload
|
||||
::float :fload
|
||||
::double :dload
|
||||
::pointer :aload})
|
||||
{::mem/byte :bload
|
||||
::mem/short :sload
|
||||
::mem/int :iload
|
||||
::mem/long :lload
|
||||
::mem/long-long :lload
|
||||
::mem/char :cload
|
||||
::mem/float :fload
|
||||
::mem/double :dload
|
||||
::mem/pointer :aload})
|
||||
|
||||
(def ^:private prim-classes
|
||||
"Mapping from primitive types to their box classes."
|
||||
{::byte Byte
|
||||
::short Short
|
||||
::int Integer
|
||||
::long Long
|
||||
::long-long Long
|
||||
::char Character
|
||||
::float Float
|
||||
::double Double})
|
||||
{::mem/byte Byte
|
||||
::mem/short Short
|
||||
::mem/int Integer
|
||||
::mem/long Long
|
||||
::mem/long-long Long
|
||||
::mem/char Character
|
||||
::mem/float Float
|
||||
::mem/double Double})
|
||||
|
||||
(defn- to-object-asm
|
||||
"Constructs a bytecode sequence to box a primitive on the top of the stack.
|
||||
|
|
@ -674,10 +95,10 @@
|
|||
null reference will be pushed to the stack."
|
||||
[type]
|
||||
(cond
|
||||
(identical? ::void type) [:ldc nil]
|
||||
(identical? ::pointer (primitive-type type)) []
|
||||
(identical? ::mem/void type) [:ldc nil]
|
||||
(identical? ::mem/pointer (mem/primitive-type type)) []
|
||||
:else
|
||||
(let [prim-type (some-> type primitive-type)]
|
||||
(let [prim-type (some-> type mem/primitive-type)]
|
||||
(if-some [prim (some-> prim-type name keyword)]
|
||||
;; Box primitive
|
||||
[:invokestatic (prim-classes prim-type) "valueOf" [prim (prim-classes prim-type)]]
|
||||
|
|
@ -687,20 +108,20 @@
|
|||
(defn- insn-layout
|
||||
"Gets the type keyword or class for referring to the type in bytecode."
|
||||
[type]
|
||||
(if (some-> (primitive-type type) (not= ::pointer))
|
||||
(if (some-> (mem/primitive-type type) (not= ::mem/pointer))
|
||||
(keyword (name type))
|
||||
(java-layout type)))
|
||||
(mem/java-layout type)))
|
||||
|
||||
(def ^:private unbox-fn-for-type
|
||||
"Map from type name to the name of its unboxing function."
|
||||
{::byte "byteValue"
|
||||
::short "shortValue"
|
||||
::int "intValue"
|
||||
::long "longValue"
|
||||
::long-long "longValue"
|
||||
::char "charValue"
|
||||
::float "floatValue"
|
||||
::double "doubleValue"})
|
||||
{::mem/byte "byteValue"
|
||||
::mem/short "shortValue"
|
||||
::mem/int "intValue"
|
||||
::mem/long "longValue"
|
||||
::mem/long-long "longValue"
|
||||
::mem/char "charValue"
|
||||
::mem/float "floatValue"
|
||||
::mem/double "doubleValue"})
|
||||
|
||||
(defn- to-prim-asm
|
||||
"Constructs a bytecode sequence to unbox a primitive type on top of the stack.
|
||||
|
|
@ -709,10 +130,10 @@
|
|||
will be popped."
|
||||
[type]
|
||||
(cond
|
||||
(identical? ::void type) [:pop]
|
||||
(identical? ::pointer (primitive-type type)) []
|
||||
(identical? ::mem/void type) [:pop]
|
||||
(identical? ::mem/pointer (mem/primitive-type type)) []
|
||||
:else
|
||||
(let [prim-type (some-> type primitive-type)]
|
||||
(let [prim-type (some-> type mem/primitive-type)]
|
||||
(if-some [prim (some-> prim-type name keyword)]
|
||||
[[:checkcast (prim-classes prim-type)]
|
||||
[:invokevirtual (prim-classes prim-type) (unbox-fn-for-type prim-type) [prim]]]
|
||||
|
|
@ -739,24 +160,24 @@
|
|||
{:name :invoke
|
||||
:flags #{:public}
|
||||
:desc (repeat (cond-> (inc (count args))
|
||||
(not (primitive-type ret)) inc)
|
||||
(not (mem/primitive-type ret)) inc)
|
||||
Object)
|
||||
:emit [[:aload 0]
|
||||
[:getfield :this "downcall_handle" MethodHandle]
|
||||
(when-not (primitive-type ret)
|
||||
(when-not (mem/primitive-type ret)
|
||||
[[:aload 1]
|
||||
[:checkcast SegmentAllocator]])
|
||||
(map-indexed
|
||||
(fn [idx arg]
|
||||
[[:aload (cond-> (inc idx)
|
||||
(not (primitive-type ret)) inc)]
|
||||
(not (mem/primitive-type ret)) inc)]
|
||||
(to-prim-asm arg)])
|
||||
args)
|
||||
[:invokevirtual MethodHandle "invokeExact"
|
||||
(cond->>
|
||||
(conj (mapv insn-layout args)
|
||||
(insn-layout ret))
|
||||
(not (primitive-type ret)) (cons SegmentAllocator))]
|
||||
(not (mem/primitive-type ret)) (cons SegmentAllocator))]
|
||||
(to-object-asm ret)
|
||||
[:areturn]]}]})
|
||||
|
||||
|
|
@ -770,7 +191,7 @@
|
|||
calls [[find-symbol]] on it."
|
||||
[symbol-or-addr]
|
||||
(if (instance? Addressable symbol-or-addr)
|
||||
(address-of symbol-or-addr)
|
||||
(mem/address-of symbol-or-addr)
|
||||
(find-symbol symbol-or-addr)))
|
||||
|
||||
(defn make-downcall
|
||||
|
|
@ -812,17 +233,17 @@
|
|||
"Constructs a wrapper function for the `downcall` which serializes the arguments
|
||||
and deserializes the return value."
|
||||
[downcall arg-types ret-type]
|
||||
(if (primitive-type ret-type)
|
||||
(if (mem/primitive-type ret-type)
|
||||
(fn native-fn [& args]
|
||||
(with-open [scope (stack-scope)]
|
||||
(deserialize
|
||||
(apply downcall (map #(serialize %1 %2 scope) args arg-types))
|
||||
(with-open [scope (mem/stack-scope)]
|
||||
(mem/deserialize
|
||||
(apply downcall (map #(mem/serialize %1 %2 scope) args arg-types))
|
||||
ret-type)))
|
||||
(fn native-fn [& args]
|
||||
(with-open [scope (stack-scope)]
|
||||
(deserialize
|
||||
(apply downcall (scope-allocator scope)
|
||||
(map #(serialize %1 %2 scope) args arg-types))
|
||||
(with-open [scope (mem/stack-scope)]
|
||||
(mem/deserialize
|
||||
(apply downcall (mem/scope-allocator scope)
|
||||
(map #(mem/serialize %1 %2 scope) args arg-types))
|
||||
ret-type)))))
|
||||
|
||||
(defn make-serde-varargs-wrapper
|
||||
|
|
@ -864,15 +285,15 @@
|
|||
|
||||
(def ^:private return-for-type
|
||||
"Map from type name to the return instruction for that type."
|
||||
{::byte :breturn
|
||||
::short :sreturn
|
||||
::int :ireturn
|
||||
::long :lreturn
|
||||
::long-long :lreturn
|
||||
::char :creturn
|
||||
::float :freturn
|
||||
::double :dreturn
|
||||
::void :return})
|
||||
{::mem/byte :breturn
|
||||
::mem/short :sreturn
|
||||
::mem/int :ireturn
|
||||
::mem/long :lreturn
|
||||
::mem/long-long :lreturn
|
||||
::mem/char :creturn
|
||||
::mem/float :freturn
|
||||
::mem/double :dreturn
|
||||
::mem/void :return})
|
||||
|
||||
(defn- upcall-class
|
||||
"Constructs a class definition for a class with a single method, `upcall`, which
|
||||
|
|
@ -893,8 +314,8 @@
|
|||
[:return]]}
|
||||
{:name :upcall
|
||||
:flags #{:public}
|
||||
:desc (conj (mapv java-layout arg-types)
|
||||
(java-layout ret-type))
|
||||
:desc (conj (mapv mem/java-layout arg-types)
|
||||
(mem/java-layout ret-type))
|
||||
:emit [[:aload 0]
|
||||
[:getfield :this "upcall_ifn" IFn]
|
||||
(map-indexed
|
||||
|
|
@ -920,21 +341,21 @@
|
|||
"upcall"
|
||||
(method-type arg-types ret-type)))
|
||||
|
||||
(defmethod primitive-type ::fn
|
||||
(defmethod mem/primitive-type ::fn
|
||||
[_type]
|
||||
::pointer)
|
||||
::mem/pointer)
|
||||
|
||||
(defn- upcall-serde-wrapper
|
||||
"Creates a function that wraps `f` which deserializes the arguments and
|
||||
serializes the return type in the [[global-scope]]."
|
||||
[f arg-types ret-type]
|
||||
(fn [& args]
|
||||
(serialize
|
||||
(apply f (map deserialize args arg-types))
|
||||
(mem/serialize
|
||||
(apply f (map mem/deserialize args arg-types))
|
||||
ret-type
|
||||
(global-scope))))
|
||||
(mem/global-scope))))
|
||||
|
||||
(defmethod serialize* ::fn
|
||||
(defmethod mem/serialize* ::fn
|
||||
[f [_fn arg-types ret-type & {:keys [raw-fn?]}] scope]
|
||||
(.upcallStub
|
||||
(CLinker/getInstance)
|
||||
|
|
@ -944,7 +365,7 @@
|
|||
(function-descriptor arg-types ret-type)
|
||||
scope))
|
||||
|
||||
(defmethod deserialize* ::fn
|
||||
(defmethod mem/deserialize* ::fn
|
||||
[addr [_fn arg-types ret-type & {:keys [raw-fn?]}]]
|
||||
(-> addr
|
||||
(downcall-handle
|
||||
|
|
@ -959,7 +380,7 @@
|
|||
(defn const
|
||||
"Gets the value of a constant stored in `symbol-or-addr`."
|
||||
[symbol-or-addr type]
|
||||
(deserialize (ensure-address symbol-or-addr) [::pointer type]))
|
||||
(mem/deserialize (ensure-address symbol-or-addr) [::mem/pointer type]))
|
||||
|
||||
(deftype StaticVariable [addr type meta]
|
||||
Addressable
|
||||
|
|
@ -967,7 +388,7 @@
|
|||
addr)
|
||||
IDeref
|
||||
(deref [_]
|
||||
(deserialize addr [::pointer type]))
|
||||
(mem/deserialize addr [::mem/pointer type]))
|
||||
|
||||
IObj
|
||||
(withMeta [_ meta-map]
|
||||
|
|
@ -984,10 +405,10 @@
|
|||
(defn freset!
|
||||
"Sets the value of `static-var` to `newval`, running it through [[serialize]]."
|
||||
[^StaticVariable static-var newval]
|
||||
(serialize-into
|
||||
(mem/serialize-into
|
||||
newval (.-type static-var)
|
||||
(slice-global (.-addr static-var) (size-of (.-type static-var)))
|
||||
(global-scope))
|
||||
(mem/slice-global (.-addr static-var) (mem/size-of (.-type static-var)))
|
||||
(mem/global-scope))
|
||||
newval)
|
||||
|
||||
(defn fswap!
|
||||
|
|
@ -1070,13 +491,6 @@
|
|||
:args (s/cat :libspec ::libspec)
|
||||
:ret (s/map-of keyword? any?))
|
||||
|
||||
(s/def ::type
|
||||
(s/spec
|
||||
(s/nonconforming
|
||||
(s/or :simple-type qualified-keyword?
|
||||
:complex-type (s/cat :base-type qualified-keyword?
|
||||
:type-args (s/* any?))))))
|
||||
|
||||
(s/def ::defcfn-args
|
||||
(s/and
|
||||
(s/cat :name simple-symbol?
|
||||
|
|
@ -1085,7 +499,7 @@
|
|||
:symbol (s/nonconforming
|
||||
(s/or :string string?
|
||||
:symbol simple-symbol?))
|
||||
:native-arglist (s/coll-of ::type :kind vector?)
|
||||
:native-arglist (s/coll-of ::mem/type :kind vector?)
|
||||
:return-type qualified-keyword?
|
||||
:wrapper (s/?
|
||||
(s/cat
|
||||
|
|
@ -1143,10 +557,10 @@
|
|||
~ret-type ~(:return-type args)
|
||||
~invoke (make-downcall ~(name (:symbol args)) ~args-types ~ret-type)
|
||||
~(or (-> args :wrapper :native-fn) native-sym)
|
||||
~(if (and (every? #(= % (primitive-type %))
|
||||
~(if (and (every? #(= % (mem/primitive-type %))
|
||||
(:native-arglist args))
|
||||
(= (:return-type args)
|
||||
(primitive-type (:return-type args))))
|
||||
(mem/primitive-type (:return-type args))))
|
||||
invoke
|
||||
`(make-serde-wrapper ~invoke ~args-types ~ret-type))
|
||||
fun# ~(if (:wrapper args)
|
||||
|
|
@ -1169,35 +583,3 @@
|
|||
fun#))))
|
||||
(s/fdef defcfn
|
||||
:args ::defcfn-args)
|
||||
|
||||
(defmacro defalias
|
||||
"Defines a type alias from `new-type` to `aliased-type`.
|
||||
|
||||
This creates needed serialization and deserialization implementations for the
|
||||
aliased type."
|
||||
{:style/indent [:defn]}
|
||||
[new-type aliased-type]
|
||||
(if (primitive-type aliased-type)
|
||||
`(let [aliased# ~aliased-type]
|
||||
(defmethod primitive-type ~new-type
|
||||
[_type#]
|
||||
(primitive-type aliased#))
|
||||
(defmethod serialize* ~new-type
|
||||
[obj# _type# scope#]
|
||||
(serialize* obj# aliased# scope#))
|
||||
(defmethod deserialize* ~new-type
|
||||
[obj# _type#]
|
||||
(deserialize* obj# aliased#)))
|
||||
`(let [aliased# ~aliased-type]
|
||||
(defmethod c-layout ~new-type
|
||||
[_type#]
|
||||
(c-layout aliased#))
|
||||
(defmethod serialize-into ~new-type
|
||||
[obj# _type# segment# scope#]
|
||||
(serialize-into obj# aliased# segment# scope#))
|
||||
(defmethod deserialize-from ~new-type
|
||||
[segment# _type#]
|
||||
(deserialize-from segment# aliased#)))))
|
||||
(s/fdef defalias
|
||||
:args (s/cat :new-type qualified-keyword?
|
||||
:aliased-type ::type))
|
||||
|
|
|
|||
654
src/clj/coffi/mem.clj
Normal file
654
src/clj/coffi/mem.clj
Normal file
|
|
@ -0,0 +1,654 @@
|
|||
(ns coffi.mem
|
||||
"Functions for managing native allocations, resource scopes, and (de)serialization.
|
||||
|
||||
For any new type to be implemented, three multimethods must be overriden, but
|
||||
which three depends on the native representation of the type.
|
||||
|
||||
If the native representation of the type is a primitive (whether or not other
|
||||
data beyond the primitive is associated with it, as e.g. a pointer),
|
||||
then [[primitive-type]] must be overriden to return which primitive type it is
|
||||
serialized as, then [[serialize*]] and [[deserialize*]] should be overriden.
|
||||
|
||||
If the native representation of the type is a composite type, like a union,
|
||||
struct, or array, then [[c-layout]] must be overriden to return the native
|
||||
layout of the type, and [[serialize-into]] and [[deserialize-from]] should be
|
||||
overriden to allow marshaling values of the type into and out of memory
|
||||
segments.
|
||||
|
||||
When writing code that manipulates a segment, it's best practice to
|
||||
use [[with-acquired]] on the [[segment-scope]] in order to ensure it won't be
|
||||
released during its manipulation."
|
||||
(:require
|
||||
[clojure.spec.alpha :as s])
|
||||
(:import
|
||||
(jdk.incubator.foreign
|
||||
Addressable
|
||||
CLinker
|
||||
MemoryAccess
|
||||
MemoryAddress
|
||||
MemoryLayout
|
||||
MemorySegment
|
||||
ResourceScope
|
||||
SegmentAllocator)))
|
||||
|
||||
;; TODO(Joshua): Ensure all the serdes acquire the scopes they use
|
||||
|
||||
(defn stack-scope
|
||||
"Constructs a new scope for use only in this thread.
|
||||
|
||||
The memory allocated within this scope is cheap to allocate, like a native
|
||||
stack."
|
||||
^ResourceScope []
|
||||
(ResourceScope/newConfinedScope))
|
||||
|
||||
(defn shared-scope
|
||||
"Constructs a new shared scope.
|
||||
|
||||
This scope can be shared across threads and memory allocated in it will only
|
||||
be cleaned up once every thread accessing the scope closes it."
|
||||
^ResourceScope []
|
||||
(ResourceScope/newSharedScope))
|
||||
|
||||
(defn connected-scope
|
||||
"Constructs a new scope to reclaim all connected resources at once.
|
||||
|
||||
The scope may be shared across threads, and all resources created with it will
|
||||
be cleaned up at the same time, when all references have been collected.
|
||||
|
||||
This type of scope cannot be closed, and therefore should not be created in
|
||||
a [[with-open]] clause."
|
||||
^ResourceScope []
|
||||
(ResourceScope/newImplicitScope))
|
||||
|
||||
(defn global-scope
|
||||
"Constructs the global scope, which will never reclaim its resources.
|
||||
|
||||
This scope may be shared across threads, but is intended mainly in cases where
|
||||
memory is allocated with [[alloc]] but is either never freed or whose
|
||||
management is relinquished to a native library, such as when returned from a
|
||||
callback."
|
||||
^ResourceScope []
|
||||
(ResourceScope/globalScope))
|
||||
|
||||
(defn scope-allocator
|
||||
"Constructs a segment allocator from the given `scope`.
|
||||
|
||||
This is primarily used when working with unwrapped downcall functions. When a
|
||||
downcall function returns a non-primitive type, it must be provided with an
|
||||
allocator."
|
||||
^SegmentAllocator [^ResourceScope scope]
|
||||
(SegmentAllocator/ofScope scope))
|
||||
|
||||
(defn segment-scope
|
||||
"Gets the scope used to construct the `segment`."
|
||||
^ResourceScope [segment]
|
||||
(.scope ^MemorySegment segment))
|
||||
|
||||
(defn alloc
|
||||
"Allocates `size` bytes.
|
||||
|
||||
If a `scope` is provided, the allocation will be reclaimed when it is closed."
|
||||
([size] (alloc size (connected-scope)))
|
||||
([size scope] (MemorySegment/allocateNative (long size) ^ResourceScope scope)))
|
||||
|
||||
(defn alloc-with
|
||||
"Allocates `size` bytes using the `allocator`."
|
||||
([allocator size]
|
||||
(.allocate ^SegmentAllocator allocator (long size)))
|
||||
([allocator size alignment]
|
||||
(.allocate ^SegmentAllocator allocator (long size) (long alignment))))
|
||||
|
||||
(defmacro with-acquired
|
||||
"Acquires a `scope` to ensure it will not be released until the `body` completes.
|
||||
|
||||
This is only necessary to do on shared scopes, however if you are operating on
|
||||
an arbitrary passed scope, it is best practice to wrap code that interacts
|
||||
with it wrapped in this."
|
||||
[scope & body]
|
||||
`(let [scope# ~scope
|
||||
handle# (.acquire ^ResourceScope scope#)]
|
||||
(try ~@body
|
||||
(finally (.release ^ResourceScope scope# handle#)))))
|
||||
|
||||
(defn address-of
|
||||
"Gets the address of a given segment.
|
||||
|
||||
This value can be used as an argument to functions which take a pointer."
|
||||
[addressable]
|
||||
(.address ^Addressable addressable))
|
||||
|
||||
(defn null?
|
||||
"Checks if a memory address is null."
|
||||
[addr]
|
||||
(.equals (MemoryAddress/NULL) addr))
|
||||
|
||||
(defn slice-global
|
||||
"Gets a slice of the global address space.
|
||||
|
||||
Because this fetches from the global segment, it has no associated scope, and
|
||||
therefore the reference created here cannot prevent the value from being
|
||||
freed. Be careful to ensure that you are not retaining an object incorrectly."
|
||||
[address size]
|
||||
(.asSlice (MemorySegment/globalNativeSegment)
|
||||
^MemoryAddress address (long size)))
|
||||
|
||||
(defn slice
|
||||
"Get a slice over the `segment` with the given `offset`."
|
||||
([segment offset]
|
||||
(.asSlice ^MemorySegment segment (long offset)))
|
||||
([segment offset size]
|
||||
(.asSlice ^MemorySegment segment (long offset) (long size))))
|
||||
|
||||
(defn slice-into
|
||||
"Get a slice into the `segment` starting at the `address`."
|
||||
([address segment]
|
||||
(.asSlice ^MemorySegment segment ^MemoryAddress address))
|
||||
([address segment size]
|
||||
(.asSlice ^MemorySegment segment ^MemoryAddress address (long size))))
|
||||
|
||||
(defn with-offset
|
||||
"Get a new address `offset` from the old `address`."
|
||||
[address offset]
|
||||
(.addOffset ^MemoryAddress address (long offset)))
|
||||
|
||||
(defn as-segment
|
||||
"Dereferences an `address` into a memory segment associated with the `scope`.
|
||||
|
||||
If `cleanup` is provided, it is a 0-arity function run when the scope is
|
||||
closed. This can be used to register a free method for the memory, or do other
|
||||
cleanup in a way that doesn't require modifying the code at the point of
|
||||
freeing, and allows shared or garbage collected resources to be freed
|
||||
correctly."
|
||||
([address size scope]
|
||||
(.asSegment ^MemoryAddress address size scope))
|
||||
([address size scope cleanup]
|
||||
(.asSegment ^MemoryAddress address size cleanup scope)))
|
||||
|
||||
(defn add-close-action!
|
||||
"Adds a 0-arity function to be run when the `scope` closes."
|
||||
[scope action]
|
||||
(.addCloseAction ^ResourceScope scope action))
|
||||
|
||||
(defn copy-segment
|
||||
"Copies the content to `dest` from `src`"
|
||||
[dest src]
|
||||
(.copyFrom ^MemorySegment dest ^MemorySegment src))
|
||||
|
||||
(defn clone-segment
|
||||
"Clones the content of `segment` into a new segment of the same size."
|
||||
([segment] (clone-segment segment (connected-scope)))
|
||||
([segment scope]
|
||||
(doto ^MemorySegment (alloc (.byteSize ^MemorySegment segment) scope)
|
||||
(copy-segment segment))))
|
||||
|
||||
(defn slice-segments
|
||||
"Constructs a lazy seq of `size`-length memory segments, sliced from `segment`."
|
||||
[segment size]
|
||||
(let [num-segments (quot (.byteSize ^MemorySegment segment) size)]
|
||||
(map #(slice segment (* % size) size)
|
||||
(range num-segments))))
|
||||
|
||||
(def primitive-types
|
||||
"A set of keywords representing all the primitive types which may be passed to
|
||||
or returned from native functions."
|
||||
#{::byte ::short ::int ::long ::long-long
|
||||
::char
|
||||
::float ::double
|
||||
::pointer ::void})
|
||||
|
||||
(defn- type-dispatch
|
||||
"Gets a type dispatch value from a (potentially composite) type."
|
||||
[type]
|
||||
(cond
|
||||
(qualified-keyword? type) type
|
||||
(sequential? type) (keyword (first type))))
|
||||
|
||||
(defmulti primitive-type
|
||||
"Gets the primitive type that is used to pass as an argument for the `type`.
|
||||
|
||||
This is for objects which are passed to native functions as primitive types,
|
||||
but which need additional logic to be performed during serialization and
|
||||
deserialization.
|
||||
|
||||
Returns nil for any type which does not have a primitive representation."
|
||||
type-dispatch)
|
||||
|
||||
(defmethod primitive-type :default
|
||||
[type]
|
||||
(primitive-types type))
|
||||
|
||||
(defmethod primitive-type ::pointer
|
||||
[_type]
|
||||
::pointer)
|
||||
|
||||
(def c-prim-layout
|
||||
"Map of primitive type names to the [[CLinker]] types for a method handle."
|
||||
{::byte CLinker/C_CHAR
|
||||
::short CLinker/C_SHORT
|
||||
::int CLinker/C_INT
|
||||
::long CLinker/C_LONG
|
||||
::long-long CLinker/C_LONG_LONG
|
||||
::char CLinker/C_CHAR
|
||||
::float CLinker/C_FLOAT
|
||||
::double CLinker/C_DOUBLE
|
||||
::pointer CLinker/C_POINTER})
|
||||
|
||||
(defmulti c-layout
|
||||
"Gets the layout object for a given `type`.
|
||||
|
||||
If a type is primitive it will return the appropriate primitive
|
||||
layout (see [[c-prim-layout]]).
|
||||
|
||||
Otherwise, it should return a [[GroupLayout]] for the given type."
|
||||
type-dispatch)
|
||||
|
||||
(defmethod c-layout :default
|
||||
[type]
|
||||
(c-prim-layout (or (primitive-type type) type)))
|
||||
|
||||
(def java-prim-layout
|
||||
"Map of primitive type names to the Java types for a method handle."
|
||||
{::byte Byte/TYPE
|
||||
::short Short/TYPE
|
||||
::int Integer/TYPE
|
||||
::long Long/TYPE
|
||||
::long-long Long/TYPE
|
||||
::char Byte/TYPE
|
||||
::float Float/TYPE
|
||||
::double Double/TYPE
|
||||
::pointer MemoryAddress
|
||||
::void Void/TYPE})
|
||||
|
||||
(defn java-layout
|
||||
"Gets the Java class to an argument of this type for a method handle.
|
||||
|
||||
If a type serializes to a primitive it returns return a Java primitive type.
|
||||
Otherwise, it returns [[MemorySegment]]."
|
||||
[type]
|
||||
(java-prim-layout (or (primitive-type type) type) MemorySegment))
|
||||
|
||||
(defn size-of
|
||||
"The size in bytes of the given `type`."
|
||||
[type]
|
||||
(.byteSize ^MemoryLayout (c-layout type)))
|
||||
|
||||
(defn alloc-instance
|
||||
"Allocates a memory segment for the given `type`."
|
||||
([type] (alloc-instance type (connected-scope)))
|
||||
([type scope] (MemorySegment/allocateNative (long (size-of type)) ^ResourceScope scope)))
|
||||
|
||||
(declare serialize serialize-into)
|
||||
|
||||
(defmulti serialize*
|
||||
"Constructs a serialized version of the `obj` and returns it.
|
||||
|
||||
Any new allocations made during the serialization should be tied to the given
|
||||
`scope`, except in extenuating circumstances.
|
||||
|
||||
This method should only be implemented for types that serialize to primitives."
|
||||
(fn
|
||||
#_{:clj-kondo/ignore [:unused-binding]}
|
||||
[obj type scope]
|
||||
(type-dispatch type)))
|
||||
|
||||
(def ^:private primitive-cast
|
||||
"Map from primitive type names to the function to cast it to a primitive."
|
||||
{::byte byte
|
||||
::short short
|
||||
::int int
|
||||
::long long
|
||||
::long-long long
|
||||
::char char
|
||||
::float float
|
||||
::double double})
|
||||
|
||||
(defmethod serialize* :default
|
||||
[obj type _scope]
|
||||
(if-let [prim (primitive-type type)]
|
||||
((primitive-cast prim) obj)
|
||||
(throw (ex-info "Attempted to serialize a non-primitive type with primitive methods"
|
||||
{:type type
|
||||
:object obj}))))
|
||||
|
||||
(defmethod serialize* ::pointer
|
||||
[obj type scope]
|
||||
(when-not (null? obj)
|
||||
(if (sequential? type)
|
||||
(let [segment (alloc-instance (second type) scope)]
|
||||
(serialize-into obj (second type) segment scope)
|
||||
(address-of segment))
|
||||
obj)))
|
||||
|
||||
(defmulti serialize-into
|
||||
"Writes a serialized version of the `obj` to the given `segment`.
|
||||
|
||||
Any new allocations made during the serialization should be tied to the given
|
||||
`scope`, except in extenuating circumstances.
|
||||
|
||||
This method should be implemented for any type which does not
|
||||
override [[c-layout]].
|
||||
|
||||
For any other type, this will serialize it as [[serialize*]] before writing
|
||||
the result value into the `segment`."
|
||||
(fn
|
||||
#_{:clj-kondo/ignore [:unused-binding]}
|
||||
[obj type segment scope]
|
||||
(type-dispatch type)))
|
||||
|
||||
(defmethod serialize-into :default
|
||||
[obj type segment scope]
|
||||
(if-some [prim-layout (primitive-type type)]
|
||||
(serialize-into (serialize* obj type scope) prim-layout segment scope)
|
||||
(throw (ex-info "Attempted to serialize an object to a type that has not been overriden"
|
||||
{:type type
|
||||
:object obj}))))
|
||||
|
||||
(defmethod serialize-into ::byte
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setByte segment (byte obj)))
|
||||
|
||||
(defmethod serialize-into ::short
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setShort segment (short obj)))
|
||||
|
||||
(defmethod serialize-into ::int
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setInt segment (int obj)))
|
||||
|
||||
(defmethod serialize-into ::long
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setLong segment (long obj)))
|
||||
|
||||
(defmethod serialize-into ::long-long
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setLong segment (long obj)))
|
||||
|
||||
(defmethod serialize-into ::char
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setChar segment (char obj)))
|
||||
|
||||
(defmethod serialize-into ::float
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setFloat segment (float obj)))
|
||||
|
||||
(defmethod serialize-into ::double
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setDouble segment (double obj)))
|
||||
|
||||
(defmethod serialize-into ::pointer
|
||||
[obj _type segment _scope]
|
||||
(MemoryAccess/setAddress segment obj))
|
||||
|
||||
(defn serialize
|
||||
"Serializes an arbitrary type.
|
||||
|
||||
For types which have a primitive representation, this serializes into that
|
||||
representation. For types which do not, it allocates a new segment and
|
||||
serializes into that."
|
||||
([obj type] (serialize obj type (connected-scope)))
|
||||
([obj type scope]
|
||||
(if (primitive-type type)
|
||||
(serialize* obj type scope)
|
||||
(let [segment (alloc-instance type scope)]
|
||||
(serialize-into obj type segment scope)
|
||||
segment))))
|
||||
|
||||
(declare deserialize deserialize*)
|
||||
|
||||
(defmulti deserialize-from
|
||||
"Deserializes the given segment into a Clojure data structure.
|
||||
|
||||
For types that serialize to primitives, a default implementation will
|
||||
deserialize the primitive before calling [[deserialize*]]."
|
||||
(fn
|
||||
#_{:clj-kondo/ignore [:unused-binding]}
|
||||
[segment type]
|
||||
(type-dispatch type)))
|
||||
|
||||
(defmethod deserialize-from :default
|
||||
[segment type]
|
||||
(if-some [prim (primitive-type type)]
|
||||
(-> segment
|
||||
(deserialize-from prim)
|
||||
(deserialize* type))
|
||||
(throw (ex-info "Attempted to deserialize a non-primitive type that has not been overriden"
|
||||
{:type type
|
||||
:segment segment}))))
|
||||
|
||||
(defmethod deserialize-from ::byte
|
||||
[segment _type]
|
||||
(MemoryAccess/getByte segment))
|
||||
|
||||
(defmethod deserialize-from ::short
|
||||
[segment _type]
|
||||
(MemoryAccess/getShort segment))
|
||||
|
||||
(defmethod deserialize-from ::int
|
||||
[segment _type]
|
||||
(MemoryAccess/getInt segment))
|
||||
|
||||
(defmethod deserialize-from ::long
|
||||
[segment _type]
|
||||
(MemoryAccess/getLong segment))
|
||||
|
||||
(defmethod deserialize-from ::long-long
|
||||
[segment _type]
|
||||
(MemoryAccess/getLong segment))
|
||||
|
||||
(defmethod deserialize-from ::char
|
||||
[segment _type]
|
||||
(MemoryAccess/getChar segment))
|
||||
|
||||
(defmethod deserialize-from ::float
|
||||
[segment _type]
|
||||
(MemoryAccess/getFloat segment))
|
||||
|
||||
(defmethod deserialize-from ::double
|
||||
[segment _type]
|
||||
(MemoryAccess/getDouble segment))
|
||||
|
||||
(defmethod deserialize-from ::pointer
|
||||
[segment type]
|
||||
(cond-> (MemoryAccess/getAddress segment)
|
||||
(sequential? type) (deserialize* type)))
|
||||
|
||||
(defmulti deserialize*
|
||||
"Deserializes a primitive object into a Clojure data structure.
|
||||
|
||||
This is intended for use with types that are returned as a primitive but which
|
||||
need additional processing before they can be returned."
|
||||
(fn
|
||||
#_{:clj-kondo/ignore [:unused-binding]}
|
||||
[obj type]
|
||||
(type-dispatch type)))
|
||||
|
||||
(defmethod deserialize* :default
|
||||
[obj type]
|
||||
(if (primitive-type type)
|
||||
obj
|
||||
(throw (ex-info "Attempted to deserialize a non-primitive type with primitive methods"
|
||||
{:type type
|
||||
:segment obj}))))
|
||||
|
||||
(defmethod deserialize* ::pointer
|
||||
[addr type]
|
||||
(when-not (null? addr)
|
||||
(if (sequential? type)
|
||||
(deserialize-from (slice-global addr (size-of (second type)))
|
||||
(second type))
|
||||
addr)))
|
||||
|
||||
(defn deserialize
|
||||
"Deserializes an arbitrary type.
|
||||
|
||||
For types which have a primitive representation, this deserializes the
|
||||
primitive representation. For types which do not, this deserializes out of
|
||||
a segment."
|
||||
[obj type]
|
||||
(when-not (identical? ::void type)
|
||||
((if (primitive-type type)
|
||||
deserialize*
|
||||
deserialize-from)
|
||||
obj type)))
|
||||
|
||||
(defn seq-of
|
||||
"Constructs a lazy sequence of `type` elements deserialized from `segment`."
|
||||
[type segment]
|
||||
(map #(deserialize % type) (slice-segments segment (size-of type))))
|
||||
|
||||
;;; C String type
|
||||
|
||||
(defmethod primitive-type ::c-string
|
||||
[_type]
|
||||
::pointer)
|
||||
|
||||
(defmethod serialize* ::c-string
|
||||
[obj _type scope]
|
||||
(if obj
|
||||
(address-of (CLinker/toCString ^String obj ^ResourceScope scope))
|
||||
(MemoryAddress/NULL)))
|
||||
|
||||
(defmethod deserialize* ::c-string
|
||||
[addr _type]
|
||||
(when-not (null? addr)
|
||||
(CLinker/toJavaString ^MemoryAddress addr)))
|
||||
|
||||
;;; Union types
|
||||
|
||||
(defmethod c-layout ::union
|
||||
[[_union types & {:as _opts} :as _type]]
|
||||
(let [items (map c-layout types)]
|
||||
(MemoryLayout/unionLayout
|
||||
(into-array MemoryLayout items))))
|
||||
|
||||
(defmethod serialize-into ::union
|
||||
[obj [_union _types & {:keys [dispatch extract]} :as type] segment scope]
|
||||
(when-not dispatch
|
||||
(throw (ex-info "Attempted to serialize a union with no dispatch function"
|
||||
{:type type
|
||||
:value obj})))
|
||||
(let [type (dispatch obj)]
|
||||
(serialize-into
|
||||
(if extract
|
||||
(extract type obj)
|
||||
obj)
|
||||
type
|
||||
segment
|
||||
scope)))
|
||||
|
||||
(defmethod deserialize-from ::union
|
||||
[segment type]
|
||||
(clone-segment (slice segment 0 (size-of type))))
|
||||
|
||||
;;; Struct types
|
||||
|
||||
(defmethod c-layout ::struct
|
||||
[[_struct fields]]
|
||||
(let [fields (for [[field-name field] fields]
|
||||
(.withName ^MemoryLayout (c-layout field)
|
||||
(name field-name)))]
|
||||
(MemoryLayout/structLayout
|
||||
(into-array MemoryLayout fields))))
|
||||
|
||||
(defmethod serialize-into ::struct
|
||||
[obj [_struct fields] segment scope]
|
||||
(loop [offset 0
|
||||
fields fields]
|
||||
(when (seq fields)
|
||||
(let [[field type] (first fields)
|
||||
size (size-of type)]
|
||||
(serialize-into
|
||||
(get obj field) type
|
||||
(slice segment offset size) scope)
|
||||
(recur (long (+ offset size)) (rest fields))))))
|
||||
|
||||
(defmethod deserialize-from ::struct
|
||||
[segment [_struct fields]]
|
||||
(loop [offset 0
|
||||
fields fields
|
||||
obj {}]
|
||||
(if (seq fields)
|
||||
(let [[field type] (first fields)
|
||||
size (size-of type)]
|
||||
(recur
|
||||
(long (+ offset size))
|
||||
(rest fields)
|
||||
(assoc obj field (deserialize-from
|
||||
(slice segment offset size)
|
||||
type))))
|
||||
obj)))
|
||||
|
||||
;;; Padding type
|
||||
|
||||
(defmethod c-layout ::padding
|
||||
[[_padding size]]
|
||||
(MemoryLayout/paddingLayout (* 8 size)))
|
||||
|
||||
(defmethod serialize-into ::padding
|
||||
[_obj [_padding _size] _segment _scope]
|
||||
nil)
|
||||
|
||||
(defmethod deserialize-from ::padding
|
||||
[_segment [_padding _size]]
|
||||
nil)
|
||||
|
||||
;;; Array types
|
||||
|
||||
(defmethod c-layout ::array
|
||||
[[_array type count]]
|
||||
(MemoryLayout/sequenceLayout
|
||||
count
|
||||
(c-layout type)))
|
||||
|
||||
(defmethod serialize-into ::array
|
||||
[obj [_array type count] segment scope]
|
||||
(dorun
|
||||
(map #(serialize-into %1 type %2 scope)
|
||||
obj
|
||||
(slice-segments (slice segment 0 (* count (size-of type)))
|
||||
(size-of type)))))
|
||||
|
||||
(defmethod deserialize-from ::array
|
||||
[segment [_array type count]]
|
||||
(map #(deserialize-from % type)
|
||||
(slice-segments (slice segment 0 (* count (size-of type)))
|
||||
(size-of type))))
|
||||
|
||||
(s/def ::type
|
||||
(s/spec
|
||||
(s/nonconforming
|
||||
(s/or :simple-type qualified-keyword?
|
||||
:complex-type (s/cat :base-type qualified-keyword?
|
||||
:type-args (s/* any?))))))
|
||||
|
||||
(defmacro defalias
|
||||
"Defines a type alias from `new-type` to `aliased-type`.
|
||||
|
||||
This creates needed serialization and deserialization implementations for the
|
||||
aliased type."
|
||||
{:style/indent [:defn]}
|
||||
[new-type aliased-type]
|
||||
(if (primitive-type aliased-type)
|
||||
`(let [aliased# ~aliased-type]
|
||||
(defmethod primitive-type ~new-type
|
||||
[_type#]
|
||||
(primitive-type aliased#))
|
||||
(defmethod serialize* ~new-type
|
||||
[obj# _type# scope#]
|
||||
(serialize* obj# aliased# scope#))
|
||||
(defmethod deserialize* ~new-type
|
||||
[obj# _type#]
|
||||
(deserialize* obj# aliased#)))
|
||||
`(let [aliased# ~aliased-type]
|
||||
(defmethod c-layout ~new-type
|
||||
[_type#]
|
||||
(c-layout aliased#))
|
||||
(defmethod serialize-into ~new-type
|
||||
[obj# _type# segment# scope#]
|
||||
(serialize-into obj# aliased# segment# scope#))
|
||||
(defmethod deserialize-from ~new-type
|
||||
[segment# _type#]
|
||||
(deserialize-from segment# aliased#)))))
|
||||
(s/fdef defalias
|
||||
:args (s/cat :new-type qualified-keyword?
|
||||
:aliased-type ::type))
|
||||
|
|
@ -1,31 +1,32 @@
|
|||
(ns coffi.ffi-test
|
||||
(:require
|
||||
[clojure.test :as t]
|
||||
[coffi.ffi :as sut]))
|
||||
[coffi.mem :as mem]
|
||||
[coffi.ffi :as ffi]))
|
||||
|
||||
(sut/load-library "target/ffi_test.so")
|
||||
(ffi/load-library "target/ffi_test.so")
|
||||
|
||||
(t/deftest can-load-symbols
|
||||
(t/is (not (nil? (sut/find-symbol "add_numbers")))))
|
||||
(t/is (not (nil? (ffi/find-symbol "add_numbers")))))
|
||||
|
||||
(t/deftest can-call-primitive-fns
|
||||
(t/is (= 5 ((sut/cfn "add_numbers" [::sut/int ::sut/int] ::sut/int) 2 3))))
|
||||
(t/is (= 5 ((ffi/cfn "add_numbers" [::mem/int ::mem/int] ::mem/int) 2 3))))
|
||||
|
||||
(sut/defalias ::point
|
||||
[::sut/struct
|
||||
[[:x ::sut/float]
|
||||
[:y ::sut/float]]])
|
||||
(mem/defalias ::point
|
||||
[::mem/struct
|
||||
[[:x ::mem/float]
|
||||
[:y ::mem/float]]])
|
||||
|
||||
(t/deftest can-call-with-structs
|
||||
(t/is (= {:x 2.0 :y 2.0}
|
||||
((sut/cfn "add_points" [::point ::point] ::point) {:x 1 :y 2} {:x 1 :y 0}))))
|
||||
((ffi/cfn "add_points" [::point ::point] ::point) {:x 1 :y 2} {:x 1 :y 0}))))
|
||||
|
||||
(t/deftest can-call-deserialized-fn-pointers
|
||||
(t/is (= "Alternate string"
|
||||
(((sut/cfn "get_downcall" [::sut/int] [::sut/fn [] ::sut/c-string])
|
||||
(((ffi/cfn "get_downcall" [::mem/int] [::ffi/fn [] ::mem/c-string])
|
||||
1)))))
|
||||
|
||||
(t/deftest can-make-upcall
|
||||
(t/is (= ((sut/cfn "upcall_test" [[::sut/fn [] ::sut/c-string]] ::sut/c-string)
|
||||
(t/is (= ((ffi/cfn "upcall_test" [[::ffi/fn [] ::mem/c-string]] ::mem/c-string)
|
||||
(fn [] "hello"))
|
||||
"hello")))
|
||||
|
|
|
|||
Loading…
Reference in a new issue