steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compilation fixes

db4
Joe Groff 2009-11-14 23:43:22 -06:00
parent 243e5b43ce
commit d56afe9c3d
2 changed files with 22 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
basis/compiler/cfg/intrinsics/simd/backend/backend.factor
View File

@ -13,6 +13,9 @@ IN: compiler.cfg.intrinsics.simd.backend
: can-has? ( quot -- ? ) : can-has? ( quot -- ? )
[ t \ can-has? ] dip '[ @ drop \ can-has? get ] with-variable ; inline [ t \ can-has? ] dip '[ @ drop \ can-has? get ] with-variable ; inline
: can-has-rep? ( rep reps -- )
member? \ can-has? [ and ] change ; inline
GENERIC: create-can-has ( word -- word' ) GENERIC: create-can-has ( word -- word' )
PREDICATE: vector-op-word < word PREDICATE: vector-op-word < word
@ -27,19 +30,22 @@ PREDICATE: vector-op-word < word
:: can-has-^^-quot ( word def effect -- quot ) :: can-has-^^-quot ( word def effect -- quot )
effect in>> { "rep" } split1 [ length ] bi@ 1 + effect in>> { "rep" } split1 [ length ] bi@ 1 +
word reps-word word reps-word 1quotation
effect out>> length f <array> >quotation effect out>> length f <array> >quotation
'[ [ _ ndrop ] _ ndip _ execute member? \ can-has? [ and ] change @ ] ; '[ [ _ ndrop ] _ ndip @ can-has-rep? @ ] ;
:: can-has-^-quot ( word def effect -- quot ) :: can-has-^-quot ( word def effect -- quot )
def create-can-has ; def create-can-has first ;
: map-concat-like ( seq quot -- seq' )
'[ _ map ] [ concat-as ] bi ; inline
M: object create-can-has 1quotation ; M: object create-can-has 1quotation ;
M: array create-can-has M: array create-can-has
[ create-can-has ] map concat ; [ create-can-has ] map-concat-like 1quotation ;
M: callable create-can-has M: callable create-can-has
[ create-can-has ] map concat ; [ create-can-has ] map-concat-like 1quotation ;
: (can-has-word) ( word -- word' ) : (can-has-word) ( word -- word' )
name>> "can-has-" prepend "compiler.cfg.intrinsics.simd.backend" lookup ; name>> "can-has-" prepend "compiler.cfg.intrinsics.simd.backend" lookup ;
@ -56,12 +62,12 @@ M: vector-op-word create-can-has
GENERIC# >can-has-cond 2 ( quot #pick #dup -- quotpair ) GENERIC# >can-has-cond 2 ( quot #pick #dup -- quotpair )
M:: callable >can-has-cond ( quot #pick #dup -- quotpair ) M:: callable >can-has-cond ( quot #pick #dup -- quotpair )
#dup quot create-can-has '[ _ ndup _ can-has? ] quot 2array ; #dup quot create-can-has '[ _ ndup @ can-has? ] quot 2array ;
M:: pair >can-has-cond ( pair #pick #dup -- quotpair ) M:: pair >can-has-cond ( pair #pick #dup -- quotpair )
pair first2 :> ( class quot ) pair first2 :> ( class quot )
#pick class #dup quot create-can-has #pick class #dup quot create-can-has
'[ _ npick _ instance? [ _ ndup _ can-has? ] dip and ] '[ _ npick _ instance? [ _ ndup @ can-has? ] dip and ]
quot 2array ; quot 2array ;
MACRO: v-vector-op ( trials -- ) MACRO: v-vector-op ( trials -- )
@ -82,6 +88,11 @@ MACRO: vvvv-vector-op ( trials -- )
\ can-has? [ and ] change \ can-has? [ and ] change
f ; f ;
: can-has-^^test-vector ( src rep vcc -- dst )
[ drop ] 2dip drop %test-vector-reps member?
\ can-has? [ and ] change
f ;
! Intrinsic code emission ! Intrinsic code emission
MACRO: if-literals-match ( quots -- ) MACRO: if-literals-match ( quots -- )

8
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -481,15 +481,15 @@ IN: compiler.cfg.intrinsics.simd
: emit-simd-vany? ( node -- ) : emit-simd-vany? ( node -- )
{ {
[ vcc-any ^^test-vector ] [ vcc-any ^^test-vector ]
} emit-vv-vector-op ; } emit-v-vector-op ;
: emit-simd-vall? ( node -- ) : emit-simd-vall? ( node -- )
{ {
[ vcc-all ^^test-vector ] [ vcc-all ^^test-vector ]
} emit-vv-vector-op ; } emit-v-vector-op ;
: emit-simd-vnone? ( node -- ) : emit-simd-vnone? ( node -- )
{ {
[ vcc-none ^^test-vector ] [ vcc-none ^^test-vector ]
} emit-vv-vector-op ; } emit-v-vector-op ;
: emit-simd-v>float ( node -- ) : emit-simd-v>float ( node -- )
{ {
@ -500,7 +500,7 @@ IN: compiler.cfg.intrinsics.simd
: emit-simd-v>integer ( node -- ) : emit-simd-v>integer ( node -- )
{ {
{ float-vector-rep [ ^^float>integer-vector ] } { float-vector-rep [ ^^float>integer-vector ] }
{ int-vector-rep [ dup ] } { int-vector-rep [ drop ] }
} emit-v-vector-op ; } emit-v-vector-op ;
: emit-simd-vpack-signed ( node -- ) : emit-simd-vpack-signed ( node -- )