basis/cpu/x86/32/32.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: locals alien.c-types alien.syntax arrays kernel
   4 math namespaces sequences system layouts io vocabs.loader
   5 accessors init combinators command-line cpu.x86.assembler
   6 cpu.x86 cpu.architecture compiler compiler.units
   7 compiler.constants compiler.alien compiler.codegen
   8 compiler.codegen.fixup compiler.cfg.instructions
   9 compiler.cfg.builder compiler.cfg.intrinsics make ;
  10 IN: cpu.x86.32
  11
  12 ! We implement the FFI for Linux, OS X and Windows all at once.
  13 ! OS X requires that the stack be 16-byte aligned, and we do
  14 ! this on all platforms, sacrificing some stack space for
  15 ! code simplicity.
  16
  17 M: x86.32 machine-registers
  18     {
  19         { int-regs { EAX ECX EDX EBP EBX } }
  20         { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
  21     } ;
  22
  23 M: x86.32 ds-reg ESI ;
  24 M: x86.32 rs-reg EDI ;
  25 M: x86.32 stack-reg ESP ;
  26 M: x86.32 temp-reg-1 ECX ;
  27 M: x86.32 temp-reg-2 EDX ;
  28
  29 M:: x86.32 %dispatch ( src temp offset -- )
  30     ! Load jump table base.
  31     src HEX: ffffffff ADD
  32     offset cells rc-absolute-cell rel-here
  33     ! Go
  34     src HEX: 7f [+] JMP
  35     ! Fix up the displacement above
  36     cell code-alignment
  37     [ 7 + building get dup pop* push ]
  38     [ align-code ]
  39     bi ;
  40
  41 ! Registers for fastcall
  42 M: x86.32 param-reg-1 EAX ;
  43 M: x86.32 param-reg-2 EDX ;
  44
  45 M: x86.32 reserved-area-size 0 ;
  46
  47 M: x86.32 %alien-invoke (CALL) rel-dlsym ;
  48
  49 M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
  50
  51 M: x86.32 struct-small-enough? ( size -- ? )
  52     heap-size { 1 2 4 8 } member?
  53     os { linux netbsd solaris } member? not and ;
  54
  55 : struct-return@ ( n -- operand )
  56     [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
  57
  58 ! On x86, parameters are never passed in registers.
  59 M: int-regs return-reg drop EAX ;
  60 M: int-regs param-regs drop { } ;
  61 M: int-regs push-return-reg return-reg PUSH ;
  62
  63 M: int-regs load-return-reg
  64     return-reg swap next-stack@ MOV ;
  65
  66 M: int-regs store-return-reg
  67     [ stack@ ] [ return-reg ] bi* MOV ;
  68
  69 M: float-regs param-regs drop { } ;
  70
  71 : FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
  72
  73 M: float-regs push-return-reg
  74     stack-reg swap reg-size
  75     [ SUB ] [ [ [] ] dip FSTP ] 2bi ;
  76
  77 : FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
  78
  79 M: float-regs load-return-reg
  80     [ next-stack@ ] [ reg-size ] bi* FLD ;
  81
  82 M: float-regs store-return-reg
  83     [ stack@ ] [ reg-size ] bi* FSTP ;
  84
  85 : align-sub ( n -- )
  86     [ align-stack ] keep - decr-stack-reg ;
  87
  88 : align-add ( n -- )
  89     align-stack incr-stack-reg ;
  90
  91 : with-aligned-stack ( n quot -- )
  92     [ [ align-sub ] [ call ] bi* ]
  93     [ [ align-add ] [ drop ] bi* ] 2bi ; inline
  94
  95 M: x86.32 %prologue ( n -- )
  96     dup PUSH
  97     0 PUSH rc-absolute-cell rel-this
  98     stack-reg swap 3 cells - SUB ;
  99
 100 M: object %load-param-reg 3drop ;
 101
 102 M: object %save-param-reg 3drop ;
 103
 104 : (%box) ( n reg-class -- )
 105     #! If n is f, push the return register onto the stack; we
 106     #! are boxing a return value of a C function. If n is an
 107     #! integer, push [ESP+n] on the stack; we are boxing a
 108     #! parameter being passed to a callback from C.
 109     over [ load-return-reg ] [ 2drop ] if ;
 110
 111 M:: x86.32 %box ( n reg-class func -- )
 112     n reg-class (%box)
 113     reg-class reg-size [
 114         reg-class push-return-reg
 115         func f %alien-invoke
 116     ] with-aligned-stack ;
 117
 118 : (%box-long-long) ( n -- )
 119     [
 120         EDX over next-stack@ MOV
 121         EAX swap cell - next-stack@ MOV
 122     ] when* ;
 123
 124 M: x86.32 %box-long-long ( n func -- )
 125     [ (%box-long-long) ] dip
 126     8 [
 127         EDX PUSH
 128         EAX PUSH
 129         f %alien-invoke
 130     ] with-aligned-stack ;
 131
 132 M:: x86.32 %box-large-struct ( n c-type -- )
 133     ! Compute destination address
 134     ECX n struct-return@ LEA
 135     8 [
 136         ! Push struct size
 137         c-type heap-size PUSH
 138         ! Push destination address
 139         ECX PUSH
 140         ! Copy the struct from the C stack
 141         "box_value_struct" f %alien-invoke
 142     ] with-aligned-stack ;
 143
 144 M: x86.32 %prepare-box-struct ( -- )
 145     ! Compute target address for value struct return
 146     EAX f struct-return@ LEA
 147     ! Store it as the first parameter
 148     0 stack@ EAX MOV ;
 149
 150 M: x86.32 %box-small-struct ( c-type -- )
 151     #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
 152     12 [
 153         heap-size PUSH
 154         EDX PUSH
 155         EAX PUSH
 156         "box_small_struct" f %alien-invoke
 157     ] with-aligned-stack ;
 158
 159 M: x86.32 %prepare-unbox ( -- )
 160     #! Move top of data stack to EAX.
 161     EAX ESI [] MOV
 162     ESI 4 SUB ;
 163
 164 : (%unbox) ( func -- )
 165     4 [
 166         ! Push parameter
 167         EAX PUSH
 168         ! Call the unboxer
 169         f %alien-invoke
 170     ] with-aligned-stack ;
 171
 172 M: x86.32 %unbox ( n reg-class func -- )
 173     #! The value being unboxed must already be in EAX.
 174     #! If n is f, we're unboxing a return value about to be
 175     #! returned by the callback. Otherwise, we're unboxing
 176     #! a parameter to a C function about to be called.
 177     (%unbox)
 178     ! Store the return value on the C stack
 179     over [ store-return-reg ] [ 2drop ] if ;
 180
 181 M: x86.32 %unbox-long-long ( n func -- )
 182     (%unbox)
 183     ! Store the return value on the C stack
 184     [
 185         dup stack@ EAX MOV
 186         cell + stack@ EDX MOV
 187     ] when* ;
 188
 189 : %unbox-struct-1 ( -- )
 190     #! Alien must be in EAX.
 191     4 [
 192         EAX PUSH
 193         "alien_offset" f %alien-invoke
 194         ! Load first cell
 195         EAX EAX [] MOV
 196     ] with-aligned-stack ;
 197
 198 : %unbox-struct-2 ( -- )
 199     #! Alien must be in EAX.
 200     4 [
 201         EAX PUSH
 202         "alien_offset" f %alien-invoke
 203         ! Load second cell
 204         EDX EAX 4 [+] MOV
 205         ! Load first cell
 206         EAX EAX [] MOV
 207     ] with-aligned-stack ;
 208
 209 M: x86 %unbox-small-struct ( size -- )
 210     #! Alien must be in EAX.
 211     heap-size cell align cell /i {
 212         { 1 [ %unbox-struct-1 ] }
 213         { 2 [ %unbox-struct-2 ] }
 214     } case ;
 215
 216 M: x86.32 %unbox-large-struct ( n c-type -- )
 217     ! Alien must be in EAX.
 218     ! Compute destination address
 219     ECX rot stack@ LEA
 220     12 [
 221         ! Push struct size
 222         heap-size PUSH
 223         ! Push destination address
 224         ECX PUSH
 225         ! Push source address
 226         EAX PUSH
 227         ! Copy the struct to the stack
 228         "to_value_struct" f %alien-invoke
 229     ] with-aligned-stack ;
 230
 231 M: x86.32 %prepare-alien-indirect ( -- )
 232     "unbox_alien" f %alien-invoke
 233     EBP EAX MOV ;
 234
 235 M: x86.32 %alien-indirect ( -- )
 236     EBP CALL ;
 237
 238 M: x86.32 %alien-callback ( quot -- )
 239     4 [
 240         EAX swap %load-indirect
 241         EAX PUSH
 242         "c_to_factor" f %alien-invoke
 243     ] with-aligned-stack ;
 244
 245 M: x86.32 %callback-value ( ctype -- )
 246     ! Align C stack
 247     ESP 12 SUB
 248     ! Save top of data stack in non-volatile register
 249     %prepare-unbox
 250     EAX PUSH
 251     ! Restore data/call/retain stacks
 252     "unnest_stacks" f %alien-invoke
 253     ! Place top of data stack in EAX
 254     EAX POP
 255     ! Restore C stack
 256     ESP 12 ADD
 257     ! Unbox EAX
 258     unbox-return ;
 259
 260 M: x86.32 %cleanup ( params -- )
 261     #! a) If we just called an stdcall function in Windows, it
 262     #! cleaned up the stack frame for us. But we don't want that
 263     #! so we 'undo' the cleanup since we do that in %epilogue.
 264     #! b) If we just called a function returning a struct, we
 265     #! have to fix ESP.
 266     {
 267         {
 268             [ dup abi>> "stdcall" = ]
 269             [ drop ESP stack-frame get params>> SUB ]
 270         } {
 271             [ dup return>> large-struct? ]
 272             [ drop EAX PUSH ]
 273         }
 274         [ drop ]
 275     } cond ;
 276
 277 M: x86.32 %callback-return ( n -- )
 278     #! a) If the callback is stdcall, we have to clean up the
 279     #! caller's stack frame.
 280     #! b) If the callback is returning a large struct, we have
 281     #! to fix ESP.
 282     {
 283         { [ dup abi>> "stdcall" = ] [
 284             <alien-stack-frame>
 285             [ params>> ] [ return>> ] bi +
 286         ] }
 287         { [ dup return>> large-struct? ] [ drop 4 ] }
 288         [ drop 0 ]
 289     } cond RET ;
 290
 291 M: x86.32 dummy-stack-params? f ;
 292
 293 M: x86.32 dummy-int-params? f ;
 294
 295 M: x86.32 dummy-fp-params? f ;
 296
 297 os windows? [
 298     cell "longlong" c-type (>>align)
 299     cell "ulonglong" c-type (>>align)
 300     4 "double" c-type (>>align)
 301 ] unless
 302
 303 FUNCTION: bool check_sse2 ( ) ;
 304
 305 : sse2? ( -- ? )
 306     check_sse2 ;
 307
 308 "-no-sse2" (command-line) member? [
 309     [ optimized-recompile-hook ] recompile-hook
 310     [ { check_sse2 } compile ] with-variable
 311
 312     "Checking if your CPU supports SSE2..." print flush
 313     sse2? [
 314         " - yes" print
 315         enable-float-intrinsics
 316         [
 317             sse2? [
 318                 "This image was built to use SSE2, which your CPU does not support." print
 319                 "You will need to bootstrap Factor again." print
 320                 flush
 321                 1 exit
 322             ] unless
 323         ] "cpu.x86" add-init-hook
 324     ] [ " - no" print ] if
 325 ] unless