basis/cpu/x86/64/64.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays kernel math namespaces make sequences
   4 system layouts alien alien.c-types alien.accessors alien.libraries
   5 slots splitting assocs combinators locals compiler.constants
   6 compiler.codegen compiler.codegen.fixup
   7 compiler.cfg.instructions compiler.cfg.builder
   8 compiler.cfg.intrinsics compiler.cfg.stack-frame
   9 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
  10 cpu.architecture vm ;
  11 FROM: layouts => cell cells ;
  12 IN: cpu.x86.64
  13
  14 : param-reg-0 ( -- reg ) 0 int-regs cdecl param-reg ; inline
  15 : param-reg-1 ( -- reg ) 1 int-regs cdecl param-reg ; inline
  16 : param-reg-2 ( -- reg ) 2 int-regs cdecl param-reg ; inline
  17 : param-reg-3 ( -- reg ) 3 int-regs cdecl param-reg ; inline
  18
  19 M: x86.64 pic-tail-reg RBX ;
  20
  21 M: int-regs return-reg drop RAX ;
  22 M: float-regs return-reg drop XMM0 ;
  23
  24 M: x86.64 ds-reg R14 ;
  25 M: x86.64 rs-reg R15 ;
  26 M: x86.64 stack-reg RSP ;
  27 M: x86.64 frame-reg RBP ;
  28
  29 M: x86.64 extra-stack-space drop 0 ;
  30
  31 M: x86.64 machine-registers
  32     {
  33         { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 } }
  34         { float-regs {
  35             XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
  36             XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
  37         } }
  38     } ;
  39
  40 : vm-reg ( -- reg ) R13 ; inline
  41 : nv-reg ( -- reg ) RBX ; inline
  42
  43 M: x86.64 %mov-vm-ptr ( reg -- )
  44     vm-reg MOV ;
  45
  46 M: x86.64 %vm-field ( dst offset -- )
  47     [ vm-reg ] dip [+] MOV ;
  48
  49 M: x86.64 %set-vm-field ( src offset -- )
  50     [ vm-reg ] dip [+] swap MOV ;
  51
  52 M: x86.64 %vm-field-ptr ( dst offset -- )
  53     [ vm-reg ] dip [+] LEA ;
  54
  55 M: x86.64 %prologue ( n -- )
  56     temp-reg -7 [RIP+] LEA
  57     dup PUSH
  58     temp-reg PUSH
  59     stack-reg swap 3 cells - SUB ;
  60
  61 M: x86.64 %prepare-jump
  62     pic-tail-reg xt-tail-pic-offset [RIP+] LEA ;
  63
  64 : load-cards-offset ( dst -- )
  65     0 MOV rc-absolute-cell rel-cards-offset ;
  66
  67 M: x86.64 %mark-card
  68     dup load-cards-offset
  69     [+] card-mark <byte> MOV ;
  70
  71 : load-decks-offset ( dst -- )
  72     0 MOV rc-absolute-cell rel-decks-offset ;
  73
  74 M: x86.64 %mark-deck
  75     dup load-decks-offset
  76     [+] card-mark <byte> MOV ;
  77
  78 M:: x86.64 %dispatch ( src temp -- )
  79     ! Load jump table base.
  80     temp HEX: ffffffff MOV
  81     building get length :> start
  82     0 rc-absolute-cell rel-here
  83     ! Add jump table base
  84     temp src ADD
  85     temp HEX: 7f [+] JMP
  86     building get length :> end
  87     ! Fix up the displacement above
  88     cell code-alignment
  89     [ end start - + building get dup pop* push ]
  90     [ align-code ]
  91     bi ;
  92
  93 M: stack-params copy-register*
  94     drop
  95     {
  96         { [ dup  integer? ] [ R11 swap next-stack@ MOV  R11 MOV ] }
  97         { [ over integer? ] [ R11 swap MOV              param@ R11 MOV ] }
  98     } cond ;
  99
 100 M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
 101
 102 M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
 103
 104 : with-return-regs ( quot -- )
 105     [
 106         V{ RDX RAX } clone int-regs set
 107         V{ XMM1 XMM0 } clone float-regs set
 108         call
 109     ] with-scope ; inline
 110
 111 M: x86.64 %pop-stack ( n -- )
 112     param-reg-0 swap ds-reg reg-stack MOV ;
 113
 114 M: x86.64 %pop-context-stack ( -- )
 115     temp-reg %context
 116     param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
 117     param-reg-0 param-reg-0 [] MOV
 118     temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
 119
 120 M:: x86.64 %unbox ( n rep func -- )
 121     param-reg-1 %mov-vm-ptr
 122     ! Call the unboxer
 123     func f %alien-invoke
 124     ! Store the return value on the C stack if this is an
 125     ! alien-invoke, otherwise leave it the return register if
 126     ! this is the end of alien-callback
 127     n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
 128
 129 : %unbox-struct-field ( c-type i -- )
 130     ! Alien must be in param-reg-0.
 131     R11 swap cells [+] swap rep>> reg-class-of {
 132         { int-regs [ int-regs get pop swap MOV ] }
 133         { float-regs [ float-regs get pop swap MOVSD ] }
 134     } case ;
 135
 136 M: x86.64 %unbox-small-struct ( c-type -- )
 137     ! Alien must be in param-reg-0.
 138     param-reg-1 %mov-vm-ptr
 139     "alien_offset" f %alien-invoke
 140     ! Move alien_offset() return value to R11 so that we don't
 141     ! clobber it.
 142     R11 RAX MOV
 143     [
 144         flatten-value-type [ %unbox-struct-field ] each-index
 145     ] with-return-regs ;
 146
 147 M:: x86.64 %unbox-large-struct ( n c-type -- )
 148     ! Source is in param-reg-0
 149     ! Load destination address into param-reg-1
 150     param-reg-1 n param@ LEA
 151     ! Load structure size into param-reg-2
 152     param-reg-2 c-type heap-size MOV
 153     param-reg-3 %mov-vm-ptr
 154     ! Copy the struct to the C stack
 155     "to_value_struct" f %alien-invoke ;
 156
 157 : load-return-value ( rep -- )
 158     [ [ 0 ] dip reg-class-of cdecl param-reg ]
 159     [ reg-class-of return-reg ]
 160     [ ]
 161     tri %copy ;
 162
 163 M:: x86.64 %box ( n rep func -- )
 164     n [
 165         n
 166         0 rep reg-class-of cdecl param-reg
 167         rep %load-param-reg
 168     ] [
 169         rep load-return-value
 170     ] if
 171     rep int-rep?
 172     cpu x86.64? os windows? and or
 173     param-reg-1 param-reg-0 ? %mov-vm-ptr
 174     func f %alien-invoke ;
 175
 176 : box-struct-field@ ( i -- operand ) 1 + cells param@ ;
 177
 178 : %box-struct-field ( c-type i -- )
 179     box-struct-field@ swap c-type-rep reg-class-of {
 180         { int-regs [ int-regs get pop MOV ] }
 181         { float-regs [ float-regs get pop MOVSD ] }
 182     } case ;
 183
 184 M: x86.64 %box-small-struct ( c-type -- )
 185     #! Box a <= 16-byte struct.
 186     [
 187         [ flatten-value-type [ %box-struct-field ] each-index ]
 188         [ param-reg-2 swap heap-size MOV ] bi
 189         param-reg-0 0 box-struct-field@ MOV
 190         param-reg-1 1 box-struct-field@ MOV
 191         param-reg-3 %mov-vm-ptr
 192         "from_small_struct" f %alien-invoke
 193     ] with-return-regs ;
 194
 195 : struct-return@ ( n -- operand )
 196     [ stack-frame get params>> ] unless* param@ ;
 197
 198 M: x86.64 %box-large-struct ( n c-type -- )
 199     ! Struct size is parameter 2
 200     param-reg-1 swap heap-size MOV
 201     ! Compute destination address
 202     param-reg-0 swap struct-return@ LEA
 203     param-reg-2 %mov-vm-ptr
 204     ! Copy the struct from the C stack
 205     "from_value_struct" f %alien-invoke ;
 206
 207 M: x86.64 %prepare-box-struct ( -- )
 208     ! Compute target address for value struct return
 209     RAX f struct-return@ LEA
 210     ! Store it as the first parameter
 211     0 param@ RAX MOV ;
 212
 213 M: x86.64 %prepare-var-args RAX RAX XOR ;
 214
 215 M: x86.64 %alien-invoke
 216     R11 0 MOV
 217     rc-absolute-cell rel-dlsym
 218     R11 CALL ;
 219
 220 M: x86.64 %prepare-alien-indirect ( -- )
 221     param-reg-0 ds-reg [] MOV
 222     ds-reg 8 SUB
 223     param-reg-1 %mov-vm-ptr
 224     "pinned_alien_offset" f %alien-invoke
 225     nv-reg RAX MOV ;
 226
 227 M: x86.64 %alien-indirect ( -- )
 228     nv-reg CALL ;
 229
 230 M: x86.64 %begin-callback ( -- )
 231     param-reg-0 %mov-vm-ptr
 232     param-reg-1 0 MOV
 233     "begin_callback" f %alien-invoke ;
 234
 235 M: x86.64 %alien-callback ( quot -- )
 236     param-reg-0 param-reg-1 %restore-context
 237     param-reg-0 swap %load-reference
 238     param-reg-0 quot-entry-point-offset [+] CALL
 239     param-reg-0 param-reg-1 %save-context ;
 240
 241 M: x86.64 %end-callback ( -- )
 242     param-reg-0 %mov-vm-ptr
 243     "end_callback" f %alien-invoke ;
 244
 245 M: x86.64 %end-callback-value ( ctype -- )
 246     %pop-context-stack
 247     nv-reg param-reg-0 MOV
 248     %end-callback
 249     param-reg-0 nv-reg MOV
 250     ! Unbox former top of data stack to return registers
 251     unbox-return ;
 252
 253 : float-function-param ( i src -- )
 254     [ float-regs cdecl param-regs nth ] dip double-rep %copy ;
 255
 256 : float-function-return ( reg -- )
 257     float-regs return-reg double-rep %copy ;
 258
 259 M:: x86.64 %unary-float-function ( dst src func -- )
 260     0 src float-function-param
 261     func "libm" load-library %alien-invoke
 262     dst float-function-return ;
 263
 264 M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
 265     ! src1 might equal dst; otherwise it will be a spill slot
 266     ! src2 is always a spill slot
 267     0 src1 float-function-param
 268     1 src2 float-function-param
 269     func "libm" load-library %alien-invoke
 270     dst float-function-return ;
 271
 272 M:: x86.64 %call-gc ( gc-root-count temp -- )
 273     ! Pass pointer to start of GC roots as first parameter
 274     param-reg-0 gc-root-base param@ LEA
 275     ! Pass number of roots as second parameter
 276     param-reg-1 gc-root-count MOV
 277     ! Pass VM ptr as third parameter
 278     param-reg-2 %mov-vm-ptr
 279     ! Call GC
 280     "inline_gc" f %alien-invoke ;
 281
 282 M: x86.64 struct-return-pointer-type void* ;
 283
 284 ! The result of reading 4 bytes from memory is a fixnum on
 285 ! x86-64.
 286 enable-alien-4-intrinsics
 287
 288 USE: vocabs.loader
 289
 290 {
 291     { [ os unix? ] [ "cpu.x86.64.unix" require ] }
 292     { [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
 293 } cond
 294
 295 check-sse