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

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

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

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 } ;
 : <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 -- ? )
     {

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

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

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 ;
 
+<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* ;

basis/specialized-arrays/double/double.factor

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

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
+kernel words classes math math.vectors.specialization parser
-accessors summary ;
+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

extra/benchmark/raytracer/raytracer.factor

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