Fix performance regression in vector ops on specialized arrays, tweak definition of <slice> and 2map-reduce to generate fewer conditionals
Slava Pestov
parent
87c3bc4e69
commit
8836ce2581
|
|
@ -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 } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue