Merge branch 'master' of github.com:cnuernber/dtype-next

src/tech/v3/datatype/ffi.clj

@@ -350,26 +350,28 @@ Finally - on my favorite topic, efficiency, dtype-next has extremely fast copies
   * :jna - namespace `''tech.v3.datatype.ffi.jna/ffi-fns` - available if JNA version 5+ is in the classpath."
   [ffi-kwd]
   (case ffi-kwd
-    :jdk (reset! ffi-impl* @(requiring-resolve 'tech.v3.datatype.ffi.mmodel/ffi-fns))
-    :jna (reset! ffi-impl* @(requiring-resolve 'tech.v3.datatype.ffi.jna/ffi-fns))))
-
+    :jdk        (reset! ffi-impl* @(requiring-resolve 'tech.v3.datatype.ffi.mmodel-jdk19/ffi-fns))
+    :jdk-pre-19 (reset! ffi-impl* @(requiring-resolve 'tech.v3.datatype.ffi.mmodel/ffi-fns))
+    :jna        (reset! ffi-impl* @(requiring-resolve 'tech.v3.datatype.ffi.jna/ffi-fns))))
 
 (defn- ffi-impl
   "Get an implementation of the actual FFI interface.  This is for internal use only."
   []
   (when (nil? @ffi-impl*)
-    ;;prefer JDK support
     (try
-      (set-ffi-impl! :jna)
+      (set-ffi-impl! :jdk)
       (catch Throwable e
-        ;;brief error report on this log.
-        (log/debugf "Failed to load JNA FFI implementation: %s" e)
+        (log/debugf "Failed to load JDK 19 FFI implementation: %s" e)
         (try
-          (set-ffi-impl! :jdk)
+          (set-ffi-impl! :jdk-pre-19)
           (catch Throwable e
-            (reset! ffi-impl* :failed)
-            (log/error e "Failed to find a suitable FFI implementation.
-Attempted both :jdk and :jna -- call set-ffi-impl! from the repl to see specific failure."))))))
+            (log/debugf "Failed to load JDK pre-19 FFI implementation: %s" e)
+            (try
+              (set-ffi-impl! :jna)
+              (catch Throwable e
+                (reset! ffi-impl* :failed)
+                (log/error e "Failed to find a suitable FFI implementation.
+Attempted :jdk, :jdk-pre-19, and :jna -- call set-ffi-impl! from the repl to see specific failure."))))))))
   @ffi-impl*)
 
 

src/tech/v3/datatype/ffi/mmodel_jdk19.clj

@@ -0,0 +1,348 @@
+(ns tech.v3.datatype.ffi.mmodel-jdk19
+  (:require [tech.v3.datatype.errors :as errors]
+            [tech.v3.datatype.ffi :as ffi]
+            [tech.v3.datatype.ffi.base :as ffi-base]
+            [tech.v3.datatype.ffi.ptr-value :as ptr-value]
+            [tech.v3.datatype.ffi.size-t :as ffi-size-t])
+  (:import [clojure.lang Keyword]
+           [java.lang.foreign
+             Addressable FunctionDescriptor Linker MemoryAddress MemoryLayout MemorySession
+             SymbolLookup ValueLayout]
+           [java.lang.invoke MethodHandle MethodHandles MethodType]
+           [java.nio.file Path Paths]
+           [java.util ArrayList]
+           [tech.v3.datatype.ffi Pointer Library]))
+
+(set! *warn-on-reflection* true)
+
+(defn ptr-value
+  ^MemoryAddress [item]
+  (MemoryAddress/ofLong (ptr-value/ptr-value item)))
+
+(defn ptr-value-q
+  ^MemoryAddress [item]
+  (MemoryAddress/ofLong (ptr-value/ptr-value? item)))
+
+(extend-protocol ffi/PToPointer
+  MemoryAddress
+    (convertible-to-pointer? [item] true)
+    (->pointer [item]
+      (Pointer. (.toRawLongValue item) {:src-ptr item}))
+  Addressable
+    (convertible-to-pointer? [item] true)
+    (->pointer [item]
+      (Pointer. (-> (.address item) (.toRawLongValue)) {:src-ptr item})))
+
+(defn ->path
+  ^Path [str-base & args]
+  (Paths/get (str str-base) (into-array String args)))
+
+(defn load-library
+  ^SymbolLookup [libname]
+  (cond
+    (instance? SymbolLookup libname)
+    libname
+    (instance? Path libname)
+    (do (System/load (.toString ^Path libname))
+        (SymbolLookup/loaderLookup))
+    (string? libname)
+    (do (let [libname (str libname)]
+          (if (or (.contains libname "/")
+                  (.contains libname "\\"))
+              (System/load libname)
+              (System/loadLibrary libname)))
+        (SymbolLookup/loaderLookup))
+    (nil? libname)
+    (.defaultLookup (Linker/nativeLinker))
+    :else
+    (errors/throwf "Unrecognized libname type %s" (type libname))))
+
+(defn find-symbol
+  (^MemoryAddress [libname symbol-name]
+   (let [symbol-name (cond
+                       (symbol? symbol-name)  (name symbol-name)
+                       (keyword? symbol-name) (name symbol-name)
+                       :else                  (str symbol-name))]
+     (-> (load-library libname)
+         (.lookup symbol-name)
+         (.get))))
+  (^MemoryAddress [symbol-name]
+   (find-symbol nil symbol-name)))
+
+(defn memory-layout-array
+  ^"[Ljava.lang.foreign.MemoryLayout;" [& args]
+  (into-array MemoryLayout args))
+
+(defn argtype->mem-layout-type
+  [argtype]
+  (case (ffi-size-t/lower-type argtype)
+    :int8     ValueLayout/JAVA_BYTE
+    :int16    ValueLayout/JAVA_SHORT
+    :int32    ValueLayout/JAVA_INT
+    :int64    ValueLayout/JAVA_LONG
+    :float32  ValueLayout/JAVA_FLOAT
+    :float64  ValueLayout/JAVA_DOUBLE
+    :pointer? ValueLayout/ADDRESS
+    :pointer  ValueLayout/ADDRESS))
+
+(defn sig->fdesc
+  ^FunctionDescriptor [{:keys [rettype argtypes]}]
+  (if (or (= :void rettype) (nil? rettype))
+      (FunctionDescriptor/ofVoid
+        (->> argtypes
+             (map argtype->mem-layout-type)
+             (apply memory-layout-array)))
+      (FunctionDescriptor/of
+        (argtype->mem-layout-type rettype)
+        (->> argtypes
+             (map argtype->mem-layout-type)
+             (apply memory-layout-array)))))
+
+(defn argtype->cls
+  ^Class [argtype]
+  (case (ffi-size-t/lower-type argtype)
+    :int8     Byte/TYPE
+    :int16    Short/TYPE
+    :int32    Integer/TYPE
+    :int64    Long/TYPE
+    :float32  Float/TYPE
+    :float64  Double/TYPE
+    :pointer  Addressable
+    :pointer? Addressable
+    :string   Addressable
+    :void     Void/TYPE
+    (do
+      (errors/when-not-errorf
+        (instance? Class argtype)
+        "argtype (%s) must be instance of class"
+        argtype)
+      argtype)))
+
+(defn sig->method-type
+  ^MethodType [{:keys [rettype argtypes]}]
+  (let [^"[Ljava.lang.Class;" cls-ary (->> argtypes
+                                           (map argtype->cls)
+                                           (into-array Class))]
+    (MethodType/methodType (argtype->cls rettype) cls-ary)))
+
+(defn library-sym-method-handle
+  ^MethodHandle [library symbol-name rettype argtypes]
+  (let [sym    (find-symbol library symbol-name)
+        sig    {:rettype  rettype
+                :argtypes argtypes}
+        fndesc (sig->fdesc sig)
+        ;methoddesc (sig->method-type sig)
+        linker (Linker/nativeLinker)]
+    (.downcallHandle linker sym #_methoddesc fndesc)))
+
+(defn emit-lib-constructor
+  [fn-defs]
+  (->>
+    (concat
+      [[:aload 0]
+        [:invokespecial :super :init [:void]]]
+      [[:aload 0]
+        [:aload 1]
+        [:invokestatic 'tech.v3.datatype.ffi.mmodel_jdk19$load_library
+          'invokeStatic [Object Object]]
+        [:checkcast SymbolLookup]
+        [:putfield :this "libraryImpl" SymbolLookup]]
+      ;;Load all the method handles.
+      (mapcat
+        (fn [[fn-name {:keys [rettype argtypes]}]]
+          (let [hdl-name (str (name fn-name) "_hdl")]
+            (concat
+              [[:aload 0]  ;;this-ptr
+                [:aload 1] ;;libname
+                [:ldc (name fn-name)]
+                [:ldc (name rettype)]
+                [:invokestatic Keyword "intern" [String Keyword]]
+                [:new ArrayList]
+                [:dup]
+                [:invokespecial ArrayList :init [:void]]
+                [:astore 2]]
+              (mapcat (fn [argtype]
+                        [[:aload 2]
+                          [:ldc (name argtype)]
+                          [:invokestatic Keyword "intern" [String Keyword]]
+                          [:invokevirtual ArrayList 'add [Object :boolean]]
+                          [:pop]])
+                argtypes)
+              [[:aload 2]
+                [:invokestatic 'tech.v3.datatype.ffi.mmodel_jdk19$library_sym_method_handle
+                  'invokeStatic
+                  [Object Object Object Object Object]]
+                [:checkcast MethodHandle]
+                [:putfield :this hdl-name MethodHandle]])))
+        fn-defs)
+      [[:aload 0]
+        [:dup]
+        [:invokevirtual :this "buildFnMap" [Object]]
+        [:putfield :this "fnMap" Object]
+        [:return]])
+    (vec)))
+
+
+(defn emit-find-symbol
+  []
+  [[:aload 0]
+    [:getfield :this "libraryImpl" SymbolLookup]
+    [:aload 1]
+    [:invokestatic 'tech.v3.datatype.ffi.mmodel_jdk19$find_symbol
+      'invokeStatic [Object Object Object]]
+    [:checkcast Addressable]
+    [:invokeinterface Addressable 'address [MemoryAddress]]
+    [:invokeinterface MemoryAddress 'toRawLongValue [:long]]
+    [:invokestatic Pointer 'constructNonZero [:long Pointer]]
+    [:areturn]])
+
+
+(def ptr-cast
+  [[:invokestatic 'tech.v3.datatype.ffi.mmodel_jdk19$ptr_value
+      'invokeStatic [Object Object]]
+    [:checkcast MemoryAddress]])
+
+(def ptr?-cast
+  [[:invokestatic 'tech.v3.datatype.ffi.mmodel_jdk19$ptr_value_q
+      'invokeStatic [Object Object]]
+    [:checkcast Addressable]])
+
+(def ptr-return
+  (ffi-base/ptr-return
+    [[:invokeinterface MemoryAddress "toRawLongValue" [:long]]]))
+
+(defn emit-fn-def
+  [hdl-name rettype argtypes]
+  (->> (concat
+         [[:aload 0]
+           [:getfield :this hdl-name MethodHandle]]
+         (ffi-base/load-ffi-args ptr-cast ptr?-cast argtypes)
+         [[:invokevirtual MethodHandle "invokeExact"
+             (concat (map (partial ffi-base/argtype->insn
+                                   Addressable
+                                   :ptr-as-platform)
+                       argtypes)
+                     [(ffi-base/argtype->insn MemoryAddress
+                                               :ptr-as-platform
+                                               rettype)])]]
+         (ffi-base/exact-type-retval
+           rettype
+           (fn [_ptr-type]
+             ptr-return)))
+       (vec)))
+
+(defn define-mmodel-library
+  [classname fn-defs _symbols _options]
+  [{:name       classname
+     :flags      #{:public}
+     :interfaces [Library]
+     :fields     (->> (concat
+                        [{:name  "fnMap"
+                           :type  Object
+                           :flags #{:public :final}}
+                          {:name  "libraryImpl"
+                           :type  SymbolLookup
+                           :flags #{:public :final}}]
+                        (map (fn [[fn-name _fn-args]]
+                               {:name  (str (name fn-name) "_hdl")
+                                :type  MethodHandle
+                                :flags #{:public :final}})
+                          fn-defs))
+                      (vec))
+     :methods
+     (->> (concat
+            [{:name  :init
+               :flags #{:public}
+               :desc  [String :void]
+               :emit  (emit-lib-constructor fn-defs)}
+              {:name  :findSymbol
+               :flags #{:public}
+               :desc  [String Pointer]
+               :emit  (emit-find-symbol)}
+              (ffi-base/emit-library-fn-map classname fn-defs)
+              {:name :deref
+               :desc [Object]
+               :emit [[:aload 0]
+                       [:getfield :this "fnMap" Object]
+                       [:areturn]]}]
+            (map
+              (fn [[fn-name fn-data]]
+                (let [hdl-name (str (name fn-name) "_hdl")
+                      {:keys [rettype argtypes]} fn-data]
+                  {:name  fn-name
+                   :flags #{:public}
+                   :desc  (concat (map (partial ffi-base/argtype->insn
+                                                MemoryAddress
+                                                :ptr-as-obj)
+                                    argtypes)
+                                  [(ffi-base/argtype->insn MemoryAddress
+                                                            :ptr-as-ptr
+                                                            rettype)])
+                   :emit  (emit-fn-def hdl-name rettype argtypes)}))
+              fn-defs))
+          (vec))}])
+
+(defn define-library
+  [fn-defs symbols
+    {:keys [classname]
+     :as   options}]
+  (let [clsname (or classname (str "tech.v3.datatype.ffi.mmodel." (name (gensym))))]
+    (ffi-base/define-library fn-defs
+                             symbols
+                             clsname
+                             define-mmodel-library
+                             (or (:instantiate? options)
+                                 (not (boolean classname)))
+                             options)))
+
+(defn platform-ptr->ptr
+  [arg-idx]
+  [[:aload arg-idx]
+    [:invokeinterface MemoryAddress "toRawLongValue" [:long]]
+    [:invokestatic Pointer "constructNonZero" [:long Pointer]]])
+
+(defn define-foreign-interface
+  [rettype argtypes options]
+  (let [classname (or (:classname options)
+                      (symbol (str "tech.v3.datatype.ffi.mmodel.ffi_"
+                                   (name (gensym)))))
+        retval    (ffi-base/define-foreign-interface classname
+                                                     rettype
+                                                     argtypes
+                                                     {:src-ns-str "tech.v3.datatype.ffi.mmodel"
+                                                      :platform-ptr->ptr platform-ptr->ptr
+                                                      :ptr->platform-ptr
+                                                      (partial ffi-base/ptr->platform-ptr
+                                                               "tech.v3.datatype.ffi.mmodel"
+                                                               MemoryAddress)
+                                                      :ptrtype MemoryAddress})
+        iface-cls (:foreign-iface-class retval)
+        lookup    (MethodHandles/lookup)
+        sig       {:rettype  rettype
+                   :argtypes argtypes}]
+    (assoc retval
+      :method-handle (.findVirtual lookup
+                                   iface-cls
+                                   "invoke"
+                                   (sig->method-type
+                                     {:rettype  rettype
+                                      :argtypes argtypes}))
+      :fndesc        (sig->fdesc sig))))
+
+(defn foreign-interface-instance->c
+  [iface-def inst]
+  (let [linker  (Linker/nativeLinker)
+        new-hdn (.bindTo ^MethodHandle (:method-handle iface-def) inst)
+        mem-seg (.upcallStub
+                  linker
+                  new-hdn
+                  ^FunctionDescriptor (:fndesc iface-def)
+                  (MemorySession/global))]
+    (ffi/->pointer mem-seg)))
+
+(def ffi-fns
+  {:load-library                  load-library
+   :find-symbol                   find-symbol
+   :define-library                define-library
+   :define-foreign-interface      define-foreign-interface
+   :foreign-interface-instance->c foreign-interface-instance->c})