basis/cpu/x86/64/64.factor

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