basis/cpu/x86/32/32.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: locals alien.c-types alien.libraries alien.syntax arrays
   4 kernel fry math namespaces sequences system layouts io
   5 vocabs.loader accessors init combinators command-line make
   6 compiler compiler.units compiler.constants compiler.alien
   7 compiler.codegen compiler.codegen.fixup
   8 compiler.cfg.instructions compiler.cfg.builder
   9 compiler.cfg.intrinsics compiler.cfg.stack-frame
  10 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
  11 cpu.architecture ;
  12 IN: cpu.x86.32
  13
  14 ! We implement the FFI for Linux, OS X and Windows all at once.
  15 ! OS X requires that the stack be 16-byte aligned.
  16
  17 M: x86.32 machine-registers
  18     {
  19         { int-regs { EAX ECX EDX EBP EBX } }
  20         { 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 ECX ;
  27
  28 M:: x86.32 %dispatch ( src temp -- )
  29     ! Load jump table base.
  30     temp src HEX: ffffffff [+] LEA
  31     building get length cell - :> start
  32     0 rc-absolute-cell rel-here
  33     ! Go
  34     temp HEX: 7f [+] JMP
  35     building get length :> end
  36     ! Fix up the displacement above
  37     cell code-alignment
  38     [ end start - + building get dup pop* push ]
  39     [ align-code ]
  40     bi ;
  41
  42 ! Registers for fastcall
  43 : param-reg-1 ( -- reg ) EAX ;
  44 : param-reg-2 ( -- reg ) EDX ;
  45
  46 M: x86.32 pic-tail-reg EBX ;
  47
  48 M: x86.32 reserved-area-size 0 ;
  49
  50 M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
  51
  52 : push-vm-ptr ( -- )
  53     0 PUSH rc-absolute-cell rt-vm rel-fixup ; ! push the vm ptr as an argument
  54
  55 M: x86.32 return-struct-in-registers? ( c-type -- ? )
  56     c-type
  57     [ return-in-registers?>> ]
  58     [ heap-size { 1 2 4 8 } member? ] bi
  59     os { linux netbsd solaris } member? not
  60     and or ;
  61
  62 : struct-return@ ( n -- operand )
  63     [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
  64
  65 ! On x86, parameters are never passed in registers.
  66 M: int-regs return-reg drop EAX ;
  67 M: int-regs param-regs drop { } ;
  68 M: float-regs param-regs drop { } ;
  69
  70 GENERIC: push-return-reg ( rep -- )
  71 GENERIC: load-return-reg ( n rep -- )
  72 GENERIC: store-return-reg ( n rep -- )
  73
  74 M: int-rep push-return-reg drop EAX PUSH ;
  75 M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
  76 M: int-rep store-return-reg drop stack@ EAX MOV ;
  77
  78 M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
  79 M: float-rep load-return-reg drop next-stack@ FLDS ;
  80 M: float-rep store-return-reg drop stack@ FSTPS ;
  81
  82 M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
  83 M: double-rep load-return-reg drop next-stack@ FLDL ;
  84 M: double-rep store-return-reg drop stack@ FSTPL ;
  85
  86 : align-sub ( n -- )
  87     [ align-stack ] keep - decr-stack-reg ;
  88
  89 : align-add ( n -- )
  90     align-stack incr-stack-reg ;
  91
  92 : with-aligned-stack ( n quot -- )
  93     '[ align-sub @ ] [ align-add ] bi ; inline
  94
  95 M: x86.32 %prologue ( n -- )
  96     dup PUSH
  97     0 PUSH rc-absolute-cell rel-this
  98     3 cells - decr-stack-reg ;
  99
 100 M: x86.32 %load-param-reg 3drop ;
 101
 102 M: x86.32 %save-param-reg 3drop ;
 103
 104 : (%box) ( n rep -- )
 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 CONSTANT: vm-ptr-size 4
 112
 113 M:: x86.32 %box ( n rep func -- )
 114     n rep (%box)
 115     rep rep-size vm-ptr-size + [
 116         push-vm-ptr
 117         rep push-return-reg
 118         func f %alien-invoke
 119     ] with-aligned-stack ;
 120
 121 : (%box-long-long) ( n -- )
 122     [
 123         EDX over next-stack@ MOV
 124         EAX swap cell - next-stack@ MOV
 125     ] when* ;
 126
 127 M: x86.32 %box-long-long ( n func -- )
 128     [ (%box-long-long) ] dip
 129     8 vm-ptr-size + [
 130         push-vm-ptr
 131         EDX PUSH
 132         EAX PUSH
 133         f %alien-invoke
 134     ] with-aligned-stack ;
 135
 136 M:: x86.32 %box-large-struct ( n c-type -- )
 137     ! Compute destination address
 138     EDX n struct-return@ LEA
 139     8 vm-ptr-size + [
 140         push-vm-ptr
 141         ! Push struct size
 142         c-type heap-size PUSH
 143         ! Push destination address
 144         EDX PUSH
 145         ! Copy the struct from the C stack
 146         "box_value_struct" f %alien-invoke
 147     ] with-aligned-stack ;
 148
 149 M: x86.32 %prepare-box-struct ( -- )
 150     ! Compute target address for value struct return
 151     EAX f struct-return@ LEA
 152     ! Store it as the first parameter
 153     0 stack@ EAX MOV ;
 154
 155 M: x86.32 %box-small-struct ( c-type -- )
 156     #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
 157     12 vm-ptr-size + [
 158         push-vm-ptr
 159         heap-size PUSH
 160         EDX PUSH
 161         EAX PUSH
 162         "box_small_struct" f %alien-invoke
 163     ] with-aligned-stack ;
 164
 165 M: x86.32 %prepare-unbox ( -- )
 166     #! Move top of data stack to EAX.
 167     EAX ESI [] MOV
 168     ESI 4 SUB ;
 169
 170 : call-unbox-func ( func -- )
 171     8 [
 172         ! push the vm ptr as an argument
 173         push-vm-ptr
 174         ! Push parameter
 175         EAX PUSH
 176         ! Call the unboxer
 177         f %alien-invoke
 178     ] with-aligned-stack ;
 179
 180 M: x86.32 %unbox ( n rep func -- )
 181     #! The value being unboxed must already be in EAX.
 182     #! If n is f, we're unboxing a return value about to be
 183     #! returned by the callback. Otherwise, we're unboxing
 184     #! a parameter to a C function about to be called.
 185     call-unbox-func
 186     ! Store the return value on the C stack
 187     over [ store-return-reg ] [ 2drop ] if ;
 188
 189 M: x86.32 %unbox-long-long ( n func -- )
 190     call-unbox-func
 191     ! Store the return value on the C stack
 192     [
 193         dup stack@ EAX MOV
 194         cell + stack@ EDX MOV
 195     ] when* ;
 196
 197 : %unbox-struct-1 ( -- )
 198     #! Alien must be in EAX.
 199     4 vm-ptr-size + [
 200         push-vm-ptr
 201         EAX PUSH
 202         "alien_offset" f %alien-invoke
 203         ! Load first cell
 204         EAX EAX [] MOV
 205     ] with-aligned-stack ;
 206
 207 : %unbox-struct-2 ( -- )
 208     #! Alien must be in EAX.
 209     4 vm-ptr-size + [
 210         push-vm-ptr
 211         EAX PUSH
 212         "alien_offset" f %alien-invoke
 213         ! Load second cell
 214         EDX EAX 4 [+] MOV
 215         ! Load first cell
 216         EAX EAX [] MOV
 217     ] with-aligned-stack ;
 218
 219 M: x86 %unbox-small-struct ( size -- )
 220     #! Alien must be in EAX.
 221     heap-size cell align cell /i {
 222         { 1 [ %unbox-struct-1 ] }
 223         { 2 [ %unbox-struct-2 ] }
 224     } case ;
 225
 226 M:: x86.32 %unbox-large-struct ( n c-type -- )
 227     ! Alien must be in EAX.
 228     ! Compute destination address
 229     EDX n stack@ LEA
 230     12 vm-ptr-size + [
 231         push-vm-ptr
 232         ! Push struct size
 233         c-type heap-size PUSH
 234         ! Push destination address
 235         EDX PUSH
 236         ! Push source address
 237         EAX PUSH
 238         ! Copy the struct to the stack
 239         "to_value_struct" f %alien-invoke
 240     ] with-aligned-stack ;
 241
 242 M: x86.32 %nest-stacks ( -- )
 243     4 [
 244         push-vm-ptr
 245         "nest_stacks" f %alien-invoke
 246     ] with-aligned-stack ;
 247
 248 M: x86.32 %unnest-stacks ( -- )
 249     4 [
 250         push-vm-ptr
 251         "unnest_stacks" f %alien-invoke
 252     ] with-aligned-stack ;
 253
 254 M: x86.32 %prepare-alien-indirect ( -- )
 255     push-vm-ptr "unbox_alien" f %alien-invoke
 256     temp-reg POP
 257     EBP EAX MOV ;
 258
 259 M: x86.32 %alien-indirect ( -- )
 260     EBP CALL ;
 261
 262 M: x86.32 %alien-callback ( quot -- )
 263     4 [
 264         EAX swap %load-reference
 265         EAX PUSH
 266         param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
 267         "c_to_factor" f %alien-invoke
 268     ] with-aligned-stack ;
 269
 270 M: x86.32 %callback-value ( ctype -- )
 271     ! Align C stack
 272     ESP 12 SUB
 273     ! Save top of data stack in non-volatile register
 274     %prepare-unbox
 275     EAX PUSH
 276     push-vm-ptr
 277     ! Restore data/call/retain stacks
 278     "unnest_stacks" f %alien-invoke
 279     ! Place top of data stack in EAX
 280     temp-reg POP
 281     EAX POP
 282     ! Restore C stack
 283     ESP 12 ADD
 284     ! Unbox EAX
 285     unbox-return ;
 286
 287 GENERIC: float-function-param ( stack-slot dst src -- )
 288
 289 M:: spill-slot float-function-param ( stack-slot dst src -- )
 290     ! We can clobber dst here since its going to contain the
 291     ! final result
 292     dst src double-rep %copy
 293     stack-slot dst double-rep %copy ;
 294
 295 M: register float-function-param
 296     nip double-rep %copy ;
 297
 298 : float-function-return ( reg -- )
 299     ESP [] FSTPL
 300     ESP [] MOVSD
 301     ESP 16 ADD ;
 302
 303 M:: x86.32 %unary-float-function ( dst src func -- )
 304     ESP -16 [+] dst src float-function-param
 305     ESP 16 SUB
 306     func "libm" load-library %alien-invoke
 307     dst float-function-return ;
 308
 309 M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
 310     ESP -16 [+] dst src1 float-function-param
 311     ESP  -8 [+] dst src2 float-function-param
 312     ESP 16 SUB
 313     func "libm" load-library %alien-invoke
 314     dst float-function-return ;
 315
 316 M: x86.32 %cleanup ( params -- )
 317     #! a) If we just called an stdcall function in Windows, it
 318     #! cleaned up the stack frame for us. But we don't want that
 319     #! so we 'undo' the cleanup since we do that in %epilogue.
 320     #! b) If we just called a function returning a struct, we
 321     #! have to fix ESP.
 322     {
 323         {
 324             [ dup abi>> "stdcall" = ]
 325             [ drop ESP stack-frame get params>> SUB ]
 326         } {
 327             [ dup return>> large-struct? ]
 328             [ drop EAX PUSH ]
 329         }
 330         [ drop ]
 331     } cond ;
 332
 333 M: x86.32 %callback-return ( n -- )
 334     #! a) If the callback is stdcall, we have to clean up the
 335     #! caller's stack frame.
 336     #! b) If the callback is returning a large struct, we have
 337     #! to fix ESP.
 338     {
 339         { [ dup abi>> "stdcall" = ] [
 340             <alien-stack-frame>
 341             [ params>> ] [ return>> ] bi +
 342         ] }
 343         { [ dup return>> large-struct? ] [ drop 4 ] }
 344         [ drop 0 ]
 345     } cond RET ;
 346
 347 M:: x86.32 %call-gc ( gc-root-count temp -- )
 348     temp gc-root-base param@ LEA
 349     12 [
 350         ! Pass the VM ptr as the third parameter
 351         0 PUSH rc-absolute-cell rt-vm rel-fixup
 352         ! Pass number of roots as second parameter
 353         gc-root-count PUSH
 354         ! Pass pointer to start of GC roots as first parameter
 355         temp PUSH
 356         ! Call GC
 357         "inline_gc" f %alien-invoke
 358     ] with-aligned-stack ;
 359
 360 M: x86.32 dummy-stack-params? f ;
 361
 362 M: x86.32 dummy-int-params? f ;
 363
 364 M: x86.32 dummy-fp-params? f ;
 365
 366 os windows? [
 367     cell "longlong" c-type (>>align)
 368     cell "ulonglong" c-type (>>align)
 369     4 "double" c-type (>>align)
 370 ] unless
 371
 372 check-sse