! Copyright (C) 2011 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators
classes.algebra byte-arrays make math math.order math.ranges
system namespaces locals layouts words alien alien.accessors
alien.c-types alien.complex alien.data alien.libraries
literals cpu.architecture cpu.ppc.assembler
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.comparisons compiler.codegen.fixup
compiler.cfg.intrinsics compiler.cfg.stack-frame
compiler.cfg.build-stack-frame compiler.units compiler.constants
compiler.codegen vm memory fry io prettyprint ;
QUALIFIED-WITH: alien.c-types c
FROM: cpu.ppc.assembler => B ;
FROM: layouts => cell ;
FROM: math => float ;
IN: cpu.ppc

! PowerPC register assignments:
! r0: reserved for function prolog/epilogues
! r1: call stack register
! r2: toc register / system reserved
! r3-r12: integer vregs
! r13: reserved by OS
! r14: data stack
! r15: retain stack
! r16: VM pointer
! r17-r29: integer vregs
! r30: integer scratch
! r31: frame register
! f0-f29: float vregs
! f30: float scratch
! f31: ?

HOOK: lr-save os ( -- n )
HOOK: has-toc os ( -- ? )
HOOK: reserved-area-size os ( -- n )
HOOK: allows-null-dereference os ( -- ? )

M: label B  ( label -- )       [ 0 B  ] dip rc-relative-ppc-3-pc label-fixup ;
M: label BL ( label -- )       [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ;
M: label BC ( bo bi label -- ) [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ;

CONSTANT: scratch-reg    30
CONSTANT: fp-scratch-reg 30
CONSTANT: ds-reg         14
CONSTANT: rs-reg         15
CONSTANT: vm-reg         16

enable-float-intrinsics

M: ppc vector-regs ( -- reg-class )
    float-regs ;

M: ppc machine-registers ( -- assoc )
    {
        { int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] }
        { float-regs $[ 0 29 [a,b] ] }
    } ;

M: ppc frame-reg ( -- reg ) 31 ;
M: ppc.32 vm-stack-space ( -- n ) 16 ;
M: ppc.64 vm-stack-space ( -- n ) 32 ;
M: ppc complex-addressing? ( -- ? ) f ;

! PW1-PW8 parameter save slots
: param-save-size ( -- n ) 8 cells ; foldable
! here be spill slots
! xt, size
: factor-area-size ( -- n ) 2 cells ; foldable

: spill@ ( n -- offset )
    spill-offset reserved-area-size + param-save-size + ;

: param@ ( n -- offset )
    reserved-area-size + ;

M: ppc gc-root-offset ( spill-slot -- n )
    n>> spill@ cell /i ;

: LOAD32 ( r n -- )
    [ -16 shift HEX: ffff bitand LIS ]
    [ [ dup ] dip HEX: ffff bitand ORI ] 2bi ;

: LOAD64 ( r n -- )
    [ dup ] dip {
        [ nip -48 shift HEX: ffff bitand LIS ]
        [ -32 shift HEX: ffff bitand ORI ]
        [ drop 32 SLDI ]
        [ -16 shift HEX: ffff bitand ORIS ]
        [ HEX: ffff bitand ORI ]
    } 3cleave ;

HOOK: %clear-tag-bits cpu ( dst src -- )
M: ppc.32 %clear-tag-bits tag-bits get CLRRWI ;
M: ppc.64 %clear-tag-bits tag-bits get CLRRDI ;

HOOK: %store-cell cpu ( dst src offset -- )
M: ppc.32 %store-cell STW ;
M: ppc.64 %store-cell STD ;

HOOK: %store-cell-x cpu ( dst src offset -- )
M: ppc.32 %store-cell-x STWX ;
M: ppc.64 %store-cell-x STDX ;

HOOK: %store-cell-update cpu ( dst src offset -- )
M: ppc.32 %store-cell-update STWU ;
M: ppc.64 %store-cell-update STDU ;

HOOK: %load-cell cpu ( dst src offset -- )
M: ppc.32 %load-cell LWZ ;
M: ppc.64 %load-cell LD ;

HOOK: %trap-null cpu ( src -- )
M: ppc.32 %trap-null
    allows-null-dereference [ 0 TWEQI ] [ drop ] if ;
M: ppc.64 %trap-null
    allows-null-dereference [ 0 TDEQI ] [ drop ] if ;

HOOK: %load-cell-x cpu ( dst src offset -- )
M: ppc.32 %load-cell-x LWZX ;
M: ppc.64 %load-cell-x LDX ;

HOOK: %load-cell-imm cpu ( dst imm -- )
M: ppc.32 %load-cell-imm LOAD32 ;
M: ppc.64 %load-cell-imm LOAD64 ;

HOOK: %compare-cell cpu ( cr lhs rhs -- )
M: ppc.32 %compare-cell CMPW ;
M: ppc.64 %compare-cell CMPD ;

HOOK: %compare-cell-imm cpu ( cr lhs imm -- )
M: ppc.32 %compare-cell-imm CMPWI ;
M: ppc.64 %compare-cell-imm CMPDI ;

HOOK: %load-cell-imm-rc cpu ( -- rel-class )
M: ppc.32 %load-cell-imm-rc rc-absolute-ppc-2/2 ;
M: ppc.64 %load-cell-imm-rc rc-absolute-ppc-2/2/2/2  ;

M: ppc.32 %load-immediate ( reg val -- )
    dup HEX: -8000 HEX: 7fff between? [ LI ] [ LOAD32 ] if ;
M: ppc.64 %load-immediate ( reg val -- )
    dup HEX: -8000 HEX: 7fff between? [ LI ] [ LOAD64 ] if ;

M: ppc %load-reference ( reg obj -- )
    [ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ]
    [ \ f type-number LI ]
    if* ;

M:: ppc %load-float ( dst val -- )
    scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
    dst scratch-reg 0 LFS ;

M:: ppc %load-double ( dst val -- )
    scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
    dst scratch-reg 0 LFD ;

M:: ppc %load-vector ( dst val rep -- )
    scratch-reg 0 %load-cell-imm val %load-cell-imm-rc rel-binary-literal
    dst 0 scratch-reg LVX ;

GENERIC: loc-reg ( loc -- reg )
M: ds-loc loc-reg drop ds-reg ;
M: rs-loc loc-reg drop rs-reg ;

! Load value at stack location loc into vreg.
M: ppc %peek ( vreg loc -- )
    [ loc-reg ] [ n>> cells neg ] bi %load-cell ;

! Replace value at stack location loc with value in vreg.
M: ppc %replace ( vreg loc -- )
    [ loc-reg ] [ n>> cells neg ] bi %store-cell ;

! Replace value at stack location with an immediate value.
M:: ppc %replace-imm ( src loc -- )
    loc loc-reg :> reg
    loc n>> cells neg :> offset
    src {
        { [ dup not ] [
            drop scratch-reg \ f type-number LI ] }
        { [ dup fixnum? ] [
            [ scratch-reg ] dip tag-fixnum LI ] }
        [ scratch-reg 0 LI rc-absolute rel-literal ]
    } cond
    scratch-reg reg offset %store-cell ;

! Increment data stack pointer by n cells.
M: ppc %inc-d ( n -- )
    [ ds-reg ds-reg ] dip cells ADDI ;

! Increment retain stack pointer by n cells.
M: ppc %inc-r ( n -- )
    [ rs-reg rs-reg ] dip cells ADDI ;

M: ppc stack-frame-size ( stack-frame -- i )
    (stack-frame-size)
    reserved-area-size +
    param-save-size +
    factor-area-size +
    16 align ;

M: ppc %call ( word -- )
    0 BL rc-relative-ppc-3-pc rel-word-pic ;

: instrs ( n -- b ) 4 * ; inline

M: ppc %jump ( word -- )
    6 0 %load-cell-imm 1 instrs %load-cell-imm-rc rel-here
    0 B rc-relative-ppc-3-pc rel-word-pic-tail ;

M: ppc %dispatch ( src temp -- )
    [ nip 0 %load-cell-imm 3 instrs %load-cell-imm-rc rel-here ]
    [ swap dupd %load-cell-x ]
    [ nip MTCTR ] 2tri BCTR ;

M: ppc %slot ( dst obj slot scale tag -- )
    [ 0 assert= ] bi@ %load-cell-x ;

M: ppc %slot-imm ( dst obj slot tag -- )
    slot-offset scratch-reg swap LI
    scratch-reg %load-cell-x ;

M: ppc %set-slot ( src obj slot scale tag -- )
    [ 0 assert= ] bi@ %store-cell-x ;

M: ppc %set-slot-imm ( src obj slot tag -- )
    slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ;

M: ppc    %jump-label B     ;
M: ppc    %return     BLR   ;
M: ppc    %add        ADD   ;
M: ppc    %add-imm    ADDI  ;
M: ppc    %sub        SUB   ;
M: ppc    %sub-imm    SUBI  ;
M: ppc.32 %mul        MULLW ;
M: ppc.64 %mul        MULLD ;
M: ppc    %mul-imm    MULLI ;
M: ppc    %and        AND   ;
M: ppc    %and-imm    ANDI. ;
M: ppc    %or         OR    ;
M: ppc    %or-imm     ORI   ;
M: ppc    %xor        XOR   ;
M: ppc    %xor-imm    XORI  ;
M: ppc.32 %shl        SLW   ;
M: ppc.64 %shl        SLD   ;
M: ppc.32 %shl-imm    SLWI  ;
M: ppc.64 %shl-imm    SLDI  ;
M: ppc.32 %shr        SRW   ;
M: ppc.64 %shr        SRD   ;
M: ppc.32 %shr-imm    SRWI  ;
M: ppc.64 %shr-imm    SRDI  ;
M: ppc.32 %sar        SRAW  ;
M: ppc.64 %sar        SRAD  ;
M: ppc.32 %sar-imm    SRAWI ;
M: ppc.64 %sar-imm    SRADI ;
M: ppc.32 %min        [ 0 CMPW ] [ 0 ISEL ] 2bi ;
M: ppc.64 %min        [ 0 CMPD ] [ 0 ISEL ] 2bi ;
M: ppc.32 %max        [ 0 CMPW ] [ swap 0 ISEL ] 2bi ;
M: ppc.64 %max        [ 0 CMPD ] [ swap 0 ISEL ] 2bi ;
M: ppc    %not        NOT ;
M: ppc    %neg        NEG ;
M: ppc.32 %log2       [ CNTLZW ] [ drop dup NEG ] [ drop dup 31 ADDI ] 2tri ;
M: ppc.64 %log2       [ CNTLZD ] [ drop dup NEG ] [ drop dup 63 ADDI ] 2tri ;
M: ppc.32 %bit-count  POPCNTW ;
M: ppc.64 %bit-count  POPCNTD ;

M: ppc %copy ( dst src rep -- )
    2over eq? [ 3drop ] [
        {
            { tagged-rep [ MR ] }
            { int-rep    [ MR ] }
            { float-rep  [ FMR ] }
            { double-rep [ FMR ] }
            { vector-rep [ dup VOR ] }
            { scalar-rep [ dup VOR ] }
        } case
    ] if ;

:: overflow-template ( label dst src1 src2 cc insn -- )
    scratch-reg 0 LI
    scratch-reg MTXER
    dst src2 src1 insn call
    cc {
        { cc-o [ 0 label BSO ] }
        { cc/o [ 0 label BNS ] }
    } case ; inline

M: ppc %fixnum-add ( label dst src1 src2 cc -- )
    [ ADDO. ] overflow-template ;

M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
    [ SUBFO. ] overflow-template ;

M: ppc.32 %fixnum-mul ( label dst src1 src2 cc -- )
    [ MULLWO. ] overflow-template ;
M: ppc.64 %fixnum-mul ( label dst src1 src2 cc -- )
    [ MULLDO. ] overflow-template ;

M: ppc %add-float FADD ;
M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ;

M: ppc %min-float ( dst src1 src2 -- )
    2dup [ scratch-reg ] 2dip FSUB
    [ scratch-reg ] 2dip FSEL ;

M: ppc %max-float ( dst src1 src2 -- )
    2dup [ scratch-reg ] 2dip FSUB
    [ scratch-reg ] 2dip FSEL ;

M: ppc %sqrt                FSQRT ;
M: ppc %single>double-float FMR   ;
M: ppc %double>single-float FRSP  ;

M: ppc integer-float-needs-stack-frame? t ;

: scratch@ ( n -- offset )
    reserved-area-size + ;

M:: ppc.32 %integer>float ( dst src -- )
    ! Sign extend to a doubleword and store.
    scratch-reg src 31 %sar-imm
    scratch-reg 1 0 scratch@ STW
    src 1 4 scratch@ STW
    ! Load back doubleword into FPR and convert from integer.
    dst 1 0 scratch@ LFD
    dst dst FCFID ;

M:: ppc.64 %integer>float ( dst src -- )
    src 1 0 scratch@ STD
    dst 1 0 scratch@ LFD
    dst dst FCFID ;

M:: ppc.32 %float>integer ( dst src -- )
    fp-scratch-reg src FRIZ
    fp-scratch-reg fp-scratch-reg FCTIWZ
    fp-scratch-reg 1 0 scratch@ STFD
    dst 1 4 scratch@ LWZ ;

M:: ppc.64 %float>integer ( dst src -- )
    fp-scratch-reg src FRIZ
    fp-scratch-reg fp-scratch-reg FCTID
    fp-scratch-reg 1 0 scratch@ STFD
    dst 1 0 scratch@ LD ;

! Scratch registers by register class.
: scratch-regs ( -- regs )
    {
        { int-regs { 30 } }
        { float-regs { 30 } }
    } ;

! Return values of this class go here
M: ppc return-regs ( -- regs )
    {
        { int-regs { 3 4 5 6 } }
        { float-regs { 1 2 3 4 } }
    } ;

! Is this structure small enough to be returned in registers?
M: ppc return-struct-in-registers? ( c-type -- ? )
    c-type return-in-registers?>> ;

! If t, floats are never passed in param regs
M: ppc float-on-stack? ( -- ? ) f ;

! If t, the struct return pointer is never passed in a param reg
M: ppc struct-return-on-stack? ( -- ? ) f ;

GENERIC: load-param ( reg src -- )
M: integer load-param ( reg src -- ) int-rep %copy ;
M: spill-slot load-param ( reg src -- ) [ 1 ] dip n>> spill@ %load-cell ;

GENERIC: store-param ( reg dst -- )
M: integer store-param ( reg dst -- ) swap int-rep %copy ;
M: spill-slot store-param ( reg dst -- ) [ 1 ] dip n>> spill@ %store-cell ;

M:: ppc %unbox ( dst src func rep -- )
    3 src load-param
    4 vm-reg MR
    func f f %c-invoke
    3 dst store-param ;

M:: ppc %unbox-long-long ( dst1 dst2 src func -- )
    3 src load-param
    4 vm-reg MR
    func f f %c-invoke
    3 dst1 store-param
    4 dst2 store-param ;

M:: ppc %local-allot ( dst size align offset -- )
    dst 1 offset local-allot-offset reserved-area-size + ADDI ;

: param-reg ( n rep -- reg )
    reg-class-of cdecl param-regs at nth ;

M:: ppc %box ( dst src func rep gc-map -- )
    3 src load-param
    4 vm-reg MR
    func f gc-map %c-invoke
    3 dst store-param ;

M:: ppc %box-long-long ( dst src1 src2 func gc-map -- )
    3 src1 load-param
    4 src2 load-param
    5 vm-reg MR
    func f gc-map %c-invoke
    3 dst store-param ;

M:: ppc %save-context ( temp1 temp2 -- )
    temp1 %context
    1 temp1 "callstack-top" context-field-offset %store-cell
    ds-reg temp1 "datastack" context-field-offset %store-cell
    rs-reg temp1 "retainstack" context-field-offset %store-cell ;

M:: ppc %c-invoke ( name dll gc-map -- )
    11 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym
    has-toc [
        2 0 %load-cell-imm name dll %load-cell-imm-rc rel-dlsym-toc
    ] when
    11 MTCTR
    BCTRL
    gc-map gc-map-here ;

: return-reg ( rep -- reg )
    reg-class-of return-regs at first ;

: scratch-reg-class ( rep -- reg )
    reg-class-of scratch-regs at first ;

:: store-stack-param ( vreg rep n -- )
    rep scratch-reg-class rep vreg %reload
    rep scratch-reg-class n param@ rep {
        { int-rep    [ [ 1 ] dip %store-cell ] }
        { tagged-rep [ [ 1 ] dip %store-cell ] }
        { float-rep  [ [ 1 ] dip STFS ] }
        { double-rep [ [ 1 ] dip STFD ] }
        { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
        { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
    } case ;

:: store-reg-param ( vreg rep reg -- )
    reg rep vreg %reload ;

: discard-reg-param ( rep reg -- )
    2drop ;

:: load-reg-param ( vreg rep reg -- )
    reg rep vreg %spill ;

:: load-stack-param ( vreg rep n -- )
    rep scratch-reg-class n param@ rep {
        { int-rep    [ [ frame-reg ] dip %load-cell ] }
        { tagged-rep [ [ frame-reg ] dip %load-cell ] }
        { float-rep  [ [ frame-reg ] dip LFS ] }
        { double-rep [ [ frame-reg ] dip LFD ] }
        { vector-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
        { scalar-rep [ scratch-reg swap LI frame-reg scratch-reg LVX ] }
    } case
    rep scratch-reg-class rep vreg %spill ;

:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot -- )
    stack-inputs [ first3 store-stack-param ] each
    reg-inputs [ first3 store-reg-param ] each
    quot call
    reg-outputs [ first3 load-reg-param ] each
    dead-outputs [ first2 discard-reg-param ] each
    ; inline

M: ppc %alien-invoke ( reg-inputs stack-inputs reg-outputs
                       dead-outputs cleanup stack-size
                       symbols dll gc-map -- )
    '[ _ _ _ %c-invoke ] emit-alien-insn ;

M:: ppc %alien-indirect ( src reg-inputs stack-inputs
                          reg-outputs dead-outputs cleanup
                          stack-size gc-map -- )
    reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [
        has-toc [
            11 src load-param
            2 11 1 cells %load-cell
            11 11 0 cells %load-cell
        ] [
            11 src load-param
        ] if
        11 MTCTR
        BCTRL
        gc-map gc-map-here
    ] emit-alien-insn ;

M: ppc %alien-assembly ( reg-inputs stack-inputs reg-outputs
                         dead-outputs cleanup stack-size quot
                         gc-map -- )
    '[ _ _ gc-map set call( -- ) ] emit-alien-insn ;

M: ppc %callback-inputs ( reg-outputs stack-outputs -- )
    [ [ first3 load-reg-param ] each ]
    [ [ first3 load-stack-param ] each ] bi*
    3 vm-reg MR
    4 0 LI
    "begin_callback" f f %c-invoke ;

M: ppc %callback-outputs ( reg-inputs -- )
    3 vm-reg MR
    "end_callback" f f %c-invoke
    [ first3 store-reg-param ] each ;

M: ppc stack-cleanup ( stack-size return abi -- n )
    3drop 0 ;

M: ppc fused-unboxing? f ;

M: ppc %alien-global ( register symbol dll -- )
    [ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ;

M: ppc %vm-field     ( dst field -- ) [ vm-reg ] dip %load-cell  ;
M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip %store-cell ;

M: ppc %unbox-alien ( dst src -- )
    scratch-reg alien-offset LI scratch-reg %load-cell-x ;

! Convert a c-ptr object to a raw C pointer.
! if (src == F_TYPE)
!   dst = NULL;
! else if ((src & tag_mask) == ALIEN_TYPE)
!   dst = ((alien*)src)->address;
! else // Assume (src & tag_mask) == BYTE_ARRAY_TYPE
!   dst = ((byte_array*)src) + 1;
M:: ppc %unbox-any-c-ptr ( dst src -- )
    [
        "end" define-label
        ! Is the object f?
        dst 0 LI
        0 src \ f type-number %compare-cell-imm
        0 "end" get BEQ

        ! Is the object an alien?
        dst src tag-mask get ANDI.
        ! Assume unboxing a byte-array.
        0 dst alien type-number %compare-cell-imm
        dst src byte-array-offset ADDI
        0 "end" get BNE

        ! Unbox the alien.
        scratch-reg alien-offset LI
        dst src scratch-reg %load-cell-x
        "end" resolve-label
    ] with-scope ;

! Be very careful with this. It cannot be used as an immediate
! offset to a load or store.
: alien@ ( n -- n' ) cells alien type-number - ;

! Convert a raw C pointer to a c-ptr object.
! if (src == NULL)
!   dst = F_TYPE;
! else {
!   dst = allot_alien(NULL);
!   dst->base = F_TYPE;
!   dst->expired = F_TYPE;
!   dst->displacement = src;
!   dst->address = src;
! }
M:: ppc %box-alien ( dst src temp -- )
    [
        "f" define-label

        ! Is the object f?
        dst \ f type-number LI
        0 src 0 %compare-cell-imm
        0 "f" get BEQ

        ! Allocate and initialize an alien object.
        dst 5 cells alien temp %allot
        temp \ f type-number LI
        scratch-reg dst %clear-tag-bits
        temp scratch-reg 1 cells %store-cell
        temp scratch-reg 2 cells %store-cell
        src scratch-reg 3 cells %store-cell
        src scratch-reg 4 cells %store-cell

        "f" resolve-label
    ] with-scope ;

! dst->base = base;
! dst->displacement = displacement;
! dst->displacement = displacement;
:: box-displaced-alien/f ( dst displacement base -- )
    scratch-reg dst %clear-tag-bits
    base scratch-reg 1 cells %store-cell
    displacement scratch-reg 3 cells %store-cell
    displacement scratch-reg 4 cells %store-cell ;

! dst->base = base->base;
! dst->displacement = base->displacement + displacement;
! dst->address = base->address + displacement;
:: box-displaced-alien/alien ( dst displacement base temp -- )
    ! Set new alien's base to base.base
    scratch-reg 1 alien@ LI
    temp base scratch-reg %load-cell-x
    temp dst scratch-reg %store-cell-x

    ! Compute displacement
    scratch-reg 3 alien@ LI
    temp base scratch-reg %load-cell-x
    temp temp displacement ADD
    temp dst scratch-reg %store-cell-x

    ! Compute address
    scratch-reg 4 alien@ LI
    temp base scratch-reg %load-cell-x
    temp temp displacement ADD
    temp dst scratch-reg %store-cell-x ;

! dst->base = base;
! dst->displacement = displacement
! dst->address = base + sizeof(byte_array) + displacement
:: box-displaced-alien/byte-array ( dst displacement base temp -- )
    scratch-reg dst %clear-tag-bits
    base scratch-reg 1 cells %store-cell
    displacement scratch-reg 3 cells %store-cell
    temp base byte-array-offset ADDI
    temp temp displacement ADD
    temp scratch-reg 4 cells %store-cell ;

! if (base == F_TYPE)
!   box_displaced_alien_f(dst, displacement, base);
! else if ((base & tag_mask) == ALIEN_TYPE)
!   box_displaced_alien_alien(dst, displacement, base, temp);
! else
!   box_displaced_alien_byte_array(dst, displacement, base, temp);
:: box-displaced-alien/dynamic ( dst displacement base temp -- )
    "not-f" define-label
    "not-alien" define-label

    ! Is base f?
    0 base \ f type-number %compare-cell-imm
    0 "not-f" get BNE
    dst displacement base box-displaced-alien/f
    "end" get B

    ! Is base an alien?
    "not-f" resolve-label
    temp base tag-mask get ANDI.
    0 temp alien type-number %compare-cell-imm
    0 "not-alien" get BNE
    dst displacement base temp box-displaced-alien/alien
    "end" get B

    ! Assume base is a byte array.
    "not-alien" resolve-label
    dst displacement base temp box-displaced-alien/byte-array ;

! if (displacement == 0)
!   dst = base;
! else {
!   dst = allot_alien(NULL);
!   dst->expired = F_TYPE;
!   if (is_subclass(base_class, F_TYPE))
!      box_displaced_alien_f(dst, displacement, base);
!   else if (is_subclass(base_class, ALIEN_TYPE))
!      box_displaced_alien_alien(dst, displacement, base, temp);
!   else if (is_subclass(base_class, BYTE_ARRAY_TYPE))
!      box_displaced_alien_byte_array(dst, displacement, base, temp);
!   else
!      box_displaced_alien_dynamic(dst, displacement, base, temp);
! }
M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
    [
        "end" define-label

        ! If displacement is zero, return the base.
        dst base MR
        0 displacement 0 %compare-cell-imm
        0 "end" get BEQ

        ! Displacement is non-zero, we're going to be allocating a new
        ! object
        dst 5 cells alien temp %allot

        ! Set expired to f
        temp \ f type-number %load-immediate
        scratch-reg 2 alien@ LI
        temp dst scratch-reg %store-cell-x

        dst displacement base temp
        {
            { [ base-class \ f class<= ] [ drop box-displaced-alien/f ] }
            { [ base-class \ alien class<= ] [ box-displaced-alien/alien ] }
            { [ base-class \ byte-array class<= ] [ box-displaced-alien/byte-array ] }
            [ box-displaced-alien/dynamic ]
        } cond

        "end" resolve-label
    ] with-scope ;

M:: ppc.32 %convert-integer ( dst src c-type -- )
    c-type {
        { c:char   [ dst src 24 CLRLWI dst dst EXTSB ] }
        { c:uchar  [ dst src 24 CLRLWI ] }
        { c:short  [ dst src 16 CLRLWI dst dst EXTSH ] }
        { c:ushort [ dst src 16 CLRLWI ] }
        { c:int    [ ] }
        { c:uint   [ ] }
    } case ;

M:: ppc.64 %convert-integer ( dst src c-type -- )
    c-type {
        { c:char      [ dst src 56 CLRLDI dst dst EXTSB ] }
        { c:uchar     [ dst src 56 CLRLDI ] }
        { c:short     [ dst src 48 CLRLDI dst dst EXTSH ] }
        { c:ushort    [ dst src 48 CLRLDI ] }
        { c:int       [ dst src 32 CLRLDI dst dst EXTSW ] }
        { c:uint      [ dst src 32 CLRLDI ] }
        { c:longlong  [ ] }
        { c:ulonglong [ ] }
    } case ;

M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
    [
        pick %trap-null
        {
            { c:char   [ [ dup ] 2dip LBZ dup EXTSB ] }
            { c:uchar  [ LBZ ] }
            { c:short  [ LHA ] }
            { c:ushort [ LHZ ] }
            { c:int    [ LWZ ] }
            { c:uint   [ LWZ ] }
        } case
    ] [
        {
            { int-rep    [ LWZ ] }
            { float-rep  [ LFS ] }
            { double-rep [ LFD ] }
        } case
    ] ?if ;

M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
    [
        pick %trap-null
        {
            { c:char      [ [ dup ] 2dip LBZ dup EXTSB ] }
            { c:uchar     [ LBZ ] }
            { c:short     [ LHA ] }
            { c:ushort    [ LHZ ] }
            { c:int       [ LWZ ] }
            { c:uint      [ LWZ ] }
            { c:longlong  [ [ scratch-reg ] dip LI scratch-reg LDX ] }
            { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg LDX ] }
        } case
    ] [
        {
            { int-rep    [ [ scratch-reg ] dip LI scratch-reg LDX  ] }
            { float-rep  [ [ scratch-reg ] dip LI scratch-reg LFSX ] }
            { double-rep [ [ scratch-reg ] dip LI scratch-reg LFDX ] }
        } case
    ] ?if ;


M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- )
    [ [ 0 assert= ] bi@ ] 2dip
    [
        pick %trap-null
        {
            { c:char   [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
            { c:uchar  [ LBZX ] }
            { c:short  [ LHAX ] }
            { c:ushort [ LHZX ] }
            { c:int    [ LWZX ] }
            { c:uint   [ LWZX ] }
        } case
    ] [
        {
            { int-rep    [ LWZX ] }
            { float-rep  [ LFSX ] }
            { double-rep [ LFDX ] }
        } case
    ] ?if ;

M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
    [ [ 0 assert= ] bi@ ] 2dip
    [
        pick %trap-null
        {
            { c:char      [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
            { c:uchar     [ LBZX ] }
            { c:short     [ LHAX ] }
            { c:ushort    [ LHZX ] }
            { c:int       [ LWZX ] }
            { c:uint      [ LWZX ] }
            { c:longlong  [ LDX  ] }
            { c:ulonglong [ LDX  ] }
        } case
    ] [
        {
            { int-rep    [ LDX  ] }
            { float-rep  [ LFSX ] }
            { double-rep [ LFDX ] }
        } case
    ] ?if ;


M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
    [
        {
            { c:char   [ STB ] }
            { c:uchar  [ STB ] }
            { c:short  [ STH ] }
            { c:ushort [ STH ] }
            { c:int    [ STW ] }
            { c:uint   [ STW ] }
        } case
    ] [
        {
            { int-rep    [ STW  ] }
            { float-rep  [ STFS ] }
            { double-rep [ STFD ] }
        } case
    ] ?if ;

M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
    [
        {
            { c:char      [ STB ] }
            { c:uchar     [ STB ] }
            { c:short     [ STH ] }
            { c:ushort    [ STH ] }
            { c:int       [ STW ] }
            { c:uint      [ STW ] }
            { c:longlong  [ [ scratch-reg ] dip LI scratch-reg STDX ] }
            { c:ulonglong [ [ scratch-reg ] dip LI scratch-reg STDX ] }
        } case
    ] [
        {
            { int-rep    [ [ scratch-reg ] dip LI scratch-reg STDX  ] }
            { float-rep  [ [ scratch-reg ] dip LI scratch-reg STFSX ] }
            { double-rep [ [ scratch-reg ] dip LI scratch-reg STFDX ] }
        } case
    ] ?if ;

M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
    [ [ 0 assert= ] bi@ ] 2dip
    [
        {
            { c:char   [ STBX ] }
            { c:uchar  [ STBX ] }
            { c:short  [ STHX ] }
            { c:ushort [ STHX ] }
            { c:int    [ STWX ] }
            { c:uint   [ STWX ] }
        } case
    ] [
        {
            { int-rep    [ STWX  ] }
            { float-rep  [ STFSX ] }
            { double-rep [ STFDX ] }
        } case
    ] ?if ;

M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- )
    [ [ 0 assert= ] bi@ ] 2dip
    [
        {
            { c:char      [ STBX ] }
            { c:uchar     [ STBX ] }
            { c:short     [ STHX ] }
            { c:ushort    [ STHX ] }
            { c:int       [ STWX ] }
            { c:uint      [ STWX ] }
            { c:longlong  [ STDX ] }
            { c:ulonglong [ STDX ] }
        } case
    ] [
        {
            { int-rep    [ STDX  ] }
            { float-rep  [ STFSX ] }
            { double-rep [ STFDX ] }
        } case
    ] ?if ;

M:: ppc %allot ( dst size class nursery-ptr -- )
    ! dst = vm->nursery.here;
    nursery-ptr vm-reg "nursery" vm-field-offset ADDI
    dst nursery-ptr 0 %load-cell
    ! vm->nursery.here += align(size, data_alignment);
    scratch-reg dst size data-alignment get align ADDI
    scratch-reg nursery-ptr 0 %store-cell
    ! ((object*) dst)->header = type_number << 2;
    scratch-reg class type-number tag-header LI
    scratch-reg dst 0 %store-cell
    ! dst |= type_number
    dst dst class type-number ORI ;

:: (%write-barrier) ( temp1 temp2 -- )
    scratch-reg card-mark LI
    ! *(char *)(cards_offset + ((cell)slot_ptr >> card_bits))
    !    = card_mark_mask;
    temp1 temp1 card-bits %shr-imm
    temp2 0 %load-cell-imm %load-cell-imm-rc rel-cards-offset
    scratch-reg temp1 temp2 STBX
    ! *(char *)(decks_offset + ((cell)slot_ptr >> deck_bits))
    !    = card_mark_mask;
    temp1 temp1 deck-bits card-bits - %shr-imm
    temp2 0 %load-cell-imm %load-cell-imm-rc rel-decks-offset
    scratch-reg temp1 temp2 STBX ;

M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
    scale 0 assert= tag 0 assert=
    temp1 src slot ADD
    temp1 temp2 (%write-barrier) ;

M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
    temp1 src slot tag slot-offset ADDI
    temp1 temp2 (%write-barrier) ;

M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
    ! if (vm->nursery.here + size >= vm->nursery.end) ...
    temp1 vm-reg "nursery" vm-field-offset %load-cell
    temp2 vm-reg "nursery" vm-field-offset 2 cells + %load-cell
    temp1 temp1 size ADDI
    0 temp1 temp2 %compare-cell
    cc {
        { cc<=  [ 0 label BLE ] }
        { cc/<= [ 0 label BGT ] }
    } case ;

M: ppc %call-gc ( gc-map -- )
    \ minor-gc %call gc-map-here ;

M:: ppc %prologue ( stack-size -- )
    0 MFLR
    0 1 lr-save %store-cell
    11 0 %load-cell-imm %load-cell-imm-rc rel-this
    11 1 2 cells neg %store-cell
    11 stack-size LI
    11 1 1 cells neg %store-cell
    1 1 stack-size neg %store-cell-update ;

! At the end of each word that calls a subroutine, we store
! the previous link register value in r0 by popping it off
! the stack, set the link register to the contents of r0,
! and jump to the link register.
M:: ppc %epilogue ( stack-size -- )
    1 1 stack-size ADDI
    0 1 lr-save %load-cell
    0 MTLR ;

:: (%boolean) ( dst temp branch1 branch2 -- )
    "end" define-label
    dst \ f type-number %load-immediate
    0 "end" get branch1 execute( n addr -- )
    branch2 [ 0 "end" get branch2 execute( n addr -- ) ] when
    dst \ t %load-reference
    "end" get resolve-label ; inline

:: %boolean ( dst cc temp -- )
    cc negate-cc order-cc {
        { cc<  [ dst temp \ BLT f (%boolean) ] }
        { cc<= [ dst temp \ BLE f (%boolean) ] }
        { cc>  [ dst temp \ BGT f (%boolean) ] }
        { cc>= [ dst temp \ BGE f (%boolean) ] }
        { cc=  [ dst temp \ BEQ f (%boolean) ] }
        { cc/= [ dst temp \ BNE f (%boolean) ] }
    } case ;

: (%compare) ( src1 src2 -- ) [ 0 ] 2dip %compare-cell ; inline

: (%compare-integer-imm) ( src1 src2 -- )
    [ 0 ] 2dip %compare-cell-imm ; inline

: (%compare-imm) ( src1 src2 -- )
    [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline

: (%compare-float-unordered) ( src1 src2 -- )
    [ 0 ] 2dip FCMPU ; inline

: (%compare-float-ordered) ( src1 src2 -- )
    [ 0 ] 2dip FCMPO ; inline

:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
    cc {
        { cc<    [ src1 src2 \ compare execute( a b -- ) \ BLT f     ] }
        { cc<=   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
        { cc>    [ src1 src2 \ compare execute( a b -- ) \ BGT f     ] }
        { cc>=   [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
        { cc=    [ src1 src2 \ compare execute( a b -- ) \ BEQ f     ] }
        { cc<>   [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
        { cc<>=  [ src1 src2 \ compare execute( a b -- ) \ BNS f     ] }
        { cc/<   [ src1 src2 \ compare execute( a b -- ) \ BGE f     ] }
        { cc/<=  [ src1 src2 \ compare execute( a b -- ) \ BGT \ BSO ] }
        { cc/>   [ src1 src2 \ compare execute( a b -- ) \ BLE f     ] }
        { cc/>=  [ src1 src2 \ compare execute( a b -- ) \ BLT \ BSO ] }
        { cc/=   [ src1 src2 \ compare execute( a b -- ) \ BNE f     ] }
        { cc/<>  [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BSO ] }
        { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BSO f     ] }
    } case ; inline

M: ppc %compare [ (%compare) ] 2dip %boolean ;

M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;

M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;

M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
    src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
    dst temp branch1 branch2 (%boolean) ;

M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
    src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
    dst temp branch1 branch2 (%boolean) ;

:: %branch ( label cc -- )
    cc order-cc {
        { cc<  [ 0 label BLT ] }
        { cc<= [ 0 label BLE ] }
        { cc>  [ 0 label BGT ] }
        { cc>= [ 0 label BGE ] }
        { cc=  [ 0 label BEQ ] }
        { cc/= [ 0 label BNE ] }
    } case ;

M:: ppc %compare-branch ( label src1 src2 cc -- )
    src1 src2 (%compare)
    label cc %branch ;

M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
    src1 src2 (%compare-imm)
    label cc %branch ;

M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
    src1 src2 (%compare-integer-imm)
    label cc %branch ;

:: (%branch) ( label branch1 branch2 -- )
    0 label branch1 execute( cr label -- )
    branch2 [ 0 label branch2 execute( cr label -- ) ] when ; inline

M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
    src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
    label branch1 branch2 (%branch) ;

M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
    src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
    label branch1 branch2 (%branch) ;

M: ppc %spill ( src rep dst -- )
    n>> spill@ swap  {
        { int-rep    [ [ 1 ] dip %store-cell ] }
        { tagged-rep [ [ 1 ] dip %store-cell ] }
        { float-rep  [ [ 1 ] dip STFS ] }
        { double-rep [ [ 1 ] dip STFD ] }
        { vector-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
        { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
    } case ;

M: ppc %reload ( dst rep src -- )
    n>> spill@ swap {
        { int-rep    [ [ 1 ] dip %load-cell ] }
        { tagged-rep [ [ 1 ] dip %load-cell ] }
        { float-rep  [ [ 1 ] dip LFS ] }
        { double-rep [ [ 1 ] dip LFD ] }
        { vector-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
        { scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
    } case ;

M: ppc %loop-entry           ( -- ) ;
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-bitwise?    ( n -- ? ) 0 65535 between? ;
M: ppc immediate-store?      ( n -- ? ) immediate-comparand? ;

USE: vocabs.loader
{
    { [ os linux? ] [
        {
            { [ cpu ppc.32? ] [ "cpu.ppc.32.linux" require ] }
            { [ cpu ppc.64? ] [ "cpu.ppc.64.linux" require ] }
            [ ]
        } cond
      ] }
    [ ]
} cond

complex-double c-type t >>return-in-registers? drop