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 slots
5 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
11 FROM: layouts => cell cells ;
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
19 M: x86.64 pic-tail-reg RBX ;
21 M: int-regs return-reg drop RAX ;
22 M: float-regs return-reg drop XMM0 ;
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 ;
29 M: x86.64 extra-stack-space drop 0 ;
31 M: x86.64 machine-registers
33 { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 } }
35 XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
36 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
40 : vm-reg ( -- reg ) R13 ; inline
42 M: x86.64 %mov-vm-ptr ( reg -- )
45 M: x86.64 %vm-field-ptr ( dst field -- )
46 [ vm-reg ] dip vm-field-offset [+] LEA ;
48 : param@ ( n -- op ) reserved-stack-space + stack@ ;
50 M: x86.64 %prologue ( n -- )
51 temp-reg 0 MOV rc-absolute-cell rel-this
54 stack-reg swap 3 cells - SUB ;
56 : load-cards-offset ( dst -- )
57 0 MOV rc-absolute-cell rel-cards-offset ;
61 [+] card-mark <byte> MOV ;
63 : load-decks-offset ( dst -- )
64 0 MOV rc-absolute-cell rel-decks-offset ;
68 [+] card-mark <byte> MOV ;
70 M:: x86.64 %dispatch ( src temp -- )
71 ! Load jump table base.
72 temp HEX: ffffffff MOV
73 building get length :> start
74 0 rc-absolute-cell rel-here
78 building get length :> end
79 ! Fix up the displacement above
81 [ end start - + building get dup pop* push ]
85 M: stack-params copy-register*
88 { [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
89 { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
92 M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
94 M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
96 : with-return-regs ( quot -- )
98 V{ RDX RAX } clone int-regs set
99 V{ XMM1 XMM0 } clone float-regs set
101 ] with-scope ; inline
103 M: x86.64 %pop-stack ( n -- )
104 param-reg-0 swap ds-reg reg-stack MOV ;
106 M: x86.64 %pop-context-stack ( -- )
107 temp-reg %load-context-datastack
108 param-reg-0 temp-reg [] MOV
109 param-reg-0 param-reg-0 [] MOV
110 temp-reg [] bootstrap-cell SUB ;
112 M:: x86.64 %unbox ( n rep func -- )
113 param-reg-1 %mov-vm-ptr
116 ! Store the return value on the C stack if this is an
117 ! alien-invoke, otherwise leave it the return register if
118 ! this is the end of alien-callback
119 n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
121 M: x86.64 %unbox-long-long ( n func -- )
122 [ int-rep ] dip %unbox ;
124 : %unbox-struct-field ( c-type i -- )
125 ! Alien must be in param-reg-0.
126 R11 swap cells [+] swap rep>> reg-class-of {
127 { int-regs [ int-regs get pop swap MOV ] }
128 { float-regs [ float-regs get pop swap MOVSD ] }
131 M: x86.64 %unbox-small-struct ( c-type -- )
132 ! Alien must be in param-reg-0.
133 param-reg-1 %mov-vm-ptr
134 "alien_offset" f %alien-invoke
135 ! Move alien_offset() return value to R11 so that we don't
139 flatten-value-type [ %unbox-struct-field ] each-index
142 M:: x86.64 %unbox-large-struct ( n c-type -- )
143 ! Source is in param-reg-0
144 ! Load destination address into param-reg-1
145 param-reg-1 n param@ LEA
146 ! Load structure size into param-reg-2
147 param-reg-2 c-type heap-size MOV
148 param-reg-3 %mov-vm-ptr
149 ! Copy the struct to the C stack
150 "to_value_struct" f %alien-invoke ;
152 : load-return-value ( rep -- )
153 [ [ 0 ] dip reg-class-of param-reg ]
154 [ reg-class-of return-reg ]
158 M:: x86.64 %box ( n rep func -- )
161 0 rep reg-class-of param-reg
164 rep load-return-value
166 rep int-rep? [ param-reg-1 ] [ param-reg-0 ] if %mov-vm-ptr
167 func f %alien-invoke ;
169 M: x86.64 %box-long-long ( n func -- )
170 [ int-rep ] dip %box ;
172 : box-struct-field@ ( i -- operand ) 1 + cells param@ ;
174 : %box-struct-field ( c-type i -- )
175 box-struct-field@ swap c-type-rep reg-class-of {
176 { int-regs [ int-regs get pop MOV ] }
177 { float-regs [ float-regs get pop MOVSD ] }
180 M: x86.64 %box-small-struct ( c-type -- )
181 #! Box a <= 16-byte struct.
183 [ flatten-value-type [ %box-struct-field ] each-index ]
184 [ param-reg-2 swap heap-size MOV ] bi
185 param-reg-0 0 box-struct-field@ MOV
186 param-reg-1 1 box-struct-field@ MOV
187 param-reg-3 %mov-vm-ptr
188 "from_small_struct" f %alien-invoke
191 : struct-return@ ( n -- operand )
192 [ stack-frame get params>> ] unless* param@ ;
194 M: x86.64 %box-large-struct ( n c-type -- )
195 ! Struct size is parameter 2
196 param-reg-1 swap heap-size MOV
197 ! Compute destination address
198 param-reg-0 swap struct-return@ LEA
199 param-reg-2 %mov-vm-ptr
200 ! Copy the struct from the C stack
201 "from_value_struct" f %alien-invoke ;
203 M: x86.64 %prepare-box-struct ( -- )
204 ! Compute target address for value struct return
205 RAX f struct-return@ LEA
206 ! Store it as the first parameter
209 M: x86.64 %prepare-var-args RAX RAX XOR ;
211 M: x86.64 %alien-invoke
213 rc-absolute-cell rel-dlsym
216 M: x86.64 %nest-stacks ( -- )
217 param-reg-0 %mov-vm-ptr
218 "nest_stacks" f %alien-invoke ;
220 M: x86.64 %unnest-stacks ( -- )
221 param-reg-0 %mov-vm-ptr
222 "unnest_stacks" f %alien-invoke ;
224 M: x86.64 %prepare-alien-indirect ( -- )
225 param-reg-0 ds-reg [] MOV
227 param-reg-1 %mov-vm-ptr
228 "pinned_alien_offset" f %alien-invoke
231 M: x86.64 %alien-indirect ( -- )
234 M: x86.64 %alien-callback ( quot -- )
235 param-reg-0 param-reg-1 %restore-context
236 param-reg-0 swap %load-reference
237 param-reg-0 quot-entry-point-offset [+] CALL
238 param-reg-0 param-reg-1 %save-context ;
240 M: x86.64 %callback-value ( ctype -- )
244 param-reg-0 %mov-vm-ptr
245 ! Restore data/call/retain stacks
246 "unnest_stacks" f %alien-invoke
247 ! Put former top of data stack in param-reg-0
250 ! Unbox former top of data stack to return registers
253 : float-function-param ( i src -- )
254 [ float-regs param-regs nth ] dip double-rep %copy ;
256 : float-function-return ( reg -- )
257 float-regs return-reg double-rep %copy ;
259 M:: x86.64 %unary-float-function ( dst src func -- )
260 0 src float-function-param
262 dst float-function-return ;
264 M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
265 ! src1 might equal dst; otherwise it will be a spill slot
266 ! src2 is always a spill slot
267 0 src1 float-function-param
268 1 src2 float-function-param
270 dst float-function-return ;
272 M:: x86.64 %call-gc ( gc-root-count temp -- )
273 ! Pass pointer to start of GC roots as first parameter
274 param-reg-0 gc-root-base param@ LEA
275 ! Pass number of roots as second parameter
276 param-reg-1 gc-root-count MOV
277 ! Pass VM ptr as third parameter
278 param-reg-2 %mov-vm-ptr
280 "inline_gc" f %alien-invoke ;
282 ! The result of reading 4 bytes from memory is a fixnum on
284 enable-alien-4-intrinsics
289 { [ os unix? ] [ "cpu.x86.64.unix" require ] }
290 { [ os winnt? ] [ "cpu.x86.64.winnt" require ] }