basis/cpu/x86/64/64.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types arrays cpu.x86.assembler
   4 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
   5 cpu.x86.allot cpu.architecture kernel kernel.private math
   6 namespaces make sequences compiler.generator
   7 compiler.generator.registers compiler.generator.fixup system
   8 layouts alien alien.accessors alien.structs slots splitting
   9 assocs combinators ;
  10 IN: cpu.x86.64
  11
  12 M: x86.64 ds-reg R14 ;
  13 M: x86.64 rs-reg R15 ;
  14 M: x86.64 stack-reg RSP ;
  15 M: x86.64 stack-save-reg RSI ;
  16 M: x86.64 temp-reg-1 RAX ;
  17 M: x86.64 temp-reg-2 RCX ;
  18
  19 M: temp-reg v>operand drop RBX ;
  20
  21 M: int-regs return-reg drop RAX ;
  22 M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
  23 M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
  24
  25 M: float-regs return-reg drop XMM0 ;
  26
  27 M: float-regs vregs
  28     drop {
  29         XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
  30         XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
  31     } ;
  32
  33 M: float-regs param-regs
  34     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
  35
  36 M: x86.64 fixnum>slot@ drop ;
  37
  38 M: x86.64 prepare-division CQO ;
  39
  40 M: x86.64 load-indirect ( literal reg -- )
  41     0 [] MOV rc-relative rel-literal ;
  42
  43 M: stack-params %load-param-reg
  44     drop
  45     >r R11 swap stack@ MOV
  46     r> stack@ R11 MOV ;
  47
  48 M: stack-params %save-param-reg
  49     >r stack-frame* + cell + swap r> %load-param-reg ;
  50
  51 : with-return-regs ( quot -- )
  52     [
  53         V{ RDX RAX } clone int-regs set
  54         V{ XMM1 XMM0 } clone float-regs set
  55         call
  56     ] with-scope ; inline
  57
  58 ! The ABI for passing structs by value is pretty messed up
  59 << "void*" c-type clone "__stack_value" define-primitive-type
  60 stack-params "__stack_value" c-type (>>reg-class) >>
  61
  62 : struct-types&offset ( struct-type -- pairs )
  63     fields>> [
  64         [ type>> ] [ offset>> ] bi 2array
  65     ] map ;
  66
  67 : split-struct ( pairs -- seq )
  68     [
  69         [ 8 mod zero? [ t , ] when , ] assoc-each
  70     ] { } make { t } split harvest ;
  71
  72 : flatten-small-struct ( c-type -- seq )
  73     struct-types&offset split-struct [
  74         [ c-type c-type-reg-class ] map
  75         int-regs swap member? "void*" "double" ? c-type
  76     ] map ;
  77
  78 : flatten-large-struct ( c-type -- seq )
  79     heap-size cell align
  80     cell /i "__stack_value" c-type <repetition> ;
  81
  82 M: struct-type flatten-value-type ( type -- seq )
  83     dup heap-size 16 > [
  84         flatten-large-struct
  85     ] [
  86         flatten-small-struct
  87     ] if ;
  88
  89 M: x86.64 %prepare-unbox ( -- )
  90     ! First parameter is top of stack
  91     RDI R14 [] MOV
  92     R14 cell SUB ;
  93
  94 M: x86.64 %unbox ( n reg-class func -- )
  95     ! Call the unboxer
  96     f %alien-invoke
  97     ! Store the return value on the C stack
  98     over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
  99
 100 M: x86.64 %unbox-long-long ( n func -- )
 101     int-regs swap %unbox ;
 102
 103 : %unbox-struct-field ( c-type i -- )
 104     ! Alien must be in RDI.
 105     RDI swap cells [+] swap reg-class>> {
 106         { int-regs [ int-regs get pop swap MOV ] }
 107         { double-float-regs [ float-regs get pop swap MOVSD ] }
 108     } case ;
 109
 110 M: x86.64 %unbox-small-struct ( c-type -- )
 111     ! Alien must be in RDI.
 112     "alien_offset" f %alien-invoke
 113     ! Move alien_offset() return value to RDI so that we don't
 114     ! clobber it.
 115     RDI RAX MOV
 116     [
 117         flatten-small-struct [ %unbox-struct-field ] each-index
 118     ] with-return-regs ;
 119
 120 M: x86.64 %unbox-large-struct ( n c-type -- )
 121     ! Source is in RDI
 122     heap-size
 123     ! Load destination address
 124     RSI RSP roll [+] LEA
 125     ! Load structure size
 126     RDX swap MOV
 127     ! Copy the struct to the C stack
 128     "to_value_struct" f %alien-invoke ;
 129
 130 : load-return-value ( reg-class -- )
 131     0 over param-reg swap return-reg
 132     2dup eq? [ 2drop ] [ MOV ] if ;
 133
 134 M: x86.64 %box ( n reg-class func -- )
 135     rot [
 136         rot [ 0 swap param-reg ] keep %load-param-reg
 137     ] [
 138         swap load-return-value
 139     ] if*
 140     f %alien-invoke ;
 141
 142 M: x86.64 %box-long-long ( n func -- )
 143     int-regs swap %box ;
 144
 145 M: x86.64 struct-small-enough? ( size -- ? )
 146     heap-size 2 cells <= ;
 147
 148 : box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
 149
 150 : %box-struct-field ( c-type i -- )
 151     box-struct-field@ swap reg-class>> {
 152         { int-regs [ int-regs get pop MOV ] }
 153         { double-float-regs [ float-regs get pop MOVSD ] }
 154     } case ;
 155
 156 M: x86.64 %box-small-struct ( c-type -- )
 157     #! Box a <= 16-byte struct.
 158     [
 159         [ flatten-small-struct [ %box-struct-field ] each-index ]
 160         [ RDX swap heap-size MOV ] bi
 161         RDI 0 box-struct-field@ MOV
 162         RSI 1 box-struct-field@ MOV
 163         "box_small_struct" f %alien-invoke
 164     ] with-return-regs ;
 165
 166 : struct-return@ ( size n -- n )
 167     [ ] [ \ stack-frame get swap - ] ?if ;
 168
 169 M: x86.64 %box-large-struct ( n c-type -- )
 170     ! Struct size is parameter 2
 171     heap-size
 172     RSI over MOV
 173     ! Compute destination address
 174     swap struct-return@ RDI RSP rot [+] LEA
 175     ! Copy the struct from the C stack
 176     "box_value_struct" f %alien-invoke ;
 177
 178 M: x86.64 %prepare-box-struct ( size -- )
 179     ! Compute target address for value struct return
 180     RAX RSP rot f struct-return@ [+] LEA
 181     RSP 0 [+] RAX MOV ;
 182
 183 M: x86.64 %prepare-var-args RAX RAX XOR ;
 184
 185 M: x86.64 %alien-global
 186     [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
 187
 188 M: x86.64 %alien-invoke
 189     R11 0 MOV
 190     rc-absolute-cell rel-dlsym
 191     R11 CALL ;
 192
 193 M: x86.64 %prepare-alien-indirect ( -- )
 194     "unbox_alien" f %alien-invoke
 195     cell temp@ RAX MOV ;
 196
 197 M: x86.64 %alien-indirect ( -- )
 198     cell temp@ CALL ;
 199
 200 M: x86.64 %alien-callback ( quot -- )
 201     RDI load-indirect "c_to_factor" f %alien-invoke ;
 202
 203 M: x86.64 %callback-value ( ctype -- )
 204     ! Save top of data stack
 205     %prepare-unbox
 206     ! Put former top of data stack in RDI
 207     cell temp@ RDI MOV
 208     ! Restore data/call/retain stacks
 209     "unnest_stacks" f %alien-invoke
 210     ! Put former top of data stack in RDI
 211     RDI cell temp@ MOV
 212     ! Unbox former top of data stack to return registers
 213     unbox-return ;
 214
 215 M: x86.64 %cleanup ( alien-node -- ) drop ;
 216
 217 M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
 218
 219 USE: cpu.x86.intrinsics
 220
 221 ! On 64-bit systems, the result of reading 4 bytes from memory
 222 ! is a fixnum.
 223 \ alien-unsigned-4 small-reg-32 define-unsigned-getter
 224 \ set-alien-unsigned-4 small-reg-32 define-setter
 225
 226 \ alien-signed-4 small-reg-32 define-signed-getter
 227 \ set-alien-signed-4 small-reg-32 define-setter