sequences: make map-reduce 5-20% faster, and 2map-reduce 3-5% faster.

core/sequences/sequences-tests.factor

@@ -331,4 +331,8 @@ USE: make
 [ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
 [ { 1 2 } { "a" "b" } cartesian-product ] unit-test
 
+[ { } [ ] [ + ] map-reduce ] must-fail
 [ 4 ] [ { 1 1 } [ 1 + ] [ + ] map-reduce ] unit-test
+
+[ { } { } [ + ] [ + ] 2map-reduce ] must-fail
+[ 24 ] [ { 1 2 } { 3 4 } [ + ] [ * ] 2map-reduce ] unit-test

core/sequences/sequences.factor

@@ -857,11 +857,17 @@ PRIVATE>
         [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
     ] all? nip ; inline
 
-: prepare-2map-reduce ( seq1 seq2 map-quot -- initial length seq1 seq2 )
-    [ drop min-length dup 1 < [ "Empty sequence" throw ] when 1 - ]
-    [ drop [ [ 1 + ] 2dip 2nth-unsafe ] 2curry ]
+: prepare-map-reduce ( seq map-quot -- initial i n quot )
+    [ drop length dup 1 < [ "Empty sequence" throw ] when ]
+    [ drop [ nth-unsafe ] curry ]
+    [ [ first-unsafe ] dip call ]
+    2tri -rot [ 1 ] 2dip ; inline
+
+: prepare-2map-reduce ( seq1 seq2 map-quot -- initial i n quot )
+    [ drop min-length dup 1 < [ "Empty sequence" throw ] when ]
+    [ drop [ 2nth-unsafe ] 2curry ]
     [ [ [ first-unsafe ] bi@ ] dip call ]
-    3tri -rot ; inline
+    3tri -rot [ 1 ] 2dip ; inline
 
 PRIVATE>
 
@@ -888,12 +894,12 @@ PRIVATE>
     [ rest-slice ] [ first-unsafe ] bi ; inline
 
 : map-reduce ( ..a seq map-quot: ( ..a x -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
-    [ [ unclip-slice ] dip [ call ] keep ] dip
-    compose reduce ; inline
+    [ [ prepare-map-reduce ] keep ] dip
+    compose compose (each-integer) ; inline
 
 : 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a elt1 elt2 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
     [ [ prepare-2map-reduce ] keep ] dip
-    compose compose each-integer ; inline
+    compose compose (each-integer) ; inline
 
 <PRIVATE
 
@@ -913,7 +919,7 @@ PRIVATE>
     [ but-last-slice ] [ last ] bi ; inline
 
 <PRIVATE
-    
+
 : (trim-head) ( seq quot -- seq n )
     over [ [ not ] compose find drop ] dip
     [ length or ] keep swap ; inline