From c2407082e0c0ce0578fe5937291a5a78e6f54379 Mon Sep 17 00:00:00 2001 From: Brandon Bloom Date: Fri, 31 Aug 2012 10:28:15 -0700 Subject: [PATCH] Capture variable shadows in analyzer. 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. --- src/clj/cljs/analyzer.clj | 119 ++++++++++++++++++++-------------------------- src/clj/cljs/compiler.clj | 64 ++++++++++++++++--------- src/clj/cljs/core.clj | 11 +++-- 3 files changed, 99 insertions(+), 95 deletions(-) diff --git a/src/clj/cljs/analyzer.clj b/src/clj/cljs/analyzer.clj index 40f1b91..6f4d0c5 100644 --- a/src/clj/cljs/analyzer.clj +++ b/src/clj/cljs/analyzer.clj @@ -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} @@ -358,31 +356,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] @@ -392,34 +383,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 @@ -436,33 +431,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))})) @@ -485,12 +470,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 @@ -502,12 +488,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 @@ -528,7 +514,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 @@ -680,7 +666,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) diff --git a/src/clj/cljs/compiler.clj b/src/clj/cljs/compiler.clj index 91baa50..e2b3952 100644 --- a/src/clj/cljs/compiler.clj +++ b/src/clj/cljs/compiler.clj @@ -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)) @@ -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 @@ -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 @@ -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) @@ -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)) {") @@ -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)) @@ -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 @@ -536,12 +553,12 @@ (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 "}"))) @@ -549,8 +566,8 @@ [{: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 "})()")))) @@ -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');")) diff --git a/src/clj/cljs/core.clj b/src/clj/cljs/core.clj index 5da3da4..9eafe82 100644 --- a/src/clj/cljs/core.clj +++ b/src/clj/cljs/core.clj @@ -539,8 +539,8 @@ (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 @@ -548,7 +548,8 @@ (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))) [] @@ -574,7 +575,7 @@ (deftype* ~t ~fields ~pmasks) (set! (.-cljs$lang$type ~t) true) (set! (.-cljs$lang$ctorPrSeq ~t) (fn [this#] (list ~(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) @@ -654,7 +655,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] -- 1.7.12