From 61d291e9bbed726332d8ae8d3b859cfa24560822 Mon Sep 17 00:00:00 2001 From: Ryan Smith Date: Mon, 19 Jul 2021 12:06:26 -0700 Subject: [PATCH] Add ability to specify a function doesn't need args fully resolved inside `let-flow` Some functions, like `d/alt` are designed to handle deferrables as arguments. `let-flow` shouldn't wait on args to functions like these to have been resolved before invoking the function. With this change set, all the functions inside `manifold.deferred` that are designed to work with deferrables will now behave as "expected" inside a `let-flow` block. Users can mark their own functions with the metadata `manifold.deferred/deferred-args` to have `let-flow` treat those the same way. --- src/manifold/deferred.clj | 61 +++++++++++++++++++++++---------- test/manifold/deferred_test.clj | 52 +++++++++++++++++++++++++++- 2 files changed, 94 insertions(+), 19 deletions(-) diff --git a/src/manifold/deferred.clj b/src/manifold/deferred.clj index 6cddce75..104f4292 100644 --- a/src/manifold/deferred.clj +++ b/src/manifold/deferred.clj @@ -931,7 +931,7 @@ ([x f g & fs] (apply chain- nil x f g fs))) -(defn catch' +(defn ^::deferred-args catch' "Like `catch`, but does not coerce deferrable values." ([x error-handler] (catch' x nil error-handler)) @@ -966,7 +966,7 @@ d')))))) -(defn catch +(defn ^::deferred-args catch "An equivalent of the catch clause, which takes an `error-handler` function that will be invoked with the exception, and whose return value will be yielded as a successful outcome. If an `error-class` is specified, only exceptions of that type will be caught. If not, all exceptions @@ -988,7 +988,7 @@ chain) x))) -(defn finally' +(defn ^::deferred-args finally' "Like `finally`, but doesn't coerce deferrable values." [x f] (success-error-unrealized x @@ -1019,7 +1019,7 @@ (error! d e)))) d))) -(defn finally +(defn ^::deferred-args finally "An equivalent of the finally clause, which takes a no-arg side-effecting function that executes no matter what the result." [x f] @@ -1027,7 +1027,7 @@ (finally' d f) (finally' x f))) -(defn zip' +(defn ^::deferred-args zip' "Like `zip`, but only unwraps Manifold deferreds." {:inline (fn [x] `(chain' ~x vector)) :inline-arities #{1}} @@ -1075,7 +1075,7 @@ (.decrementAndGet counter) (recur d idx' rst)))))))) -(defn zip +(defn ^::deferred-args zip "Takes a list of values, some of which may be deferrable, and returns a deferred that will yield a list of realized values. @@ -1101,7 +1101,7 @@ (aset a j i) (recur (inc i))))))) -(defn alt' +(defn ^::deferred-args alt' "Like `alt`, but only unwraps Manifold deferreds." [& vals] (let [d (deferred) @@ -1122,7 +1122,7 @@ (success! d x))))) d)) -(defn alt +(defn ^::deferred-args alt "Takes a list of values, some of which may be deferrable, and returns a deferred that will yield the value which was realized first. @@ -1276,18 +1276,36 @@ ;;; -(defn- back-references [marker form] +(defn- ignore-symbol? + "If the metadata of a symbol indicates that it's args can all be deffereds, + then the symbol can be skipped for back-references purposes." + [s] + (when (and (symbol? s) + (not (contains? (compiler/locals) s))) + (-> s resolve meta ::deferred-args))) + +(defn- back-references + "When used in the let bindings, always calculate all back references to guarantee + consistency of arg names in later forms. For use in the body, we can skip S-expressions + who's operator matches `ignore-symbol?`." + [body? marker form] (let [syms (atom #{})] (walk/walk-exprs - symbol? + (fn [expr] + (or (and body? + (seq? expr) + (ignore-symbol? (first expr))) + (symbol? expr))) (fn [s] (when (some-> (compiler/locals) (find s) key meta (get marker)) (swap! syms conj s))) + ignore-symbol? form) @syms)) (defn- expand-let-flow [chain-fn zip-fn bindings body] - (let [[_ bindings & body] (walk/macroexpand-all `(let ~bindings ~@body)) + (let [orig-body body + [_ bindings & body] (walk/walk-exprs (constantly false) nil ignore-symbol? `(let ~bindings ~@body)) locals (keys (compiler/locals)) vars (->> bindings (partition 2) (map first)) marker (gensym) @@ -1307,7 +1325,7 @@ (fn [n form] (map (zipmap vars' (take n gensyms)) - (back-references marker form))) + (back-references false marker form))) (range)))) binding-dep? (->> gensym->deps vals (apply concat) set) @@ -1315,7 +1333,7 @@ vars' (repeat nil))] ~@body) - (back-references marker) + (back-references true marker) (concat vars) (map (zipmap vars' gensyms)) set) @@ -1324,13 +1342,20 @@ (manifold.executor/with-executor nil (let [~@(mapcat (fn [n var val gensym] - (let [deps (gensym->deps gensym)] + (let [deps (gensym->deps gensym) + ignore-deps? (and (seq? val) + (symbol (first val)) + (ignore-symbol? (first val)))] (if (empty? deps) (when (dep? gensym) [gensym val]) [gensym - `(~chain-fn (~zip-fn ~@deps) - (bound-fn [[~@(map gensym->var deps)]] + ;; don't wait for args to a function if the function can directly work + ;; with deferrables + `(~chain-fn (if ~ignore-deps? + [~@deps] + (~zip-fn ~@deps)) + (bound-fn [[~@(map gensym->var deps)]] ~val))]))) (range) vars' @@ -1340,7 +1365,7 @@ (bound-fn [[~@(map gensym->var body-dep?)]] ~@body))))))) -(defmacro let-flow +(defmacro ^::deferred-args let-flow "A version of `let` where deferred values that are let-bound or closed over can be treated as if they are realized values. The body will only be executed once all of the let-bound values, even ones only used for side effects, have been computed. @@ -1364,7 +1389,7 @@ bindings body)) -(defmacro let-flow' +(defmacro ^::deferred-args let-flow' "Like `let-flow`, but only for Manifold deferreds." [bindings & body] (expand-let-flow diff --git a/test/manifold/deferred_test.clj b/test/manifold/deferred_test.clj index ac4eacdc..76331557 100644 --- a/test/manifold/deferred_test.clj +++ b/test/manifold/deferred_test.clj @@ -118,7 +118,57 @@ (is (= ["cat" "cat" "cat"] @(d/let-flow [a d b (do a *test-dynamic-var*)] - [a b *test-dynamic-var*]))))))) + [a b *test-dynamic-var*])))))) + + (let [start (System/currentTimeMillis) + future-timeout (d/future (Thread/sleep 500) "b") + expected (d/future (Thread/sleep 5) "cat")] + @(d/let-flow [x (d/alt future-timeout expected)] + x) + + (is (>= 300 (- (System/currentTimeMillis) start)) + "Alt in let-flow should only take as long as the first deferred to finish.")) + + (is (every? #(= "cat" %) + (for [i (range 50)] + (let [future-timeout (d/future (Thread/sleep 100) "b") + expected (d/future (Thread/sleep 5) "cat")] + @(d/let-flow [x (d/alt future-timeout expected)] + x)))) + "Resolution of deferreds in alt inside a let-flow should always be consistent.") + + (let [start (System/currentTimeMillis) + future-timeout (d/future (Thread/sleep 300) "b") + expected (d/future (Thread/sleep 5) "cat")] + (is (= "cat" + @(d/let-flow [x (d/alt future-timeout expected) + y (d/alt x future-timeout)] + (d/alt future-timeout y))) + "Alts referencing newly introduced symbols shouldn't cause compiler errors.") + (is (>= 200 (- (System/currentTimeMillis) start)) + "Alt in body should only take as long as the first deferred to finish.")) + + (is (= ::timeout + @(d/let-flow [x (d/timeout! (d/future (Thread/sleep 1000) "cat") 50 ::timeout)] + x)) + "Timeouts introduced in let-flow should be respected.") + + (let [start (System/currentTimeMillis) + slow (d/future (Thread/sleep 300) "slow") + fast (d/future (Thread/sleep 5) "fast")] + (is (= "fast" + @(d/let-flow [x "cat"] + (d/let-flow [z (d/alt slow fast)] + z))) + "let-flow's should behave identically inside the body of another let-flow") + (is (= "fast" + @(d/let-flow [x "cat" + y (d/let-flow [z (d/alt slow fast)] + z)] + y)) + "let-flow's should behave identically inside the bindings of another let-flow") + (is (>= 200 (- (System/currentTimeMillis) start)) + "let-flow's should behave identically inside another let-flow"))) (deftest test-chain-errors (let [boom (fn [n] (throw (ex-info "" {:n n})))]