Optional interruption support #1039
+294
−9
There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,176 @@ | ||
| (ns sci.impl.interruptible | ||
| {:no-doc true} | ||
| (:require | ||
| [sci.ctx-store :as store] | ||
| [sci.impl.utils :as utils])) | ||
|
|
||
| (defn- get-ifn [] | ||
| (:interrupt-fn (store/get-ctx))) | ||
|
|
||
| ;;; Producers — lazy sequences that fire interrupt-fn on each step | ||
|
|
||
| (defn- range-seq [start end step ifn] | ||
| (let [pred (cond | ||
| (nil? end) (constantly true) | ||
| (pos? step) #(< % end) | ||
| (neg? step) #(> % end) | ||
| :else (constantly false))] | ||
| (letfn [(gen [i] | ||
| (lazy-seq | ||
| (when (pred i) | ||
| (ifn) | ||
| (cons i (gen (+ i step))))))] | ||
| (gen start)))) | ||
|
|
||
| (defn- sci-range | ||
| ([] (let [ifn (get-ifn)] (if ifn (range-seq 0 nil 1 ifn) (range)))) | ||
| ([end] (let [ifn (get-ifn)] (if ifn (range-seq 0 end 1 ifn) (range end)))) | ||
| ([start end] | ||
| (let [ifn (get-ifn)] (if ifn (range-seq start end 1 ifn) (range start end)))) | ||
| ([start end step] | ||
| (let [ifn (get-ifn)] (if ifn (range-seq start end step ifn) (range start end step))))) | ||
|
|
||
| (defn- sci-repeat | ||
| ([x] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (repeat x) | ||
| (letfn [(gen [] (lazy-seq (ifn) (cons x (gen))))] | ||
| (gen))))) | ||
| ([n x] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (repeat n x) | ||
| (letfn [(gen [i] | ||
| (lazy-seq | ||
| (when (pos? i) | ||
| (ifn) | ||
| (cons x (gen (dec i))))))] | ||
| (gen n)))))) | ||
|
|
||
| (defn- sci-cycle [coll] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (cycle coll) | ||
| (when (seq coll) | ||
| (letfn [(gen [s] | ||
| (lazy-seq | ||
| (ifn) | ||
| (let [cur (or (seq s) (seq coll))] | ||
| (cons (first cur) (gen (rest cur))))))] | ||
| (gen coll)))))) | ||
|
|
||
| (defn- sci-iterate [f x] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (iterate f x) | ||
| (letfn [(gen [v] | ||
| (lazy-seq | ||
| (ifn) | ||
| (cons v (gen (f v)))))] | ||
| (gen x))))) | ||
|
|
||
| ;;; Materializers — consuming functions that fire interrupt-fn per element | ||
|
|
||
| (defn- sci-dorun | ||
| ([coll] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (dorun coll) | ||
| (loop [s (seq coll)] | ||
| (when s | ||
| (ifn) | ||
| (recur (next s))))))) | ||
| ([n coll] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (dorun n coll) | ||
| (loop [s (seq coll) i 0] | ||
| (when (and s (< i n)) | ||
| (ifn) | ||
| (recur (next s) (inc i)))))))) | ||
|
|
||
| (defn- sci-doall | ||
| ([coll] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (doall coll) | ||
| (do (loop [s (seq coll)] | ||
| (when s (ifn) (recur (next s)))) | ||
| coll)))) | ||
| ([n coll] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (doall n coll) | ||
| (do (loop [s (seq coll) i 0] | ||
| (when (and s (< i n)) (ifn) (recur (next s) (inc i)))) | ||
| coll))))) | ||
|
|
||
| (defn- sci-count [coll] | ||
| (let [ifn (get-ifn)] | ||
| (if (or (not ifn) (counted? coll)) | ||
| (count coll) | ||
| (loop [s (seq coll) n 0] | ||
| (if s | ||
| (do (ifn) (recur (next s) (inc n))) | ||
| n))))) | ||
|
|
||
| (defn- sci-into | ||
| ([to from] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (into to from) | ||
| (reduce (fn [acc x] (ifn) (conj acc x)) to from)))) | ||
| ([to xf from] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (into to xf from) | ||
| (transduce (comp (map (fn [x] (ifn) x)) xf) conj to from))))) | ||
|
|
||
| (defn- sci-reduce | ||
| ([f coll] | ||
| (let [ifn (get-ifn) | ||
| s (seq coll)] | ||
| (if-not ifn | ||
| (reduce f coll) | ||
| (if s | ||
| (loop [v (first s) s (next s)] | ||
| (if s | ||
| (do (ifn) | ||
| (let [ret (f v (first s))] | ||
| (if (reduced? ret) @ret (recur ret (next s))))) | ||
| v)) | ||
| (f))))) | ||
| ([f init coll] | ||
| (let [ifn (get-ifn)] | ||
| (if-not ifn | ||
| (reduce f init coll) | ||
| (loop [v init s (seq coll)] | ||
| (if s | ||
| (do (ifn) | ||
| (let [ret (f v (first s))] | ||
| (if (reduced? ret) @ret (recur ret (next s))))) | ||
| v)))))) | ||
|
|
||
| ;;; Installation | ||
|
|
||
| (defn install! | ||
| "Replaces dangerous host functions in the clojure.core namespace with | ||
| interruptible versions. Called by opts/init when :interrupt-fn is set." | ||
| [env] | ||
| (swap! env | ||
| (fn [e] | ||
| (let [core (get-in e [:namespaces 'clojure.core]) | ||
| ns-obj (:ns (meta (get core 'range))) | ||
| mk (fn [sym f] | ||
| (utils/new-var sym f {:ns ns-obj :name sym :sci/built-in true}))] | ||
| (update-in e [:namespaces 'clojure.core] merge | ||
| {'range (mk 'range sci-range) | ||
| 'repeat (mk 'repeat sci-repeat) | ||
| 'cycle (mk 'cycle sci-cycle) | ||
| 'iterate (mk 'iterate sci-iterate) | ||
| 'doall (mk 'doall sci-doall) | ||
| 'dorun (mk 'dorun sci-dorun) | ||
| 'count (mk 'count sci-count) | ||
| 'into (mk 'into sci-into) | ||
| 'reduce (mk 'reduce sci-reduce)}))))) |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,94 @@ | ||
| (ns sci.interrupt-fn-test | ||
| (:require | ||
| [clojure.test :refer [deftest is testing]] | ||
| [sci.core :as sci])) | ||
|
|
||
| (defn limit-interrupt [n] | ||
| (let [counter (atom 0)] | ||
| (fn [] | ||
| (when (> (swap! counter inc) n) | ||
| (throw (ex-info "interrupted" {:type :interrupt})))))) | ||
|
|
||
| (deftest loop-forms-test | ||
| (testing "interrupt-fn fires in loop/recur and derived forms (dotimes, while)" | ||
| (let [ctx (sci/init {:interrupt-fn (limit-interrupt 500)})] | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* ctx "(loop [] (recur))"))) | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* (sci/init {:interrupt-fn (limit-interrupt 500)}) | ||
| "(dotimes [_ 1000000] nil)")))))) | ||
|
|
||
| (deftest mutual-recursion-test | ||
| (testing "interrupt-fn fires on every fn entry, catching mutual recursion" | ||
| (let [ctx (sci/init {:interrupt-fn (limit-interrupt 200)})] | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* ctx "(declare b) (defn a [] (b)) (defn b [] (a)) (a)")))))) | ||
|
|
||
| (deftest direct-recursion-no-recur-test | ||
| (testing "interrupt-fn fires on fn entry for non-recur self-calls" | ||
| ;; low limit to fire well before JVM stack overflow | ||
| (let [ctx (sci/init {:interrupt-fn (limit-interrupt 50)})] | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* ctx "(defn f [] (f)) (f)")))))) | ||
|
|
||
| (deftest no-interrupt-fn-test | ||
| (testing "absent interrupt-fn does not affect execution" | ||
| (let [ctx (sci/init {})] | ||
| (is (= 10 (sci/eval-string* ctx "(loop [i 0] (if (= i 10) i (recur (inc i))))"))) | ||
| (is (= 99 (sci/eval-string* ctx "(dotimes [i 100] i) 99")))))) | ||
|
|
||
| (deftest normal-completion-under-budget-test | ||
| (testing "execution completes normally when budget is not exceeded" | ||
| (let [ctx (sci/init {:interrupt-fn (limit-interrupt 10000)})] | ||
| (is (= 100 (sci/eval-string* ctx "(loop [i 0] (if (= i 100) i (recur (inc i))))"))) | ||
| (is (= 45 (sci/eval-string* ctx "(reduce + (range 10))")))))) | ||
|
|
||
| (deftest host-seq-producers-test | ||
| (testing "interruptible range/repeat/cycle/iterate fire interrupt-fn" | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* (sci/init {:interrupt-fn (limit-interrupt 500)}) | ||
| "(doall (range))"))) | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* (sci/init {:interrupt-fn (limit-interrupt 500)}) | ||
| "(doall (repeat :x))"))) | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* (sci/init {:interrupt-fn (limit-interrupt 500)}) | ||
| "(doall (cycle [1 2 3]))"))) | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* (sci/init {:interrupt-fn (limit-interrupt 500)}) | ||
| "(doall (iterate inc 0))"))))) | ||
|
|
||
| (deftest host-materializers-test | ||
| (testing "interruptible doall/dorun/count/into/reduce fire interrupt-fn on host sequences" | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* (sci/init {:interrupt-fn (limit-interrupt 500)}) | ||
| "(reduce + (range))"))) | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* (sci/init {:interrupt-fn (limit-interrupt 500)}) | ||
| "(count (range))"))) | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* (sci/init {:interrupt-fn (limit-interrupt 500)}) | ||
| "(into [] (range))"))))) | ||
|
|
||
| (deftest host-fns-no-overhead-test | ||
| (testing "absent interrupt-fn: host functions are unaffected" | ||
| (let [ctx (sci/init {})] | ||
| (is (= [0 1 2] (sci/eval-string* ctx "(vec (range 3))"))) | ||
| (is (= 3 (sci/eval-string* ctx "(count [1 2 3])"))) | ||
| (is (= 6 (sci/eval-string* ctx "(reduce + [1 2 3])"))) | ||
| (is (= [1 1 1] (sci/eval-string* ctx "(vec (take 3 (repeat 1)))"))) | ||
| (is (= [0 1 2] (sci/eval-string* ctx "(vec (take 3 (iterate inc 0)))"))))) ) | ||
|
|
||
| (deftest fork-preserves-interrupt-fn-test | ||
| (testing "forked context inherits interrupt-fn" | ||
| (let [ctx (sci/init {:interrupt-fn (limit-interrupt 1000)}) | ||
| forked (sci/fork ctx)] | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* forked "(loop [] (recur))")))))) | ||
|
|
||
| (deftest merge-opts-preserves-interrupt-fn-test | ||
| (testing "merge-opts carries interrupt-fn forward when not overridden" | ||
| (let [ctx (sci/init {:interrupt-fn (limit-interrupt 1000)}) | ||
| ctx2 (sci/merge-opts ctx {:namespaces {'user {'x 1}}})] | ||
| (is (thrown-with-msg? #?(:clj Exception :cljs js/Error) #"interrupted" | ||
| (sci/eval-string* ctx2 "(loop [] (recur))")))))) |
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Please don't remove anything unrelated to the PR
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Sorry, undone.