basis/cpu/x86/32/32.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: locals alien alien.c-types alien.libraries alien.syntax
   4 arrays kernel fry math namespaces sequences system layouts io
   5 vocabs.loader accessors init classes.struct combinators make
   6 words compiler.constants compiler.codegen.fixup
   7 compiler.cfg.instructions compiler.cfg.builder
   8 compiler.cfg.builder.alien.boxing compiler.cfg.intrinsics
   9 compiler.cfg.stack-frame cpu.x86.assembler
  10 cpu.x86.assembler.operands cpu.x86 cpu.architecture vm vocabs ;
  11 FROM: layouts => cell ;
  12 IN: cpu.x86.32
  13
  14 : x86-float-regs ( -- seq )
  15     "cpu.x86.sse" vocab
  16     { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 }
  17     { ST0 ST1 ST2 ST3 ST4 ST5 ST6 }
  18     ? ;
  19
  20 M: x86.32 machine-registers
  21     { int-regs { EAX ECX EDX EBP EBX } }
  22     float-regs x86-float-regs 2array
  23     2array ;
  24
  25 M: x86.32 ds-reg ESI ;
  26 M: x86.32 rs-reg EDI ;
  27 M: x86.32 stack-reg ESP ;
  28 M: x86.32 frame-reg EBP ;
  29
  30 M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
  31
  32 M:: x86.32 %load-vector ( dst val rep -- )
  33     dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
  34
  35 M: x86.32 %mov-vm-ptr ( reg -- )
  36     0 MOV 0 rc-absolute-cell rel-vm ;
  37
  38 M: x86.32 %vm-field ( dst field -- )
  39     [ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
  40
  41 M: x86.32 %set-vm-field ( dst field -- )
  42     [ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
  43
  44 M: x86.32 %vm-field-ptr ( dst field -- )
  45     [ 0 MOV ] dip rc-absolute-cell rel-vm ;
  46
  47 M: x86.32 %mark-card
  48     drop HEX: ffffffff [+] card-mark <byte> MOV
  49     building get pop
  50     rc-absolute-cell rel-cards-offset
  51     building get push ;
  52
  53 M: x86.32 %mark-deck
  54     drop HEX: ffffffff [+] card-mark <byte> MOV
  55     building get pop
  56     rc-absolute-cell rel-decks-offset
  57     building get push ;
  58
  59 M:: x86.32 %dispatch ( src temp -- )
  60     ! Load jump table base.
  61     temp src HEX: ffffffff [+] LEA
  62     building get length :> start
  63     0 rc-absolute-cell rel-here
  64     ! Go
  65     temp HEX: 7f [+] JMP
  66     building get length :> end
  67     ! Fix up the displacement above
  68     cell alignment
  69     [ end start - + building get dup pop* push ]
  70     [ (align-code) ]
  71     bi ;
  72
  73 M: x86.32 pic-tail-reg EDX ;
  74
  75 M: x86.32 reserved-stack-space 0 ;
  76
  77 M: x86.32 vm-stack-space 16 ;
  78
  79 : save-vm-ptr ( n -- )
  80     stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
  81
  82 M: x86.32 return-struct-in-registers? ( c-type -- ? )
  83     c-type
  84     [ return-in-registers?>> ]
  85     [ heap-size { 1 2 4 8 } member? ] bi
  86     os { linux netbsd solaris } member? not
  87     and or ;
  88
  89 ! On x86, parameters are usually never passed in registers,
  90 ! except with Microsoft's "thiscall" and "fastcall" abis
  91 M: x86.32 param-regs
  92     {
  93         { thiscall [ { { int-regs { ECX } } { float-regs { } } } ] }
  94         { fastcall [ { { int-regs { ECX EDX } } { float-regs { } } } ] }
  95         [ drop { { int-regs { } } { float-regs { } } } ]
  96     } case ;
  97
  98 ! Need a fake return-reg for floats
  99 M: x86.32 return-regs
 100     {
 101         { int-regs { EAX EDX } }
 102         { float-regs { ST0 } }
 103     } ;
 104
 105 M: x86.32 %prologue ( n -- )
 106     dup PUSH
 107     0 PUSH rc-absolute-cell rel-this
 108     3 cells - decr-stack-reg ;
 109
 110 M: x86.32 %prepare-jump
 111     pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
 112
 113 :: load-float-return ( dst x87-insn rep -- )
 114     dst register? [
 115         ESP 4 SUB
 116         ESP [] x87-insn execute
 117         dst ESP [] rep %copy
 118         ESP 4 ADD
 119     ] [
 120         dst ?spill-slot x87-insn execute
 121     ] if ; inline
 122
 123 M: x86.32 %load-reg-param ( dst reg rep -- )
 124     {
 125         { int-rep [ int-rep %copy ] }
 126         { float-rep [ drop \ FSTPS float-rep load-float-return ] }
 127         { double-rep [ drop \ FSTPL double-rep load-float-return ] }
 128     } case ;
 129
 130 :: store-float-return ( src x87-insn rep -- )
 131     src register? [
 132         ESP 4 SUB
 133         ESP [] src rep %copy
 134         ESP [] x87-insn execute
 135         ESP 4 ADD
 136     ] [
 137         src ?spill-slot x87-insn execute
 138     ] if ; inline
 139
 140 M: x86.32 %store-reg-param ( src reg rep -- )
 141     {
 142         { int-rep [ swap int-rep %copy ] }
 143         { float-rep [ drop \ FLDS float-rep store-float-return ] }
 144         { double-rep [ drop \ FLDL double-rep store-float-return ] }
 145     } case ;
 146
 147 :: call-unbox-func ( src func -- )
 148     EAX src tagged-rep %copy
 149     4 save-vm-ptr
 150     0 stack@ EAX MOV
 151     func f %alien-invoke ;
 152
 153 M:: x86.32 %unbox ( dst src func rep -- )
 154     src func call-unbox-func
 155     dst rep %load-return ;
 156
 157 M:: x86.32 %unbox-long-long ( src out func -- )
 158     EAX src int-rep %copy
 159     0 stack@ EAX MOV
 160     EAX out int-rep %copy
 161     4 stack@ EAX MOV
 162     8 save-vm-ptr
 163     func f %alien-invoke ;
 164
 165 M:: x86.32 %box ( dst src func rep -- )
 166     rep rep-size save-vm-ptr
 167     src rep %store-return
 168     0 stack@ rep %load-return
 169     func f %alien-invoke
 170     dst EAX tagged-rep %copy ;
 171
 172 M:: x86.32 %box-long-long ( dst src1 src2 func -- )
 173     8 save-vm-ptr
 174     EAX src1 int-rep %copy
 175     0 stack@ EAX int-rep %copy
 176     EAX src2 int-rep %copy
 177     4 stack@ EAX int-rep %copy
 178     func f %alien-invoke
 179     dst EAX tagged-rep %copy ;
 180
 181 M:: x86.32 %allot-byte-array ( dst size -- )
 182     4 save-vm-ptr
 183     0 stack@ size MOV
 184     "allot_byte_array" f %alien-invoke
 185     dst EAX tagged-rep %copy ;
 186
 187 M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
 188
 189 M: x86.32 %begin-callback ( -- )
 190     0 save-vm-ptr
 191     4 stack@ 0 MOV
 192     "begin_callback" f %alien-invoke ;
 193
 194 M: x86.32 %alien-callback ( quot -- )
 195     [ EAX ] dip %load-reference
 196     EAX quot-entry-point-offset [+] CALL ;
 197
 198 M: x86.32 %end-callback ( -- )
 199     0 save-vm-ptr
 200     "end_callback" f %alien-invoke ;
 201
 202 GENERIC: float-function-param ( n dst src -- )
 203
 204 M:: spill-slot float-function-param ( n dst src -- )
 205     ! We can clobber dst here since its going to contain the
 206     ! final result
 207     dst src double-rep %copy
 208     dst n double-rep %store-stack-param ;
 209
 210 M:: register float-function-param ( n dst src -- )
 211     src n double-rep %store-stack-param ;
 212
 213 M:: x86.32 %unary-float-function ( dst src func -- )
 214     0 dst src float-function-param
 215     func "libm" load-library %alien-invoke
 216     dst double-rep %load-return ;
 217
 218 M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
 219     0 dst src1 float-function-param
 220     8 dst src2 float-function-param
 221     func "libm" load-library %alien-invoke
 222     dst double-rep %load-return ;
 223
 224 : funny-large-struct-return? ( return abi -- ? )
 225     #! MINGW ABI incompatibility disaster
 226     [ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
 227
 228 M:: x86.32 stack-cleanup ( stack-size return abi -- n )
 229     #! a) Functions which are stdcall/fastcall/thiscall have to
 230     #! clean up the caller's stack frame.
 231     #! b) Functions returning large structs on MINGW have to
 232     #! fix ESP.
 233     {
 234         { [ abi callee-cleanup? ] [ stack-size ] }
 235         { [ return abi funny-large-struct-return? ] [ 4 ] }
 236         [ 0 ]
 237     } cond ;
 238
 239 M: x86.32 %cleanup ( n -- )
 240     [ ESP swap SUB ] unless-zero ;
 241
 242 M:: x86.32 %call-gc ( gc-roots -- )
 243     4 save-vm-ptr
 244     0 stack@ gc-roots gc-root-offsets %load-reference
 245     "inline_gc" f %alien-invoke ;
 246
 247 M: x86.32 dummy-stack-params? f ;
 248
 249 M: x86.32 dummy-int-params? f ;
 250
 251 M: x86.32 dummy-fp-params? f ;
 252
 253 M: x86.32 long-long-on-stack? t ;
 254
 255 M: x86.32 float-on-stack? t ;
 256
 257 M: x86.32 flatten-struct-type
 258     call-next-method [ first t 2array ] map ;
 259
 260 M: x86.32 struct-return-on-stack? os linux? not ;
 261
 262 check-sse