factor/basis/compiler/cfg/intrinsics/slots/slots.factor

! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences math
classes.algebra classes.builtin locals combinators
combinators.short-circuit cpu.architecture
compiler.tree.propagation.info compiler.cfg.stacks
compiler.cfg.hats compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots

: class-tag ( class -- tag/f )
    builtins get [ class<= ] with find drop ;

: value-tag ( info -- n ) class>> class-tag ;

: slot-indexing ( slot tag -- slot scale tag )
    complex-addressing?
    [ [ cell log2 ] dip ] [ [ ^^offset>slot ] dip ^^sub-imm 0 0 ] if ;

: (emit-slot) ( infos -- dst )
    [ 2inputs ] [ first value-tag ] bi*
    slot-indexing ^^slot ;

: (emit-slot-imm) ( infos -- dst )
    ds-drop
    [ ds-pop ]
    [ [ second literal>> ] [ first value-tag ] bi ] bi*
    ^^slot-imm ;

: immediate-slot-offset? ( value-info -- ? )
    literal>> {
        [ fixnum? ]
        [ cell * immediate-arithmetic? ]
    } 1&& ;

: emit-slot ( node -- )
    dup node-input-infos
    dup first value-tag [
        nip
        dup second immediate-slot-offset?
        [ (emit-slot-imm) ] [ (emit-slot) ] if
        ds-push
    ] [ drop emit-primitive ] if ;

: emit-write-barrier? ( infos -- ? )
    first class>> immediate class<= not ;

:: (emit-set-slot) ( infos -- )
    3inputs :> ( src obj slot )

    infos second value-tag :> tag

    slot tag slot-indexing :> ( slot scale tag )
    src obj slot scale tag ##set-slot,

    infos emit-write-barrier?
    [ obj slot scale tag next-vreg next-vreg ##write-barrier, ] when ;

:: (emit-set-slot-imm) ( infos -- )
    ds-drop

    2inputs :> ( src obj )

    infos third literal>> :> slot
    infos second value-tag :> tag

    src obj slot tag ##set-slot-imm,

    infos emit-write-barrier?
    [ obj slot tag next-vreg next-vreg ##write-barrier-imm, ] when ;

: emit-set-slot ( node -- )
    dup node-input-infos
    dup second value-tag [
        nip
        dup third immediate-slot-offset?
        [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
    ] [ drop emit-primitive ] if ;