factor/basis/cpu/x86/32/32.factor

! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: locals alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
stack-checker.known-words compiler.generator.registers
compiler.generator.fixup compiler.generator system layouts
combinators command-line compiler compiler.units io
vocabs.loader accessors init ;
IN: cpu.x86.32

! We implement the FFI for Linux, OS X and Windows all at once.
! OS X requires that the stack be 16-byte aligned, and we do
! this on all platforms, sacrificing some stack space for
! code simplicity.

M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;

M: temp-reg v>operand drop EBX ;

M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;

M: x86.32 %alien-invoke (CALL) rel-dlsym ;

M: x86.32 struct-small-enough? ( size -- ? )
    heap-size { 1 2 4 8 } member?
    os { linux netbsd solaris } member? not and ;

: struct-return@ ( n -- operand )
    [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;

! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;

M: int-regs load-return-reg
    return-reg swap next-stack@ MOV ;

M: int-regs store-return-reg
    [ stack@ ] [ return-reg ] bi* MOV ;

M: float-regs param-regs drop { } ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;

: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;

M: float-regs push-return-reg
    stack-reg swap reg-size
    [ SUB ] [ [ [] ] dip FSTP ] 2bi ;

: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;

M: float-regs load-return-reg
    [ next-stack@ ] [ reg-size ] bi* FLD ;

M: float-regs store-return-reg
    [ stack@ ] [ reg-size ] bi* FSTP ;

: align-sub ( n -- )
    [ align-stack ] keep - decr-stack-reg ;

: align-add ( n -- )
    align-stack incr-stack-reg ;

: with-aligned-stack ( n quot -- )
    [ [ align-sub ] [ call ] bi* ]
    [ [ align-add ] [ drop ] bi* ] 2bi ; inline

M: x86.32 fixnum>slot@ 1 SHR ;

M: x86.32 prepare-division CDQ ;

M: x86.32 load-indirect
    0 [] MOV rc-absolute-cell rel-literal ;

M: object %load-param-reg 3drop ;

M: object %save-param-reg 3drop ;

: (%box) ( n reg-class -- )
    #! If n is f, push the return register onto the stack; we
    #! are boxing a return value of a C function. If n is an
    #! integer, push [ESP+n] on the stack; we are boxing a
    #! parameter being passed to a callback from C.
    over [ load-return-reg ] [ 2drop ] if ;

M:: x86.32 %box ( n reg-class func -- )
    n reg-class (%box)
    reg-class reg-size [
        reg-class push-return-reg
        func f %alien-invoke
    ] with-aligned-stack ;
    
: (%box-long-long) ( n -- )
    [
        EDX over next-stack@ MOV
        EAX swap cell - next-stack@ MOV 
    ] when* ;

M: x86.32 %box-long-long ( n func -- )
    [ (%box-long-long) ] dip
    8 [
        EDX PUSH
        EAX PUSH
        f %alien-invoke
    ] with-aligned-stack ;

M:: x86.32 %box-large-struct ( n c-type -- )
    ! Compute destination address
    ECX n struct-return@ LEA
    8 [
        ! Push struct size
        c-type heap-size PUSH
        ! Push destination address
        ECX PUSH
        ! Copy the struct from the C stack
        "box_value_struct" f %alien-invoke
    ] with-aligned-stack ;

M: x86.32 %prepare-box-struct ( -- )
    ! Compute target address for value struct return
    EAX f struct-return@ LEA
    ! Store it as the first parameter
    0 stack@ EAX MOV ;

M: x86.32 %box-small-struct ( c-type -- )
    #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
    12 [
        heap-size PUSH
        EDX PUSH
        EAX PUSH
        "box_small_struct" f %alien-invoke
    ] with-aligned-stack ;

M: x86.32 %prepare-unbox ( -- )
    #! Move top of data stack to EAX.
    EAX ESI [] MOV
    ESI 4 SUB ;

: (%unbox) ( func -- )
    4 [
        ! Push parameter
        EAX PUSH
        ! Call the unboxer
        f %alien-invoke
    ] with-aligned-stack ;

M: x86.32 %unbox ( n reg-class func -- )
    #! The value being unboxed must already be in EAX.
    #! If n is f, we're unboxing a return value about to be
    #! returned by the callback. Otherwise, we're unboxing
    #! a parameter to a C function about to be called.
    (%unbox)
    ! Store the return value on the C stack
    over [ store-return-reg ] [ 2drop ] if ;

M: x86.32 %unbox-long-long ( n func -- )
    (%unbox)
    ! Store the return value on the C stack
    [
        dup stack@ EAX MOV
        cell + stack@ EDX MOV
    ] when* ;

: %unbox-struct-1 ( -- )
    #! Alien must be in EAX.
    4 [
        EAX PUSH
        "alien_offset" f %alien-invoke
        ! Load first cell
        EAX EAX [] MOV
    ] with-aligned-stack ;

: %unbox-struct-2 ( -- )
    #! Alien must be in EAX.
    4 [
        EAX PUSH
        "alien_offset" f %alien-invoke
        ! Load second cell
        EDX EAX 4 [+] MOV
        ! Load first cell
        EAX EAX [] MOV
    ] with-aligned-stack ;

M: x86 %unbox-small-struct ( size -- )
    #! Alien must be in EAX.
    heap-size cell align cell /i {
        { 1 [ %unbox-struct-1 ] }
        { 2 [ %unbox-struct-2 ] }
    } case ;

M: x86.32 %unbox-large-struct ( n c-type -- )
    ! Alien must be in EAX.
    ! Compute destination address
    ECX rot stack@ LEA
    12 [
        ! Push struct size
        heap-size PUSH
        ! Push destination address
        ECX PUSH
        ! Push source address
        EAX PUSH
        ! Copy the struct to the stack
        "to_value_struct" f %alien-invoke
    ] with-aligned-stack ;

M: x86.32 %prepare-alien-indirect ( -- )
    "unbox_alien" f %alien-invoke
    EBP EAX MOV ;

M: x86.32 %alien-indirect ( -- )
    EBP CALL ;

M: x86.32 %alien-callback ( quot -- )
    4 [
        EAX load-indirect
        EAX PUSH
        "c_to_factor" f %alien-invoke
    ] with-aligned-stack ;

M: x86.32 %callback-value ( ctype -- )
    ! Align C stack
    ESP 12 SUB
    ! Save top of data stack in non-volatile register
    %prepare-unbox
    EAX PUSH
    ! Restore data/call/retain stacks
    "unnest_stacks" f %alien-invoke
    ! Place top of data stack in EAX
    EAX POP
    ! Restore C stack
    ESP 12 ADD
    ! Unbox EAX
    unbox-return ;

M: x86.32 %cleanup ( alien-node -- )
    #! a) If we just called an stdcall function in Windows, it
    #! cleaned up the stack frame for us. But we don't want that
    #! so we 'undo' the cleanup since we do that in %epilogue.
    #! b) If we just called a function returning a struct, we
    #! have to fix ESP.
    {
        {
            [ dup abi>> "stdcall" = ]
            [ drop ESP stack-frame get params>> SUB ]
        } {
            [ dup return>> large-struct? ]
            [ drop EAX PUSH ]
        }
        [ drop ]
    } cond ;

M: x86.32 %unwind ( n -- ) %epilogue-later RET ;

os windows? [
    cell "longlong" c-type (>>align)
    cell "ulonglong" c-type (>>align)
    4 "double" c-type (>>align)
] unless

: (sse2?) ( -- ? ) "Intrinsic" throw ;

<<

\ (sse2?) [
    { EAX EBX ECX EDX } [ PUSH ] each
    EAX 1 MOV
    CPUID
    EDX 26 SHR
    EDX 1 AND
    { EAX EBX ECX EDX } [ POP ] each
    JE
] { } define-if-intrinsic

\ (sse2?) { } { object } define-primitive

>>

: sse2? ( -- ? ) (sse2?) ;

"-no-sse2" cli-args member? [
    "Checking if your CPU supports SSE2..." print flush
    [ optimized-recompile-hook ] recompile-hook [
        [ sse2? ] compile-call
    ] with-variable
    [
        " - yes" print
        "cpu.x86.sse2" require
        [
            sse2? [
                "This image was built to use SSE2, which your CPU does not support." print
                "You will need to bootstrap Factor again." print
                flush
                1 exit
            ] unless
        ] "cpu.x86" add-init-hook
    ] [
        " - no" print
    ] if
] unless