Skip to content

Commit

Permalink
Replace Clojure functions that contain metadata with custom FnWithMeta (
Browse files Browse the repository at this point in the history 
#150)

* Attempt at widening the arities for multimethod calls

There's a lot of `apply`/`RestFn`/`invoke` etc. dynamic call machinery
in Methodical's stack traces. This is an attempt to remove some of it
by going up to 7 direct args for multimethod calls. (And dispatch
functions.)

This hasn't removed much of the `apply` overhead in practice because
`with-meta` on a function wraps it with a naive function subclass that
always does a dynamic call. There are probably still some places that
more dynamic calls are creeping in, but I ran out of time to dig
deeper.

This may not go anywhere until I get back, but I wanted to publish this
just in case.

* Fix tests after widening arities

marg

* Introduce custom FnWithMeta to attach metadata to functions

* Reimplement threaded combinator with explicit first/last separation

---------

Co-authored-by: Braden Shepherdson <[email protected]>
  • Loading branch information
@alexander-yakushev @bshepherdson
alexander-yakushev and bshepherdson authored Aug 14, 2024
1 parent 2e8f8f5 commit 5e24b0c
Show file tree
Hide file tree
Showing 22 changed files with 394 additions and 212 deletions.
3 changes: 2 additions & 1 deletion .clj-kondo/config.edn
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,8 @@

:unresolved-symbol
{:exclude
[(clojure.test/is [macroexpansion-spec-error?])]}
[->FnWithMeta FnWithMeta
(clojure.test/is [macroexpansion-spec-error?])]}

:consistent-alias
{:aliases
Expand Down
43 changes: 29 additions & 14 deletions src/methodical/impl/combo/clos.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,34 +22,49 @@
combined-method
(fn
([]
(doseq [f befores]
(f))
(doseq [before befores]
(before))
(combined-method))

([a]
(doseq [f befores]
(f a))
(doseq [before befores]
(before a))
(combined-method a))

([a b]
(doseq [f befores]
(f a b))
(doseq [before befores]
(before a b))
(combined-method a b))

([a b c]
(doseq [f befores]
(f a b c))
(doseq [before befores]
(before a b c))
(combined-method a b c))

([a b c d]
(doseq [f befores]
(f a b c d))
(doseq [before befores]
(before a b c d))
(combined-method a b c d))

([a b c d & more]
(doseq [f befores]
(apply f a b c d more))
(apply combined-method a b c d more)))))
([a b c d e]
(doseq [before befores]
(before a b c d e))
(combined-method a b c d e))

([a b c d e f]
(doseq [before befores]
(before a b c d e f))
(combined-method a b c d e f))

([a b c d e f g]
(doseq [before befores]
(before a b c d e f g))
(combined-method a b c d e f g))

([a b c d e f g & more]
(doseq [before befores]
(apply before a b c d e f g more))
(apply combined-method a b c d e f g more)))))

(defn- apply-afters [combined-method afters]
(if (empty? afters)
Expand Down
96 changes: 92 additions & 4 deletions src/methodical/impl/combo/common.clj
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,91 @@
(ns methodical.impl.combo.common
"Utility functions for implementing method combinations.")
"Utility functions for implementing method combinations."
(:require [methodical.util :as u]))

(defn partial*
"[[clojure.core/partial]] but with more direct arities."
([inner] inner)
([inner a]
(fn
([] (inner a))
([p] (inner a p))
([p q] (inner a p q))
([p q r] (inner a p q r))
([p q r s] (inner a p q r s))
([p q r s t] (inner a p q r s t))
([p q r s t u] (inner a p q r s t u))
([p q r s t u v] (inner a p q r s t u v))
([p q r s t u v x] (inner a p q r s t u v x))
([p q r s t u v x y] (inner a p q r s t u v x y))
([p q r s t u v x y & z] (apply inner a p q r s t u v x y z))))
([inner a b]
(fn
([] (inner a b))
([p] (inner a b p))
([p q] (inner a b p q))
([p q r] (inner a b p q r))
([p q r s] (inner a b p q r s))
([p q r s t] (inner a b p q r s t))
([p q r s t u] (inner a b p q r s t u))
([p q r s t u v] (inner a b p q r s t u v))
([p q r s t u v x] (inner a b p q r s t u v x))
([p q r s t u v x y] (inner a b p q r s t u v x y))
([p q r s t u v x y & z] (apply inner a b p q r s t u v x y z))))
([inner a b c]
(fn
([] (inner a b c))
([p] (inner a b c p))
([p q] (inner a b c p q))
([p q r] (inner a b c p q r))
([p q r s] (inner a b c p q r s))
([p q r s t] (inner a b c p q r s t))
([p q r s t u] (inner a b c p q r s t u))
([p q r s t u v] (inner a b c p q r s t u v))
([p q r s t u v x] (inner a b c p q r s t u v x))
([p q r s t u v x y] (inner a b c p q r s t u v x y))
([p q r s t u v x y & z] (apply inner a b c p q r s t u v x y z))))
([inner a b c d]
(fn
([] (inner a b c d))
([p] (inner a b c d p))
([p q] (inner a b c d p q))
([p q r] (inner a b c d p q r))
([p q r s] (inner a b c d p q r s))
([p q r s t] (inner a b c d p q r s t))
([p q r s t u] (inner a b c d p q r s t u))
([p q r s t u v] (inner a b c d p q r s t u v))
([p q r s t u v x] (inner a b c d p q r s t u v x))
([p q r s t u v x y] (inner a b c d p q r s t u v x y))
([p q r s t u v x y & z] (apply inner a b c d p q r s t u v x y z))))
([inner a b c d e]
(fn
([] (inner a b c d e))
([p] (inner a b c d e p))
([p q] (inner a b c d e p q))
([p q r] (inner a b c d e p q r))
([p q r s] (inner a b c d e p q r s))
([p q r s t] (inner a b c d e p q r s t))
([p q r s t u] (inner a b c d e p q r s t u))
([p q r s t u v] (inner a b c d e p q r s t u v))
([p q r s t u v x] (inner a b c d e p q r s t u v x))
([p q r s t u v x y] (inner a b c d e p q r s t u v x y))
([p q r s t u v x y & z] (apply inner a e b c d p q r s t u v x y z))))
([inner a b c d e f]
(fn
([] (inner a b c d e f))
([p] (inner a b c d e f p))
([p q] (inner a b c d e f p q))
([p q r] (inner a b c d e f p q r))
([p q r s] (inner a b c d e f p q r s))
([p q r s t] (inner a b c d e f p q r s t))
([p q r s t u] (inner a b c d e f p q r s t u))
([p q r s t u v] (inner a b c d e f p q r s t u v))
([p q r s t u v x] (inner a b c d e f p q r s t u v x))
([p q r s t u v x y] (inner a b c d e f p q r s t u v x y))
([p q r s t u v x y & z] (apply inner a e f b c d p q r s t u v x y z))))
([inner a b c d e f & more]
(fn [& args]
(inner a b c d e f (concat more args)))))

(defn combine-primary-methods
"Combine all `primary-methods` into a single combined method. Each method is partially bound with a `next-method`
Expand All @@ -8,7 +94,8 @@
(when (seq primary-methods)
(reduce
(fn [next-method primary-method]
(with-meta (partial primary-method next-method) (meta primary-method)))
(u/fn-with-meta (partial* (u/unwrap-fn-with-meta primary-method) next-method)
(meta primary-method)))
nil
(reverse primary-methods))))

Expand All @@ -19,7 +106,8 @@
[combined-method around-methods]
(reduce
(fn [combined-method around-method]
(with-meta (partial around-method combined-method) (meta around-method)))
(u/fn-with-meta (partial* (u/unwrap-fn-with-meta around-method) combined-method)
(meta around-method)))
combined-method
around-methods))

Expand All @@ -36,7 +124,7 @@
(apply f fn-tail)

(vector? (ffirst fn-tail))
(map (partial transform-fn-tail f) fn-tail)
(map (partial* transform-fn-tail f) fn-tail)

:else
(throw (ex-info (format "Invalid fn tail: %s. Expected ([arg*] & body) or (([arg*] & body)+)"
Expand Down
127 changes: 60 additions & 67 deletions src/methodical/impl/combo/threaded.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@
[clojure.core.protocols :as clojure.protocols]
[methodical.impl.combo.common :as combo.common]
[methodical.interface]
[methodical.util :as u]
[methodical.util.describe :as describe]
[pretty.core :as pretty])
(:import
Expand All @@ -13,71 +14,61 @@

(comment methodical.interface/keep-me)

(defn reducer-fn
"Reduces a series of before/combined-primary/after methods, threading the resulting values to the next method by
calling the `invoke` function, which is generated by `threaded-invoker`."
[before-primary-after-methods]
(fn [[initial-value invoke]]
(reduce
(fn [last-result method]
(invoke method last-result))
initial-value
before-primary-after-methods)))

(defn combine-with-threader
"Combine primary and auxiliary methods using a threading invoker, i.e. something you'd get by calling
`threading-invoker`. The way these methods are combined/reduced is the same, regardless of how args are threaded;
thus, various strategies such as `:thread-first` and `:thread-last` can both share the same `reducer-fn`."
([threader before-primary-afters]
(comp (reducer-fn before-primary-afters) threader))

([threader primary-methods {:keys [before after around]}]
(when-let [primary (combo.common/combine-primary-methods primary-methods)]
(let [methods (concat before [primary] (reverse after))
threaded-fn (combine-with-threader threader methods)
optimized-one-arg-fn (apply comp (reverse methods))]
(combo.common/apply-around-methods
(-> (fn
([] (optimized-one-arg-fn))
([a] (optimized-one-arg-fn a))
([a b] (threaded-fn a b))
([a b c] (threaded-fn a b c))
([a b c d] (threaded-fn a b c d))
([a b c d & more] (apply threaded-fn a b c d more)))
(vary-meta assoc :methodical/combined-method? true))
around)))))

(defmulti threading-invoker
"Define a new 'threading invoker', which define how before/combined-primary/after methods should thread values to
subsequent methods. These methods take the initial values used to invoke a multifn, then return a pair like
`[initial-value threading-fn]`. The threading function is used to invoke any subsequent methods using only q single
value, the result of the previous method; if effectively partially binds subsequent methods so that they are always
invoked with the initial values of this invocation, excluding the threaded value."
{:arglists '([threading-type])}
keyword)

(defmethod threading-invoker :thread-first
[_]
(fn
([a b] [a (fn [method a*] (method a* b))])
([a b c] [a (fn [method a*] (method a* b c))])
([a b c d] [a (fn [method a*] (method a* b c d))])
([a b c d & more] [a (fn [method a*] (apply method a* b c d more))])))

(defmethod threading-invoker :thread-last
[_]
(fn
([a b] [b (fn [method b*] (method a b*))])
([a b c] [c (fn [method c*] (method a b c*))])
([a b c d] [d (fn [method d*] (method a b c d*))])

([a b c d & more]
(let [last-val (last more)
butlast* (vec (concat [a b c d] (butlast more)))]
[last-val
(fn [method last*]
(apply method (conj butlast* last*)))]))))

(defn combine-methods-thread-first
"Combine primary and auxiliary methods using a thread-first threading type."
[primary-methods {:keys [before after around]}]
(when-let [primary (combo.common/combine-primary-methods primary-methods)]
(combo.common/apply-around-methods
(if (and (empty? before) (empty? after))
;; If there is only the combined primary method, skip the wrapping dance and just return it.
primary

(let [methods (concat before [primary] (reverse after))]
(-> (reduce
(fn [current nxt]
(let [nxt (u/unwrap-fn-with-meta nxt)]
(fn combined-method-thread-first
([] (current) (nxt))
([a] (nxt (current a)))
([a b] (nxt (current a b) b))
([a b c] (nxt (current a b c) b c))
([a b c d] (nxt (current a b c d) b c d))
([a b c d e] (nxt (current a b c d e) b c d e))
([a b c d e f] (nxt (current a b c d e f) b c d e f))
([a b c d e f g] (nxt (current a b c d e f g) b c d e f g))
([a b c d e f g & more] (apply nxt (apply current a b c d e f g more) b c d e f g more)))))
(u/unwrap-fn-with-meta (first methods))
(rest methods))
(u/fn-vary-meta assoc :methodical/combined-method? true))))
around)))

(defn combine-methods-thread-last
"Combine primary and auxiliary methods using a thread-last threading type."
[primary-methods {:keys [before after around]}]
(when-let [primary (combo.common/combine-primary-methods primary-methods)]
(combo.common/apply-around-methods
(if (and (empty? before) (empty? after))
;; If there is only the combined primary method, skip the wrapping dance and just return it.
primary

(let [methods (concat before [primary] (reverse after))]
(-> (reduce
(fn [current nxt]
(let [nxt (u/unwrap-fn-with-meta nxt)]
(fn combined-method-thread-last
([] (current) (nxt))
([a] (nxt (current a)))
([a b] (nxt a (current a b)))
([a b c] (nxt a b (current a b c)))
([a b c d] (nxt a b c (current a b c d)))
([a b c d e] (nxt a b c d (current a b c d e)))
([a b c d e f] (nxt a b c d e (current a b c d e f)))
([a b c d e f g] (nxt a b c d e f (current a b c d e f g)))
([a b c d e f g & more] (apply nxt a b c d e f g (concat (butlast more) [(apply current a b c d e f g more)]))))))
(u/unwrap-fn-with-meta (first methods))
(rest methods))
(u/fn-vary-meta assoc :methodical/combined-method? true))))
around)))

(deftype ThreadingMethodCombination [threading-type]
pretty/PrettyPrintable
Expand All @@ -95,7 +86,9 @@
#{nil :before :after :around})

(combine-methods [_ primary-methods aux-methods]
(combine-with-threader (threading-invoker threading-type) primary-methods aux-methods))
(case threading-type
:thread-first (combine-methods-thread-first primary-methods aux-methods)
:thread-last (combine-methods-thread-last primary-methods aux-methods)))

(transform-fn-tail [_ qualifier fn-tail]
(combo.common/add-implicit-next-method-args qualifier fn-tail))
Expand All @@ -115,5 +108,5 @@
"Create a new `ThreadingMethodCombination` using the keyword `threading-type` strategy, e.g. `:thread-first` or
`:thread-last`."
[threading-type]
{:pre [(get-method threading-invoker threading-type)]}
{:pre [(#{:thread-first :thread-last} threading-type)]}
(ThreadingMethodCombination. threading-type))
20 changes: 12 additions & 8 deletions src/methodical/impl/dispatcher/everything.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@
[clojure.core.protocols :as clojure.protocols]
[methodical.impl.dispatcher.common :as dispatcher.common]
[methodical.interface :as i]
[methodical.util :as u]
[methodical.util.describe :as describe]
[pretty.core :as pretty])
(:import
Expand Down Expand Up @@ -32,26 +33,29 @@
(= prefs (.prefs another))))))

Dispatcher
(dispatch-value [_] nil)
(dispatch-value [_ _a] nil)
(dispatch-value [_ _a _b] nil)
(dispatch-value [_ _a _b _c] nil)
(dispatch-value [_ _a _b _c _d] nil)
(dispatch-value [_ _a _b _c _d _more] nil)
(dispatch-value [_] nil)
(dispatch-value [_ _a] nil)
(dispatch-value [_ _a _b] nil)
(dispatch-value [_ _a _b _c] nil)
(dispatch-value [_ _a _b _c _d] nil)
(dispatch-value [_ _a _b _c _d _e] nil)
(dispatch-value [_ _a _b _c _d _e _f] nil)
(dispatch-value [_ _a _b _c _d _e _f _g] nil)
(dispatch-value [_ _a _b _c _d _e _f _g _more] nil)

(matching-primary-methods [_ method-table _]
(let [primary-methods (i/primary-methods method-table)
comparatorr (dispatcher.common/domination-comparator (deref hierarchy-var) prefs)]
(for [[dispatch-value method] (sort-by first comparatorr primary-methods)]
(vary-meta method assoc :dispatch-value dispatch-value))))
(u/fn-vary-meta method assoc :dispatch-value dispatch-value))))

(matching-aux-methods [_ method-table _]
(let [aux-methods (i/aux-methods method-table)
comparatorr (dispatcher.common/domination-comparator (deref hierarchy-var) prefs)]
(into {} (for [[qualifier dispatch-value->methods] aux-methods]
[qualifier (for [[dispatch-value methods] (sort-by first comparatorr dispatch-value->methods)
method methods]
(vary-meta method assoc :dispatch-value dispatch-value))]))))
(u/fn-vary-meta method assoc :dispatch-value dispatch-value))]))))

(default-dispatch-value [_]
nil)
Expand Down
Loading

0 comments on commit 5e24b0c

Please sign in to comment.