From f545c5d3e5c812a968b0a5bd4c8514567b50ae63 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 18 Nov 2009 12:36:41 -0800
Subject: [PATCH] properly handle -vector-op and case words in simd.backend
---
.../intrinsics/simd/backend/backend.factor | 64 +++++++++++++++++--
.../cfg/intrinsics/simd/simd-tests.factor | 9 ++-
2 files changed, 64 insertions(+), 9 deletions(-)
diff --git a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor
index 8f9fa801e2..f2ba9af41d 100644
--- a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor
+++ b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor
@@ -1,11 +1,11 @@
! (c)2009 Joe Groff bsd license
-USING: accessors arrays classes combinators
+USING: accessors arrays assocs classes combinators
combinators.short-circuit compiler.cfg.builder.blocks
compiler.cfg.registers compiler.cfg.stacks
compiler.cfg.stacks.local compiler.tree.propagation.info
cpu.architecture effects fry generalizations help.lint.checks
kernel locals macros math namespaces quotations sequences
-splitting words ;
+splitting stack-checker words ;
IN: compiler.cfg.intrinsics.simd.backend
! Selection of implementation based on available CPU instructions
@@ -18,20 +18,25 @@ IN: compiler.cfg.intrinsics.simd.backend
GENERIC: create-can-has ( word -- word' )
-PREDICATE: vector-op-word < word
+PREDICATE: hat-word < word
{
- [ name>> { [ { [ "^" head? ] [ "##" head? ] } 1|| ] [ "-vector" swap subseq? ] } 1&& ]
+ [ name>> { [ "^" head? ] [ "##" head? ] } 1|| ]
[ vocabulary>> { "compiler.cfg.intrinsics.simd" "compiler.cfg.hats" } member? ]
} 1&& ;
+PREDICATE: vector-op-word < hat-word
+ name>> "-vector" swap subseq? ;
+
: reps-word ( word -- word' )
name>> "^^" ?head drop "##" ?head drop
"%" "-reps" surround "cpu.architecture" lookup ;
+SYMBOL: blub
+
:: can-has-^^-quot ( word def effect -- quot )
effect in>> { "rep" } split1 [ length ] bi@ 1 +
word reps-word 1quotation
- effect out>> length f <array> >quotation
+ effect out>> length blub <array> >quotation
'[ [ _ ndrop ] _ ndip @ can-has-rep? @ ] ;
:: can-has-^-quot ( word def effect -- quot )
@@ -57,6 +62,17 @@ M: callable create-can-has
{ [ pick name>> "^" head? ] [ can-has-^-quot ] }
} cond ;
+: (can-has-nop-quot) ( word -- quot )
+ stack-effect in>> length '[ _ ndrop blub ] ;
+
+DEFER: can-has-words
+
+M: word create-can-has
+ can-has-words ?at drop 1quotation ;
+
+M: hat-word create-can-has
+ (can-has-nop-quot) ;
+
M: vector-op-word create-can-has
dup (can-has-word) [ 1quotation ] [ (can-has-quot) ] ?if ;
@@ -86,12 +102,46 @@ MACRO: vvvv-vector-op ( trials -- )
: can-has-^(compare-vector) ( src1 src2 rep cc -- dst )
[ 2drop ] 2dip %compare-vector-reps member?
\ can-has? [ and ] change
- f ;
+ blub ;
: can-has-^^test-vector ( src rep vcc -- dst )
[ drop ] 2dip drop %test-vector-reps member?
\ can-has? [ and ] change
- f ;
+ blub ;
+
+MACRO: can-has-case ( cases -- )
+ dup first second infer in>> length 1 +
+ '[ _ ndrop f ] suffix '[ _ case ] ;
+
+GENERIC# >can-has-trial 1 ( obj #pick -- quot )
+
+M: callable >can-has-trial
+ drop '[ _ can-has? ] ;
+M: pair >can-has-trial
+ swap first2 dup infer in>> length
+ '[ _ npick _ instance? [ _ can-has? ] [ _ ndrop blub ] if ] ;
+
+MACRO: can-has-vector-op ( trials #pick #dup -- )
+ [ '[ _ >can-has-trial ] map ] dip '[ _ _ n|| \ can-has? [ and ] change blub ] ;
+
+: can-has-v-vector-op ( trials -- ? )
+ 1 2 can-has-vector-op ; inline
+: can-has-vv-vector-op ( trials -- ? )
+ 1 3 can-has-vector-op ; inline
+: can-has-vv-cc-vector-op ( trials -- ? )
+ 2 4 can-has-vector-op ; inline
+: can-has-vvvv-vector-op ( trials -- ? )
+ 1 5 can-has-vector-op ; inline
+
+CONSTANT: can-has-words
+ H{
+ { case can-has-case }
+ { v-vector-op can-has-v-vector-op }
+ { vl-vector-op can-has-vv-vector-op }
+ { vv-vector-op can-has-vv-vector-op }
+ { vv-cc-vector-op can-has-vv-cc-vector-op }
+ { vvvv-vector-op can-has-vvvv-vector-op }
+ }
! Intrinsic code emission
diff --git a/basis/compiler/cfg/intrinsics/simd/simd-tests.factor b/basis/compiler/cfg/intrinsics/simd/simd-tests.factor
index c7d999f029..fadabbe604 100644
--- a/basis/compiler/cfg/intrinsics/simd/simd-tests.factor
+++ b/basis/compiler/cfg/intrinsics/simd/simd-tests.factor
@@ -44,14 +44,14 @@ IN: compiler.cfg.intrinsics.simd.tests
: 1test-emit ( cpu rep quot -- node )
[
- [ new cpu ] 2dip '[
+ [ new \ cpu ] 2dip '[
test-compiler-env [ _ 1test-node @ ] bind
] with-variable
] make-classes ; inline
: 2test-emit ( cpu rep cc quot -- node )
[
- [ new cpu ] 3dip '[
+ [ new \ cpu ] 3dip '[
test-compiler-env [ _ _ 2test-node @ ] bind
] with-variable
] make-classes ; inline
@@ -64,6 +64,11 @@ M: simple-ops-cpu %add-vector-reps { int-4-rep float-4-rep } ;
M: simple-ops-cpu %sub-vector-reps { int-4-rep float-4-rep } ;
M: simple-ops-cpu %mul-vector-reps { int-4-rep float-4-rep } ;
M: simple-ops-cpu %div-vector-reps { float-4-rep } ;
+M: simple-ops-cpu %not-vector-reps { int-4-rep float-4-rep } ;
+M: simple-ops-cpu %andn-vector-reps { int-4-rep float-4-rep } ;
+M: simple-ops-cpu %and-vector-reps { int-4-rep float-4-rep } ;
+M: simple-ops-cpu %or-vector-reps { int-4-rep float-4-rep } ;
+M: simple-ops-cpu %xor-vector-reps { int-4-rep float-4-rep } ;
! v+
[ { ##add-vector } ]