diff --git a/src/sci/impl/fns.cljc b/src/sci/impl/fns.cljc index 28abe454..adf74ee6 100644 --- a/src/sci/impl/fns.cljc +++ b/src/sci/impl/fns.cljc @@ -25,7 +25,8 @@ ([n _disable-arity-checks varargs] (if (zero? n) (let [varargs-param (when varargs (gensym))] - `(let [recur# recur] + `(let [recur# recur + interrupt-fn# (:interrupt-fn ~'ctx)] (fn ~'arity-0 ~(cond-> [] varargs (conj '& varargs-param)) (let [~'invoc-array (when-not (zero? ~'invoc-size) @@ -36,6 +37,7 @@ ~@(when varargs [`(aset ~'invoc-array ~'vararg-idx ~varargs-param)]) (loop [] + (when (some? interrupt-fn#) (interrupt-fn#)) (let [ret# (types/eval ~'body ~'ctx ~'invoc-array)] (if (identical? recur# ret#) (recur) @@ -46,7 +48,8 @@ `(aset ~(with-meta 'invoc-array {:tag 'objects}) ~idx ~fn-param)) fn-params (range)))] - `(let [recur# recur] + `(let [recur# recur + interrupt-fn# (:interrupt-fn ~'ctx)] (fn ~(symbol (str "arity-" n)) ~(cond-> fn-params varargs (conj '& varargs-param)) (let [~'invoc-array (when-not (zero? ~'invoc-size) @@ -58,6 +61,7 @@ ~@(when varargs [`(aset ~'invoc-array ~'vararg-idx ~varargs-param)]) (loop [] + (when (some? interrupt-fn#) (interrupt-fn#)) (let [ret# (types/eval ~'body ~'ctx ~'invoc-array)] (if (identical? recur# ret#) (recur) @@ -142,7 +146,8 @@ 19 (gen-fn 19) 20 (gen-fn 20) ;; default case for 20+ args (used by loop) - (let [recur# recur] + (let [recur# recur + interrupt-fn# (:interrupt-fn ctx)] (fn arity-many [& args] (let [invoc-array (when-not (zero? invoc-size) (object-array invoc-size))] @@ -153,6 +158,7 @@ (aset ^objects invoc-array i (first args)) (recur (next args) (inc i)))) (loop [] + (when (some? interrupt-fn#) (interrupt-fn#)) (let [ret (types/eval body ctx invoc-array)] (if (identical? recur# ret) (recur) diff --git a/src/sci/impl/interruptible.cljc b/src/sci/impl/interruptible.cljc new file mode 100644 index 00000000..306ca532 --- /dev/null +++ b/src/sci/impl/interruptible.cljc @@ -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)}))))) diff --git a/src/sci/impl/opts.cljc b/src/sci/impl/opts.cljc index 71acd879..0eb20d1c 100644 --- a/src/sci/impl/opts.cljc +++ b/src/sci/impl/opts.cljc @@ -2,6 +2,7 @@ {:no-doc true} (:require #?(:cljs [goog.string]) + [sci.impl.interruptible :as interruptible] [sci.impl.namespaces :as namespaces] [sci.impl.types] [sci.impl.utils :as utils :refer [strip-core-ns]] @@ -147,15 +148,17 @@ #?(:clj (defrecord Ctx [bindings env features readers reload-all - check-permissions])) + check-permissions + interrupt-fn])) -(defn ->ctx [bindings env features readers check-permissions?] +(defn ->ctx [bindings env features readers check-permissions? & {:keys [interrupt-fn]}] #?(:cljs {:bindings bindings :env env :features features :readers readers - :check-permissions check-permissions?} - :clj (->Ctx bindings env features readers false check-permissions?))) + :check-permissions check-permissions? + :interrupt-fn interrupt-fn} + :clj (->Ctx bindings env features readers false check-permissions? interrupt-fn))) (def default-ns-aliases #?(:clj {} @@ -176,6 +179,7 @@ reify-fn proxy-fn deftype-fn + interrupt-fn #?(:cljs async-load-fn) #?(:cljs js-libs) ns-aliases]}] @@ -188,7 +192,9 @@ bindings (merge {'user (assoc bindings :obj utils/user-ns)})) _ (init-env! env aliases namespaces classes raw-classes imports load-fn #?(:cljs async-load-fn) #?(:cljs js-libs) ns-aliases) - ctx (assoc (->ctx {} env features readers (or allow deny)) + _ (when interrupt-fn (interruptible/install! env)) + ctx (assoc (->ctx {} env features readers (or allow deny) + :interrupt-fn interrupt-fn) :allow (when allow (process-permissions #{} allow)) :deny (when deny (process-permissions #{} deny)) :reify-fn (or reify-fn default-reify-fn) @@ -222,7 +228,10 @@ namespaces (cond-> namespaces bindings (merge {'user (assoc bindings :obj utils/user-ns)})) _ (init-env! !env aliases namespaces classes raw-classes imports load-fn #?(:cljs async-load-fn) #?(:cljs js-libs) ns-aliases) - ctx (assoc (->ctx {} !env features readers (or (:check-permissions ctx) allow deny)) + interrupt-fn (if (contains? opts :interrupt-fn) (:interrupt-fn opts) (:interrupt-fn ctx)) + _ (when interrupt-fn (interruptible/install! !env)) + ctx (assoc (->ctx {} !env features readers (or (:check-permissions ctx) allow deny) + :interrupt-fn interrupt-fn) :allow (when allow (process-permissions (:allow ctx) allow)) :deny (when deny (process-permissions (:deny ctx) deny)) :reify-fn reify-fn diff --git a/test/sci/interrupt_fn_test.cljc b/test/sci/interrupt_fn_test.cljc new file mode 100644 index 00000000..67ec53fc --- /dev/null +++ b/test/sci/interrupt_fn_test.cljc @@ -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))"))))))