steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix performance regression in vector ops on specialized arrays, tweak definition of <slice> and 2map-reduce to generate fewer conditionals

db4
Slava Pestov 2010-01-19 17:48:10 +13:00
parent 87c3bc4e69
commit 8836ce2581
3 changed files with 71 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
basis/math/vectors/vectors.factor
View File

@ -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 } ;

8
basis/specialized-arrays/specialized-arrays.factor
View File

@ -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

12
core/sequences/sequences.factor
View File

@ -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