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 param-reg ; inline
  15 : param-reg-1 ( -- reg ) 1 int-regs param-reg ; inline
  16 : param-reg-2 ( -- reg ) 2 int-regs param-reg ; inline
  17 : param-reg-3 ( -- reg ) 3 int-regs 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 : param@ ( n -- op ) reserved-stack-space + stack@ ;
  56
  57 M: x86.64 %prologue ( n -- )
  58     temp-reg -7 [RIP+] LEA
  59     dup PUSH
  60     temp-reg PUSH
  61     stack-reg swap 3 cells - SUB ;
  62
  63 M: x86.64 %prepare-jump
  64     pic-tail-reg xt-tail-pic-offset [RIP+] LEA ;
  65
  66 : load-cards-offset ( dst -- )
  67     0 MOV rc-absolute-cell rel-cards-offset ;
  68
  69 M: x86.64 %mark-card
  70     dup load-cards-offset
  71     [+] card-mark <byte> MOV ;
  72
  73 : load-decks-offset ( dst -- )
  74     0 MOV rc-absolute-cell rel-decks-offset ;
  75
  76 M: x86.64 %mark-deck
  77     dup load-decks-offset
  78     [+] card-mark <byte> MOV ;
  79
  80 M:: x86.64 %dispatch ( src temp -- )
  81     ! Load jump table base.
  82     temp HEX: ffffffff MOV
  83     building get length :> start
  84     0 rc-absolute-cell rel-here
  85     ! Add jump table base
  86     temp src ADD
  87     temp HEX: 7f [+] JMP
  88     building get length :> end
  89     ! Fix up the displacement above
  90     cell code-alignment
  91     [ end start - + building get dup pop* push ]
  92     [ align-code ]
  93     bi ;
  94
  95 M: stack-params copy-register*
  96     drop
  97     {
  98         { [ dup  integer? ] [ R11 swap next-stack@ MOV  R11 MOV ] }
  99         { [ over integer? ] [ R11 swap MOV              param@ R11 MOV ] }
 100     } cond ;
 101
 102 M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
 103
 104 M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
 105
 106 : with-return-regs ( quot -- )
 107     [
 108         V{ RDX RAX } clone int-regs set
 109         V{ XMM1 XMM0 } clone float-regs set
 110         call
 111     ] with-scope ; inline
 112
 113 M: x86.64 %pop-stack ( n -- )
 114     param-reg-0 swap ds-reg reg-stack MOV ;
 115
 116 M: x86.64 %pop-context-stack ( -- )
 117     temp-reg %context
 118     param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
 119     param-reg-0 param-reg-0 [] MOV
 120     temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
 121
 122 M:: x86.64 %unbox ( n rep func -- )
 123     param-reg-1 %mov-vm-ptr
 124     ! Call the unboxer
 125     func f %alien-invoke
 126     ! Store the return value on the C stack if this is an
 127     ! alien-invoke, otherwise leave it the return register if
 128     ! this is the end of alien-callback
 129     n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
 130
 131 : %unbox-struct-field ( c-type i -- )
 132     ! Alien must be in param-reg-0.
 133     R11 swap cells [+] swap rep>> reg-class-of {
 134         { int-regs [ int-regs get pop swap MOV ] }
 135         { float-regs [ float-regs get pop swap MOVSD ] }
 136     } case ;
 137
 138 M: x86.64 %unbox-small-struct ( c-type -- )
 139     ! Alien must be in param-reg-0.
 140     param-reg-1 %mov-vm-ptr
 141     "alien_offset" f %alien-invoke
 142     ! Move alien_offset() return value to R11 so that we don't
 143     ! clobber it.
 144     R11 RAX MOV
 145     [
 146         flatten-value-type [ %unbox-struct-field ] each-index
 147     ] with-return-regs ;
 148
 149 M:: x86.64 %unbox-large-struct ( n c-type -- )
 150     ! Source is in param-reg-0
 151     ! Load destination address into param-reg-1
 152     param-reg-1 n param@ LEA
 153     ! Load structure size into param-reg-2
 154     param-reg-2 c-type heap-size MOV
 155     param-reg-3 %mov-vm-ptr
 156     ! Copy the struct to the C stack
 157     "to_value_struct" f %alien-invoke ;
 158
 159 : load-return-value ( rep -- )
 160     [ [ 0 ] dip reg-class-of param-reg ]
 161     [ reg-class-of return-reg ]
 162     [ ]
 163     tri %copy ;
 164
 165 M:: x86.64 %box ( n rep func -- )
 166     n [
 167         n
 168         0 rep reg-class-of param-reg
 169         rep %load-param-reg
 170     ] [
 171         rep load-return-value
 172     ] if
 173     rep int-rep?
 174     cpu x86.64? os windows? and or
 175     param-reg-1 param-reg-0 ? %mov-vm-ptr
 176     func f %alien-invoke ;
 177
 178 : box-struct-field@ ( i -- operand ) 1 + cells param@ ;
 179
 180 : %box-struct-field ( c-type i -- )
 181     box-struct-field@ swap c-type-rep reg-class-of {
 182         { int-regs [ int-regs get pop MOV ] }
 183         { float-regs [ float-regs get pop MOVSD ] }
 184     } case ;
 185
 186 M: x86.64 %box-small-struct ( c-type -- )
 187     #! Box a <= 16-byte struct.
 188     [
 189         [ flatten-value-type [ %box-struct-field ] each-index ]
 190         [ param-reg-2 swap heap-size MOV ] bi
 191         param-reg-0 0 box-struct-field@ MOV
 192         param-reg-1 1 box-struct-field@ MOV
 193         param-reg-3 %mov-vm-ptr
 194         "from_small_struct" f %alien-invoke
 195     ] with-return-regs ;
 196
 197 : struct-return@ ( n -- operand )
 198     [ stack-frame get params>> ] unless* param@ ;
 199
 200 M: x86.64 %box-large-struct ( n c-type -- )
 201     ! Struct size is parameter 2
 202     param-reg-1 swap heap-size MOV
 203     ! Compute destination address
 204     param-reg-0 swap struct-return@ LEA
 205     param-reg-2 %mov-vm-ptr
 206     ! Copy the struct from the C stack
 207     "from_value_struct" f %alien-invoke ;
 208
 209 M: x86.64 %prepare-box-struct ( -- )
 210     ! Compute target address for value struct return
 211     RAX f struct-return@ LEA
 212     ! Store it as the first parameter
 213     0 param@ RAX MOV ;
 214
 215 M: x86.64 %prepare-var-args RAX RAX XOR ;
 216
 217 M: x86.64 %alien-invoke
 218     R11 0 MOV
 219     rc-absolute-cell rel-dlsym
 220     R11 CALL ;
 221
 222 M: x86.64 %prepare-alien-indirect ( -- )
 223     param-reg-0 ds-reg [] MOV
 224     ds-reg 8 SUB
 225     param-reg-1 %mov-vm-ptr
 226     "pinned_alien_offset" f %alien-invoke
 227     nv-reg RAX MOV ;
 228
 229 M: x86.64 %alien-indirect ( -- )
 230     nv-reg CALL ;
 231
 232 M: x86.64 %begin-callback ( -- )
 233     param-reg-0 %mov-vm-ptr
 234     param-reg-1 0 MOV
 235     "begin_callback" f %alien-invoke ;
 236
 237 M: x86.64 %alien-callback ( quot -- )
 238     param-reg-0 param-reg-1 %restore-context
 239     param-reg-0 swap %load-reference
 240     param-reg-0 quot-entry-point-offset [+] CALL
 241     param-reg-0 param-reg-1 %save-context ;
 242
 243 M: x86.64 %end-callback ( -- )
 244     param-reg-0 %mov-vm-ptr
 245     "end_callback" f %alien-invoke ;
 246
 247 M: x86.64 %end-callback-value ( ctype -- )
 248     %pop-context-stack
 249     nv-reg param-reg-0 MOV
 250     %end-callback
 251     param-reg-0 nv-reg MOV
 252     ! Unbox former top of data stack to return registers
 253     unbox-return ;
 254
 255 : float-function-param ( i src -- )
 256     [ float-regs param-regs nth ] dip double-rep %copy ;
 257
 258 : float-function-return ( reg -- )
 259     float-regs return-reg double-rep %copy ;
 260
 261 M:: x86.64 %unary-float-function ( dst src func -- )
 262     0 src float-function-param
 263     func "libm" load-library %alien-invoke
 264     dst float-function-return ;
 265
 266 M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
 267     ! src1 might equal dst; otherwise it will be a spill slot
 268     ! src2 is always a spill slot
 269     0 src1 float-function-param
 270     1 src2 float-function-param
 271     func "libm" load-library %alien-invoke
 272     dst float-function-return ;
 273
 274 M:: x86.64 %call-gc ( gc-root-count temp -- )
 275     ! Pass pointer to start of GC roots as first parameter
 276     param-reg-0 gc-root-base param@ LEA
 277     ! Pass number of roots as second parameter
 278     param-reg-1 gc-root-count MOV
 279     ! Pass VM ptr as third parameter
 280     param-reg-2 %mov-vm-ptr
 281     ! Call GC
 282     "inline_gc" f %alien-invoke ;
 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