factor/basis/compiler/cfg/intrinsics/simd/backend/backend.factor

! (c)2009 Joe Groff bsd license
USING: accessors arrays 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 ;
IN: compiler.cfg.intrinsics.simd.backend

! Selection of implementation based on available CPU instructions

: can-has? ( quot -- ? )
    [ 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' )

PREDICATE: vector-op-word < word
    {
        [ name>> { [ { [ "^" head? ] [ "##" head? ] } 1|| ] [ "-vector" swap subseq? ] } 1&& ]
        [ vocabulary>> { "compiler.cfg.intrinsics.simd" "compiler.cfg.hats" } member? ]
    } 1&& ;

: reps-word ( word -- word' )
    name>> "^^" ?head drop "##" ?head drop
    "%" "-reps" surround "cpu.architecture" lookup ;

:: can-has-^^-quot ( word def effect -- quot )
    effect in>> { "rep" } split1 [ length ] bi@ 1 +
    word reps-word 1quotation
    effect out>> length f <array> >quotation
    '[ [ _ ndrop ] _ ndip @ can-has-rep? @ ] ;

:: can-has-^-quot ( word def effect -- quot )
    def create-can-has first ;

: map-concat-like ( seq quot -- seq' )
    '[ _ map ] [ concat-as ] bi ; inline

M: object create-can-has 1quotation ;

M: array create-can-has
    [ create-can-has ] map-concat-like 1quotation ;
M: callable create-can-has
    [ create-can-has ] map-concat-like 1quotation ;

: (can-has-word) ( word -- word' )
    name>> "can-has-" prepend "compiler.cfg.intrinsics.simd.backend" lookup ;

: (can-has-quot) ( word -- quot )
    [ ] [ def>> ] [ stack-effect ] tri {
        { [ pick name>> "^^" head? ] [ can-has-^^-quot ] }
        { [ pick name>> "##" head? ] [ can-has-^^-quot ] }
        { [ pick name>> "^"  head? ] [ can-has-^-quot  ] }
    } cond ;

M: vector-op-word create-can-has
    dup (can-has-word) [ 1quotation ] [ (can-has-quot) ] ?if ;

GENERIC# >can-has-cond 2 ( quot #pick #dup -- quotpair )
M:: callable >can-has-cond ( quot #pick #dup -- quotpair )
    #dup quot create-can-has '[ _ ndup @ can-has? ] quot 2array ;

M:: pair >can-has-cond ( pair #pick #dup -- quotpair )
    pair first2 :> ( class quot )
    #pick class #dup quot create-can-has
    '[ _ npick _ instance? [ _ ndup @ can-has? ] dip and ]
    quot 2array ;

MACRO: v-vector-op ( trials -- )
    [ 1 2 >can-has-cond ] map '[ _ cond ] ;
MACRO: vl-vector-op ( trials -- )
    [ 1 3 >can-has-cond ] map '[ _ cond ] ;
MACRO: vv-vector-op ( trials -- )
    [ 1 3 >can-has-cond ] map '[ _ cond ] ;
MACRO: vv-cc-vector-op ( trials -- )
    [ 2 4 >can-has-cond ] map '[ _ cond ] ;
MACRO: vvvv-vector-op ( trials -- )
    [ 1 5 >can-has-cond ] map '[ _ cond ] ;

! Special-case conditional instructions

: can-has-^(compare-vector) ( src1 src2 rep cc -- dst )
    [ 2drop ] 2dip %compare-vector-reps member?
    \ can-has? [ and ] change
    f ;

: can-has-^^test-vector ( src rep vcc -- dst )
    [ drop ] 2dip drop %test-vector-reps member?
    \ can-has? [ and ] change
    f ;

! Intrinsic code emission

MACRO: if-literals-match ( quots -- )
    [ length ] [ ] [ length ] tri
    ! n quots n
    '[
        ! node quot
        [
            dup node-input-infos
            _ tail-slice* [ literal>> ] map
            dup _ check-elements
        ] dip
        swap [
            ! node literals quot
            [ _ firstn ] dip call
            drop
        ] [ 2drop emit-primitive ] if
    ] ;

CONSTANT: [unary]       [ ds-drop  ds-pop ]
CONSTANT: [unary/param] [ [ -2 inc-d ds-pop ] dip ]
CONSTANT: [binary]      [ ds-drop 2inputs ]
CONSTANT: [quaternary]
    [
        ds-drop 
        D 3 peek-loc
        D 2 peek-loc
        D 1 peek-loc
        D 0 peek-loc
        -4 inc-d
    ]

:: [emit-vector-op] ( trials params-quot op-quot literal-preds -- quot )
    params-quot trials op-quot literal-preds 
    '[ [ _ dip _ @ ds-push ] _ if-literals-match ] ;

MACRO: emit-v-vector-op ( trials -- )
    [unary] [ v-vector-op ] { [ representation? ] } [emit-vector-op] ;
MACRO: emit-vl-vector-op ( trials literal-pred -- )
    [ [unary/param] [ vl-vector-op ] { [ representation? ] } ] dip prefix [emit-vector-op] ;
MACRO: emit-vv-vector-op ( trials -- )
    [binary] [ vv-vector-op ] { [ representation? ] } [emit-vector-op] ;
MACRO: emit-vvvv-vector-op ( trials -- )
    [quaternary] [ vvvv-vector-op ] { [ representation? ] } [emit-vector-op] ;

MACRO:: emit-vv-or-vl-vector-op ( var-trials imm-trials literal-pred -- )
    literal-pred imm-trials literal-pred var-trials
    '[
        dup node-input-infos 2 tail-slice* first literal>> @
        [ _ _ emit-vl-vector-op ]
        [ _   emit-vv-vector-op ] if 
    ] ;