Fix performance regression in vector ops on specialized arrays, tweak definition...

diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor
index 69d8929c651d49d90f4a67f739a887ed9cf0f9d7..6cb16e5efc5f5f96180c9b953583bb4692c9405f 100644 (file)
--- a/basis/math/vectors/vectors.factor
+++ b/basis/math/vectors/vectors.factor
@@ -1,49 +1,49 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays alien.c-types assocs kernel sequences math math.functions
-grouping hints math.order math.libm math.floats.private fry combinators
-byte-arrays accessors locals ;
+USING: arrays alien.c-types assocs kernel sequences math
+math.functions grouping math.order math.libm math.floats.private
+fry combinators byte-arrays accessors locals ;
 QUALIFIED-WITH: alien.c-types c
 IN: math.vectors
 
 GENERIC: vneg ( u -- v )
-M: object vneg [ neg ] map ;
+M: object vneg [ neg ] map ; inline
 
 GENERIC# v+n 1 ( u n -- w )
-M: object v+n [ + ] curry map ;
+M: object v+n [ + ] curry map ; inline
 
 GENERIC: n+v ( n v -- w )
-M: object n+v [ + ] with map ;
+M: object n+v [ + ] with map ; inline
 
 GENERIC# v-n 1 ( u n -- w )
-M: object v-n [ - ] curry map ;
+M: object v-n [ - ] curry map ; inline
 
 GENERIC: n-v ( n v -- w )
-M: object n-v [ - ] with map ;
+M: object n-v [ - ] with map ; inline
 
 GENERIC# v*n 1 ( u n -- w )
-M: object v*n [ * ] curry map ;
+M: object v*n [ * ] curry map ; inline
 
 GENERIC: n*v ( n v -- w )
-M: object n*v [ * ] with map ;
+M: object n*v [ * ] with map ; inline
 
 GENERIC# v/n 1 ( u n -- w )
-M: object v/n [ / ] curry map ;
+M: object v/n [ / ] curry map ; inline
 
 GENERIC: n/v ( n v -- w )
-M: object n/v [ / ] with map ;
+M: object n/v [ / ] with map ; inline
 
 GENERIC: v+  ( u v -- w )
-M: object v+ [ + ] 2map ;
+M: object v+ [ + ] 2map ; inline
 
 GENERIC: v-  ( u v -- w )
-M: object v- [ - ] 2map ;
+M: object v- [ - ] 2map ; inline
 
 GENERIC: [v-] ( u v -- w )
-M: object [v-] [ [-] ] 2map ;
+M: object [v-] [ [-] ] 2map ; inline
 
 GENERIC: v* ( u v -- w )
-M: object v* [ * ] 2map ;
+M: object v* [ * ] 2map ; inline
 
 GENERIC: v*high ( u v -- w )
 
@@ -53,43 +53,43 @@ GENERIC: v*high ( u v -- w )
 PRIVATE>
 
 GENERIC: v*hs+ ( u v -- w )
-M: object v*hs+ [ * ] 2map (h+) ;
+M: object v*hs+ [ * ] 2map (h+) ; inline
 
 GENERIC: v/ ( u v -- w )
-M: object v/ [ / ] 2map ;
+M: object v/ [ / ] 2map ; inline
 
 GENERIC: vavg ( u v -- w )
-M: object vavg [ + 2 / ] 2map ;
+M: object vavg [ + 2 / ] 2map ; inline
 
 GENERIC: vmax ( u v -- w )
-M: object vmax [ max ] 2map ;
+M: object vmax [ max ] 2map ; inline
 
 GENERIC: vmin ( u v -- w )
-M: object vmin [ min ] 2map ;
+M: object vmin [ min ] 2map ; inline
 
 GENERIC: v+- ( u v -- w )
 M: object v+-
     [ t ] 2dip
     [ [ not ] 2dip pick [ + ] [ - ] if ] 2map
-    nip ;
+    nip ; inline
 
 GENERIC: vs+ ( u v -- w )
-M: object vs+ [ + ] 2map ;
+M: object vs+ [ + ] 2map ; inline
 
 GENERIC: vs- ( u v -- w )
-M: object vs- [ - ] 2map ;
+M: object vs- [ - ] 2map ; inline
 
 GENERIC: vs* ( u v -- w )
-M: object vs* [ * ] 2map ;
+M: object vs* [ * ] 2map ; inline
 
 GENERIC: vabs ( u -- v )
-M: object vabs [ abs ] map ;
+M: object vabs [ abs ] map ; inline
 
 GENERIC: vsqrt ( u -- v )
-M: object vsqrt [ >float fsqrt ] map ;
+M: object vsqrt [ >float fsqrt ] map ; inline
 
 GENERIC: vsad ( u v -- n )
-M: object vsad [ - abs ] [ + ] 2map-reduce ;
+M: object vsad [ - abs ] [ + ] 2map-reduce ; inline
 
 <PRIVATE
 
@@ -98,23 +98,23 @@ M: object vsad [ - abs ] [ + ] 2map-reduce ;
 PRIVATE>
 
 GENERIC: vbitand ( u v -- w )
-M: object vbitand [ bitand ] 2map ;
+M: object vbitand [ bitand ] 2map ; inline
 GENERIC: vbitandn ( u v -- w )
-M: object vbitandn [ bitandn ] 2map ;
+M: object vbitandn [ bitandn ] 2map ; inline
 GENERIC: vbitor ( u v -- w )
-M: object vbitor [ bitor ] 2map ;
+M: object vbitor [ bitor ] 2map ; inline
 GENERIC: vbitxor ( u v -- w )
-M: object vbitxor [ bitxor ] 2map ;
+M: object vbitxor [ bitxor ] 2map ; inline
 GENERIC: vbitnot ( u -- w )
-M: object vbitnot [ bitnot ] map ;
+M: object vbitnot [ bitnot ] map ; inline
 
 GENERIC# vbroadcast 1 ( u n -- v )
-M:: object vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
+M:: object vbroadcast ( u n -- v ) u length n u nth <repetition> u like ; inline
 
 GENERIC# vshuffle-elements 1 ( u perm -- v )
 M: object vshuffle-elements
     over length 0 pad-tail
-    swap [ '[ _ nth ] ] keep map-as ;
+    swap [ '[ _ nth ] ] keep map-as ; inline
 
 GENERIC# vshuffle-bytes 1 ( u perm -- v )
 
@@ -123,66 +123,66 @@ M: array vshuffle ( u perm -- v )
     vshuffle-elements ; inline
 
 GENERIC# vlshift 1 ( u n -- w )
-M: object vlshift '[ _ shift ] map ;
+M: object vlshift '[ _ shift ] map ; inline
 GENERIC# vrshift 1 ( u n -- w )
-M: object vrshift neg '[ _ shift ] map ;
+M: object vrshift neg '[ _ shift ] map ; inline
 
 GENERIC# hlshift 1 ( u n -- w )
 GENERIC# hrshift 1 ( u n -- w )
 
 GENERIC: (vmerge-head) ( u v -- h )
-M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ;
+M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; inline
 GENERIC: (vmerge-tail) ( u v -- t )
-M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ;
+M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; inline
 
 GENERIC: (vmerge) ( u v -- h t )
 M: object (vmerge)
     [ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline
 
 GENERIC: vmerge ( u v -- w )
-M: object vmerge [ zip ] keep concat-as ;
+M: object vmerge [ zip ] keep concat-as ; inline
 
 GENERIC: vand ( u v -- w )
-M: object vand [ and ] 2map ;
+M: object vand [ and ] 2map ; inline
 
 GENERIC: vandn ( u v -- w )
-M: object vandn [ [ not ] dip and ] 2map ;
+M: object vandn [ [ not ] dip and ] 2map ; inline
 
 GENERIC: vor  ( u v -- w )
-M: object vor  [ or  ] 2map ;
+M: object vor  [ or  ] 2map ; inline
 
 GENERIC: vxor ( u v -- w )
-M: object vxor [ xor ] 2map ;
+M: object vxor [ xor ] 2map ; inline
 
 GENERIC: vnot ( u -- w )
-M: object vnot [ not ] map ;
+M: object vnot [ not ] map ; inline
 
 GENERIC: vall? ( v -- ? )
-M: object vall? [ ] all? ;
+M: object vall? [ ] all? ; inline
 
 GENERIC: vany? ( v -- ? )
-M: object vany? [ ] any? ;
+M: object vany? [ ] any? ; inline
 
 GENERIC: vnone? ( v -- ? )
-M: object vnone? [ not ] all? ;
+M: object vnone? [ not ] all? ; inline
 
 GENERIC: v<  ( u v -- w )
-M: object v<  [ <   ] 2map ;
+M: object v<  [ <   ] 2map ; inline
 
 GENERIC: v<= ( u v -- w )
-M: object v<= [ <=  ] 2map ;
+M: object v<= [ <=  ] 2map ; inline
 
 GENERIC: v>= ( u v -- w )
-M: object v>= [ >=  ] 2map ;
+M: object v>= [ >=  ] 2map ; inline
 
 GENERIC: v>  ( u v -- w )
-M: object v>  [ >   ] 2map ;
+M: object v>  [ >   ] 2map ; inline
 
 GENERIC: vunordered? ( u v -- w )
-M: object vunordered? [ unordered? ] 2map ;
+M: object vunordered? [ unordered? ] 2map ; inline
 
 GENERIC: v=  ( u v -- w )
-M: object v=  [ =   ] 2map ;
+M: object v=  [ =   ] 2map ; inline
 
 GENERIC: v? ( mask true false -- result )
 M: object v? 
@@ -203,17 +203,17 @@ M: object v?
 : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; inline
 
 GENERIC: v. ( u v -- x )
-M: object v. [ conjugate * ] [ + ] 2map-reduce ;
+M: object v. [ conjugate * ] [ + ] 2map-reduce ; inline
 
 GENERIC: norm-sq ( v -- x )
-M: object norm-sq [ absq ] [ + ] map-reduce ;
+M: object norm-sq [ absq ] [ + ] map-reduce ; inline
 
 : norm ( v -- x ) norm-sq sqrt ; inline
 
 : normalize ( u -- v ) dup norm v/n ; inline
 
 GENERIC: distance ( u v -- x )
-M: object distance [ - absq ] [ + ] 2map-reduce sqrt ;
+M: object distance [ - absq ] [ + ] 2map-reduce sqrt ; inline
 
 : set-axis ( u v axis -- w )
     [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
@@ -245,28 +245,3 @@ PRIVATE>
 
 : v~ ( a b epsilon -- ? )
     [ ~ ] curry 2all? ; inline
-
-HINTS: M\ object vneg { array } ;
-HINTS: M\ object norm-sq { array } ;
-HINTS: norm { array } ;
-HINTS: M\ object distance { array array } ;
-
-HINTS: M\ object n*v { object array } ;
-HINTS: M\ object v*n { array object } ;
-HINTS: M\ object n/v { object array } ;
-HINTS: M\ object v/n { array object } ;
-
-HINTS: M\ object v+ { array array } ;
-HINTS: M\ object v- { array array } ;
-HINTS: M\ object v* { array array } ;
-HINTS: M\ object v/ { array array } ;
-HINTS: M\ object vmax { array array } ;
-HINTS: M\ object vmin { array array } ;
-HINTS: M\ object v. { array array } ;
-
-HINTS: vlerp { array array array } ;
-HINTS: vnlerp { array array object } ;
-
-HINTS: bilerp { object object object object array } ;
-HINTS: trilerp { object object object object object object object object array } ;
-

diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor
index ba7c2723e945a35e83dd2980be0d47a0f74a8984..eda793ff22030e93478ff3c1fe59098abbf1fe1b 100644 (file)
--- a/basis/specialized-arrays/specialized-arrays.factor
+++ b/basis/specialized-arrays/specialized-arrays.factor
@@ -101,11 +101,11 @@ SYNTAX: A@ scan-object scan-object <direct-A> suffix! ;
 
 INSTANCE: A specialized-array
 
-M: A vs+ [ + \ T c-type-clamp ] 2map ;
-M: A vs- [ - \ T c-type-clamp ] 2map ;
-M: A vs* [ * \ T c-type-clamp ] 2map ;
+M: A vs+ [ + \ T c-type-clamp ] 2map ; inline
+M: A vs- [ - \ T c-type-clamp ] 2map ; inline
+M: A vs* [ * \ T c-type-clamp ] 2map ; inline
 
-M: A v*high [ * \ T heap-size neg shift ] 2map ;
+M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
 
 ;FUNCTOR
 

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 7d1e45aca0ffb0db67182d67e0593b4c23dfd138..b8a8d5f89de2fa5f888a485371e88fbd093a6c89 100644 (file)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -221,8 +221,8 @@ TUPLE: slice-error from to seq reason ;
     3tri ; inline
 
 : <slice> ( from to seq -- slice )
-    dup slice? [ collapse-slice ] when
     check-slice
+    dup slice? [ collapse-slice ] when
     slice boa ; inline
 
 M: slice virtual-exemplar seq>> ; inline
@@ -836,6 +836,12 @@ 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 ]
+    [ [ [ first-unsafe ] bi@ ] dip call ]
+    3tri -rot ; inline
+
 PRIVATE>
 
 : start* ( subseq seq n -- i )
@@ -868,8 +874,8 @@ PRIVATE>
     compose reduce ; inline
 
 : 2map-reduce ( seq1 seq2 map-quot reduce-quot -- result )
-    [ [ 2unclip-slice ] dip [ call ] keep ] dip
-    compose 2reduce ; inline
+    [ [ prepare-2map-reduce ] keep ] dip
+    compose compose each-integer ; inline
 
 <PRIVATE