! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: alien assembler kernel kernel-internals math
math-internals namespaces sequences words ;

: generate-slot ( size quot -- )
    >r >r
    ! turn tagged fixnum slot # into an offset, multiple of 4
    "n" operand dup tag-bits r> - SRAWI
    ! compute slot address
    "obj" operand dup "n" operand ADD
    ! load slot value
    "obj" operand dup r> call ; inline

\ slot [
    "obj" operand dup %untag
    cell log2 [ 0 LWZ ] generate-slot
] H{
    { +input+ { { f "obj" } { f "n" } } }
    { +output+ { "obj" } }
} define-intrinsic

\ char-slot [
    1 [ string-offset LHZ ] generate-slot
    "obj" operand dup %tag-fixnum
] H{
    { +input+ { { f "n" } { f "obj" } } }
    { +output+ { "obj" } }
} define-intrinsic

: generate-set-slot ( size quot -- )
    >r >r
    ! turn tagged fixnum slot # into an offset, multiple of 4
    "slot" operand dup tag-bits r> - SRAWI
    ! compute slot address in 1st input
    "slot" operand dup "obj" operand ADD
    ! store new slot value
    "val" operand "slot" operand r> call ; inline

: generate-write-barrier ( -- )
    #! Mark the card pointed to by vreg.
    "obj" operand dup card-bits SRAWI
    "obj" operand dup 16 ADD
    "x" operand "obj" operand 0 LBZ
    "x" operand dup card-mark ORI
    "x" operand "obj" operand 0 STB ;

\ set-slot [
    "obj" operand dup %untag
    cell log2 [ 0 STW ] generate-set-slot generate-write-barrier
] H{
    { +input+ { { f "val" } { f "obj" } { f "slot" } } }
    { +scratch+ { { f "x" } } }
    { +clobber+ { "obj" "slot" } }
} define-intrinsic

\ set-char-slot [
    ! untag the new value in 0th input
    "val" operand dup %untag-fixnum
    1 [ string-offset STH ] generate-set-slot
] H{
    { +input+ { { f "val" } { f "slot" } { f "obj" } } }
    { +scratch+ { { f "x" } } }
    { +clobber+ { "val" "slot" "obj" } }
} define-intrinsic

: define-fixnum-op ( word op -- )
    [ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
        { +input+ { { f "x" } { f "y" } } }
        { +output+ { "x" } }
    } define-intrinsic ;

{
    { fixnum+fast ADD }
    { fixnum-fast SUBF }
    { fixnum-bitand AND }
    { fixnum-bitor OR }
    { fixnum-bitxor XOR }
} [
    first2 define-fixnum-op
] each

: generate-fixnum-mod
    #! PowerPC doesn't have a MOD instruction; so we compute
    #! x-(x/y)*y. Puts the result in "s" operand.
    "s" operand "r" operand "y" operand MULLW
    "s" operand "s" operand "x" operand SUBF ;

\ fixnum-mod [
    ! divide x by y, store result in x
    "r" operand "x" operand "y" operand DIVW
    generate-fixnum-mod
] H{
    { +input+ { { f "x" } { f "y" } } }
    { +scratch+ { { f "r" } { f "s" } } }
    { +output+ { "s" } }
} define-intrinsic

\ fixnum-bitnot [
    "x" operand dup NOT
    "x" operand dup %untag
] H{
    { +input+ { { f "x" } } }
    { +output+ { "x" } }
} define-intrinsic

: define-fixnum-jump ( word op -- )
    [ "x" operand 0 "y" operand CMP ] swap add
    { { f "x" } { f "y" } } define-if-intrinsic ;

{
    { fixnum< BLT }
    { fixnum<= BLE }
    { fixnum> BGT }
    { fixnum>= BGE }
    { eq? BEQ }
} [
    first2 define-fixnum-jump
] each

: simple-overflow ( word -- )
    [
        >r
        "end" define-label
        "end" get BNO
        { "x" "y" } [ dup %untag-fixnum ] unique-operands
        "r" operand "y" operand "x" operand r> execute
        "r" operand %allot-bignum-signed-1
        "end" resolve-label
    ] with-scope ; inline

\ fixnum+ [
    0 MTXER
    "r" operand "y" operand "x" operand ADDO.
    \ ADD simple-overflow
] H{
    { +input+ { { f "x" } { f "y" } } }
    { +scratch+ { { f "r" } } }
    { +output+ { "r" } }
    { +clobber+ { "x" "y" } }
} define-intrinsic

\ fixnum- [
    0 MTXER
    "r" operand "y" operand "x" operand SUBFO.
    \ SUBF simple-overflow
] H{
    { +input+ { { f "x" } { f "y" } } }
    { +scratch+ { { f "r" } } }
    { +output+ { "r" } }
    { +clobber+ { "x" "y" } }
} define-intrinsic

! \ fixnum* [
!     "end" define-label
!     "r" operand "x" operand %untag-fixnum
!     0 MTXER
!     "s" operand "y" operand "r" operand MULLWO.
!     "end" get BNO
!     "s" operand "y" operand 1 SRAWI
!     "x" operand "s" operand "r" operand MULLWO.
!     "x" operand dup 2 SRAWI
!     "s" operand "s" operand "r" operand MULHW
!     "s" operand "x" operand %allot-bignum-signed-2
!     "end" resolve-label
! ] H{
!     { +input+ { { f "x" } { f "y" } } }
!     { +scratch+ { { f "r" } { f "s" } } }
!     { +output+ { "s" } }
!     { +clobber+ { "x" "y" } }
! } define-intrinsic

: generate-fixnum/i
    #! This VOP is funny. If there is an overflow, it falls
    #! through to the end, and the result is in "x" operand.
    #! Otherwise it jumps to the "no-overflow" label and the
    #! result is in "r" operand.
    "end" define-label
    "no-overflow" define-label
    "r" operand "x" operand "y" operand DIVW
    ! if the result is greater than the most positive fixnum,
    ! which can only ever happen if we do
    ! most-negative-fixnum -1 /i, then the result is a bignum.
    most-positive-fixnum "s" operand LOAD
    "r" operand 0 "s" operand CMP
    "no-overflow" get BLE
    most-negative-fixnum neg "x" operand LOAD
    "x" operand %allot-bignum-signed-1 ;

\ fixnum/i [
    generate-fixnum/i
    "end" get B
    "no-overflow" resolve-label
    "r" operand "x" operand %tag-fixnum
    "end" resolve-label
] H{
    { +input+ { { f "x" } { f "y" } } }
    { +scratch+ { { f "r" } { f "s" } } }
    { +output+ { "x" } }
    { +clobber+ { "y" } }
} define-intrinsic

\ fixnum/mod [
    generate-fixnum/i
    0 "s" operand LI
    "end" get B
    "no-overflow" resolve-label
    generate-fixnum-mod
    "r" operand "x" operand %tag-fixnum
    "end" resolve-label
] H{
    { +input+ { { f "x" } { f "y" } } }
    { +scratch+ { { f "r" } { f "s" } } }
    { +output+ { "x" "s" } }
    { +clobber+ { "y" } }
} define-intrinsic

\ fixnum>bignum [
    "nonzero" define-label
    "end" define-label
    0 "x" operand 0 CMPI ! is it zero?
    "nonzero" get BNE
    0 >bignum "x" get load-literal
    "end" get B
    "nonzero" resolve-label
    "x" operand dup %untag-fixnum
    "x" operand %allot-bignum-signed-1
    "end" resolve-label
] H{
    { +input+ { { f "x" } } }
    { +output+ { "x" } }
} define-intrinsic

\ bignum>fixnum [
    "nonzero" define-label
    "positive" define-label
    "end" define-label
    "x" operand dup %untag
    "y" operand "x" operand cell LWZ
     ! if the length is 1, its just the sign and nothing else,
     ! so output 0
    0 "y" operand 1 tag-bits shift CMPI
    "nonzero" get BNE
    0 "y" operand LI
    "end" get B
    "nonzero" resolve-label
    ! load the value
    "y" operand "x" operand 3 cells LWZ
    ! load the sign
    "x" operand "x" operand 2 cells LWZ
    ! is the sign negative?
    0 "x" operand 0 CMPI
    "positive" get BEQ
    "y" operand dup -1 MULI
    "positive" resolve-label
    "y" operand dup %tag-fixnum
    "end" resolve-label
] H{
    { +input+ { { f "x" } } }
    { +scratch+ { { f "y" } } }
    { +clobber+ { "x" } }
    { +output+ { "y" } }
} define-intrinsic

: define-float-op ( word op -- )
    [ [ "x" operand "x" operand "y" operand ] % , ] [ ] make H{
        { +input+ { { float "x" } { float "y" } } }
        { +output+ { "x" } }
    } define-intrinsic ;

{
    { float+ FADD }
    { float- FSUB }
    { float* FMUL }
    { float/f FDIV }
} [
    first2 define-float-op
] each

: define-float-jump ( word op -- )
    [ "x" operand 0 "y" operand FCMPU ] swap add
    { { float "x" } { float "y" } } define-if-intrinsic ;

{
    { float< BLT }
    { float<= BLE }
    { float> BGT }
    { float>= BGE }
    { float= BEQ }
} [
    first2 define-float-jump
] each

\ float>fixnum [
    "scratch" operand "in" operand FCTIWZ
    "scratch" operand 1 0 stack@ STFD
    "out" operand 1 cell stack@ LWZ
    "out" operand dup %tag-fixnum
] H{
    { +input+ { { float "in" } } }
    { +scratch+ { { float "scratch" } { f "out" } } }
    { +output+ { "out" } }
} define-intrinsic

\ tag [
    "in" operand "out" operand tag-mask ANDI
    "out" operand dup %tag-fixnum
] H{
    { +input+ { { f "in" } } }
    { +scratch+ { { f "out" } } }
    { +output+ { "out" } }
} define-intrinsic

\ type [
    "f" define-label
    "end" define-label
    ! Get the tag
    "obj" operand "y" operand tag-mask ANDI
    ! Tag the tag
    "y" operand "x" operand %tag-fixnum
    ! Compare with object tag number (3).
    0 "y" operand object-tag CMPI
    ! Jump if the object doesn't store type info in its header
    "end" get BNE
    ! It does store type info in its header
    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
    0 "obj" operand object-tag CMPI
    "f" get BEQ
    ! The pointer is not equal to 3. Load the object header.
    "x" operand "obj" operand object-tag neg LWZ
    "x" operand dup %untag
    "end" get B
    "f" resolve-label
    ! The pointer is equal to 3. Load F_TYPE (9).
    f type tag-bits shift "x" operand LI
    "end" resolve-label
] H{
    { +input+ { { f "obj" } } }
    { +scratch+ { { f "x" } { f "y" } } }
    { +output+ { "x" } }
} define-intrinsic

: userenv ( reg -- )
    #! Load the userenv pointer in a register.
    "userenv" f rot compile-dlsym ;

\ getenv [
    "n" operand dup 1 SRAWI
    "x" operand userenv
    "x" operand "n" operand "x" operand ADD
    "x" operand dup 0 LWZ
] H{
    { +input+ { { f "n" } } }
    { +scratch+ { { f "x" } } }
    { +output+ { "x" } }
    { +clobber+ { "n" } }
} define-intrinsic

\ setenv [
    "n" operand dup 1 SRAWI
    "x" operand userenv
    "x" operand "n" operand "x" operand ADD
    "val" operand "x" operand 0 STW
] H{
    { +input+ { { f "val" } { f "n" } } }
    { +scratch+ { { f "x" } } }
    { +clobber+ { "n" } }
} define-intrinsic