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

Add ability to specify a function doesn't need args fully resolved when used inside let-flow #203

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Add ability to specify a function doesn't need args fully resolved when used inside let-flow #203

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
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
61 changes: 43 additions & 18 deletions src/manifold/deferred.clj
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -1019,15 +1019,15 @@
(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]
(if-let [d (->deferred x nil)]
(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}}
Expand Down Expand Up @@ -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.

Expand All @@ -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)
Expand All @@ -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.

Expand Down Expand Up @@ -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)
Expand All @@ -1307,15 +1325,15 @@
(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)

body-dep? (->> `(let [~@(interleave
vars'
(repeat nil))]
~@body)
(back-references marker)
(back-references true marker)
(concat vars)
(map (zipmap vars' gensyms))
set)
Expand All @@ -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'
Expand All @@ -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.
Expand All @@ -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
Expand Down
52 changes: 51 additions & 1 deletion test/manifold/deferred_test.clj
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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."))
Comment on lines +148 to +149
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't think we can make this change for let-flow bodies, only bindings. The docstring explicitly says "The body will only be executed once all of the let-bound
values, even ones only used for side effects, have been computed.", and some users may be relying on that.

More generally, an alt in the body only makes sense if some of its arguments aren't bound in the let-flow. If all of them are, then it's essentially random, which is fine, but may not be what they expect.


(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})))]
Expand Down