Skip to content

Commit

Permalink
CLJS-369: Capture variable shadows in analyzer; avoid
Browse files Browse the repository at this point in the history 
 gensyms.

AST Changes

* Anywhere a binding was introduced for a local used to be a symbol,
  now it is a map with a :name key and potentially a :shadow key.

* Bindings vectors are no longer alternating symbols, then init maps.
  Instead, the are a vector of maps of the shape described for locals
  plus an :init key.

* The :gthis key for functions has been replaced with :type, which
  is the symbol describing the type name of the enclosing deftype form.

* recur frames now expose :params as binding maps, instead of :names

Benefits:

* Shadowed variables are now visible to downstream AST transforms.

* :tag, :mutable, and other metadata are now uniform across ops

* Eliminates usages of gensym inside the analyzer, which was a source
  of state that made the analyzer impossible to use for some
  transformations of let, letfn, etc which require re-analyzing forms.

* Removes JavaScript shadowing semantics from the analyze phase.
  • Loading branch information
David Nolen authored and David Nolen committed Oct 16, 2012
1 parent 62aca8f commit 19afb31
Show file tree
Hide file tree
Showing 3 changed files with 99 additions and 95 deletions.
119 changes: 52 additions & 67 deletions src/clj/cljs/analyzer.clj
View file
Expand Up @@ -31,8 +31,6 @@
(defonce namespaces (atom '{cljs.core {:name cljs.core}
cljs.user {:name cljs.user}}))

(defonce ns-first-segments (atom '#{"cljs" "clojure"}))

(defn reset-namespaces! []
(reset! namespaces
'{cljs.core {:name cljs.core}
Expand Down Expand Up @@ -360,31 +358,24 @@
(when export-as {:export export-as})
(when init-expr {:children [init-expr]})))))

(defn- analyze-fn-method [env locals meth gthis]
(letfn [(uniqify [[p & r]]
(when p
(cons (if (some #{p} r) (gensym (str p)) p)
(uniqify r))))
(prevent-ns-shadow [p]
(if (@ns-first-segments (str p))
(symbol (str p "$"))
p))]
(let [params (first meth)
variadic (boolean (some '#{&} params))
params (vec (uniqify (remove '#{&} params)))
fixed-arity (count (if variadic (butlast params) params))
body (next meth)
locals (reduce (fn [m name]
(assoc m name {:name (prevent-ns-shadow name)
:tag (-> name meta :tag)}))
locals params)
params (vec (map prevent-ns-shadow params))
recur-frame {:names params :flag (atom nil)}
block (binding [*recur-frames* (cons recur-frame *recur-frames*)]
(analyze-block (assoc env :context :return :locals locals) body))]
(merge {:env env :variadic variadic :params params :max-fixed-arity fixed-arity
:gthis gthis :recurs @(:flag recur-frame)}
block))))
(defn- analyze-fn-method [env locals meth type]
(let [param-names (first meth)
variadic (boolean (some '#{&} param-names))
param-names (vec (remove '#{&} param-names))
body (next meth)
[locals params] (reduce (fn [[locals params] name]
(let [param {:name name
:tag (-> name meta :tag)
:shadow (locals name)}]
[(assoc locals name param) (conj params param)]))
[locals []] param-names)
fixed-arity (count (if variadic (butlast params) params))
recur-frame {:params params :flag (atom nil)}
block (binding [*recur-frames* (cons recur-frame *recur-frames*)]
(analyze-block (assoc env :context :return :locals locals) body))]
(merge {:env env :variadic variadic :params params :max-fixed-arity fixed-arity
:type type :recurs @(:flag recur-frame)}
block)))

(defmethod parse 'fn*
[op env [_ & args :as form] name]
Expand All @@ -394,34 +385,38 @@
;;turn (fn [] ...) into (fn ([]...))
meths (if (vector? (first meths)) (list meths) meths)
locals (:locals env)
locals (if name (assoc locals name {:name name}) locals)
locals (if name (assoc locals name {:name name :shadow (locals name)}) locals)
type (-> form meta ::type)
fields (-> form meta ::fields)
protocol-impl (-> form meta :protocol-impl)
protocol-inline (-> form meta :protocol-inline)
gthis (and fields (gensym "this__"))
locals (reduce (fn [m fld]
(assoc m fld
{:name (symbol (str gthis "." fld))
{:name fld
:field true
:mutable (-> fld meta :mutable)
:tag (-> fld meta :tag)}))
:tag (-> fld meta :tag)
:shadow (m fld)}))
locals fields)

menv (if (> (count meths) 1) (assoc env :context :expr) env)
menv (merge menv
{:protocol-impl protocol-impl
:protocol-inline protocol-inline})
methods (map #(analyze-fn-method menv locals % gthis) meths)
methods (map #(analyze-fn-method menv locals % type) meths)
max-fixed-arity (apply max (map :max-fixed-arity methods))
variadic (boolean (some :variadic methods))
locals (if name (assoc locals name {:name name :fn-var true
:variadic variadic
:max-fixed-arity max-fixed-arity
:method-params (map :params methods)}))
locals (if name
(update-in locals [name] assoc
:fn-var true
:variadic variadic
:max-fixed-arity max-fixed-arity
:method-params (map :params methods))
locals)
methods (if name
;; a second pass with knowledge of our function-ness/arity
;; lets us optimize self calls
(map #(analyze-fn-method menv locals % gthis) meths)
(map #(analyze-fn-method menv locals % type) meths)
methods)]
;;todo - validate unique arities, at most one variadic, variadic takes max required args
{:env env :op :fn :form form :name name :methods methods :variadic variadic
Expand All @@ -438,33 +433,23 @@
(assert (and (vector? bindings) (even? (count bindings))) "bindings must be vector of even number of elements")
(let [n->fexpr (into {} (map (juxt first second) (partition 2 bindings)))
names (keys n->fexpr)
n->gsym (into {} (map (juxt identity #(gensym (str % "__"))) names))
gsym->n (into {} (map (juxt n->gsym identity) names))
context (:context env)
bes (reduce (fn [bes n]
(let [g (n->gsym n)]
(conj bes {:name g
:tag (-> n meta :tag)
:local true})))
[]
names)
meth-env (reduce (fn [env be]
(let [n (gsym->n (be :name))]
(assoc-in env [:locals n] be)))
(assoc env :context :expr)
bes)
[meth-env finits]
(reduce (fn [[env finits] n]
(let [finit (analyze meth-env (n->fexpr n))
be (-> (get-in env [:locals n])
(assoc :init finit))]
[meth-env bes]
(reduce (fn [[{:keys [locals] :as env} bes] n]
(let [be {:name n
:tag (-> n meta :tag)
:local true
:shadow (locals n)}]
[(assoc-in env [:locals n] be)
(conj finits finit)]))
[meth-env []]
names)
(conj bes be)]))
[env []] names)
meth-env (assoc meth-env :context :expr)
bes (vec (map (fn [{:keys [name shadow] :as be}]
(let [env (assoc-in meth-env [:locals name] shadow)]
(assoc be :init (analyze env (n->fexpr name)))))
bes))
{:keys [statements ret]}
(analyze-block (assoc meth-env :context (if (= :expr context) :return context)) exprs)
bes (vec (map #(get-in meth-env [:locals %]) names))]
(analyze-block (assoc meth-env :context (if (= :expr context) :return context)) exprs)]
{:env env :op :letfn :bindings bes :statements statements :ret ret :form form
:children (into (vec (map :init bes))
(conj (vec statements) ret))}))
Expand All @@ -487,12 +472,13 @@
(do
(assert (not (or (namespace name) (.contains (str name) "."))) (str "Invalid local name: " name))
(let [init-expr (analyze env init)
be {:name (gensym (str name "__"))
be {:name name
:init init-expr
:tag (or (-> name meta :tag)
(-> init-expr :tag)
(-> init-expr :info :tag))
:local true}
:local true
:shadow (-> env :locals name)}
be (if (= (:op init-expr) :fn)
(merge be
{:fn-var true
Expand All @@ -504,12 +490,12 @@
(assoc-in env [:locals name] be)
(next bindings))))
[bes env])))
recur-frame (when is-loop {:names (vec (map :name bes)) :flag (atom nil)})
recur-frame (when is-loop {:params bes :flag (atom nil)})
{:keys [statements ret]}
(binding [*recur-frames* (if recur-frame (cons recur-frame *recur-frames*) *recur-frames*)
*loop-lets* (cond
is-loop (or *loop-lets* ())
*loop-lets* (cons {:names (vec (map :name bes))} *loop-lets*))]
*loop-lets* (cons {:params bes} *loop-lets*))]
(analyze-block (assoc env :context (if (= :expr context) :return context)) exprs))]
{:env encl-env :op :let :loop is-loop
:bindings bes :statements statements :ret ret :form form
Expand All @@ -530,7 +516,7 @@
frame (first *recur-frames*)
exprs (disallowing-recur (vec (map #(analyze (assoc env :context :expr) %) exprs)))]
(assert frame "Can't recur here")
(assert (= (count exprs) (count (:names frame))) "recur argument count mismatch")
(assert (= (count exprs) (count (:params frame))) "recur argument count mismatch")
(reset! (:flag frame) true)
(assoc {:env env :op :recur :form form}
:frame frame
Expand Down Expand Up @@ -682,7 +668,6 @@
(load-core)
(doseq [nsym (concat (vals requires-macros) (vals uses-macros))]
(clojure.core/require nsym))
(swap! ns-first-segments conj (first (string/split (str name) #"\.")))
(swap! namespaces #(-> %
(assoc-in [name :name] name)
(assoc-in [name :excludes] excludes)
Expand Down
64 changes: 41 additions & 23 deletions src/clj/cljs/compiler.clj
View file
Expand Up @@ -36,16 +36,33 @@
(def ^:dynamic *emitted-provides* nil)
(def cljs-reserved-file-names #{"deps.cljs"})

(defonce ns-first-segments (atom '#{"cljs" "clojure"}))

(defn munge
([s] (munge s js-reserved))
([s reserved]
(let [ss (string/replace (str s) #"\/(.)" ".$1") ; Division is special
ss (apply str (map #(if (reserved %) (str % "$") %)
(string/split ss #"(?<=\.)|(?=\.)")))
ms (clojure.lang.Compiler/munge ss)]
(if (symbol? s)
(symbol ms)
ms))))
(if (map? s)
; Unshadowing
(let [{:keys [name field] :as info} s
depth (loop [d 0, {:keys [shadow]} info]
(cond
shadow (recur (inc d) shadow)
(@ns-first-segments (str name)) (inc d)
:else d))
name (if field
(str "self__." name)
name)]
(if (zero? depth)
(munge name reserved)
(symbol (str (munge name reserved) "__$" depth))))
; String munging
(let [ss (string/replace (str s) #"\/(.)" ".$1") ; Division is special
ss (apply str (map #(if (reserved %) (str % "$") %)
(string/split ss #"(?<=\.)|(?=\.)")))
ms (clojure.lang.Compiler/munge ss)]
(if (symbol? s)
(symbol ms)
ms)))))

(defn- comma-sep [xs]
(interpose "," xs))
Expand Down Expand Up @@ -197,7 +214,7 @@
(let [n (:name info)
n (if (= (namespace n) "js")
(name n)
n)]
info)]
(emit-wrap env (emits (munge n)))))

(defmethod emit :meta
Expand Down Expand Up @@ -359,11 +376,11 @@
(emits "})")))

(defn emit-fn-method
[{:keys [gthis name variadic params statements ret env recurs max-fixed-arity]}]
[{:keys [type name variadic params statements ret env recurs max-fixed-arity]}]
(emit-wrap env
(emitln "(function " (munge name) "(" (comma-sep (map munge params)) "){")
(when gthis
(emitln "var " gthis " = this;"))
(when type
(emitln "var self__ = this;"))
(when recurs (emitln "while(true){"))
(emit-block :return statements ret)
(when recurs
Expand All @@ -372,7 +389,7 @@
(emits "})")))

(defn emit-variadic-fn-method
[{:keys [gthis name variadic params statements ret env recurs max-fixed-arity] :as f}]
[{:keys [type name variadic params statements ret env recurs max-fixed-arity] :as f}]
(emit-wrap env
(let [name (or name (gensym))
mname (munge name)
Expand All @@ -391,8 +408,8 @@
(if variadic
(concat (butlast params) ['var_args])
params)) "){")
(when gthis
(emitln "var " gthis " = this;"))
(when type
(emitln "var self__ = this;"))
(when variadic
(emitln "var " (last params) " = null;")
(emitln "if (goog.isDef(var_args)) {")
Expand All @@ -413,14 +430,14 @@
[{:keys [name env methods max-fixed-arity variadic recur-frames loop-lets]}]
;;fn statements get erased, serve no purpose and can pollute scope if named
(when-not (= :statement (:context env))
(let [loop-locals (->> (concat (mapcat :names (filter #(and % @(:flag %)) recur-frames))
(mapcat :names loop-lets))
(let [loop-locals (->> (concat (mapcat :params (filter #(and % @(:flag %)) recur-frames))
(mapcat :params loop-lets))
(map munge)
seq)]
(when loop-locals
(when (= :return (:context env))
(emits "return "))
(emitln "((function (" (comma-sep loop-locals) "){")
(emitln "((function (" (comma-sep (map munge loop-locals)) "){")
(when-not (= :return (:context env))
(emits "return ")))
(if (= 1 (count methods))
Expand Down Expand Up @@ -523,8 +540,8 @@
[{:keys [bindings statements ret env loop]}]
(let [context (:context env)]
(when (= :expr context) (emits "(function (){"))
(doseq [{:keys [name init]} bindings]
(emitln "var " (munge name) " = " init ";"))
(doseq [{:keys [init] :as binding} bindings]
(emitln "var " (munge binding) " = " init ";"))
(when loop (emitln "while(true){"))
(emit-block (if (= :expr context) :return context) statements ret)
(when loop
Expand All @@ -536,21 +553,21 @@
(defmethod emit :recur
[{:keys [frame exprs env]}]
(let [temps (vec (take (count exprs) (repeatedly gensym)))
names (:names frame)]
params (:params frame)]
(emitln "{")
(dotimes [i (count exprs)]
(emitln "var " (temps i) " = " (exprs i) ";"))
(dotimes [i (count exprs)]
(emitln (munge (names i)) " = " (temps i) ";"))
(emitln (munge (params i)) " = " (temps i) ";"))
(emitln "continue;")
(emitln "}")))

(defmethod emit :letfn
[{:keys [bindings statements ret env]}]
(let [context (:context env)]
(when (= :expr context) (emits "(function (){"))
(doseq [{:keys [name init]} bindings]
(emitln "var " (munge name) " = " init ";"))
(doseq [{:keys [init] :as binding} bindings]
(emitln "var " (munge binding) " = " init ";"))
(emit-block (if (= :expr context) :return context) statements ret)
(when (= :expr context) (emits "})()"))))

Expand Down Expand Up @@ -648,6 +665,7 @@

(defmethod emit :ns
[{:keys [name requires uses requires-macros env]}]
(swap! ns-first-segments conj (first (string/split (str name) #"\.")))
(emitln "goog.provide('" (munge name) "');")
(when-not (= name 'cljs.core)
(emitln "goog.require('cljs.core');"))
Expand Down
11 changes: 6 additions & 5 deletions src/clj/cljs/core.clj
View file
Expand Up @@ -545,16 +545,17 @@
(range fast-path-protocol-partitions-count))]))))

(defn dt->et
([specs fields] (dt->et specs fields false))
([specs fields inline]
([t specs fields] (dt->et t specs fields false))
([t specs fields inline]
(loop [ret [] s specs]
(if (seq s)
(recur (-> ret
(conj (first s))
(into
(reduce (fn [v [f sigs]]
(conj v (vary-meta (cons f (map #(cons (second %) (nnext %)) sigs))
assoc :cljs.analyzer/fields fields
assoc :cljs.analyzer/type t
:cljs.analyzer/fields fields
:protocol-impl true
:protocol-inline inline)))
[]
Expand All @@ -581,7 +582,7 @@
(set! (.-cljs$lang$type ~t) true)
(set! (.-cljs$lang$ctorPrSeq ~t) (fn [this#] (list ~(core/str r))))
(set! (.-cljs$lang$ctorPrWriter ~t) (fn [this# writer#] (-write writer# ~(core/str r))))
(extend-type ~t ~@(dt->et impls fields true))
(extend-type ~t ~@(dt->et t impls fields true))
~t)
`(do
(deftype* ~t ~fields ~pmasks)
Expand Down Expand Up @@ -663,7 +664,7 @@
:skip-protocol-flag fpps)]
`(do
(~'defrecord* ~tagname ~hinted-fields ~pmasks)
(extend-type ~tagname ~@(dt->et impls fields true))))))
(extend-type ~tagname ~@(dt->et tagname impls fields true))))))

(defn- build-positional-factory
[rsym rname fields]
Expand Down

0 comments on commit 19afb31

Please sign in to comment.