Navigation Menu

Skip to content

Commit

Permalink
case changes: handles hash collisions, can emit return type, performa…
Browse files Browse the repository at this point in the history 
…nce path for all-int test constants

Signed-off-by: Stuart Halloway <stu@thinkrelevance.com>
  • Loading branch information
@stuarthalloway
Alexander Taggart authored and stuarthalloway committed Apr 29, 2011
1 parent 71b5461 commit 34489bd
Show file tree
Hide file tree
Showing 5 changed files with 546 additions and 137 deletions.
226 changes: 173 additions & 53 deletions src/clj/clojure/core.clj
View file
Expand Up @@ -5714,25 +5714,154 @@
(map #(cons `fn %) fnspecs)))
~@body))

(defn fnil
"Takes a function f, and returns a function that calls f, replacing
a nil first argument to f with the supplied value x. Higher arity
versions can replace arguments in the second and third
positions (y, z). Note that the function f can take any number of
arguments, not just the one(s) being nil-patched."
{:added "1.2"
:static true}
([f x]
(fn
([a] (f (if (nil? a) x a)))
([a b] (f (if (nil? a) x a) b))
([a b c] (f (if (nil? a) x a) b c))
([a b c & ds] (apply f (if (nil? a) x a) b c ds))))
([f x y]
(fn
([a b] (f (if (nil? a) x a) (if (nil? b) y b)))
([a b c] (f (if (nil? a) x a) (if (nil? b) y b) c))
([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) c ds))))
([f x y z]
(fn
([a b] (f (if (nil? a) x a) (if (nil? b) y b)))
([a b c] (f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c)))
([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) ds)))))


;;;;;;; case ;;;;;;;;;;;;;
(defn- shift-mask [shift mask x]
(-> x (bit-shift-right shift) (bit-and mask)))

(def ^:private max-mask-bits 13)
(def ^:private max-switch-table-size (bit-shift-left 1 max-mask-bits))

(defn- maybe-min-hash
"takes a collection of hashes and returns [shift mask] or nil if none found"
[hashes]
(first
(filter (fn [[s m]]
(apply distinct? (map #(shift-mask s m %) hashes)))
(for [mask (map #(dec (bit-shift-left 1 %)) (range 1 (inc max-mask-bits)))
shift (range 0 31)]
[shift mask]))))

(defn- min-hash
"takes a collection of keys and returns [shift mask]"
[keys]
(let [hashes (map hash keys)
cnt (count keys)]
(when-not (apply distinct? hashes)
(throw (IllegalArgumentException. "Hashes must be distinct")))
(or (first
(filter (fn [[s m]]
(apply distinct? (map #(shift-mask s m %) hashes)))
(for [mask (map #(dec (bit-shift-left 1 %)) (range 1 14))
shift (range 0 31)]
[shift mask])))
(throw (IllegalArgumentException. "No distinct mapping found")))))
_ (when-not (apply distinct? hashes)
(throw (IllegalArgumentException. "Hashes must be distinct")))
sm (maybe-min-hash hashes)]
(or sm (throw (IllegalArgumentException. "No distinct mapping found")))))

(defn- case-map
"Transforms a sequence of test constants and a corresponding sequence of then
expressions into a sorted map to be consumed by case*. The form of the map
entries are {(case-f test) [(test-f test) then]}."
[case-f test-f tests thens]
(into1 (sorted-map)
(zipmap (map case-f tests)
(map vector
(map test-f tests)
thens))))

(defn- fits-table?
"Returns true if the collection of ints can fit within the
max-table-switch-size, false otherwise."
[ints]
(< (- (apply max (seq ints)) (apply min (seq ints))) max-switch-table-size))

(defn- prep-ints
"Takes a sequence of int-sized test constants and a corresponding sequence of
then expressions. Returns a tuple of [shift mask case-map switch-type] where
case-map is a map of int case values to [test then] tuples, and switch-type
is either :sparse or :compact."
[tests thens]
(if (fits-table? tests)
; compact case ints, no shift-mask
[0 0 (case-map int int tests thens) :compact]
(let [[shift mask] (or (maybe-min-hash (map int tests)) [0 0])]
(if (zero? mask)
; sparse case ints, no shift-mask
[0 0 (case-map int int tests thens) :sparse]
; compact case ints, with shift-mask
[shift mask (case-map #(shift-mask shift mask (int %)) int tests thens) :compact]))))

(defn- merge-hash-collisions
"Takes a case expression, default expression, and a sequence of test constants
and a corresponding sequence of then expressions. Returns a tuple of
[tests thens skip-check-set] where no tests have the same hash. Each set of
input test constants with the same hash is replaced with a single test
constant (the case int), and their respective thens are combined into:
(condp = expr
test-1 then-1
...
test-n then-n
default).
The skip-check is a set of case ints for which post-switch equivalence
checking must not be done (the cases holding the above condp thens)."
[expr-sym default tests thens]
(let [buckets (loop [m {} ks tests vs thens]
(if (and ks vs)
(recur
(update-in m [(hash (first ks))] (fnil conj []) [(first ks) (first vs)])
(next ks) (next vs))
m))
assoc-multi (fn [m h bucket]
(let [testexprs (apply concat bucket)
expr `(condp = ~expr-sym ~@testexprs ~default)]
(assoc m h expr)))
hmap (reduce1
(fn [m [h bucket]]
(if (== 1 (count bucket))
(assoc m (ffirst bucket) (second (first bucket)))
(assoc-multi m h bucket)))
{} buckets)
skip-check (->> buckets
(filter #(< 1 (count (second %))))
(map first)
(into1 #{}))]
[(keys hmap) (vals hmap) skip-check]))

(defn- prep-hashes
"Takes a sequence of test constants and a corresponding sequence of then
expressions. Returns a tuple of [shift mask case-map switch-type skip-check]
where case-map is a map of int case values to [test then] tuples, switch-type
is either :sparse or :compact, and skip-check is a set of case ints for which
post-switch equivalence checking must not be done (occurs with hash
collisions)."
[expr-sym default tests thens]
(let [hashes (into1 #{} (map hash tests))]
(if (== (count tests) (count hashes))
(if (fits-table? hashes)
; compact case ints, no shift-mask
[0 0 (case-map hash identity tests thens) :compact]
(let [[shift mask] (or (maybe-min-hash hashes) [0 0])]
(if (zero? mask)
; sparse case ints, no shift-mask
[0 0 (case-map hash identity tests thens) :sparse]
; compact case ints, with shift-mask
[shift mask (case-map #(shift-mask shift mask (hash %)) identity tests thens) :compact])))
; resolve hash collisions and try again
(let [[tests thens skip-check] (merge-hash-collisions expr-sym default tests thens)
[shift mask case-map switch-type] (prep-hashes expr-sym default tests thens)
skip-check (if (zero? mask)
skip-check
(into1 #{} (map #(shift-mask shift mask %) skip-check)))]
[shift mask case-map switch-type skip-check]))))


(defmacro case
"Takes an expression, and a set of clauses.
Expand Down Expand Up @@ -5763,24 +5892,40 @@
(let [ge (with-meta (gensym) {:tag Object})
default (if (odd? (count clauses))
(last clauses)
`(throw (IllegalArgumentException. (str "No matching clause: " ~ge))))
cases (partition 2 clauses)
case-map (reduce1 (fn [m [test expr]]
(if (seq? test)
(into1 m (zipmap test (repeat expr)))
(assoc m test expr)))
{} cases)
[shift mask] (if (seq case-map) (min-hash (keys case-map)) [0 0])

hmap (reduce1 (fn [m [test expr :as te]]
(assoc m (shift-mask shift mask (hash test)) te))
(sorted-map) case-map)]
`(let [~ge ~e]
~(condp = (count clauses)
0 default
1 default
`(case* ~ge ~shift ~mask ~(key (first hmap)) ~(key (last hmap)) ~default ~hmap
~(every? keyword? (keys case-map)))))))
`(throw (IllegalArgumentException. (str "No matching clause: " ~ge))))]
(if (> 2 (count clauses))
`(let [~ge ~e] ~default)
(let [pairs (partition 2 clauses)
assoc-test (fn assoc-test [m test expr]
(if (contains? m test)
(throw (IllegalArgumentException. (str "Duplicate case test constant: " test)))
(assoc m test expr)))
pairs (reduce1
(fn [m [test expr]]
(if (seq? test)
(reduce1 #(assoc-test %1 %2 expr) m test)
(assoc-test m test expr)))
{} pairs)
tests (keys pairs)
thens (vals pairs)
mode (cond
(every? #(and (integer? %) (<= Integer/MIN_VALUE % Integer/MAX_VALUE)) tests)
:ints
(every? keyword? tests)
:identity
:else :hashes)]
(condp = mode
:ints
(let [[shift mask imap switch-type] (prep-ints tests thens)]
`(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :int)))
:hashes
(let [[shift mask imap switch-type skip-check] (prep-hashes ge default tests thens)]
`(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :hash-equiv ~skip-check)))
:identity
(let [[shift mask imap switch-type skip-check] (prep-hashes ge default tests thens)]
`(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :hash-identity ~skip-check))))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; helper files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(alter-meta! (find-ns 'clojure.core) assoc :doc "Fundamental library of the Clojure language")
Expand Down Expand Up @@ -6194,31 +6339,6 @@
(cons x (keepi (inc idx) (rest s)))))))))]
(keepi 0 coll))))

(defn fnil
"Takes a function f, and returns a function that calls f, replacing
a nil first argument to f with the supplied value x. Higher arity
versions can replace arguments in the second and third
positions (y, z). Note that the function f can take any number of
arguments, not just the one(s) being nil-patched."
{:added "1.2"
:static true}
([f x]
(fn
([a] (f (if (nil? a) x a)))
([a b] (f (if (nil? a) x a) b))
([a b c] (f (if (nil? a) x a) b c))
([a b c & ds] (apply f (if (nil? a) x a) b c ds))))
([f x y]
(fn
([a b] (f (if (nil? a) x a) (if (nil? b) y b)))
([a b c] (f (if (nil? a) x a) (if (nil? b) y b) c))
([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) c ds))))
([f x y z]
(fn
([a b] (f (if (nil? a) x a) (if (nil? b) y b)))
([a b c] (f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c)))
([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) ds)))))

(defn every-pred
"Takes a set of predicates and returns a function f that returns true if all of its
composing predicates return a logical true value against all of its arguments, else it returns
Expand Down

0 comments on commit 34489bd

Please sign in to comment.