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 arrays kernel math namespaces make sequences
   4 system layouts alien alien.c-types alien.accessors alien.structs
   5 slots splitting assocs combinators make locals cpu.x86.assembler
   6 cpu.x86 cpu.architecture compiler.constants
   7 compiler.codegen compiler.codegen.fixup
   8 compiler.cfg.instructions compiler.cfg.builder
   9 compiler.cfg.intrinsics ;
  10 IN: cpu.x86.64
  11
  12 M: x86.64 machine-registers
  13     {
  14         { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
  15         { double-float-regs {
  16             XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
  17             XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
  18         } }
  19     } ;
  20
  21 M: x86.64 ds-reg R14 ;
  22 M: x86.64 rs-reg R15 ;
  23 M: x86.64 stack-reg RSP ;
  24
  25 M:: x86.64 %dispatch ( src temp offset -- )
  26     ! Load jump table base.
  27     temp HEX: ffffffff MOV
  28     offset cells rc-absolute-cell rel-here
  29     ! Add jump table base
  30     src temp ADD
  31     src HEX: 7f [+] JMP
  32     ! Fix up the displacement above
  33     cell code-alignment
  34     [ 15 + building get dup pop* push ]
  35     [ align-code ]
  36     bi ;
  37
  38 M: x86.64 param-reg-1 int-regs param-regs first ;
  39 M: x86.64 param-reg-2 int-regs param-regs second ;
  40 : param-reg-3 int-regs param-regs third ; inline
  41
  42 M: int-regs return-reg drop RAX ;
  43 M: float-regs return-reg drop XMM0 ;
  44
  45 M: x86.64 %prologue ( n -- )
  46     temp-reg-1 0 MOV rc-absolute-cell rel-this
  47     dup PUSH
  48     temp-reg-1 PUSH
  49     stack-reg swap 3 cells - SUB ;
  50
  51 M: stack-params %load-param-reg
  52     drop
  53     >r R11 swap param@ MOV
  54     r> param@ R11 MOV ;
  55
  56 M: stack-params %save-param-reg
  57     drop
  58     R11 swap next-stack@ MOV
  59     param@ R11 MOV ;
  60
  61 : with-return-regs ( quot -- )
  62     [
  63         V{ RDX RAX } clone int-regs set
  64         V{ XMM1 XMM0 } clone float-regs set
  65         call
  66     ] with-scope ; inline
  67
  68 M: x86.64 %prepare-unbox ( -- )
  69     ! First parameter is top of stack
  70     param-reg-1 R14 [] MOV
  71     R14 cell SUB ;
  72
  73 M: x86.64 %unbox ( n reg-class func -- )
  74     ! Call the unboxer
  75     f %alien-invoke
  76     ! Store the return value on the C stack
  77     over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
  78
  79 M: x86.64 %unbox-long-long ( n func -- )
  80     int-regs swap %unbox ;
  81
  82 : %unbox-struct-field ( c-type i -- )
  83     ! Alien must be in param-reg-1.
  84     R11 swap cells [+] swap reg-class>> {
  85         { int-regs [ int-regs get pop swap MOV ] }
  86         { double-float-regs [ float-regs get pop swap MOVSD ] }
  87     } case ;
  88
  89 M: x86.64 %unbox-small-struct ( c-type -- )
  90     ! Alien must be in param-reg-1.
  91     "alien_offset" f %alien-invoke
  92     ! Move alien_offset() return value to R11 so that we don't
  93     ! clobber it.
  94     R11 RAX MOV
  95     [
  96         flatten-value-type [ %unbox-struct-field ] each-index
  97     ] with-return-regs ;
  98
  99 M: x86.64 %unbox-large-struct ( n c-type -- )
 100     ! Source is in param-reg-1
 101     heap-size
 102     ! Load destination address
 103     param-reg-2 rot param@ LEA
 104     ! Load structure size
 105     param-reg-3 swap MOV
 106     ! Copy the struct to the C stack
 107     "to_value_struct" f %alien-invoke ;
 108
 109 : load-return-value ( reg-class -- )
 110     0 over param-reg swap return-reg
 111     2dup eq? [ 2drop ] [ MOV ] if ;
 112
 113 M: x86.64 %box ( n reg-class func -- )
 114     rot [
 115         rot [ 0 swap param-reg ] keep %load-param-reg
 116     ] [
 117         swap load-return-value
 118     ] if*
 119     f %alien-invoke ;
 120
 121 M: x86.64 %box-long-long ( n func -- )
 122     int-regs swap %box ;
 123
 124 : box-struct-field@ ( i -- operand ) 1+ cells param@ ;
 125
 126 : %box-struct-field ( c-type i -- )
 127     box-struct-field@ swap reg-class>> {
 128         { int-regs [ int-regs get pop MOV ] }
 129         { double-float-regs [ float-regs get pop MOVSD ] }
 130     } case ;
 131
 132 M: x86.64 %box-small-struct ( c-type -- )
 133     #! Box a <= 16-byte struct.
 134     [
 135         [ flatten-value-type [ %box-struct-field ] each-index ]
 136         [ param-reg-3 swap heap-size MOV ] bi
 137         param-reg-1 0 box-struct-field@ MOV
 138         param-reg-2 1 box-struct-field@ MOV
 139         "box_small_struct" f %alien-invoke
 140     ] with-return-regs ;
 141
 142 : struct-return@ ( n -- operand )
 143     [ stack-frame get params>> ] unless* param@ ;
 144
 145 M: x86.64 %box-large-struct ( n c-type -- )
 146     ! Struct size is parameter 2
 147     param-reg-2 swap heap-size MOV
 148     ! Compute destination address
 149     param-reg-1 swap struct-return@ LEA
 150     ! Copy the struct from the C stack
 151     "box_value_struct" f %alien-invoke ;
 152
 153 M: x86.64 %prepare-box-struct ( -- )
 154     ! Compute target address for value struct return
 155     RAX f struct-return@ LEA
 156     ! Store it as the first parameter
 157     0 param@ RAX MOV ;
 158
 159 M: x86.64 %prepare-var-args RAX RAX XOR ;
 160
 161 M: x86.64 %alien-invoke
 162     R11 0 MOV
 163     rc-absolute-cell rel-dlsym
 164     R11 CALL ;
 165
 166 M: x86.64 %alien-invoke-tail
 167     R11 0 MOV
 168     rc-absolute-cell rel-dlsym
 169     R11 JMP ;
 170
 171 M: x86.64 %prepare-alien-indirect ( -- )
 172     "unbox_alien" f %alien-invoke
 173     RBP RAX MOV ;
 174
 175 M: x86.64 %alien-indirect ( -- )
 176     RBP CALL ;
 177
 178 M: x86.64 %alien-callback ( quot -- )
 179     param-reg-1 swap %load-indirect
 180     "c_to_factor" f %alien-invoke ;
 181
 182 M: x86.64 %callback-value ( ctype -- )
 183     ! Save top of data stack
 184     %prepare-unbox
 185     ! Save top of data stack
 186     RSP 8 SUB
 187     param-reg-1 PUSH
 188     ! Restore data/call/retain stacks
 189     "unnest_stacks" f %alien-invoke
 190     ! Put former top of data stack in param-reg-1
 191     param-reg-1 POP
 192     RSP 8 ADD
 193     ! Unbox former top of data stack to return registers
 194     unbox-return ;
 195
 196 ! The result of reading 4 bytes from memory is a fixnum on
 197 ! x86-64.
 198 enable-alien-4-intrinsics
 199
 200 ! SSE2 is always available on x86-64.
 201 enable-float-intrinsics
 202
 203 USE: vocabs.loader
 204
 205 {
 206     { [ os unix? ] [ "cpu.x86.64.unix" require ] }
 207     { [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
 208 } cond