math.vectors.specialization: first attempt at some call site splitting for vector ops. Specialized array types generate customized variants of all vector words, if input types are known at compile time, a call to the specialized version is inserted
Slava Pestov
parent
687454878a
commit
1cb0f3370b
|
|
@ -69,7 +69,7 @@ t specialize-method? set-global
|
|||
dup [ array? ] all? [ first ] when length ;
|
||||
|
||||
SYNTAX: HINTS:
|
||||
scan-object
|
||||
scan-object dup wrapper? [ wrapped>> ] when
|
||||
[ changed-definition ]
|
||||
[ parse-definition { } like "specializer" set-word-prop ] bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ IN: math.intervals.tests
|
|||
|
||||
[ empty-interval ] [ 2 2 (a,b) ] unit-test
|
||||
|
||||
[ empty-interval ] [ 2 2.0 (a,b) ] unit-test
|
||||
|
||||
[ empty-interval ] [ 2 2 [a,b) ] unit-test
|
||||
|
||||
[ empty-interval ] [ 2 2 (a,b] ] unit-test
|
||||
|
|
@ -189,6 +191,10 @@ IN: math.intervals.tests
|
|||
|
||||
[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test
|
||||
|
||||
[ f ] [ 0 10 [a,b] 0.0 [a,a] interval< ] unit-test
|
||||
|
||||
[ f ] [ 0.0 10 [a,b] 0 [a,a] interval< ] unit-test
|
||||
|
||||
[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test
|
||||
|
||||
[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
|
||||
USING: accessors kernel sequences arrays math math.order
|
||||
|
|
@ -14,7 +14,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
: <interval> ( from to -- interval )
|
||||
2dup [ first ] bi@ {
|
||||
{ [ 2dup > ] [ 2drop 2drop empty-interval ] }
|
||||
{ [ 2dup = ] [
|
||||
{ [ 2dup number= ] [
|
||||
2drop 2dup [ second ] both?
|
||||
[ interval boa ] [ 2drop empty-interval ] if
|
||||
] }
|
||||
|
|
@ -56,20 +56,23 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
[ 2dup [ first ] bi@ ] dip call [
|
||||
2drop t
|
||||
] [
|
||||
2dup [ first ] bi@ = [
|
||||
2dup [ first ] bi@ number= [
|
||||
[ second ] bi@ not or
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: endpoint= ( p1 p2 -- ? )
|
||||
[ [ first ] bi@ number= ] [ [ second ] bi@ eq? ] 2bi and ;
|
||||
|
||||
: endpoint< ( p1 p2 -- ? ) [ < ] compare-endpoints ;
|
||||
|
||||
: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] 2keep = or ;
|
||||
: endpoint<= ( p1 p2 -- ? ) [ endpoint< ] [ endpoint= ] 2bi or ;
|
||||
|
||||
: endpoint> ( p1 p2 -- ? ) [ > ] compare-endpoints ;
|
||||
|
||||
: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] 2keep = or ;
|
||||
: endpoint>= ( p1 p2 -- ? ) [ endpoint> ] [ endpoint= ] 2bi or ;
|
||||
|
||||
: endpoint-min ( p1 p2 -- p3 ) [ endpoint< ] most ;
|
||||
|
||||
|
|
@ -180,7 +183,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
] [
|
||||
interval>points
|
||||
2dup [ second ] both?
|
||||
[ [ first ] bi@ = ]
|
||||
[ [ first ] bi@ number= ]
|
||||
[ 2drop f ] if
|
||||
] if ;
|
||||
|
||||
|
|
@ -278,13 +281,13 @@ SYMBOL: incomparable
|
|||
: left-endpoint-< ( i1 i2 -- ? )
|
||||
[ swap interval-subset? ]
|
||||
[ nip interval-singleton? ]
|
||||
[ [ from>> ] bi@ = ]
|
||||
[ [ from>> ] bi@ endpoint= ]
|
||||
2tri and and ;
|
||||
|
||||
: right-endpoint-< ( i1 i2 -- ? )
|
||||
[ interval-subset? ]
|
||||
[ drop interval-singleton? ]
|
||||
[ [ to>> ] bi@ = ]
|
||||
[ [ to>> ] bi@ endpoint= ]
|
||||
2tri and and ;
|
||||
|
||||
: (interval<) ( i1 i2 -- i1 i2 ? )
|
||||
|
|
@ -300,10 +303,10 @@ SYMBOL: incomparable
|
|||
} cond 2nip ;
|
||||
|
||||
: left-endpoint-<= ( i1 i2 -- ? )
|
||||
[ from>> ] dip to>> = ;
|
||||
[ from>> ] [ to>> ] bi* endpoint= ;
|
||||
|
||||
: right-endpoint-<= ( i1 i2 -- ? )
|
||||
[ to>> ] dip from>> = ;
|
||||
[ to>> ] [ from>> ] bi* endpoint= ;
|
||||
|
||||
: interval<= ( i1 i2 -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
IN: math.vectors.specialization.tests
|
||||
USING: compiler.tree.debugger math.vectors tools.test kernel
|
||||
kernel.private math specialized-arrays.double
|
||||
specialized-arrays.float ;
|
||||
|
||||
[ V{ t } ] [
|
||||
[ { double-array double-array } declare distance 0.0 < not ] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ float } ] [
|
||||
[ { float-array float } declare v*n norm ] final-classes
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words kernel make sequences effects kernel.private accessors
|
||||
combinators math math.intervals math.vectors namespaces assocs fry
|
||||
splitting classes.algebra generalizations
|
||||
compiler.tree.propagation.info ;
|
||||
IN: math.vectors.specialization
|
||||
|
||||
SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
|
||||
|
||||
: signature-for-schema ( array-type elt-type schema -- signature )
|
||||
[
|
||||
{
|
||||
{ +vector+ [ drop ] }
|
||||
{ +scalar+ [ nip ] }
|
||||
{ +nonnegative+ [ nip ] }
|
||||
} case
|
||||
] with with map ;
|
||||
|
||||
: (specialize-vector-word) ( word array-type elt-type schema -- word' )
|
||||
signature-for-schema
|
||||
[ [ name>> ] [ [ name>> ] map "," join ] bi* "=>" glue f <word> ]
|
||||
[ [ , \ declare , def>> % ] [ ] make ]
|
||||
[ drop stack-effect ]
|
||||
2tri
|
||||
[ define-declared ] [ 2drop ] 3bi ;
|
||||
|
||||
: output-infos ( array-type elt-type schema -- value-infos )
|
||||
[
|
||||
{
|
||||
{ +vector+ [ drop <class-info> ] }
|
||||
{ +scalar+ [ nip <class-info> ] }
|
||||
{ +nonnegative+ [ nip real class-and [0,inf] <class/interval-info> ] }
|
||||
} case
|
||||
] with with map ;
|
||||
|
||||
: record-output-signature ( word array-type elt-type schema -- word )
|
||||
output-infos
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
[ [ stack-effect in>> length '[ _ ndrop ] ] dip append ] 2tri
|
||||
"outputs" set-word-prop ;
|
||||
|
||||
CONSTANT: vector-words
|
||||
H{
|
||||
{ [v-] { +vector+ +vector+ -> +vector+ } }
|
||||
{ distance { +vector+ +vector+ -> +nonnegative+ } }
|
||||
{ n*v { +scalar+ +vector+ -> +vector+ } }
|
||||
{ n+v { +scalar+ +vector+ -> +vector+ } }
|
||||
{ n-v { +scalar+ +vector+ -> +vector+ } }
|
||||
{ n/v { +scalar+ +vector+ -> +vector+ } }
|
||||
{ norm { +vector+ -> +nonnegative+ } }
|
||||
{ norm-sq { +vector+ -> +nonnegative+ } }
|
||||
{ normalize { +vector+ -> +vector+ } }
|
||||
{ v* { +vector+ +vector+ -> +vector+ } }
|
||||
{ v*n { +vector+ +scalar+ -> +vector+ } }
|
||||
{ v+ { +vector+ +vector+ -> +vector+ } }
|
||||
{ v+n { +vector+ +scalar+ -> +vector+ } }
|
||||
{ v- { +vector+ +vector+ -> +vector+ } }
|
||||
{ v-n { +vector+ +scalar+ -> +vector+ } }
|
||||
{ v. { +vector+ +vector+ -> +scalar+ } }
|
||||
{ v/ { +vector+ +vector+ -> +vector+ } }
|
||||
{ v/n { +vector+ +scalar+ -> +vector+ } }
|
||||
{ vceiling { +vector+ -> +vector+ } }
|
||||
{ vfloor { +vector+ -> +vector+ } }
|
||||
{ vmax { +vector+ +vector+ -> +vector+ } }
|
||||
{ vmin { +vector+ +vector+ -> +vector+ } }
|
||||
{ vneg { +vector+ -> +vector+ } }
|
||||
{ vtruncate { +vector+ -> +vector+ } }
|
||||
}
|
||||
|
||||
SYMBOL: specializations
|
||||
|
||||
specializations [ vector-words keys [ V{ } clone ] H{ } map>assoc ] initialize
|
||||
|
||||
: add-specialization ( new-word signature word -- )
|
||||
specializations get at set-at ;
|
||||
|
||||
: word-schema ( word -- schema ) vector-words at ;
|
||||
|
||||
: inputs ( schema -- seq ) { -> } split first ;
|
||||
|
||||
: outputs ( schema -- seq ) { -> } split second ;
|
||||
|
||||
: specialize-vector-word ( word array-type elt-type -- word' )
|
||||
pick word-schema
|
||||
[ inputs (specialize-vector-word) ]
|
||||
[ outputs record-output-signature ] 3bi ;
|
||||
|
||||
: input-signature ( word -- signature ) def>> first ;
|
||||
|
||||
: specialize-vector-words ( array-type elt-type -- )
|
||||
[ vector-words keys ] 2dip
|
||||
'[
|
||||
[ _ _ specialize-vector-word ] keep
|
||||
[ dup input-signature ] dip
|
||||
add-specialization
|
||||
] each ;
|
||||
|
||||
: find-specialization ( classes word -- word/f )
|
||||
specializations get at
|
||||
[ first [ class<= ] 2all? ] with find
|
||||
swap [ second ] when ;
|
||||
|
||||
: vector-word-custom-inlining ( #call -- word/f )
|
||||
[ in-d>> [ value-info class>> ] map ] [ word>> ] bi
|
||||
find-specialization ;
|
||||
|
||||
vector-words keys [
|
||||
[ vector-word-custom-inlining ]
|
||||
"custom-inlining" set-word-prop
|
||||
] each
|
||||
|
|
@ -41,9 +41,13 @@ IN: math.vectors
|
|||
: set-axis ( u v axis -- w )
|
||||
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: 2tetra@ ( p q r s t u v w quot -- )
|
||||
dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
|
||||
[ first lerp ] [ second lerp ] [ third lerp ] tri-curry
|
||||
[ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
|
||||
|
|
|
|||
|
|
@ -11,61 +11,14 @@ HINTS: <double-array> { 2 } { 3 } ;
|
|||
|
||||
HINTS: (double-array) { 2 } { 3 } ;
|
||||
|
||||
HINTS: vneg { array } { double-array } ;
|
||||
HINTS: v*n { array object } { double-array float } ;
|
||||
HINTS: n*v { array object } { float double-array } ;
|
||||
HINTS: v/n { array object } { double-array float } ;
|
||||
HINTS: n/v { object array } { float double-array } ;
|
||||
HINTS: v+ { array array } { double-array double-array } ;
|
||||
HINTS: v- { array array } { double-array double-array } ;
|
||||
HINTS: v* { array array } { double-array double-array } ;
|
||||
HINTS: v/ { array array } { double-array double-array } ;
|
||||
HINTS: vmax { array array } { double-array double-array } ;
|
||||
HINTS: vmin { array array } { double-array double-array } ;
|
||||
HINTS: v. { array array } { double-array double-array } ;
|
||||
HINTS: norm-sq { array } { double-array } ;
|
||||
HINTS: norm { array } { double-array } ;
|
||||
HINTS: normalize { array } { double-array } ;
|
||||
HINTS: distance { array array } { double-array double-array } ;
|
||||
|
||||
! Type functions
|
||||
USING: words classes.algebra compiler.tree.propagation.info
|
||||
math.intervals ;
|
||||
|
||||
{ v+ v- v* v/ vmax vmin } [
|
||||
[
|
||||
[ class>> double-array class<= ] both?
|
||||
double-array object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
{ n*v n/v } [
|
||||
[
|
||||
nip class>> double-array class<= double-array object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
{ v*n v/n } [
|
||||
[
|
||||
drop class>> double-array class<= double-array object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
{ vneg normalize } [
|
||||
[
|
||||
class>> double-array class<= double-array object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
\ norm-sq [
|
||||
class>> double-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ v. [
|
||||
[ class>> double-array class<= ] both?
|
||||
float object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ distance [
|
||||
[ class>> double-array class<= ] both?
|
||||
[ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: functors sequences sequences.private prettyprint.custom
|
||||
kernel words classes math parser alien.c-types byte-arrays
|
||||
accessors summary ;
|
||||
kernel words classes math math.vectors.specialization parser
|
||||
alien.c-types byte-arrays accessors summary ;
|
||||
IN: specialized-arrays.functor
|
||||
|
||||
ERROR: bad-byte-array-length byte-array type ;
|
||||
|
|
@ -74,4 +74,6 @@ SYNTAX: A{ \ } [ >A ] parse-literal ;
|
|||
|
||||
INSTANCE: A sequence
|
||||
|
||||
A T c-type class>> specialize-vector-words
|
||||
|
||||
;FUNCTOR
|
||||
|
|
|
|||
|
|
@ -78,6 +78,8 @@ C: <sphere> sphere
|
|||
M: sphere intersect-scene ( hit ray sphere -- hit )
|
||||
[ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
|
||||
|
||||
HINTS: M\ sphere intersect-scene { hit ray sphere } ;
|
||||
|
||||
TUPLE: group < sphere { objs array read-only } ;
|
||||
|
||||
: <group> ( objs bound -- group )
|
||||
|
|
@ -89,6 +91,8 @@ TUPLE: group < sphere { objs array read-only } ;
|
|||
M: group intersect-scene ( hit ray group -- hit )
|
||||
[ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
|
||||
|
||||
HINTS: M\ group intersect-scene { hit ray group } ;
|
||||
|
||||
CONSTANT: initial-hit T{ hit f double-array{ 0.0 0.0 0.0 } 1/0. }
|
||||
|
||||
: initial-intersect ( ray scene -- hit )
|
||||
|
|
|
|||
Loading…
Reference in New Issue