From 5f96439432e2c1417bc187c02ff1d8a50e2b565e Mon Sep 17 00:00:00 2001 From: Joshua Suskalo Date: Sun, 26 Sep 2021 14:11:29 -0500 Subject: [PATCH] Separate memory ops into their own ns --- README.md | 120 +++--- src/clj/coffi/ffi.clj | 778 ++++-------------------------------- src/clj/coffi/mem.clj | 654 ++++++++++++++++++++++++++++++ test/clj/coffi/ffi_test.clj | 23 +- 4 files changed, 807 insertions(+), 768 deletions(-) create mode 100644 src/clj/coffi/mem.clj diff --git a/README.md b/README.md index d0b810e..e5a3c0b 100644 --- a/README.md +++ b/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 diff --git a/src/clj/coffi/ffi.clj b/src/clj/coffi/ffi.clj index db2e1ad..1d9c544 100644 --- a/src/clj/coffi/ffi.clj +++ b/src/clj/coffi/ffi.clj @@ -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)) diff --git a/src/clj/coffi/mem.clj b/src/clj/coffi/mem.clj new file mode 100644 index 0000000..483aff8 --- /dev/null +++ b/src/clj/coffi/mem.clj @@ -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)) diff --git a/test/clj/coffi/ffi_test.clj b/test/clj/coffi/ffi_test.clj index 9c0d556..122e075 100644 --- a/test/clj/coffi/ffi_test.clj +++ b/test/clj/coffi/ffi_test.clj @@ -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")))