Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

CLJS-235: WIP on David Nolen's protocol mask idea

  • Loading branch information...
commit 8352984ea946f4731a8518842663fb861925612a 1 parent de72ace
@michalmarczyk michalmarczyk authored David Nolen committed
Showing with 40 additions and 13 deletions.
  1. +8 −6 src/clj/cljs/compiler.clj
  2. +32 −7 src/clj/cljs/core.clj
View
14 src/clj/cljs/compiler.clj
@@ -715,7 +715,7 @@
(emitln "goog.require('" (munge lib) "');")))
(defmethod emit :deftype*
- [{:keys [t fields]}]
+ [{:keys [t fields pmask]}]
(let [fields (map munge fields)]
(emitln "")
(emitln "/**")
@@ -724,10 +724,11 @@
(emitln t " = (function (" (comma-sep (map str fields)) "){")
(doseq [fld fields]
(emitln "this." fld " = " fld ";"))
+ (when pmask (emitln "this.__protocol_mask = " pmask ";"))
(emitln "})")))
(defmethod emit :defrecord*
- [{:keys [t fields]}]
+ [{:keys [t fields pmask]}]
(let [fields (concat (map munge fields) '[__meta __extmap])]
(emitln "")
(emitln "/**")
@@ -740,6 +741,7 @@
(emitln t " = (function (" (comma-sep (map str fields)) "){")
(doseq [fld fields]
(emitln "this." fld " = " fld ";"))
+ (when pmask (emitln "this.__protocol_mask = " pmask ";"))
(emitln "if(arguments.length>" (- (count fields) 2) "){")
(emitln "this.__meta = __meta;")
(emitln "this.__extmap = __extmap;")
@@ -1111,7 +1113,7 @@
:uses-macros uses-macros :requires-macros requires-macros :excludes excludes}))
(defmethod parse 'deftype*
- [_ env [_ tsym fields :as form] _]
+ [_ env [_ tsym fields pmask :as form] _]
(let [t (munge (:name (resolve-var (dissoc env :locals) tsym)))]
(swap! namespaces update-in [(-> env :ns :name) :defs tsym]
(fn [m]
@@ -1121,10 +1123,10 @@
(assoc :file *cljs-file*)
(assoc :line line))
m))))
- {:env env :op :deftype* :as form :t t :fields fields}))
+ {:env env :op :deftype* :as form :t t :fields fields :pmask pmask}))
(defmethod parse 'defrecord*
- [_ env [_ tsym fields :as form] _]
+ [_ env [_ tsym fields pmask :as form] _]
(let [t (munge (:name (resolve-var (dissoc env :locals) tsym)))]
(swap! namespaces update-in [(-> env :ns :name) :defs tsym]
(fn [m]
@@ -1134,7 +1136,7 @@
(assoc :file *cljs-file*)
(assoc :line line))
m))))
- {:env env :op :defrecord* :form form :t t :fields fields}))
+ {:env env :op :defrecord* :form form :t t :fields fields :pmask pmask}))
;; dot accessor code
View
39 src/clj/cljs/core.clj
@@ -42,6 +42,12 @@
or
when when-first when-let when-not while])
+(def fast-path-protocols
+ (zipmap (map #(symbol (core/str "cljs.core." %))
+ '[ISeq IFn IHash IEquiv ISeqable ILookup ICounted IIndexed
+ ICollection IAssociative])
+ (iterate (partial core/* 2) 1)))
+
(defmacro str [& xs]
(let [strs (->> (repeat (count xs) "cljs.core.str(~{})")
(interpose ",")
@@ -315,6 +321,20 @@
sigs)))))]
`(do ~@(mapcat assign-impls impl-map))))))
+(defn- prepare-protocol-mask [env t impls]
+ (let [resolve #(let [ret (:name (cljs.compiler/resolve-var (dissoc env :locals) %))]
+ (assert ret (core/str "Can't resolve: " %))
+ ret)
+ impl-map (loop [ret {} s impls]
+ (if (seq s)
+ (recur (assoc ret (first s) (take-while seq? (next s)))
+ (drop-while seq? (next s)))
+ ret))]
+ (if-let [fpp-bits (seq (keep fast-path-protocols
+ (map resolve
+ (keys impl-map))))]
+ (reduce core/bit-or fpp-bits))))
+
(defmacro deftype [t fields & impls]
(let [adorn-params (fn [sig]
(cons (vary-meta (second sig) assoc :cljs.compiler/fields fields)
@@ -332,27 +352,29 @@
(group-by first (take-while seq? (next s))))))
(drop-while seq? (next s)))
ret)))
- r (:name (cljs.compiler/resolve-var (dissoc &env :locals) t))]
+ r (:name (cljs.compiler/resolve-var (dissoc &env :locals) t))
+ pmask (prepare-protocol-mask &env t impls)]
(if (seq impls)
`(do
- (deftype* ~t ~fields)
+ (deftype* ~t ~fields ~pmask)
(set! (.-cljs$lang$type ~t) true)
(set! (.-cljs$lang$ctorPrSeq ~t) (fn [this#] (list ~(core/str r))))
(extend-type ~t ~@(dt->et impls))
~t)
`(do
- (deftype* ~t ~fields)
+ (deftype* ~t ~fields ~pmask)
(set! (.-cljs$lang$type ~t) true)
(set! (.-cljs$lang$ctorPrSeq ~t) (fn [this#] (list ~(core/str r))))
~t))))
(defn- emit-defrecord
"Do not use this directly - use defrecord"
- [tagname rname fields impls]
+ [env tagname rname fields impls]
(let [hinted-fields fields
fields (vec (map #(with-meta % nil) fields))
base-fields fields
fields (conj fields '__meta '__extmap)
+ pmask (prepare-protocol-mask env tagname impls)
adorn-params (fn [sig]
(cons (vary-meta (second sig) assoc :cljs.compiler/fields fields)
(nnext sig)))
@@ -427,7 +449,7 @@
~'__extmap))))
])]
`(do
- (~'defrecord* ~tagname ~hinted-fields)
+ (~'defrecord* ~tagname ~hinted-fields ~pmask)
(extend-type ~tagname ~@(dt->et impls))))))
(defn- build-positional-factory
@@ -450,7 +472,7 @@
(defmacro defrecord [rsym fields & impls]
(let [r (:name (cljs.compiler/resolve-var (dissoc &env :locals) rsym))]
`(let []
- ~(emit-defrecord rsym r fields impls)
+ ~(emit-defrecord &env rsym r fields impls)
(set! (.-cljs$lang$type ~r) true)
(set! (.-cljs$lang$ctorPrSeq ~r) (fn [this#] (list ~(core/str r))))
~(build-positional-factory rsym r fields)
@@ -492,9 +514,12 @@
[psym x]
(let [p (:name (cljs.compiler/resolve-var (dissoc &env :locals) psym))
prefix (protocol-prefix p)
- xsym (gensym)]
+ xsym (gensym)
+ msym (symbol "-__protocol_mask")]
`(let [~xsym ~x]
(if (and (coercive-not= ~xsym nil)
+ ~@(if-let [bit (fast-path-protocols p)]
+ [(bool-expr `(bit-and (. ~xsym ~msym) ~bit))])
~(bool-expr `(. ~xsym ~(symbol (core/str "-" prefix)))))
true
(cljs.core/type_satisfies_ ~psym ~xsym)))))
Please sign in to comment.
Something went wrong with that request. Please try again.