From 1cb0f3370bd3eff6ffdad231053c953c0bff0f87 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 9 Aug 2009 03:07:33 -0500 Subject: [PATCH] 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 --- basis/hints/hints.factor | 2 +- basis/math/intervals/intervals-tests.factor | 6 + basis/math/intervals/intervals.factor | 23 ++-- .../specialization-tests.factor | 12 ++ .../specialization/specialization.factor | 112 ++++++++++++++++++ basis/math/vectors/vectors.factor | 4 + basis/specialized-arrays/double/double.factor | 47 -------- .../specialized-arrays/functor/functor.factor | 6 +- extra/benchmark/raytracer/raytracer.factor | 4 + 9 files changed, 156 insertions(+), 60 deletions(-) create mode 100644 basis/math/vectors/specialization/specialization-tests.factor create mode 100644 basis/math/vectors/specialization/specialization.factor diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d10bd5f8a9..6b7a6ae8ca 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -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 ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 929df04e9e..dbf014bda8 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -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 diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index e216b35d51..39582eafa4 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -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 } ; : ( 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 -- ? ) { diff --git a/basis/math/vectors/specialization/specialization-tests.factor b/basis/math/vectors/specialization/specialization-tests.factor new file mode 100644 index 0000000000..36f4fadf00 --- /dev/null +++ b/basis/math/vectors/specialization/specialization-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor new file mode 100644 index 0000000000..c9db3e02b3 --- /dev/null +++ b/basis/math/vectors/specialization/specialization.factor @@ -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 ] + [ [ , \ declare , def>> % ] [ ] make ] + [ drop stack-effect ] + 2tri + [ define-declared ] [ 2drop ] 3bi ; + +: output-infos ( array-type elt-type schema -- value-infos ) + [ + { + { +vector+ [ drop ] } + { +scalar+ [ nip ] } + { +nonnegative+ [ nip real class-and [0,inf] ] } + } 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 \ No newline at end of file diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 14a66b5c18..dd48525b53 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -41,9 +41,13 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; + + : 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* ; diff --git a/basis/specialized-arrays/double/double.factor b/basis/specialized-arrays/double/double.factor index 02e47ca140..95324bd2d5 100644 --- a/basis/specialized-arrays/double/double.factor +++ b/basis/specialized-arrays/double/double.factor @@ -11,61 +11,14 @@ HINTS: { 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 ? - ] "outputs" set-word-prop -] each - -{ n*v n/v } [ - [ - nip class>> double-array class<= double-array object ? - ] "outputs" set-word-prop -] each - -{ v*n v/n } [ - [ - drop class>> double-array class<= double-array object ? - ] "outputs" set-word-prop -] each - -{ vneg normalize } [ - [ - class>> double-array class<= double-array object ? - ] "outputs" set-word-prop -] each - \ norm-sq [ class>> double-array class<= [ float 0. 1/0. [a,b] ] [ object-info ] if ] "outputs" set-word-prop -\ v. [ - [ class>> double-array class<= ] both? - float object ? -] "outputs" set-word-prop - \ distance [ [ class>> double-array class<= ] both? [ float 0. 1/0. [a,b] ] [ object-info ] if diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index c6641463f9..beb4aa89ac 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -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 diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 642b3dbb93..25915404be 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -78,6 +78,8 @@ C: sphere M: sphere intersect-scene ( hit ray sphere -- hit ) [ [ sphere-n normalize ] keep nip ] if-ray-sphere ; +HINTS: M\ sphere intersect-scene { hit ray sphere } ; + TUPLE: group < sphere { objs array read-only } ; : ( 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 )