Skip to content

Commit 71f1de2

Browse files
bronsabronsa
committed
import collect and clear-locals
1 parent 9dd8663 commit 71f1de2

File tree

4 files changed

+351
-4
lines changed

4 files changed

+351
-4
lines changed

‎src/main/clojure/clojure/tools/emitter/jvm.clj

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -16,12 +16,10 @@
1616
[clojure.tools.emitter.jvm.emit :as e]
1717
[clojure.tools.emitter.jvm.transform :as t]
1818
[clojure.tools.analyzer.passes.collect-closed-overs :refer [collect-closed-overs]]
19-
[clojure.tools.analyzer.passes.jvm
20-
[infer-tag :refer [ensure-tag]]
21-
[clear-locals :refer [clear-locals]]
22-
[collect :refer [collect]]]
2319
[clojure.tools.emitter.passes.jvm
20+
[collect :refer [collect]]
2421
[collect-internal-methods :refer :all]
22+
[clear-locals :refer [clear-locals]]
2523
[annotate-class-id :refer [annotate-class-id]]
2624
[annotate-internal-name :refer [annotate-internal-name]]
2725
[ensure-tag :refer [ensure-tag]]]

‎src/main/clojure/clojure/tools/emitter/passes/jvm/clear_locals.clj

Lines changed: 156 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,156 @@
1+
;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
2+
;; The use and distribution terms for this software are covered by the
3+
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4+
;; which can be found in the file epl-v10.html at the root of this distribution.
5+
;; By using this software in any fashion, you are agreeing to be bound by
6+
;; the terms of this license.
7+
;; You must not remove this notice, or any other, from this software.
8+
9+
(ns clojure.tools.emitter.passes.jvm.clear-locals
10+
(:require [clojure.tools.analyzer.ast :refer [update-children]]
11+
[clojure.tools.analyzer.utils :refer [ctx rseqv]]
12+
[clojure.tools.analyzer.passes.jvm
13+
[annotate-branch :refer [annotate-branch]]
14+
[annotate-loops :refer [annotate-loops]]]
15+
[clojure.tools.analyzer.passes.collect-closed-overs :refer [collect-closed-overs]]))
16+
17+
(def ^:dynamic *clears*)
18+
19+
(defmulti -clear-locals :op)
20+
(defmulti should-not-clear :op)
21+
22+
(defmethod should-not-clear :local
23+
[ast]
24+
(or (= :letfn (:local ast))
25+
(:case-test ast)))
26+
27+
(defmethod should-not-clear :binding
28+
[ast]
29+
(:case-test @(:atom ast)))
30+
31+
(defmethod should-not-clear :default [ast]
32+
false)
33+
34+
(defn maybe-clear-local
35+
[{:keys [name local env loops] :as ast}]
36+
(let [{:keys [closed-overs locals loop-closed-overs]} @*clears*
37+
loop-id (:loop-id env)]
38+
(if (and (#{:let :loop :catch :arg} local)
39+
(or (not (get (loop-closed-overs loop-id) name)) ;; if we're in a loop and the local is defined outside the loop
40+
(not loops) ;; it's only safe to clear it if we're in the loop exit path for this loop
41+
(and (not (loops loop-id)) ;; and if the local isn't defined outside different loop than this and we're
42+
(not (some (fn [id] (get (loop-closed-overs id) name)) loops)))) ;; in a recur path for that loop
43+
(or (not (closed-overs name)) ;; if it's a closed-over var, we can only clear it if we explicitely
44+
(:once env)) ;; declared the function to be run :once
45+
(not (locals name)) ;; if the local is in `locals` it means that it's used later in the body and can't be cleared here
46+
(not (should-not-clear ast))) ;; letfn bindings/case test
47+
(assoc ast :to-clear? true)
48+
ast)))
49+
50+
(defn maybe-clear-this
51+
[{:keys [env] :as ast}]
52+
(-> (if (and (isa? (:context env) :ctx/return)
53+
(not (:in-try env)))
54+
(assoc ast :to-clear? true)
55+
ast)
56+
(update-children -clear-locals rseqv)))
57+
58+
(defmethod -clear-locals :invoke
59+
[ast]
60+
(maybe-clear-this ast))
61+
62+
(defmethod -clear-locals :protocol-invoke
63+
[ast]
64+
(maybe-clear-this ast))
65+
66+
(defmethod -clear-locals :prim-invoke
67+
[ast]
68+
(maybe-clear-this ast))
69+
70+
(defmethod -clear-locals :static-call
71+
[ast]
72+
(maybe-clear-this ast))
73+
74+
(defmethod -clear-locals :instance-call
75+
[ast]
76+
(maybe-clear-this ast))
77+
78+
(defmethod -clear-locals :default
79+
[{:keys [closed-overs op loop-id] :as ast}]
80+
(if closed-overs
81+
(let [key (if (= :loop op) :loop-closed-overs ) ;; if we're in a loop those are not actually closed-overs
82+
[ast body-locals] (binding [*clears* (atom (if (= :loop op)
83+
(assoc-in @*clears* [:loop-closed-overs loop-id] closed-overs)
84+
(update-in @*clears* [:closed-overs] merge closed-overs)))] ;; clear locals in the body
85+
[(update-children ast -clear-locals rseqv) (:locals @*clears*)]) ;; and save encountered locals
86+
[ks vs] (reduce-kv (fn [[keys vals] k v]
87+
[(conj keys k) (conj vals v)])
88+
[[] []] closed-overs)
89+
closed-overs (zipmap ks (mapv maybe-clear-local vs))] ;; clear outer closed-overs at the point of the closure creation
90+
(swap! *clears* #(update-in % [:locals] into body-locals)) ;; merge the locals so that we know not to clear them "before"
91+
(if (#{:fn :reify} op)
92+
(assoc ast :closed-overs closed-overs)
93+
ast))
94+
(update-children ast -clear-locals rseqv)))
95+
96+
(defmethod -clear-locals :if
97+
[{:keys [test then else] :as ast}]
98+
(let [[then then-clears] (binding [*clears* (atom @*clears*)] ;; push a new locals frame for every path so that
99+
[(-clear-locals then) @*clears*]) ;; we can clear the same local in different branches
100+
[else else-clears] (binding [*clears* (atom @*clears*)] ;; this is safe to do since the different paths will
101+
[(-clear-locals else) @*clears*]) ;; never interfere
102+
locals (into (:locals then-clears) ;; merge all the locals encountered in the branch paths
103+
(:locals else-clears))] ;; so that if we encounter them "before" in the body we know
104+
(swap! *clears* #(update-in % [:locals] into locals)) ;; that we cannot clear them since they are needed later
105+
(let [test (-clear-locals test)]
106+
(assoc ast
107+
:test test
108+
:then then
109+
:else else))))
110+
111+
(defmethod -clear-locals :case
112+
[{:keys [test default thens] :as ast}]
113+
(let [[thens thens-locals]
114+
(reduce (fn [[thens locals] then]
115+
(let [[t l] (binding [*clears* (atom @*clears*)]
116+
[(-clear-locals then) (:locals @*clears*)])]
117+
[(conj thens t) (into locals l)]))
118+
[[] #{}] thens)
119+
[default {:keys [locals]}] (binding [*clears* (atom @*clears*)]
120+
[(-clear-locals default) @*clears*])]
121+
(swap! *clears* #(update-in % [:locals] into (into thens-locals locals)))
122+
(assoc ast
123+
:test test
124+
:thens thens
125+
:default default)))
126+
127+
(defmethod -clear-locals :local
128+
[ast]
129+
(let [ast (maybe-clear-local ast)]
130+
(swap! *clears* #(update-in % [:locals] conj (:name ast))) ;; register that the local has been used and potentially cleared
131+
ast))
132+
133+
(defmethod -clear-locals :binding
134+
[ast]
135+
(let [{:keys [init to-clear?] :as ast} (-> ast (update-children -clear-locals rseqv)
136+
maybe-clear-local)]
137+
(if (and init to-clear?)
138+
(update-in ast [:init :env] ctx :statement)
139+
ast)))
140+
141+
(defn clear-locals
142+
"Attached :to-clear? true to all the nodes that the compiler
143+
can clear, those nodes can be:
144+
* :local nodes
145+
* :binding nodes
146+
* :invoke/protocol-invoke/prim-invoke/static-call/instance-call nodes
147+
in return position, meaning that the \"this\" local is eligible for
148+
clearing"
149+
{:pass-info {:walk :none :depends #{#'collect-closed-overs #'annotate-branch #'annotate-loops}}}
150+
[ast]
151+
(if (:disable-locals-clearing *compiler-options*)
152+
ast
153+
(binding [*clears* (atom {:closed-overs {}
154+
:loop-closed-overs {}
155+
:locals #{}})]
156+
(-clear-locals ast))))

‎src/main/clojure/clojure/tools/emitter/passes/jvm/collect.clj

Lines changed: 130 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,130 @@
1+
;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
2+
;; The use and distribution terms for this software are covered by the
3+
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4+
;; which can be found in the file epl-v10.html at the root of this distribution.
5+
;; By using this software in any fashion, you are agreeing to be bound by
6+
;; the terms of this license.
7+
;; You must not remove this notice, or any other, from this software.
8+
9+
(ns clojure.tools.emitter.passes.jvm.collect
10+
(:require [clojure.tools.analyzer.ast :refer [update-children]]
11+
[clojure.tools.analyzer.env :as env]
12+
[clojure.tools.analyzer.passes.jvm
13+
[constant-lifter :refer [constant-lift]]
14+
[annotate-tag :refer [annotate-tag]]
15+
[classify-invoke :refer [classify-invoke]]]))
16+
17+
(def ^:private ^:dynamic *collects*)
18+
19+
(defn -register-constant
20+
[form tag type meta]
21+
(let [key {:form form
22+
:meta meta
23+
:tag tag}
24+
collects @*collects*]
25+
(or (:id ((:constants collects) key)) ;; constant already in the constant table
26+
(let [id (:next-id collects)]
27+
(swap! *collects* #(assoc-in (update-in % [:next-id] inc)
28+
[:constants key]
29+
{:id id
30+
:tag tag
31+
:val form
32+
:type type}))
33+
id))))
34+
35+
(defmulti -collect-const :op)
36+
(defmulti -collect-callsite :op)
37+
38+
(defmethod -collect-const :default [ast] ast)
39+
(defmethod -collect-callsite :default [ast] ast)
40+
41+
(defmethod -collect-const :const
42+
[{:keys [val tag type] :as ast}]
43+
(if (and (not= type :nil) ;; nil and true/false can be emitted as literals,
44+
(not= type :boolean)) ;; no need to put them on the constant table
45+
(let [id (-register-constant val tag type (meta val))]
46+
(assoc ast :id id))
47+
ast))
48+
49+
(defmethod -collect-const :def
50+
[ast]
51+
(let [var (:var ast)
52+
id (-register-constant var clojure.lang.Var :var (meta var))]
53+
(assoc ast :id id)))
54+
55+
(defmethod -collect-const :var
56+
[ast]
57+
(let [id (-register-constant (:var ast) clojure.lang.Var :var (:meta ast))]
58+
(assoc ast :id id)))
59+
60+
(defmethod -collect-const :the-var
61+
[ast]
62+
(let [var (:var ast)
63+
id (-register-constant var clojure.lang.Var :var (meta var))]
64+
(assoc ast :id id)))
65+
66+
(defmethod -collect-callsite :keyword-invoke
67+
[ast]
68+
(swap! *collects* #(update-in % [:keyword-callsites] conj (-> ast :keyword :form)))
69+
ast)
70+
71+
(defmethod -collect-callsite :protocol-invoke
72+
[ast]
73+
(swap! *collects* #(update-in % [:protocol-callsites] conj (-> ast :protocol-fn :var)))
74+
ast)
75+
76+
(defn merge-collects [ast]
77+
(merge ast (dissoc @*collects* :where :what :next-id :top-level?)))
78+
79+
;; collects constants and callsites in one pass
80+
(defn -collect [ast collect-fn]
81+
(let [collects @*collects*
82+
collect? ((:where collects) (:op ast))
83+
84+
ast (with-bindings ;; if it's a collection point, set up an empty constant/callsite frame
85+
(if collect? {#'*collects* (atom (merge collects
86+
{:next-id 0
87+
:constants {}
88+
:protocol-callsites #{}
89+
:keyword-callsites #{}}))}
90+
{})
91+
(let [ast (-> ast (update-children #(-collect % collect-fn))
92+
collect-fn)]
93+
(if collect?
94+
(merge-collects ast)
95+
ast)))]
96+
ast))
97+
98+
99+
(defn collect-fns [what]
100+
(case what
101+
:constants -collect-const
102+
:callsites -collect-callsite
103+
nil))
104+
105+
(defn collect
106+
"Takes an AST and returns it with the collected info, as specified by
107+
the passes opts:
108+
109+
* :collect/what set of keywords describing what to collect, some of:
110+
** :constants constant expressions
111+
** :callsites keyword and protocol callsites
112+
* :collect/where set of :op nodes where to attach collected info
113+
* :collect/top-level? if true attach collected info to the top-level node"
114+
{:pass-info {:walk :none :depends #{#'classify-invoke #'annotate-tag} :after #{#'constant-lift}}}
115+
[ast]
116+
(let [passes-opts (:passes-opts (env/deref-env))
117+
{:keys [what top-level?] :as opts} {:what (:collect/what passes-opts)
118+
:where (:collect/where passes-opts)
119+
:top-level? (:collect/top-level? passes-opts)}]
120+
(binding [*collects* (atom (merge {:constants {}
121+
:protocol-callsites #{}
122+
:keyword-callsites #{}
123+
:where #{}
124+
:what #{}
125+
:next-id 0}
126+
opts))]
127+
(let [ast (-collect ast (apply comp (keep collect-fns what)))]
128+
(if top-level?
129+
(merge-collects ast)
130+
ast)))))

‎src/test/clojure/clojure/tools/emitter/jvm/passes_test.clj

Lines changed: 63 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,63 @@
1+
(ns clojure.tools.emitter.jvm.passes-test
2+
(:require [clojure.tools.analyzer.jvm :as ana.jvm]
3+
[clojure.tools.analyzer.passes :refer [schedule]]
4+
[clojure.test :refer [deftest is]]
5+
[clojure.set :as set]
6+
[clojure.tools.analyzer.passes.collect-closed-overs :refer [collect-closed-overs]]
7+
[clojure.tools.emitter.passes.jvm.clear-locals :refer [clear-locals]]
8+
[clojure.tools.emitter.passes.jvm.collect :refer [collect]])
9+
(:import (clojure.lang Keyword Var PersistentArrayMap)))
10+
11+
(defmacro ast1 [form]
12+
`(ana.jvm/analyze '~form))
13+
14+
(deftest collect-test
15+
(binding [ana.jvm/run-passes (schedule (conj ana.jvm/default-passes #'collect #'collect-closed-overs))]
16+
(let [c-test (-> (ast1 (let [a 1 b 2] (fn [x] (fn [] [+ (:foo {}) x a]))))
17+
:body :ret)]
18+
(is (= '#{a__#0} (-> c-test :closed-overs keys set)))
19+
(is (set/subset? #{{:form :foo
20+
:tag Keyword
21+
:meta nil}
22+
{:form #'+
23+
:meta (meta #'+)
24+
:tag Var}
25+
{:form {}
26+
:tag PersistentArrayMap
27+
:meta nil}}
28+
(-> c-test :methods first :body :ret :constants keys set))) ;; it registers metadata too (line+col info)
29+
(is (= '#{a__#0 x__#0} (-> c-test :methods first :body :ret :closed-overs keys set))))))
30+
31+
(deftest clear-locals-test
32+
(binding [ana.jvm/run-passes (schedule (conj ana.jvm/default-passes #'clear-locals))]
33+
(let [f-expr (-> (ast1 (fn [x] (if x x x) x (if x (do x x) (if x x x))))
34+
:methods first :body)]
35+
(is (= true (-> f-expr :statements first :then :to-clear? nil?)))
36+
(is (= true (-> f-expr :statements first :else :to-clear? nil?)))
37+
(is (= true (-> f-expr :statements second :to-clear? nil?)))
38+
(is (= true (-> f-expr :ret :then :statements first :to-clear? nil?)))
39+
(is (= true (-> f-expr :ret :then :ret :to-clear?)))
40+
(is (= true (-> f-expr :ret :else :then :to-clear?)))
41+
(is (= true (-> f-expr :ret :else :else :to-clear?))))
42+
(let [f-expr (-> (ast1 (fn [x] (loop [a x] (if 1 x (do x (recur x))))))
43+
:methods first :body :ret)]
44+
(is (= true (-> f-expr :bindings first :init :to-clear? nil?)))
45+
(is (= true (-> f-expr :body :ret :then :to-clear?)))
46+
(is (= true (-> f-expr :body :ret :else :statements first :to-clear? nil?)))
47+
(is (= true (-> f-expr :body :ret :else :ret :exprs first :to-clear? nil?))))
48+
(let [f-expr (-> (ast1 (loop [] (let [a 1] (loop [] a)) (recur)))
49+
:body :statements first :body :ret :body :ret)]
50+
(is (= true (-> f-expr :to-clear?))))
51+
(let [f-expr (-> (ast1 (loop [] (let [a 1] (loop [] (if 1 a (recur)))) (recur)))
52+
:body :statements first :body :ret :body :ret :then)]
53+
(is (= true (-> f-expr :to-clear?))))
54+
(let [f-expr (-> (ast1 (let [a 1] (loop [] (let [b 2] (loop [] (if 1 [a b] (recur)))) (recur))))
55+
:body :ret :body :statements first :body :ret :body :ret :then :items)]
56+
(is (= true (-> f-expr first :to-clear? nil?)))
57+
(is (= true (-> f-expr second :to-clear?))))
58+
(let [f-expr (-> (ast1 (let [a 1] (loop [] (if 1 a) (recur))))
59+
:body :ret :body :statements first :then)]
60+
(is (= true (-> f-expr :to-clear? nil?))))
61+
(let [f-expr (-> (ast1 (let [a 1] (loop [] (let [x (if 1 a)]) (recur))))
62+
:body :ret :body :statements first :bindings first :init :then)]
63+
(is (= true (-> f-expr :to-clear? nil?))))))

0 commit comments

Comments
 (0)