core/cpu/x86/64/64.factor

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