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