InternalReduce

Signed-off-by: Stuart Halloway <stu@thinkrelevance.com>

8 files changed, 200 insertions, 24 deletions

diff --git a/build.xml b/build.xml
index 2b59ddc4..99661c4e 100644
--- a/build.xml
+++ b/build.xml
@@ -92,6 +92,7 @@
       <sysproperty key="clojure.compile.path" value="${build}"/>
       <!-- <sysproperty key="clojure.compile.warn-on-reflection" value="true"/> -->
       <arg value="clojure.core"/>
+      <arg value="clojure.core.protocols"/>
       <arg value="clojure.main"/>
       <arg value="clojure.set"/>
       <arg value="clojure.xml"/>
diff --git a/src/clj/clojure/core.clj b/src/clj/clojure/core.clj
index 06ca970b..cb2f1d2b 100644
--- a/src/clj/clojure/core.clj
+++ b/src/clj/clojure/core.clj
@@ -690,16 +690,8 @@
   {:inline (fn [x] `(. clojure.lang.Numbers (inc ~x)))}
   [x] (. clojure.lang.Numbers (inc x)))
 
+;; reduce is defined again later after InternalReduce loads
 (defn reduce
-  "f should be a function of 2 arguments. If val is not supplied,
-  returns the result of applying f to the first 2 items in coll, then
-  applying f to that result and the 3rd item, etc. If coll contains no
-  items, f must accept no arguments as well, and reduce returns the
-  result of calling f with no arguments.  If coll has only 1 item, it
-  is returned and f is not called.  If val is supplied, returns the
-  result of applying f to val and the first item in coll, then
-  applying f to that result and the 2nd item, etc. If coll contains no
-  items, returns val and f is not called."
   ([f coll]
    (let [s (seq coll)]
      (if s
@@ -4704,7 +4696,28 @@
 (load "core_print")
 (load "genclass")
 (load "core_deftype")
+(load "core/protocols")
 (load "gvec")
+
+;; redefine reduce with internal-reduce
+(defn reduce
+  "f should be a function of 2 arguments. If val is not supplied,
+  returns the result of applying f to the first 2 items in coll, then
+  applying f to that result and the 3rd item, etc. If coll contains no
+  items, f must accept no arguments as well, and reduce returns the
+  result of calling f with no arguments.  If coll has only 1 item, it
+  is returned and f is not called.  If val is supplied, returns the
+  result of applying f to val and the first item in coll, then
+  applying f to that result and the 2nd item, etc. If coll contains no
+  items, returns val and f is not called."
+  ([f coll]
+     (if-let [s (seq coll)]
+       (reduce f (first s) (next s))
+       (f)))
+  ([f start coll]
+     (let [s (seq coll)]
+       (clojure.core.protocols/internal-reduce s f start))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; futures (needs proxy);;;;;;;;;;;;;;;;;;
 (defn future-call 
   "Takes a function of no args and yields a future object that will
diff --git a/src/clj/clojure/core/protocols.clj b/src/clj/clojure/core/protocols.clj
new file mode 100644
index 00000000..4184e91e
--- /dev/null
+++ b/src/clj/clojure/core/protocols.clj
@@ -0,0 +1,92 @@
+;   Copyright (c) Rich Hickey. All rights reserved.
+;   The use and distribution terms for this software are covered by the
+;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;   which can be found in the file epl-v10.html at the root of this distribution.
+;   By using this software in any fashion, you are agreeing to be bound by
+;   the terms of this license.
+;   You must not remove this notice, or any other, from this software.
+
+(ns clojure.core.protocols)
+
+(defprotocol InternalReduce
+  "Protocol for concrete seq types that can reduce themselves
+   faster than first/next recursion. Called by clojure.core/reduce."
+  (internal-reduce [seq f start]))
+
+(extend-protocol InternalReduce
+  nil
+  (internal-reduce
+   [s f val]
+   val)
+  
+  ;; handles vectors and ranges
+  clojure.lang.IChunkedSeq
+  (internal-reduce
+   [s f val]
+   (if-let [s (seq s)]
+     (recur (chunk-next s)
+            f
+            (.reduce (chunk-first s) f val))
+     val))
+
+  clojure.lang.StringSeq
+  (internal-reduce
+   [str-seq f val]
+   (let [s (.s str-seq)]
+     (loop [i (.i str-seq)
+            val val]
+       (if (< i (.length s))
+         (recur (inc i) (f val (.charAt s i)))
+         val))))
+  
+  clojure.lang.ArraySeq
+  (internal-reduce
+       [a-seq f val]
+       (let [#^objects arr (.array a-seq)]
+         (loop [i (.index a-seq)
+                val val]
+           (if (< i (alength arr))
+             (recur (inc i) (f val (aget arr i)))
+             val))))
+  
+  java.lang.Object
+  (internal-reduce
+   [s f val]
+   (loop [cls (class s)
+          s s
+          f f
+          val val]
+     (if-let [s (seq s)]
+       ;; roll over to faster implementation if underlying seq changes type
+       (if (identical? (class s) cls)
+         (recur cls (next s) f (f val (first s)))
+         (internal-reduce s f val))
+       val))))
+
+(def arr-impl
+  '(internal-reduce
+       [a-seq f val]
+       (let [arr (.array a-seq)]
+         (loop [i (.index a-seq)
+                val val]
+           (if (< i (alength arr))
+             (recur (inc i) (f val (aget arr i)))
+             val)))))
+
+(defn- emit-array-impls*
+  [syms]
+  (apply
+   concat
+   (map
+    (fn [s]
+      [(symbol (str "clojure.lang.ArraySeq$ArraySeq_" s))
+       arr-impl])
+    syms)))
+
+(defmacro emit-array-impls
+  [& syms]
+  `(extend-protocol InternalReduce
+     ~@(emit-array-impls* syms)))
+
+(emit-array-impls int long float double byte char boolean)
+
diff --git a/src/clj/clojure/gvec.clj b/src/clj/clojure/gvec.clj
index 2b1223ad..d5d947d6 100644
--- a/src/clj/clojure/gvec.clj
+++ b/src/clj/clojure/gvec.clj
@@ -54,6 +54,21 @@
 (deftype VecSeq [#^clojure.core.ArrayManager am #^clojure.core.IVecImpl vec anode #^int i #^int offset] 
   :no-print true
 
+  clojure.core.protocols.InternalReduce
+  (internal-reduce
+   [_ f val]
+   (loop [result val
+          aidx offset]
+     (if (< aidx (count vec))
+       (let [node (.arrayFor vec aidx)
+             result (loop [result result
+                           node-idx (bit-and (int 0x1f) aidx)]
+                      (if (< node-idx (.alength am node))
+                        (recur (f result (.aget am node node-idx)) (inc node-idx))
+                        result))]
+         (recur result (bit-and (int 0xffe0) (+ aidx (int 32)))))
+       result)))
+  
   clojure.lang.ISeq
   (first [_] (.aget am anode offset))
   (next [this] 
diff --git a/src/jvm/clojure/lang/ArraySeq.java b/src/jvm/clojure/lang/ArraySeq.java
index 117dd4f5..3517eab4 100644
--- a/src/jvm/clojure/lang/ArraySeq.java
+++ b/src/jvm/clojure/lang/ArraySeq.java
@@ -15,7 +15,7 @@ package clojure.lang;
 import java.lang.reflect.Array;
 
 public class ArraySeq extends ASeq implements IndexedSeq, IReduce{
-final Object array;
+public final Object array;
 final int i;
 final Object[] oa;
 //ISeq _rest;
@@ -164,7 +164,7 @@ public int lastIndexOf(Object o) {
 //////////////////////////////////// specialized primitive versions ///////////////////////////////
 
 static public class ArraySeq_int extends ASeq implements IndexedSeq, IReduce{
-	final int[] array;
+	public final int[] array;
 	final int i;
 
 	ArraySeq_int(IPersistentMap meta, int[] array, int i){
@@ -240,7 +240,7 @@ static public class ArraySeq_int extends ASeq implements IndexedSeq, IReduce{
 
 
 static public class ArraySeq_float extends ASeq implements IndexedSeq, IReduce{
-	final float[] array;
+	public final float[] array;
 	final int i;
 
 	ArraySeq_float(IPersistentMap meta, float[] array, int i){
@@ -315,7 +315,7 @@ static public class ArraySeq_float extends ASeq implements IndexedSeq, IReduce{
 }
 
 static public class ArraySeq_double extends ASeq implements IndexedSeq, IReduce{
-	final double[] array;
+	public final double[] array;
 	final int i;
 
 	ArraySeq_double(IPersistentMap meta, double[] array, int i){
@@ -390,7 +390,7 @@ static public class ArraySeq_double extends ASeq implements IndexedSeq, IReduce{
 }
 
 static public class ArraySeq_long extends ASeq implements IndexedSeq, IReduce{
-	final long[] array;
+	public final long[] array;
 	final int i;
 
 	ArraySeq_long(IPersistentMap meta, long[] array, int i){
@@ -465,7 +465,7 @@ static public class ArraySeq_long extends ASeq implements IndexedSeq, IReduce{
 }
 
 static public class ArraySeq_byte extends ASeq implements IndexedSeq, IReduce{
-	final byte[] array;
+	public final byte[] array;
 	final int i;
 
 	ArraySeq_byte(IPersistentMap meta, byte[] array, int i){
@@ -540,7 +540,7 @@ static public class ArraySeq_byte extends ASeq implements IndexedSeq, IReduce{
 }
 
 static public class ArraySeq_char extends ASeq implements IndexedSeq, IReduce{
-	final char[] array;
+	public final char[] array;
 	final int i;
 
 	ArraySeq_char(IPersistentMap meta, char[] array, int i){
@@ -615,7 +615,7 @@ static public class ArraySeq_char extends ASeq implements IndexedSeq, IReduce{
 }
 
 static public class ArraySeq_boolean extends ASeq implements IndexedSeq, IReduce{
-	final boolean[] array;
+	public final boolean[] array;
 	final int i;
 
 	ArraySeq_boolean(IPersistentMap meta, boolean[] array, int i){
diff --git a/src/jvm/clojure/lang/PersistentVector.java b/src/jvm/clojure/lang/PersistentVector.java
index e93052e4..a521eaa8 100644
--- a/src/jvm/clojure/lang/PersistentVector.java
+++ b/src/jvm/clojure/lang/PersistentVector.java
@@ -233,10 +233,10 @@ public ISeq seq(){
 
 static public final class ChunkedSeq extends ASeq implements IChunkedSeq{
 
-	final PersistentVector vec;
+	public final PersistentVector vec;
 	final Object[] node;
 	final int i;
-	final int offset;
+	public final int offset;
 
 	public ChunkedSeq(PersistentVector vec, int i, int offset){
 		this.vec = vec;
diff --git a/src/jvm/clojure/lang/StringSeq.java b/src/jvm/clojure/lang/StringSeq.java
index aa70617b..bcb269d5 100644
--- a/src/jvm/clojure/lang/StringSeq.java
+++ b/src/jvm/clojure/lang/StringSeq.java
@@ -13,8 +13,8 @@
 package clojure.lang;
 
 public class StringSeq extends ASeq implements IndexedSeq{
-final CharSequence s;
-final int i;
+public final CharSequence s;
+public final int i;
 
 static public StringSeq create(CharSequence s){
 	if(s.length() == 0)
diff --git a/test/clojure/test_clojure/sequences.clj b/test/clojure/test_clojure/sequences.clj
index 6aa3c695..51d379b1 100644
--- a/test/clojure/test_clojure/sequences.clj
+++ b/test/clojure/test_clojure/sequences.clj
@@ -7,18 +7,73 @@
 ;   You must not remove this notice, or any other, from this software.
 
 ; Author: Frantisek Sodomka
-
+; Contributors: Stuart Halloway
 
 (ns clojure.test-clojure.sequences
   (:use clojure.test))
 
-
 ;; *** Tests ***
 
 ; TODO:
-; apply, map, reduce, filter, remove
+; apply, map, filter, remove
 ; and more...
 
+(deftest test-reduce
+  (let [int+ (fn [a b] (+ (int a) (int b)))
+        arange (range 100) ;; enough to cross nodes
+        avec (into [] arange)
+        alist (into () arange)
+        obj-array (into-array arange)
+        int-array (into-array Integer/TYPE arange)
+        long-array (into-array Long/TYPE arange)
+        float-array (into-array Float/TYPE arange)
+        char-array (into-array Character/TYPE (map char arange))
+        double-array (into-array Double/TYPE arange)
+        byte-array (into-array Byte/TYPE (map byte arange))
+        int-vec (into (vector-of :int) arange)
+        long-vec (into (vector-of :long) arange)
+        float-vec (into (vector-of :float) arange)
+        char-vec (into (vector-of :char) (map char arange))
+        double-vec (into (vector-of :double) arange)
+        byte-vec (into (vector-of :byte) (map byte arange))
+        all-true (into-array Boolean/TYPE (repeat 10 true))]
+    (is (= 4950
+           (reduce + arange)
+           (reduce + avec)
+           (reduce + alist)
+           (reduce + obj-array)
+           (reduce + int-array)
+           (reduce + long-array)
+           (reduce + float-array)
+           (reduce int+ char-array)
+           (reduce + double-array)
+           (reduce int+ byte-array)
+           (reduce + int-vec)
+           (reduce + long-vec)
+           (reduce + float-vec)
+           (reduce int+ char-vec)
+           (reduce + double-vec)
+           (reduce int+ byte-vec)))
+    (is (= 4951
+           (reduce + 1 arange)
+           (reduce + 1 avec)
+           (reduce + 1 alist)
+           (reduce + 1 obj-array)
+           (reduce + 1 int-array)
+           (reduce + 1 long-array)
+           (reduce + 1 float-array)
+           (reduce int+ 1 char-array)
+           (reduce + 1 double-array)
+           (reduce int+ 1 byte-array)
+           (reduce + 1 int-vec)
+           (reduce + 1 long-vec)
+           (reduce + 1 float-vec)
+           (reduce int+ 1 char-vec)
+           (reduce + 1 double-vec)
+           (reduce int+ 1 byte-vec)))
+    (is (= true
+           (reduce #(and %1 %2) all-true)
+           (reduce #(and %1 %2) true all-true)))))
 
 (deftest test-equality
   ; lazy sequences