Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Defprotocol #12

Merged
merged 2 commits into from
Dec 24, 2023
Merged

Defprotocol #12

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
ed467f0
Working towards getting test coverage of alternate protocol impl.
cnuernber Dec 24, 2023
7d26a7a
Unit tests should be passing now.
cnuernber Dec 24, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 4 additions & 1 deletion java/ham_fisted/MethodImplCache.java
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,10 @@ public void extend(Class c, IFn fn) {
if(c == null)
nullExtension = fn;
else {
extensions.put(c, fn);
if(fn == null)
extensions.remove(c);
else
extensions.put(c, fn);
}
} finally {
extLock.unlock();
Expand Down
105 changes: 64 additions & 41 deletions src/ham_fisted/defprotocol.clj
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,21 +4,27 @@
and prefer normal def, defn definitions which themselves respond to static linking. This continues
work on cnuernber/clojure attempting to dramatically decrease startup times."
(:refer-clojure :exclude [defprotocol extend extend-type extend-protocol extends? satisfies?
find-protocol-method extenders])
find-protocol-method find-protocol-impl extenders])
(:import [ham_fisted MethodImplCache]))

(set! *warn-on-reflection* true)


(defn find-protocol-cache-method
[protocol ^MethodImplCache cache x]
(when cache
(let [cc (class x)]
(if (.isAssignableFrom (.-iface cache) cc)
(.-ifaceFn cache)
(if-let [mfn (when (get protocol :extend-via-metadata)
(get (meta x) (.-ns_methodk cache)))]
mfn
(.findFnFor cache cc))))))

(defn find-protocol-method
"It may be more efficient in a tight loop to bypass the protocol dispatch on a per-call basis."
([protocol methodk x]
(when-let [^MethodImplCache c (get (get protocol :method-caches) methodk)]
(let [cc (class x)]
(if (.isAssignableFrom (.-iface c) cc)
(.-ifaceFn c)
(if-let [mfn (when (:extend-via-metadata protocol)
(get (meta x) (.-ns_methodk c)))]
mfn
(.findFnFor c cc)))))))
(find-protocol-cache-method protocol @(get (get protocol :method-caches) methodk) x)))

(defn- protocol?
[maybe-p]
Expand All @@ -41,7 +47,9 @@
(defn satisfies?
"Returns true if x satisfies the protocol"
[protocol x]
(boolean (find-protocol-impl protocol x)))
(or (instance? (get protocol :on-interface) x)
(every? #(boolean (find-protocol-cache-method protocol % x))
(vals (get protocol :method-caches)))))

(defn- assert-same-protocol [protocol-var method-syms]
(doseq [m method-syms]
Expand All @@ -51,22 +59,28 @@
(binding [*out* *err*]
(println "Warning: protocol" protocol-var "is overwriting"
(if p
(str "method " (.sym v) " of protocol " (.sym p))
(str "function " (.sym v)))))))))
(str "method " (.sym ^clojure.lang.Var v) " of protocol " (.sym ^clojure.lang.Var p))
(str "function " (.sym ^clojure.lang.Var v)))))))))

(defn ^:no-doc find-fn
[target ^MethodImplCache cache]
[target ^MethodImplCache cache ns protocol]
(if-let [rv (.findFnFor cache (class target))]
rv
(throw (RuntimeException. (str "Failed to find specific overload: " (.-ns_methodk cache)
" for type " (class target))))))
(throw (IllegalArgumentException. (format
"No implementation of method: %s of protocol: #'%s/%s found for class: %s"
(.-methodk cache)
ns
protocol
(if-let [c (class target)]
(.getName ^Class c)
"nil"))))))

;;Instance check is already taken care of
(defn ^:no-doc find-fn-via-metadata
[target ns-method cache]
[target ns-method cache ns protocol]
(if-let [f (get (meta target) ns-method)]
f
(find-fn target cache)))
(find-fn target cache ns protocol)))


(defn- emit-protocol [name opts+sigs]
Expand All @@ -85,7 +99,7 @@
(not (contains? '#{int long float double char short byte boolean void
ints longs floats doubles chars shorts bytes booleans objects} tag))
(resolve tag))]
(symbol (.getName c))
(symbol (.getName ^Class c))
tag))
name-meta (update-in (meta (first s)) [:tag] tag-to-class)
mname (with-meta (first s) nil)
Expand All @@ -100,14 +114,20 @@
(when (m (keyword mname))
(throw (IllegalArgumentException. (str "Function " mname " in protocol " name " was redefined. Specify all arities in single definition."))))
(assoc m (keyword mname)
{:name (vary-meta mname assoc :doc doc :arglists arglists)
:methodk name-kwd
:ns-methodk (keyword (clojure.core/name (.-name *ns*))
(clojure.core/name mname))
:arglists arglists
:doc doc
:cache-sym (symbol (str "-" mname "-cache"))
:iface-sym (symbol (str "-" mname "-iface"))})))
(merge name-meta
{:name (vary-meta mname assoc :doc doc :arglists arglists
:tag (or (when-let [t (:tag name-meta)]
(if (instance? Class t)
t
(list 'quote t)))
(:tag (meta mname))))
:methodk name-kwd
:ns-methodk (keyword (clojure.core/name (.-name *ns*))
(clojure.core/name mname))
:arglists arglists
:doc doc
:cache-sym (symbol (str "-" mname "-cache"))
:iface-sym (symbol (str "-" mname "-iface"))}))))
{} sigs))
meths (mapcat (fn [sig]
(let [m (munge (:name sig))]
Expand All @@ -118,13 +138,13 @@
name (if-let [proto-doc (:doc opts)]
(with-meta name {:doc proto-doc})
name)]
(println "UPDATES!!")
`(do
(gen-interface :name ~iname :methods ~meths)
~@(mapcat (fn [{:keys [methodk ns-methodk cache-sym iface-sym arglists]
~@(mapcat (fn [{:keys [methodk ns-methodk cache-sym iface-sym arglists tag]
mname :name}]
[`(defn ~(with-meta iface-sym
{:private true})
{:private true
:tag (list 'quote tag)})
~@(map (fn [args]
(let [args (vec args) #_(mapv #(gensym (str %)) args)
target (first args)]
Expand All @@ -139,7 +159,7 @@
{:private true
:tag 'ham_fisted.MethodImplCache})
(ham_fisted.MethodImplCache. ~methodk ~ns-methodk ~iname ~iface-sym))
`(defn ~mname
`(defn ~mname {:hamf-protocol ~(list 'quote name)}
~@(map (fn [args]
(let [args (vec args) #_(mapv #(gensym (str %)) args)
target (first args)]
Expand All @@ -149,9 +169,12 @@
~(if (:extend-via-metadata opts)
`((find-fn-via-metadata ~target
~ns-methodk
~cache-sym)
~cache-sym
~(list 'quote (.-name *ns*))
~(list 'quote name))
~@args)
`((find-fn ~target ~cache-sym)
`((find-fn ~target ~cache-sym ~(list 'quote (.-name *ns*))
~(list 'quote name))
~@args))))))
arglists))])
(vals sigs))
Expand All @@ -167,6 +190,7 @@
(list 'quote sym))
arglist))
arglists)))
(update :tag (fn [t] (when t (list 'quote t))))
(update :name #(list 'quote %)))]))
(into {}))))
:method-caches (->> (map (fn [{:keys [methodk cache-sym]}]
Expand Down Expand Up @@ -285,16 +309,15 @@
(throw (IllegalArgumentException.
(str atype " already directly implements " (:on-interface proto)))))
(let [impls (:impls proto)
method-caches (:method-caches proto)
mmap-iter (.iterator (.entrySet ^java.util.Map mmap))]
method-caches (:method-caches proto)]
(swap! impls assoc atype mmap)
(loop [c? (.hasNext mmap-iter)]
(when c?
(let [e (.next mmap-iter)]
(if-let [cache (get method-caches (key e))]
(.extend ^MethodImplCache @cache atype (val e))
(throw (RuntimeException. (str "Unable to find protocol method for " (key e)))))
(recur (.hasNext mmap-iter))))))))
(loop [^clojure.lang.ISeq es (clojure.lang.RT/seq method-caches)]
(when es
(let [e (.first es)
methodk (key e)]
;;Note the method cache has to handle potentially nil values.
(.extend ^MethodImplCache @(val e) atype (mmap methodk))
(recur (.next es))))))))

(defn- emit-impl [[p fs]]
[p (zipmap (map #(-> % first keyword) fs)
Expand Down
Loading