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 M:: x86.64 %dispatch ( src temp -- )
  25     building get length :> start
  26     ! Load jump table base.
  27     temp HEX: ffffffff MOV
  28     0 rc-absolute-cell rel-here
  29     ! Add jump table base
  30     temp src ADD
  31     temp HEX: 7f [+] JMP
  32     building get length :> end
  33     ! Fix up the displacement above
  34     cell code-alignment
  35     [ end start - 2 - + building get dup pop* push ]
  36     [ align-code ]
  37     bi ;
  38
  39 M: x86.64 param-reg-1 int-regs param-regs first ;
  40 M: x86.64 param-reg-2 int-regs param-regs second ;
  41 : param-reg-3 ( -- reg ) int-regs param-regs third ; inline
  42
  43 M: x86.64 pic-tail-reg RBX ;
  44
  45 M: int-regs return-reg drop RAX ;
  46 M: float-regs return-reg drop XMM0 ;
  47
  48 M: x86.64 %prologue ( n -- )
  49     temp-reg 0 MOV rc-absolute-cell rel-this
  50     dup PUSH
  51     temp-reg PUSH
  52     stack-reg swap 3 cells - SUB ;
  53
  54 M: stack-params copy-register*
  55     drop
  56     {
  57         { [ dup  integer? ] [ R11 swap next-stack@ MOV  R11 MOV ] }
  58         { [ over integer? ] [ R11 swap MOV              param@ R11 MOV ] }
  59     } cond ;
  60
  61 M: x86 %save-param-reg [ param@ ] 2dip copy-register ;
  62
  63 M: x86 %load-param-reg [ swap param@ ] dip copy-register ;
  64
  65 : with-return-regs ( quot -- )
  66     [
  67         V{ RDX RAX } clone int-regs set
  68         V{ XMM1 XMM0 } clone float-regs set
  69         call
  70     ] with-scope ; inline
  71
  72 M: x86.64 %prepare-unbox ( -- )
  73     ! First parameter is top of stack
  74     param-reg-1 R14 [] MOV
  75     R14 cell SUB ;
  76
  77 M: x86.64 %vm-invoke-1st-arg ( function -- )
  78     param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
  79     f %alien-invoke ;
  80
  81 : %vm-invoke-2nd-arg ( function -- )
  82     param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
  83     f %alien-invoke ;
  84
  85 M: x86.64 %vm-invoke-3rd-arg ( function -- )
  86     param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup
  87     f %alien-invoke ;
  88
  89 : %vm-invoke-4th-arg ( function -- )
  90     int-regs param-regs fourth 0 MOV rc-absolute-cell rt-vm rel-fixup
  91     f %alien-invoke ;
  92
  93
  94 M:: x86.64 %unbox ( n rep func -- )
  95     ! Call the unboxer
  96     func %vm-invoke-2nd-arg
  97     ! Store the return value on the C stack if this is an
  98     ! alien-invoke, otherwise leave it the return register if
  99     ! this is the end of alien-callback
 100     n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
 101
 102 M: x86.64 %unbox-long-long ( n func -- )
 103     [ int-rep ] dip %unbox ;
 104
 105 : %unbox-struct-field ( c-type i -- )
 106     ! Alien must be in param-reg-1.
 107     R11 swap cells [+] swap rep>> reg-class-of {
 108         { int-regs [ int-regs get pop swap MOV ] }
 109         { float-regs [ float-regs get pop swap MOVSD ] }
 110     } case ;
 111
 112
 113 M: x86.64 %unbox-small-struct ( c-type -- )
 114     ! Alien must be in param-reg-1.
 115     "alien_offset" %vm-invoke-2nd-arg
 116     ! Move alien_offset() return value to R11 so that we don't
 117     ! clobber it.
 118     R11 RAX MOV
 119     [
 120         flatten-value-type [ %unbox-struct-field ] each-index
 121     ] with-return-regs ;
 122
 123 M:: x86.64 %unbox-large-struct ( n c-type -- )
 124     ! Source is in param-reg-1
 125     ! Load destination address into param-reg-2
 126     param-reg-2 n param@ LEA
 127     ! Load structure size into param-reg-3
 128     param-reg-3 c-type heap-size MOV
 129     ! Copy the struct to the C stack
 130     "to_value_struct" %vm-invoke-4th-arg ;
 131
 132 : load-return-value ( rep -- )
 133     [ [ 0 ] dip reg-class-of param-reg ]
 134     [ reg-class-of return-reg ]
 135     [ ]
 136     tri copy-register ;
 137
 138
 139
 140 M:: x86.64 %box ( n rep func -- )
 141     n [
 142         n
 143         0 rep reg-class-of param-reg
 144         rep %load-param-reg
 145     ] [
 146         rep load-return-value
 147     ] if
 148     rep int-rep? [ func %vm-invoke-2nd-arg ] [ func %vm-invoke-1st-arg ] if ;
 149
 150 M: x86.64 %box-long-long ( n func -- )
 151     [ int-rep ] dip %box ;
 152
 153 : box-struct-field@ ( i -- operand ) 1 + cells param@ ;
 154
 155 : %box-struct-field ( c-type i -- )
 156     box-struct-field@ swap c-type-rep reg-class-of {
 157         { int-regs [ int-regs get pop MOV ] }
 158         { float-regs [ float-regs get pop MOVSD ] }
 159     } case ;
 160
 161 M: x86.64 %box-small-struct ( c-type -- )
 162     #! Box a <= 16-byte struct.
 163     [
 164         [ flatten-value-type [ %box-struct-field ] each-index ]
 165         [ param-reg-3 swap heap-size MOV ] bi
 166         param-reg-1 0 box-struct-field@ MOV
 167         param-reg-2 1 box-struct-field@ MOV
 168         "box_small_struct" %vm-invoke-4th-arg
 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     ! Copy the struct from the C stack
 180     "box_value_struct" %vm-invoke-3rd-arg ;
 181
 182 M: x86.64 %prepare-box-struct ( -- )
 183     ! Compute target address for value struct return
 184     RAX f struct-return@ LEA
 185     ! Store it as the first parameter
 186     0 param@ RAX MOV ;
 187
 188 M: x86.64 %prepare-var-args RAX RAX XOR ;
 189
 190 M: x86.64 %alien-invoke
 191     R11 0 MOV
 192     rc-absolute-cell rel-dlsym
 193     R11 CALL ;
 194
 195
 196 M: x86.64 %prepare-alien-indirect ( -- )
 197     "unbox_alien" %vm-invoke-1st-arg
 198     RBP RAX MOV ;
 199
 200 M: x86.64 %alien-indirect ( -- )
 201     RBP CALL ;
 202
 203 M: x86.64 %alien-callback ( quot -- )
 204     param-reg-1 swap %load-reference
 205     "c_to_factor" %vm-invoke-2nd-arg ;
 206
 207 M: x86.64 %callback-value ( ctype -- )
 208     ! Save top of data stack
 209     %prepare-unbox
 210     ! Save top of data stack
 211     RSP 8 SUB
 212     param-reg-1 PUSH
 213     ! Restore data/call/retain stacks
 214     "unnest_stacks" %vm-invoke-1st-arg
 215     ! Put former top of data stack in param-reg-1
 216     param-reg-1 POP
 217     RSP 8 ADD
 218     ! Unbox former top of data stack to return registers
 219     unbox-return ;
 220
 221 : float-function-param ( i spill-slot -- )
 222     [ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
 223
 224 : float-function-return ( reg -- )
 225     float-regs return-reg double-rep copy-register ;
 226
 227 M:: x86.64 %unary-float-function ( dst src func -- )
 228     0 src float-function-param
 229     func f %alien-invoke
 230     dst float-function-return ;
 231
 232 M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
 233     0 src1 float-function-param
 234     1 src2 float-function-param
 235     func f %alien-invoke
 236     dst float-function-return ;
 237
 238 ! The result of reading 4 bytes from memory is a fixnum on
 239 ! x86-64.
 240 enable-alien-4-intrinsics
 241
 242 ! Enable fast calling of libc math functions
 243 enable-float-functions
 244
 245 USE: vocabs.loader
 246
 247 {
 248     { [ os unix? ] [ "cpu.x86.64.unix" require ] }
 249     { [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
 250 } cond
 251
 252 "cpu.x86.features" require