Update x86 backend for SSA codegen
Slava Pestov
parent
37cf7d9a9c
commit
508b1f52b8
|
|
@ -1,13 +1,12 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: locals alien.c-types arrays kernel kernel.private math
|
USING: locals alien.c-types alien.syntax arrays kernel
|
||||||
namespaces sequences stack-checker.known-words system layouts io
|
math namespaces sequences system layouts io vocabs.loader
|
||||||
vocabs.loader accessors init combinators command-line
|
accessors init combinators command-line cpu.x86.assembler
|
||||||
cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics
|
cpu.x86.architecture cpu.architecture compiler compiler.units
|
||||||
cpu.x86.allot cpu.architecture compiler compiler.units
|
|
||||||
compiler.constants compiler.alien compiler.codegen
|
compiler.constants compiler.alien compiler.codegen
|
||||||
compiler.codegen.fixup compiler.cfg.builder
|
compiler.codegen.fixup compiler.cfg.instructions
|
||||||
compiler.cfg.instructions ;
|
compiler.cfg.builder compiler.cfg.builder.calls ;
|
||||||
IN: cpu.x86.32
|
IN: cpu.x86.32
|
||||||
|
|
||||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||||
|
|
@ -75,12 +74,8 @@ M: float-regs store-return-reg
|
||||||
[ [ align-sub ] [ call ] bi* ]
|
[ [ align-sub ] [ call ] bi* ]
|
||||||
[ [ align-add ] [ drop ] bi* ] 2bi ; inline
|
[ [ align-add ] [ drop ] bi* ] 2bi ; inline
|
||||||
|
|
||||||
M: x86.32 fixnum>slot@ 1 SHR ;
|
|
||||||
|
|
||||||
M: x86.32 prepare-division CDQ ;
|
|
||||||
|
|
||||||
M: x86.32 %load-indirect
|
M: x86.32 %load-indirect
|
||||||
swap 0 [] MOV rc-absolute-cell rel-literal ;
|
0 [] MOV rc-absolute-cell rel-literal ;
|
||||||
|
|
||||||
M: object %load-param-reg 3drop ;
|
M: object %load-param-reg 3drop ;
|
||||||
|
|
||||||
|
|
@ -222,7 +217,7 @@ M: x86.32 %alien-indirect ( -- )
|
||||||
|
|
||||||
M: x86.32 %alien-callback ( quot -- )
|
M: x86.32 %alien-callback ( quot -- )
|
||||||
4 [
|
4 [
|
||||||
EAX load-indirect
|
EAX %load-indirect
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
"c_to_factor" f %alien-invoke
|
"c_to_factor" f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
@ -279,34 +274,17 @@ os windows? [
|
||||||
4 "double" c-type (>>align)
|
4 "double" c-type (>>align)
|
||||||
] unless
|
] unless
|
||||||
|
|
||||||
: (sse2?) ( -- ? ) "Intrinsic" throw ;
|
FUNCTION: bool check_sse2 ( ) ;
|
||||||
|
|
||||||
<<
|
: sse2? ( -- ? )
|
||||||
|
[ optimized-recompile-hook ] recompile-hook
|
||||||
\ (sse2?) [
|
[ [ check_sse2 ] compile-call ] with-variable ;
|
||||||
{ EAX EBX ECX EDX } [ PUSH ] each
|
|
||||||
EAX 1 MOV
|
|
||||||
CPUID
|
|
||||||
EDX 26 SHR
|
|
||||||
EDX 1 AND
|
|
||||||
{ EAX EBX ECX EDX } [ POP ] each
|
|
||||||
JNE
|
|
||||||
] { } define-if-intrinsic
|
|
||||||
|
|
||||||
\ (sse2?) { } { object } define-primitive
|
|
||||||
|
|
||||||
>>
|
|
||||||
|
|
||||||
: sse2? ( -- ? ) (sse2?) ;
|
|
||||||
|
|
||||||
"-no-sse2" cli-args member? [
|
"-no-sse2" cli-args member? [
|
||||||
"Checking if your CPU supports SSE2..." print flush
|
"Checking if your CPU supports SSE2..." print flush
|
||||||
[ optimized-recompile-hook ] recompile-hook [
|
sse2? [
|
||||||
[ sse2? ] compile-call
|
|
||||||
] with-variable
|
|
||||||
[
|
|
||||||
" - yes" print
|
" - yes" print
|
||||||
"cpu.x86.sse2" require
|
enable-float-intrinsics
|
||||||
[
|
[
|
||||||
sse2? [
|
sse2? [
|
||||||
"This image was built to use SSE2, which your CPU does not support." print
|
"This image was built to use SSE2, which your CPU does not support." print
|
||||||
|
|
@ -315,7 +293,5 @@ os windows? [
|
||||||
1 exit
|
1 exit
|
||||||
] unless
|
] unless
|
||||||
] "cpu.x86" add-init-hook
|
] "cpu.x86" add-init-hook
|
||||||
] [
|
] [ " - no" print ] if
|
||||||
" - no" print
|
|
||||||
] if
|
|
||||||
] unless
|
] unless
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,12 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien.c-types arrays kernel kernel.private math
|
USING: accessors arrays kernel math namespaces make sequences
|
||||||
namespaces make sequences system
|
system layouts alien alien.c-types alien.accessors alien.structs
|
||||||
layouts alien alien.accessors alien.structs slots splitting
|
slots splitting assocs combinators cpu.x86.assembler
|
||||||
assocs combinators cpu.x86.assembler
|
cpu.x86.architecture cpu.architecture compiler.constants
|
||||||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
compiler.codegen compiler.codegen.fixup
|
||||||
cpu.x86.allot cpu.architecture compiler.constants
|
compiler.cfg.instructions compiler.cfg.builder
|
||||||
compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
|
compiler.cfg.builder.calls ;
|
||||||
compiler.cfg.builder ;
|
|
||||||
IN: cpu.x86.64
|
IN: cpu.x86.64
|
||||||
|
|
||||||
M: x86.64 machine-registers
|
M: x86.64 machine-registers
|
||||||
|
|
@ -33,12 +32,8 @@ M: float-regs return-reg drop XMM0 ;
|
||||||
M: float-regs param-regs
|
M: float-regs param-regs
|
||||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||||
|
|
||||||
M: x86.64 fixnum>slot@ drop ;
|
M: x86.64 %load-indirect
|
||||||
|
0 [] MOV rc-relative rel-literal ;
|
||||||
M: x86.64 prepare-division CQO ;
|
|
||||||
|
|
||||||
M: x86.64 %load-indirect ( literal reg -- )
|
|
||||||
swap 0 [] MOV rc-relative rel-literal ;
|
|
||||||
|
|
||||||
M: stack-params %load-param-reg
|
M: stack-params %load-param-reg
|
||||||
drop
|
drop
|
||||||
|
|
@ -58,8 +53,8 @@ M: stack-params %save-param-reg
|
||||||
] with-scope ; inline
|
] with-scope ; inline
|
||||||
|
|
||||||
! The ABI for passing structs by value is pretty messed up
|
! The ABI for passing structs by value is pretty messed up
|
||||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
"void*" c-type clone "__stack_value" define-primitive-type
|
||||||
stack-params "__stack_value" c-type (>>reg-class) >>
|
stack-params "__stack_value" c-type (>>reg-class)
|
||||||
|
|
||||||
: struct-types&offset ( struct-type -- pairs )
|
: struct-types&offset ( struct-type -- pairs )
|
||||||
fields>> [
|
fields>> [
|
||||||
|
|
@ -200,7 +195,7 @@ M: x86.64 %alien-indirect ( -- )
|
||||||
RBP CALL ;
|
RBP CALL ;
|
||||||
|
|
||||||
M: x86.64 %alien-callback ( quot -- )
|
M: x86.64 %alien-callback ( quot -- )
|
||||||
RDI load-indirect "c_to_factor" f %alien-invoke ;
|
RDI %load-indirect "c_to_factor" f %alien-invoke ;
|
||||||
|
|
||||||
M: x86.64 %callback-value ( ctype -- )
|
M: x86.64 %callback-value ( ctype -- )
|
||||||
! Save top of data stack
|
! Save top of data stack
|
||||||
|
|
@ -216,66 +211,9 @@ M: x86.64 %callback-value ( ctype -- )
|
||||||
! Unbox former top of data stack to return registers
|
! Unbox former top of data stack to return registers
|
||||||
unbox-return ;
|
unbox-return ;
|
||||||
|
|
||||||
USE: cpu.x86.intrinsics
|
! The result of reading 4 bytes from memory is a fixnum on
|
||||||
|
! x86-64.
|
||||||
|
enable-alien-4-intrinsics
|
||||||
|
|
||||||
: (%alien-get-4) ( -- )
|
! SSE2 is always available on x86-64.
|
||||||
small-reg-32 "offset" operand [] MOV ; inline
|
enable-float-intrinsics
|
||||||
|
|
||||||
: %alien-unsigned-4 ( -- )
|
|
||||||
%prepare-alien-accessor
|
|
||||||
"value" operand small-reg = [
|
|
||||||
(%alien-get-4)
|
|
||||||
] [
|
|
||||||
small-reg PUSH
|
|
||||||
(%alien-get-4)
|
|
||||||
"value" operand small-reg MOV
|
|
||||||
small-reg POP
|
|
||||||
] if
|
|
||||||
"value" operand %tag-fixnum ; inline
|
|
||||||
|
|
||||||
: (%alien-signed-4) ( -- )
|
|
||||||
(%alien-get-4)
|
|
||||||
"value" operand small-reg-32 MOVSX ;
|
|
||||||
|
|
||||||
: %alien-signed-4 ( -- )
|
|
||||||
%prepare-alien-accessor
|
|
||||||
"value" operand small-reg = [
|
|
||||||
(%alien-signed-4)
|
|
||||||
] [
|
|
||||||
small-reg PUSH
|
|
||||||
(%alien-signed-4)
|
|
||||||
small-reg POP
|
|
||||||
] if
|
|
||||||
"value" operand %tag-fixnum ; inline
|
|
||||||
|
|
||||||
: define-alien-unsigned-4-getter ( word -- )
|
|
||||||
[ %alien-unsigned-4 ] alien-integer-get-template define-intrinsic ;
|
|
||||||
|
|
||||||
: define-alien-signed-4-getter ( word -- )
|
|
||||||
[ %alien-signed-4 ] alien-integer-get-template define-intrinsic ;
|
|
||||||
|
|
||||||
: %set-alien-4 ( -- )
|
|
||||||
"value" operand "offset" operand = [
|
|
||||||
"value" operand %untag-fixnum
|
|
||||||
] unless
|
|
||||||
%prepare-alien-accessor
|
|
||||||
small-reg "offset" operand = [
|
|
||||||
"value" operand "offset" operand XCHG
|
|
||||||
"value" operand [] small-reg-32 MOV
|
|
||||||
] [
|
|
||||||
small-reg PUSH
|
|
||||||
small-reg "value" operand MOV
|
|
||||||
"offset" operand [] small-reg-32 MOV
|
|
||||||
small-reg POP
|
|
||||||
] if ; inline
|
|
||||||
|
|
||||||
: define-alien-4-setter ( word -- )
|
|
||||||
[ %set-alien-4 ] alien-integer-set-template define-intrinsic ;
|
|
||||||
|
|
||||||
! On 64-bit systems, the result of reading 4 bytes from memory
|
|
||||||
! is a fixnum.
|
|
||||||
\ alien-unsigned-4 define-alien-unsigned-4-getter
|
|
||||||
\ set-alien-unsigned-4 define-alien-4-setter
|
|
||||||
|
|
||||||
\ alien-signed-4 define-alien-signed-4-getter
|
|
||||||
\ set-alien-signed-4 define-alien-4-setter
|
|
||||||
|
|
|
||||||
|
|
@ -1,141 +0,0 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: kernel words kernel.private namespaces math math.private
|
|
||||||
sequences generic arrays system layouts alien locals fry
|
|
||||||
cpu.architecture cpu.x86.assembler cpu.x86.architecture
|
|
||||||
compiler.constants compiler.cfg.templates compiler.cfg.builder
|
|
||||||
compiler.codegen compiler.codegen.fixup ;
|
|
||||||
IN: cpu.x86.allot
|
|
||||||
|
|
||||||
M:: x86 %write-barrier ( src card# table -- )
|
|
||||||
#! Mark the card pointed to by vreg.
|
|
||||||
! Mark the card
|
|
||||||
card# src MOV
|
|
||||||
card# card-bits SHR
|
|
||||||
"cards_offset" f table %alien-global
|
|
||||||
table card# [+] card-mark <byte> MOV
|
|
||||||
|
|
||||||
! Mark the card deck
|
|
||||||
card# deck-bits card-bits - SHR
|
|
||||||
"decks_offset" f table %alien-global
|
|
||||||
table card# [+] card-mark <byte> MOV ;
|
|
||||||
|
|
||||||
: load-zone-ptr ( reg -- )
|
|
||||||
#! Load pointer to start of zone array
|
|
||||||
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
|
||||||
|
|
||||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
|
||||||
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
|
|
||||||
|
|
||||||
: inc-allot-ptr ( nursery-ptr n -- )
|
|
||||||
[ cell [+] ] dip 8 align ADD ;
|
|
||||||
|
|
||||||
: store-header ( temp type -- )
|
|
||||||
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
|
|
||||||
|
|
||||||
: store-tagged ( dst tag -- )
|
|
||||||
tag-number OR ;
|
|
||||||
|
|
||||||
M:: x86 %allot ( dst size type tag nursery-ptr -- )
|
|
||||||
nursery-ptr dst load-allot-ptr
|
|
||||||
dst type store-header
|
|
||||||
dst tag store-tagged
|
|
||||||
nursery-ptr size inc-allot-ptr ;
|
|
||||||
|
|
||||||
M: x86 %gc ( -- )
|
|
||||||
"end" define-label
|
|
||||||
temp-reg-1 load-zone-ptr
|
|
||||||
temp-reg-2 temp-reg-1 cell [+] MOV
|
|
||||||
temp-reg-2 1024 ADD
|
|
||||||
temp-reg-1 temp-reg-1 3 cells [+] MOV
|
|
||||||
temp-reg-2 temp-reg-1 CMP
|
|
||||||
"end" get JLE
|
|
||||||
%prepare-alien-invoke
|
|
||||||
"minor_gc" f %alien-invoke
|
|
||||||
"end" resolve-label ;
|
|
||||||
|
|
||||||
: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
|
|
||||||
|
|
||||||
:: %allot-bignum-signed-1 ( dst src temp -- )
|
|
||||||
#! on entry, inreg is a signed 32-bit quantity
|
|
||||||
#! exits with tagged ptr to bignum in outreg
|
|
||||||
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
|
||||||
#! length is the # of digits + sign
|
|
||||||
[
|
|
||||||
{ "end" "nonzero" "positive" "store" } [ define-label ] each
|
|
||||||
src 0 CMP ! is it zero?
|
|
||||||
"nonzero" get JNE
|
|
||||||
! Use cached zero value
|
|
||||||
0 >bignum dst load-indirect
|
|
||||||
"end" get JMP
|
|
||||||
"nonzero" resolve-label
|
|
||||||
! Allocate a bignum
|
|
||||||
dst 4 cells bignum bignum temp %allot
|
|
||||||
! Write length
|
|
||||||
dst 1 bignum@ 2 tag-fixnum MOV
|
|
||||||
! Test sign
|
|
||||||
src 0 CMP
|
|
||||||
"positive" get JGE
|
|
||||||
dst 2 bignum@ 1 MOV ! negative sign
|
|
||||||
src NEG
|
|
||||||
"store" get JMP
|
|
||||||
"positive" resolve-label
|
|
||||||
dst 2 bignum@ 0 MOV ! positive sign
|
|
||||||
"store" resolve-label
|
|
||||||
dst 3 bignum@ src MOV
|
|
||||||
"end" resolve-label
|
|
||||||
] with-scope ;
|
|
||||||
|
|
||||||
: alien@ ( reg n -- op ) cells object tag-number - [+] ;
|
|
||||||
|
|
||||||
M:: x86 %box-alien ( dst src temp -- )
|
|
||||||
[
|
|
||||||
{ "end" "f" } [ define-label ] each
|
|
||||||
src 0 CMP
|
|
||||||
"f" get JE
|
|
||||||
dst 4 cells alien object temp %allot
|
|
||||||
dst 1 alien@ \ f tag-number MOV
|
|
||||||
dst 2 alien@ \ f tag-number MOV
|
|
||||||
! Store src in alien-offset slot
|
|
||||||
dst 3 alien@ src MOV
|
|
||||||
"end" get JMP
|
|
||||||
"f" resolve-label
|
|
||||||
dst \ f tag-number MOV
|
|
||||||
"end" resolve-label
|
|
||||||
] with-scope ;
|
|
||||||
|
|
||||||
: overflow-check ( word -- )
|
|
||||||
"end" define-label
|
|
||||||
"z" operand "x" operand MOV
|
|
||||||
"z" operand "y" operand pick execute
|
|
||||||
! If the previous arithmetic operation overflowed, then we
|
|
||||||
! turn the result into a bignum and leave it in EAX.
|
|
||||||
"end" get JNO
|
|
||||||
! There was an overflow. Recompute the original operand.
|
|
||||||
{ "y" "x" } [ %untag-fixnum ] unique-operands
|
|
||||||
"x" operand "y" operand rot execute
|
|
||||||
"z" operand "x" operand "y" operand %allot-bignum-signed-1
|
|
||||||
"end" resolve-label ; inline
|
|
||||||
|
|
||||||
: overflow-template ( word insn -- )
|
|
||||||
'[ _ overflow-check ] T{ template
|
|
||||||
{ input { { f "x" } { f "y" } } }
|
|
||||||
{ scratch { { f "z" } } }
|
|
||||||
{ output { "z" } }
|
|
||||||
{ clobber { "x" "y" } }
|
|
||||||
{ gc t }
|
|
||||||
} define-intrinsic ;
|
|
||||||
|
|
||||||
\ fixnum+ \ ADD overflow-template
|
|
||||||
\ fixnum- \ SUB overflow-template
|
|
||||||
|
|
||||||
\ fixnum>bignum [
|
|
||||||
"x" operand %untag-fixnum
|
|
||||||
"y" operand "x" operand "scratch" operand %allot-bignum-signed-1
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "x" } } }
|
|
||||||
{ scratch { { f "y" } { f "scratch" } } }
|
|
||||||
{ output { "y" } }
|
|
||||||
{ clobber { "x" } }
|
|
||||||
{ gc t }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
||||||
|
|
@ -3,16 +3,416 @@
|
||||||
USING: accessors assocs alien alien.c-types arrays
|
USING: accessors assocs alien alien.c-types arrays
|
||||||
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
|
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
|
||||||
kernel kernel.private math memory namespaces make sequences
|
kernel kernel.private math memory namespaces make sequences
|
||||||
words system layouts combinators math.order locals
|
words system layouts combinators math.order fry locals
|
||||||
compiler.constants compiler.cfg.registers
|
compiler.constants compiler.cfg.registers
|
||||||
compiler.cfg.instructions compiler.codegen
|
compiler.cfg.instructions compiler.codegen
|
||||||
compiler.codegen.fixup ;
|
compiler.codegen.fixup ;
|
||||||
IN: cpu.x86.architecture
|
IN: cpu.x86.architecture
|
||||||
|
|
||||||
|
HOOK: temp-reg-1 cpu ( -- reg )
|
||||||
|
HOOK: temp-reg-2 cpu ( -- reg )
|
||||||
|
|
||||||
|
M: x86 %load-immediate MOV ;
|
||||||
|
|
||||||
HOOK: ds-reg cpu ( -- reg )
|
HOOK: ds-reg cpu ( -- reg )
|
||||||
HOOK: rs-reg cpu ( -- reg )
|
HOOK: rs-reg cpu ( -- reg )
|
||||||
|
|
||||||
|
: reg-stack ( n reg -- op ) swap cells neg [+] ;
|
||||||
|
|
||||||
|
GENERIC: loc>operand ( loc -- operand )
|
||||||
|
|
||||||
|
M: ds-loc loc>operand n>> ds-reg reg-stack ;
|
||||||
|
M: rs-loc loc>operand n>> rs-reg reg-stack ;
|
||||||
|
|
||||||
|
M: x86 %peek loc>operand MOV ;
|
||||||
|
M: x86 %replace loc>operand swap MOV ;
|
||||||
|
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; inline
|
||||||
|
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
|
||||||
|
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
|
||||||
|
|
||||||
|
: align-stack ( n -- n' )
|
||||||
|
os macosx? cpu x86.64? or [ 16 align ] when ;
|
||||||
|
|
||||||
|
M: x86 stack-frame-size ( stack-frame -- i )
|
||||||
|
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
|
||||||
|
[ params>> ]
|
||||||
|
[ return>> ]
|
||||||
|
tri + +
|
||||||
|
3 cells +
|
||||||
|
align-stack ;
|
||||||
|
|
||||||
|
M: x86 %call ( label -- ) CALL ;
|
||||||
|
M: x86 %jump-label ( label -- ) JMP ;
|
||||||
|
M: x86 %return ( -- ) 0 RET ;
|
||||||
|
|
||||||
|
: code-alignment ( -- n )
|
||||||
|
building get length dup cell align swap - ;
|
||||||
|
|
||||||
|
: align-code ( n -- )
|
||||||
|
0 <repetition> % ;
|
||||||
|
|
||||||
|
M:: x86 %dispatch ( src temp -- )
|
||||||
|
! Load jump table base. We use a temporary register
|
||||||
|
! since on AMD64 we have to load a 64-bit immediate. On
|
||||||
|
! x86, this is redundant.
|
||||||
|
! Add jump table base
|
||||||
|
temp HEX: ffffffff MOV rc-absolute-cell rel-here
|
||||||
|
src temp ADD
|
||||||
|
src HEX: 7f [+] JMP
|
||||||
|
! Fix up the displacement above
|
||||||
|
code-alignment dup bootstrap-cell 8 = 15 9 ? +
|
||||||
|
building get dup pop* push
|
||||||
|
align-code ;
|
||||||
|
|
||||||
|
M: x86 %dispatch-label ( word -- )
|
||||||
|
0 cell, rc-absolute-cell rel-word ;
|
||||||
|
|
||||||
|
:: (%slot) ( obj slot tag temp -- op )
|
||||||
|
temp slot obj [+] LEA
|
||||||
|
temp tag neg [+] ; inline
|
||||||
|
|
||||||
|
:: (%slot-imm) ( obj slot tag -- op )
|
||||||
|
obj slot cells tag - [+] ; inline
|
||||||
|
|
||||||
|
M: x86 %slot ( dst obj slot tag temp -- ) (%slot) MOV ;
|
||||||
|
M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
|
||||||
|
M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
|
||||||
|
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
|
||||||
|
|
||||||
|
: ?MOV ( dst src -- )
|
||||||
|
2dup = [ 2drop ] [ MOV ] if ; inline
|
||||||
|
|
||||||
|
: 1operand ( dst src -- dst' )
|
||||||
|
dupd ?MOV ; inline
|
||||||
|
|
||||||
|
: 2operand ( dst src1 src2 -- dst src )
|
||||||
|
[ 1operand ] dip ; inline
|
||||||
|
|
||||||
|
M: x86 %add [+] LEA ;
|
||||||
|
M: x86 %add-imm [+] LEA ;
|
||||||
|
M: x86 %sub 2operand SUB ;
|
||||||
|
M: x86 %sub-imm neg [+] LEA ;
|
||||||
|
M: x86 %mul 2operand IMUL2 ;
|
||||||
|
M: x86 %mul-imm 2operand IMUL2 ;
|
||||||
|
M: x86 %and 2operand AND ;
|
||||||
|
M: x86 %and-imm 2operand AND ;
|
||||||
|
M: x86 %or 2operand OR ;
|
||||||
|
M: x86 %or-imm 2operand OR ;
|
||||||
|
M: x86 %xor 2operand XOR ;
|
||||||
|
M: x86 %xor-imm 2operand XOR ;
|
||||||
|
M: x86 %shl-imm 2operand SHL ;
|
||||||
|
M: x86 %shr-imm 2operand SHR ;
|
||||||
|
M: x86 %sar-imm 2operand SAR ;
|
||||||
|
M: x86 %not 1operand NOT ;
|
||||||
|
|
||||||
|
: bignum@ ( reg n -- op )
|
||||||
|
cells bignum tag-number - [+] ; inline
|
||||||
|
|
||||||
|
M:: x86 %integer>bignum ( dst src temp -- )
|
||||||
|
#! on entry, inreg is a signed 32-bit quantity
|
||||||
|
#! exits with tagged ptr to bignum in outreg
|
||||||
|
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
||||||
|
#! length is the # of digits + sign
|
||||||
|
[
|
||||||
|
{ "end" "nonzero" "positive" } [ define-label ] each
|
||||||
|
src 0 CMP ! is it zero?
|
||||||
|
"nonzero" get JNE
|
||||||
|
! Use cached zero value
|
||||||
|
dst 0 >bignum %load-indirect
|
||||||
|
"end" get JMP
|
||||||
|
"nonzero" resolve-label
|
||||||
|
! Allocate a bignum
|
||||||
|
dst 4 cells bignum bignum temp %allot
|
||||||
|
! Write length
|
||||||
|
dst 1 bignum@ 2 tag-fixnum MOV
|
||||||
|
! Test sign
|
||||||
|
src 0 CMP
|
||||||
|
"positive" get JGE
|
||||||
|
dst 2 bignum@ 1 MOV ! negative sign
|
||||||
|
src NEG
|
||||||
|
dst 3 bignum@ src MOV
|
||||||
|
src NEG ! we don't want to clobber src
|
||||||
|
"end" get JMP
|
||||||
|
"positive" resolve-label
|
||||||
|
dst 2 bignum@ 0 MOV ! positive sign
|
||||||
|
dst 3 bignum@ src MOV
|
||||||
|
"end" resolve-label
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
M:: x86 %bignum>integer ( dst src -- )
|
||||||
|
[
|
||||||
|
"nonzero" define-label
|
||||||
|
"positive" define-label
|
||||||
|
"end" define-label
|
||||||
|
dst src 1 bignum@ MOV
|
||||||
|
! if the length is 1, its just the sign and nothing else,
|
||||||
|
! so output 0
|
||||||
|
dst 1 tag-fixnum CMP
|
||||||
|
"nonzero" get JNE
|
||||||
|
dst 0 MOV
|
||||||
|
"end" get JMP
|
||||||
|
"nonzero" resolve-label
|
||||||
|
! load the value
|
||||||
|
dst src 3 bignum@ MOV
|
||||||
|
! is the sign negative?
|
||||||
|
src 2 bignum@ 0 CMP
|
||||||
|
"positive" get JE
|
||||||
|
dst -1 IMUL2
|
||||||
|
"positive" resolve-label
|
||||||
|
dst 3 SHL
|
||||||
|
"end" resolve-label
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
M: x86 %add-float 2operand ADDSD ;
|
||||||
|
M: x86 %sub-float 2operand SUBSD ;
|
||||||
|
M: x86 %mul-float 2operand MULSD ;
|
||||||
|
M: x86 %div-float 2operand DIVSD ;
|
||||||
|
|
||||||
|
M: x86 %integer>float CVTTSD2SI ;
|
||||||
|
M: x86 %float>integer CVTSI2SD ;
|
||||||
|
|
||||||
|
M: x86 %copy ( dst src -- ) MOV ;
|
||||||
|
|
||||||
|
M: x86 %copy-float MOVSD ;
|
||||||
|
|
||||||
|
M: x86 %unbox-float ( dst src -- )
|
||||||
|
float-offset [+] MOVSD ;
|
||||||
|
|
||||||
|
M:: x86 %unbox-any-c-ptr ( dst src dst temp -- )
|
||||||
|
[
|
||||||
|
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||||
|
dst 0 MOV
|
||||||
|
temp src MOV
|
||||||
|
! We come back here with displaced aliens
|
||||||
|
"start" resolve-label
|
||||||
|
! Is the object f?
|
||||||
|
temp \ f tag-number CMP
|
||||||
|
"end" get JE
|
||||||
|
! Is the object an alien?
|
||||||
|
temp header-offset [+] alien type-number tag-fixnum CMP
|
||||||
|
"is-byte-array" get JNE
|
||||||
|
! If so, load the offset and add it to the address
|
||||||
|
dst temp alien-offset [+] ADD
|
||||||
|
! Now recurse on the underlying alien
|
||||||
|
temp temp underlying-alien-offset [+] MOV
|
||||||
|
"start" get JMP
|
||||||
|
"is-byte-array" resolve-label
|
||||||
|
! Add byte array address to address being computed
|
||||||
|
dst temp ADD
|
||||||
|
! Add an offset to start of byte array's data
|
||||||
|
dst byte-array-offset ADD
|
||||||
|
"end" resolve-label
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
M:: x86 %box-float ( dst src temp -- )
|
||||||
|
dst 16 float float temp %allot
|
||||||
|
dst 8 float tag-number - [+] src MOVSD ;
|
||||||
|
|
||||||
|
: alien@ ( reg n -- op ) cells object tag-number - [+] ;
|
||||||
|
|
||||||
|
M:: x86 %box-alien ( dst src temp -- )
|
||||||
|
[
|
||||||
|
{ "end" "f" } [ define-label ] each
|
||||||
|
src 0 CMP
|
||||||
|
"f" get JE
|
||||||
|
dst 4 cells alien object temp %allot
|
||||||
|
dst 1 alien@ \ f tag-number MOV
|
||||||
|
dst 2 alien@ \ f tag-number MOV
|
||||||
|
! Store src in alien-offset slot
|
||||||
|
dst 3 alien@ src MOV
|
||||||
|
"end" get JMP
|
||||||
|
"f" resolve-label
|
||||||
|
dst \ f tag-number MOV
|
||||||
|
"end" resolve-label
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
: small-reg-4 ( reg -- reg' )
|
||||||
|
H{
|
||||||
|
{ EAX EAX }
|
||||||
|
{ ECX ECX }
|
||||||
|
{ EDX EDX }
|
||||||
|
{ EBX EBX }
|
||||||
|
{ ESP ESP }
|
||||||
|
{ EBP EBP }
|
||||||
|
{ ESI ESP }
|
||||||
|
{ EDI EDI }
|
||||||
|
|
||||||
|
{ RAX EAX }
|
||||||
|
{ RCX ECX }
|
||||||
|
{ RDX EDX }
|
||||||
|
{ RBX EBX }
|
||||||
|
{ RSP ESP }
|
||||||
|
{ RBP EBP }
|
||||||
|
{ RSI ESP }
|
||||||
|
{ RDI EDI }
|
||||||
|
} at ; inline
|
||||||
|
|
||||||
|
: small-reg-2 ( reg -- reg' )
|
||||||
|
small-reg-4 H{
|
||||||
|
{ EAX AX }
|
||||||
|
{ ECX CX }
|
||||||
|
{ EDX DX }
|
||||||
|
{ EBX BX }
|
||||||
|
{ ESP SP }
|
||||||
|
{ EBP BP }
|
||||||
|
{ ESI SI }
|
||||||
|
{ EDI DI }
|
||||||
|
} at ; inline
|
||||||
|
|
||||||
|
: small-reg-1 ( reg -- reg' )
|
||||||
|
small-reg-4 {
|
||||||
|
{ EAX AL }
|
||||||
|
{ ECX CL }
|
||||||
|
{ EDX DL }
|
||||||
|
{ EBX BL }
|
||||||
|
} at ; inline
|
||||||
|
|
||||||
|
: small-reg ( reg size -- reg' )
|
||||||
|
{
|
||||||
|
{ 1 small-reg-1 }
|
||||||
|
{ 2 small-reg-2 }
|
||||||
|
{ 4 small-reg-4 }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
|
||||||
|
|
||||||
|
: small-reg-that-isn't ( exclude -- reg' )
|
||||||
|
small-reg-4 small-regs [ eq? not ] with find nip ;
|
||||||
|
|
||||||
|
: with-save/restore ( reg quot -- )
|
||||||
|
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
|
||||||
|
|
||||||
|
:: with-small-register ( dst src quot: ( dst src -- ) -- )
|
||||||
|
#! If the destination register overlaps a small register, we
|
||||||
|
#! call the quot with that. Otherwise, we find a small
|
||||||
|
#! register that is not equal to src, and call quot, saving
|
||||||
|
#! and restoring the small register.
|
||||||
|
dst small-regs memq? [ src quot call ] [
|
||||||
|
src small-reg-that-isn't
|
||||||
|
[ src quot call ]
|
||||||
|
with-save/restore
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
: %alien-integer-getter ( dst src size quot -- )
|
||||||
|
'[ [ _ small-reg ] dip @ ] with-small-register ; inline
|
||||||
|
|
||||||
|
: %alien-unsigned-getter ( dst src size -- )
|
||||||
|
[ MOVZX ] %alien-integer-getter ; inline
|
||||||
|
|
||||||
|
M: x86 %alien-unsigned-1 1 %alien-unsigned-getter ;
|
||||||
|
M: x86 %alien-unsigned-2 2 %alien-unsigned-getter ;
|
||||||
|
M: x86 %alien-unsigned-4 4 %alien-unsigned-getter ;
|
||||||
|
|
||||||
|
: %alien-signed-getter ( dst src size -- )
|
||||||
|
[ MOVSX ] %alien-integer-getter ; inline
|
||||||
|
|
||||||
|
M: x86 %alien-signed-1 1 %alien-signed-getter ;
|
||||||
|
M: x86 %alien-signed-2 2 %alien-signed-getter ;
|
||||||
|
M: x86 %alien-signed-4 4 %alien-signed-getter ;
|
||||||
|
|
||||||
|
M: x86 %alien-cell [] MOV ;
|
||||||
|
M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
|
||||||
|
M: x86 %alien-double [] MOVSD ;
|
||||||
|
|
||||||
|
:: %alien-integer-setter ( ptr value size -- )
|
||||||
|
value ptr [| new-value ptr |
|
||||||
|
new-value value ?MOV
|
||||||
|
ptr [] new-value size small-reg MOV
|
||||||
|
] with-small-register ; inline
|
||||||
|
|
||||||
|
M: x86 %set-alien-integer-1 1 %alien-integer-setter ;
|
||||||
|
M: x86 %set-alien-integer-2 2 %alien-integer-setter ;
|
||||||
|
M: x86 %set-alien-integer-4 4 %alien-integer-setter ;
|
||||||
|
M: x86 %set-alien-cell [ [] ] dip MOV ;
|
||||||
|
M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
|
||||||
|
M: x86 %set-alien-double [ [] ] dip MOVSD ;
|
||||||
|
|
||||||
|
: load-zone-ptr ( reg -- )
|
||||||
|
#! Load pointer to start of zone array
|
||||||
|
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
||||||
|
|
||||||
|
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||||
|
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
|
||||||
|
|
||||||
|
: inc-allot-ptr ( nursery-ptr n -- )
|
||||||
|
[ cell [+] ] dip 8 align ADD ;
|
||||||
|
|
||||||
|
: store-header ( temp type -- )
|
||||||
|
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||||
|
|
||||||
|
: store-tagged ( dst tag -- )
|
||||||
|
tag-number OR ;
|
||||||
|
|
||||||
|
M:: x86 %allot ( dst size type tag nursery-ptr -- )
|
||||||
|
nursery-ptr dst load-allot-ptr
|
||||||
|
dst type store-header
|
||||||
|
dst tag store-tagged
|
||||||
|
nursery-ptr size inc-allot-ptr ;
|
||||||
|
|
||||||
|
HOOK: %alien-global cpu ( symbol dll register -- )
|
||||||
|
|
||||||
|
M:: x86 %write-barrier ( src card# table -- )
|
||||||
|
#! Mark the card pointed to by vreg.
|
||||||
|
! Mark the card
|
||||||
|
card# src MOV
|
||||||
|
card# card-bits SHR
|
||||||
|
"cards_offset" f table %alien-global
|
||||||
|
table card# [+] card-mark <byte> MOV
|
||||||
|
|
||||||
|
! Mark the card deck
|
||||||
|
card# deck-bits card-bits - SHR
|
||||||
|
"decks_offset" f table %alien-global
|
||||||
|
table card# [+] card-mark <byte> MOV ;
|
||||||
|
|
||||||
|
M: x86 %gc ( -- )
|
||||||
|
"end" define-label
|
||||||
|
temp-reg-1 load-zone-ptr
|
||||||
|
temp-reg-2 temp-reg-1 cell [+] MOV
|
||||||
|
temp-reg-2 1024 ADD
|
||||||
|
temp-reg-1 temp-reg-1 3 cells [+] MOV
|
||||||
|
temp-reg-2 temp-reg-1 CMP
|
||||||
|
"end" get JLE
|
||||||
|
%prepare-alien-invoke
|
||||||
|
"minor_gc" f %alien-invoke
|
||||||
|
"end" resolve-label ;
|
||||||
|
|
||||||
HOOK: stack-reg cpu ( -- reg )
|
HOOK: stack-reg cpu ( -- reg )
|
||||||
|
|
||||||
|
: decr-stack-reg ( n -- )
|
||||||
|
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
|
||||||
|
|
||||||
|
M: x86 %prologue ( n -- )
|
||||||
|
temp-reg-1 0 MOV rc-absolute-cell rel-this
|
||||||
|
dup PUSH
|
||||||
|
temp-reg-1 PUSH
|
||||||
|
stack-reg swap 3 cells - SUB ;
|
||||||
|
|
||||||
|
: incr-stack-reg ( n -- )
|
||||||
|
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
|
||||||
|
|
||||||
|
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
||||||
|
|
||||||
|
M: x86 %compare-branch ( label cc src1 src2 -- )
|
||||||
|
CMP {
|
||||||
|
{ cc< [ JL ] }
|
||||||
|
{ cc<= [ JLE ] }
|
||||||
|
{ cc> [ JG ] }
|
||||||
|
{ cc>= [ JGE ] }
|
||||||
|
{ cc= [ JE ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
M: x86 %compare-imm-branch ( label src1 src2 cc -- )
|
||||||
|
%compare-branch ;
|
||||||
|
|
||||||
|
M: x86 %compare-float-branch ( label cc src1 src2 -- )
|
||||||
|
UCOMISD {
|
||||||
|
{ cc< [ JB ] }
|
||||||
|
{ cc<= [ JBE ] }
|
||||||
|
{ cc> [ JA ] }
|
||||||
|
{ cc>= [ JAE ] }
|
||||||
|
{ cc= [ JE ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
: stack@ ( n -- op ) stack-reg swap [+] ;
|
: stack@ ( n -- op ) stack-reg swap [+] ;
|
||||||
|
|
||||||
: spill-integer-base ( stack-frame -- n )
|
: spill-integer-base ( stack-frame -- n )
|
||||||
|
|
@ -34,19 +434,11 @@ HOOK: stack-reg cpu ( -- reg )
|
||||||
stack-frame get spill-float-base
|
stack-frame get spill-float-base
|
||||||
+ stack@ ;
|
+ stack@ ;
|
||||||
|
|
||||||
: next-stack@ ( n -- operand )
|
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
|
||||||
#! nth parameter from the next stack frame. Used to box
|
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
|
||||||
#! input values to callbacks; the callback has its own
|
|
||||||
#! stack frame set up, and we want to read the frame
|
|
||||||
#! set up by the caller.
|
|
||||||
stack-frame get total-size>> + stack@ ;
|
|
||||||
|
|
||||||
: reg-stack ( n reg -- op ) swap cells neg [+] ;
|
M: x86 %spill-float spill-float@ swap MOVSD ;
|
||||||
|
M: x86 %reload-float spill-float@ MOVSD ;
|
||||||
GENERIC: loc>operand ( loc -- operand )
|
|
||||||
|
|
||||||
M: ds-loc loc>operand n>> ds-reg reg-stack ;
|
|
||||||
M: rs-loc loc>operand n>> rs-reg reg-stack ;
|
|
||||||
|
|
||||||
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
|
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
|
||||||
M: int-regs %load-param-reg drop swap stack@ MOV ;
|
M: int-regs %load-param-reg drop swap stack@ MOV ;
|
||||||
|
|
@ -54,7 +446,6 @@ M: int-regs %load-param-reg drop swap stack@ MOV ;
|
||||||
GENERIC: MOVSS/D ( dst src reg-class -- )
|
GENERIC: MOVSS/D ( dst src reg-class -- )
|
||||||
|
|
||||||
M: single-float-regs MOVSS/D drop MOVSS ;
|
M: single-float-regs MOVSS/D drop MOVSS ;
|
||||||
|
|
||||||
M: double-float-regs MOVSS/D drop MOVSD ;
|
M: double-float-regs MOVSS/D drop MOVSD ;
|
||||||
|
|
||||||
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
|
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
|
||||||
|
|
@ -64,42 +455,6 @@ GENERIC: push-return-reg ( reg-class -- )
|
||||||
GENERIC: load-return-reg ( n reg-class -- )
|
GENERIC: load-return-reg ( n reg-class -- )
|
||||||
GENERIC: store-return-reg ( n reg-class -- )
|
GENERIC: store-return-reg ( n reg-class -- )
|
||||||
|
|
||||||
! Only used by inline allocation
|
|
||||||
HOOK: temp-reg-1 cpu ( -- reg )
|
|
||||||
HOOK: temp-reg-2 cpu ( -- reg )
|
|
||||||
|
|
||||||
HOOK: fixnum>slot@ cpu ( op -- )
|
|
||||||
HOOK: prepare-division cpu ( -- )
|
|
||||||
|
|
||||||
M: x86 %load-immediate MOV ;
|
|
||||||
|
|
||||||
: align-stack ( n -- n' )
|
|
||||||
os macosx? cpu x86.64? or [ 16 align ] when ;
|
|
||||||
|
|
||||||
M: x86 stack-frame-size ( stack-frame -- i )
|
|
||||||
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
|
|
||||||
[ params>> ]
|
|
||||||
[ return>> ]
|
|
||||||
tri + +
|
|
||||||
3 cells +
|
|
||||||
align-stack ;
|
|
||||||
|
|
||||||
: decr-stack-reg ( n -- )
|
|
||||||
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
|
|
||||||
|
|
||||||
M: x86 %prologue ( n -- )
|
|
||||||
temp-reg-1 0 MOV rc-absolute-cell rel-this
|
|
||||||
dup PUSH
|
|
||||||
temp-reg-1 PUSH
|
|
||||||
stack-reg swap 3 cells - SUB ;
|
|
||||||
|
|
||||||
: incr-stack-reg ( n -- )
|
|
||||||
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
|
|
||||||
|
|
||||||
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
|
||||||
|
|
||||||
HOOK: %alien-global cpu ( symbol dll register -- )
|
|
||||||
|
|
||||||
M: x86 %prepare-alien-invoke
|
M: x86 %prepare-alien-invoke
|
||||||
#! Save Factor stack pointers in case the C code calls a
|
#! Save Factor stack pointers in case the C code calls a
|
||||||
#! callback which does a GC, which must reliably trace
|
#! callback which does a GC, which must reliably trace
|
||||||
|
|
@ -110,52 +465,6 @@ M: x86 %prepare-alien-invoke
|
||||||
temp-reg-1 2 cells [+] ds-reg MOV
|
temp-reg-1 2 cells [+] ds-reg MOV
|
||||||
temp-reg-1 3 cells [+] rs-reg MOV ;
|
temp-reg-1 3 cells [+] rs-reg MOV ;
|
||||||
|
|
||||||
M: x86 %call ( label -- ) CALL ;
|
|
||||||
|
|
||||||
M: x86 %jump-label ( label -- ) JMP ;
|
|
||||||
|
|
||||||
! M: x86 %jump-f ( label reg -- )
|
|
||||||
! \ f tag-number CMP JE ;
|
|
||||||
!
|
|
||||||
! M: x86 %jump-t ( label reg -- )
|
|
||||||
! \ f tag-number CMP JNE ;
|
|
||||||
|
|
||||||
: code-alignment ( -- n )
|
|
||||||
building get length dup cell align swap - ;
|
|
||||||
|
|
||||||
: align-code ( n -- )
|
|
||||||
0 <repetition> % ;
|
|
||||||
|
|
||||||
M:: x86 %dispatch ( src temp -- )
|
|
||||||
! Load jump table base. We use a temporary register
|
|
||||||
! since on AMD64 we have to load a 64-bit immediate. On
|
|
||||||
! x86, this is redundant.
|
|
||||||
! Untag and multiply to get a jump table offset
|
|
||||||
src fixnum>slot@
|
|
||||||
! Add jump table base
|
|
||||||
temp HEX: ffffffff MOV rc-absolute-cell rel-here
|
|
||||||
src temp ADD
|
|
||||||
src HEX: 7f [+] JMP
|
|
||||||
! Fix up the displacement above
|
|
||||||
code-alignment dup bootstrap-cell 8 = 15 9 ? +
|
|
||||||
building get dup pop* push
|
|
||||||
align-code ;
|
|
||||||
|
|
||||||
M: x86 %dispatch-label ( word -- )
|
|
||||||
0 cell, rc-absolute-cell rel-word ;
|
|
||||||
|
|
||||||
M: x86 %peek loc>operand MOV ;
|
|
||||||
|
|
||||||
M: x86 %replace loc>operand swap MOV ;
|
|
||||||
|
|
||||||
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
|
|
||||||
|
|
||||||
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
|
|
||||||
|
|
||||||
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
|
|
||||||
|
|
||||||
M: x86 %copy ( dst src -- ) MOV ;
|
|
||||||
|
|
||||||
M: x86 fp-shadows-int? ( -- ? ) f ;
|
M: x86 fp-shadows-int? ( -- ? ) f ;
|
||||||
|
|
||||||
M: x86 value-structs? t ;
|
M: x86 value-structs? t ;
|
||||||
|
|
@ -163,60 +472,9 @@ M: x86 value-structs? t ;
|
||||||
M: x86 small-enough? ( n -- ? )
|
M: x86 small-enough? ( n -- ? )
|
||||||
HEX: -80000000 HEX: 7fffffff between? ;
|
HEX: -80000000 HEX: 7fffffff between? ;
|
||||||
|
|
||||||
: %untag ( reg -- ) tag-mask get bitnot AND ;
|
: next-stack@ ( n -- operand )
|
||||||
|
#! nth parameter from the next stack frame. Used to box
|
||||||
: %untag-fixnum ( reg -- ) tag-bits get SAR ;
|
#! input values to callbacks; the callback has its own
|
||||||
|
#! stack frame set up, and we want to read the frame
|
||||||
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
|
#! set up by the caller.
|
||||||
|
stack-frame get total-size>> + stack@ ;
|
||||||
M: x86 %return ( -- ) 0 RET ;
|
|
||||||
|
|
||||||
! Alien intrinsics
|
|
||||||
M: x86 %unbox-byte-array ( dst src -- )
|
|
||||||
byte-array-offset [+] LEA ;
|
|
||||||
|
|
||||||
M: x86 %unbox-alien ( dst src -- )
|
|
||||||
alien-offset [+] MOV ;
|
|
||||||
|
|
||||||
M: x86 %unbox-f ( dst src -- )
|
|
||||||
drop 0 MOV ;
|
|
||||||
|
|
||||||
M: x86 %unbox-any-c-ptr ( dst src -- )
|
|
||||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
|
||||||
! Address is computed in ds-reg
|
|
||||||
ds-reg PUSH
|
|
||||||
ds-reg 0 MOV
|
|
||||||
! Object is stored in ds-reg
|
|
||||||
rs-reg PUSH
|
|
||||||
rs-reg swap MOV
|
|
||||||
! We come back here with displaced aliens
|
|
||||||
"start" resolve-label
|
|
||||||
! Is the object f?
|
|
||||||
rs-reg \ f tag-number CMP
|
|
||||||
"end" get JE
|
|
||||||
! Is the object an alien?
|
|
||||||
rs-reg header-offset [+] alien type-number tag-fixnum CMP
|
|
||||||
"is-byte-array" get JNE
|
|
||||||
! If so, load the offset and add it to the address
|
|
||||||
ds-reg rs-reg alien-offset [+] ADD
|
|
||||||
! Now recurse on the underlying alien
|
|
||||||
rs-reg rs-reg underlying-alien-offset [+] MOV
|
|
||||||
"start" get JMP
|
|
||||||
"is-byte-array" resolve-label
|
|
||||||
! Add byte array address to address being computed
|
|
||||||
ds-reg rs-reg ADD
|
|
||||||
! Add an offset to start of byte array's data
|
|
||||||
ds-reg byte-array-offset ADD
|
|
||||||
"end" resolve-label
|
|
||||||
! Done, store address in destination register
|
|
||||||
ds-reg MOV
|
|
||||||
! Restore rs-reg
|
|
||||||
rs-reg POP
|
|
||||||
! Restore ds-reg
|
|
||||||
ds-reg POP ;
|
|
||||||
|
|
||||||
M: x86 %spill-integer ( src n -- )
|
|
||||||
spill-integer@ swap MOV ;
|
|
||||||
|
|
||||||
M: x86 %reload-integer ( dst n -- )
|
|
||||||
spill-integer@ MOV ;
|
|
||||||
|
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
||||||
|
|
@ -1,328 +0,0 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: accessors arrays byte-arrays alien.accessors kernel
|
|
||||||
kernel.private math memory namespaces make sequences words
|
|
||||||
system layouts combinators math.order math.private alien
|
|
||||||
alien.c-types slots.private locals fry cpu.architecture
|
|
||||||
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.architecture
|
|
||||||
compiler.codegen.fixup compiler.constants compiler.intrinsics
|
|
||||||
compiler.cfg.builder compiler.cfg.registers compiler.cfg.stacks
|
|
||||||
compiler.cfg.templates compiler.codegen ;
|
|
||||||
IN: cpu.x86.intrinsics
|
|
||||||
|
|
||||||
! Type checks
|
|
||||||
\ tag [
|
|
||||||
"in" operand tag-mask get AND
|
|
||||||
"in" operand %tag-fixnum
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "in" } } }
|
|
||||||
{ output { "in" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
! Slots
|
|
||||||
: %constant-slot ( -- op )
|
|
||||||
"obj" operand
|
|
||||||
"n" literal cells "tag" literal - [+] ;
|
|
||||||
|
|
||||||
: %computed-slot ( -- op )
|
|
||||||
"n" operand fixnum>slot@
|
|
||||||
"n" operand "obj" operand ADD
|
|
||||||
"n" operand "tag" literal neg [+] ;
|
|
||||||
|
|
||||||
\ (slot) {
|
|
||||||
{
|
|
||||||
[ "val" operand %constant-slot MOV ] T{ template
|
|
||||||
{ input { { f "obj" } { small-slot "n" } { small-slot "tag" } } }
|
|
||||||
{ scratch { { f "val" } } }
|
|
||||||
{ output { "val" } }
|
|
||||||
}
|
|
||||||
}
|
|
||||||
{
|
|
||||||
[ "val" operand %computed-slot MOV ] T{ template
|
|
||||||
{ input { { f "obj" } { f "n" } { small-slot "tag" } } }
|
|
||||||
{ scratch { { f "val" } } }
|
|
||||||
{ output { "val" } }
|
|
||||||
{ clobber { "n" } }
|
|
||||||
}
|
|
||||||
}
|
|
||||||
} define-intrinsics
|
|
||||||
|
|
||||||
\ (set-slot) {
|
|
||||||
{
|
|
||||||
[ %constant-slot "val" operand MOV ] T{ template
|
|
||||||
{ input { { f "val" } { f "obj" } { small-slot "n" } { small-slot "tag" } } }
|
|
||||||
}
|
|
||||||
}
|
|
||||||
{
|
|
||||||
[ %computed-slot "val" operand MOV ] T{ template
|
|
||||||
{ input { { f "val" } { f "obj" } { f "n" } { small-slot "tag" } } }
|
|
||||||
{ clobber { "n" } }
|
|
||||||
}
|
|
||||||
}
|
|
||||||
} define-intrinsics
|
|
||||||
|
|
||||||
! Fixnums
|
|
||||||
: fixnum-op ( op hash -- pair )
|
|
||||||
>r [ "x" operand "y" operand ] swap suffix r> 2array ;
|
|
||||||
|
|
||||||
: fixnum-value-op ( op -- pair )
|
|
||||||
T{ template
|
|
||||||
{ input { { f "x" } { small-tagged "y" } } }
|
|
||||||
{ output { "x" } }
|
|
||||||
} fixnum-op ;
|
|
||||||
|
|
||||||
: fixnum-register-op ( op -- pair )
|
|
||||||
T{ template
|
|
||||||
{ input { { f "x" } { f "y" } } }
|
|
||||||
{ output { "x" } }
|
|
||||||
} fixnum-op ;
|
|
||||||
|
|
||||||
: define-fixnum-op ( word op -- )
|
|
||||||
[ fixnum-value-op ] keep fixnum-register-op
|
|
||||||
2array define-intrinsics ;
|
|
||||||
|
|
||||||
{
|
|
||||||
{ fixnum+fast ADD }
|
|
||||||
{ fixnum-fast SUB }
|
|
||||||
{ fixnum-bitand AND }
|
|
||||||
{ fixnum-bitor OR }
|
|
||||||
{ fixnum-bitxor XOR }
|
|
||||||
} [
|
|
||||||
first2 define-fixnum-op
|
|
||||||
] each
|
|
||||||
|
|
||||||
\ fixnum-bitnot [
|
|
||||||
"x" operand NOT
|
|
||||||
"x" operand tag-mask get XOR
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "x" } } }
|
|
||||||
{ output { "x" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ fixnum*fast {
|
|
||||||
{
|
|
||||||
[
|
|
||||||
"x" operand "y" literal IMUL2
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "x" } { small-tagged "y" } } }
|
|
||||||
{ output { "x" } }
|
|
||||||
}
|
|
||||||
} {
|
|
||||||
[
|
|
||||||
"out" operand "x" operand MOV
|
|
||||||
"out" operand %untag-fixnum
|
|
||||||
"y" operand "out" operand IMUL2
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "x" } { f "y" } } }
|
|
||||||
{ scratch { { f "out" } } }
|
|
||||||
{ output { "out" } }
|
|
||||||
}
|
|
||||||
}
|
|
||||||
} define-intrinsics
|
|
||||||
|
|
||||||
\ fixnum-shift-fast [
|
|
||||||
"x" operand "y" literal
|
|
||||||
dup 0 < [ neg SAR ] [ SHL ] if
|
|
||||||
! Mask off low bits
|
|
||||||
"x" operand %untag
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "x" } { small-tagged "y" } } }
|
|
||||||
{ output { "x" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
: fixnum-jump ( op inputs -- pair )
|
|
||||||
>r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
|
|
||||||
|
|
||||||
: fixnum-value-jump ( op -- pair )
|
|
||||||
{ { f "x" } { small-tagged "y" } } fixnum-jump ;
|
|
||||||
|
|
||||||
: fixnum-register-jump ( op -- pair )
|
|
||||||
{ { f "x" } { f "y" } } fixnum-jump ;
|
|
||||||
|
|
||||||
: define-fixnum-jump ( word op -- )
|
|
||||||
[ fixnum-value-jump ] [ fixnum-register-jump ] bi
|
|
||||||
2array define-if-intrinsics ;
|
|
||||||
|
|
||||||
{
|
|
||||||
{ fixnum< JL }
|
|
||||||
{ fixnum<= JLE }
|
|
||||||
{ fixnum> JG }
|
|
||||||
{ fixnum>= JGE }
|
|
||||||
{ eq? JE }
|
|
||||||
} [
|
|
||||||
first2 define-fixnum-jump
|
|
||||||
] each
|
|
||||||
|
|
||||||
\ bignum>fixnum [
|
|
||||||
"nonzero" define-label
|
|
||||||
"positive" define-label
|
|
||||||
"end" define-label
|
|
||||||
"x" operand %untag
|
|
||||||
"y" operand "x" operand cell [+] MOV
|
|
||||||
! if the length is 1, its just the sign and nothing else,
|
|
||||||
! so output 0
|
|
||||||
"y" operand 1 tag-fixnum CMP
|
|
||||||
"nonzero" get JNE
|
|
||||||
"y" operand 0 MOV
|
|
||||||
"end" get JMP
|
|
||||||
"nonzero" resolve-label
|
|
||||||
! load the value
|
|
||||||
"y" operand "x" operand 3 cells [+] MOV
|
|
||||||
! load the sign
|
|
||||||
"x" operand "x" operand 2 cells [+] MOV
|
|
||||||
! is the sign negative?
|
|
||||||
"x" operand 0 CMP
|
|
||||||
"positive" get JE
|
|
||||||
"y" operand -1 IMUL2
|
|
||||||
"positive" resolve-label
|
|
||||||
"y" operand 3 SHL
|
|
||||||
"end" resolve-label
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "x" } } }
|
|
||||||
{ scratch { { f "y" } } }
|
|
||||||
{ clobber { "x" } }
|
|
||||||
{ output { "y" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
! User environment
|
|
||||||
: %userenv ( -- )
|
|
||||||
"x" operand 0 MOV
|
|
||||||
"userenv" f rc-absolute-cell rel-dlsym
|
|
||||||
"n" operand fixnum>slot@
|
|
||||||
"n" operand "x" operand ADD ;
|
|
||||||
|
|
||||||
\ getenv [
|
|
||||||
%userenv "n" operand dup [] MOV
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "n" } } }
|
|
||||||
{ scratch { { f "x" } } }
|
|
||||||
{ output { "n" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ setenv [
|
|
||||||
%userenv "n" operand [] "val" operand MOV
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "val" } { f "n" } } }
|
|
||||||
{ scratch { { f "x" } } }
|
|
||||||
{ clobber { "n" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
! Alien intrinsics
|
|
||||||
|
|
||||||
! Sometimes, we need to do stuff with operands which are
|
|
||||||
! less than the word size. Instead of teaching the register
|
|
||||||
! allocator about the different sized registers, with all
|
|
||||||
! the complexity this entails, we just push/pop a register
|
|
||||||
! which is guaranteed to be unused (the tempreg)
|
|
||||||
: small-reg cell 8 = RDX EDX ? ; inline
|
|
||||||
: small-reg-8 DL ; inline
|
|
||||||
: small-reg-16 DX ; inline
|
|
||||||
: small-reg-32 EDX ; inline
|
|
||||||
|
|
||||||
: %prepare-alien-accessor ( -- )
|
|
||||||
"offset" operand %untag-fixnum
|
|
||||||
"offset" operand "alien" operand ADD ;
|
|
||||||
|
|
||||||
:: (%alien-integer-get) ( reg quot -- )
|
|
||||||
reg "offset" operand [] MOV
|
|
||||||
"value" operand reg quot call ; inline
|
|
||||||
|
|
||||||
: %alien-integer-get ( reg quot -- )
|
|
||||||
%prepare-alien-accessor
|
|
||||||
"value" operand small-reg = [
|
|
||||||
(%alien-integer-get)
|
|
||||||
] [
|
|
||||||
small-reg PUSH
|
|
||||||
(%alien-integer-get)
|
|
||||||
small-reg POP
|
|
||||||
] if
|
|
||||||
"value" operand %tag-fixnum ; inline
|
|
||||||
|
|
||||||
: alien-integer-get-template
|
|
||||||
T{ template
|
|
||||||
{ input {
|
|
||||||
{ unboxed-c-ptr "alien" c-ptr }
|
|
||||||
{ f "offset" fixnum }
|
|
||||||
} }
|
|
||||||
{ scratch { { f "value" } } }
|
|
||||||
{ output { "value" } }
|
|
||||||
{ clobber { "offset" } }
|
|
||||||
} ;
|
|
||||||
|
|
||||||
: define-getter ( word reg quot -- )
|
|
||||||
'[ _ _ %alien-integer-get ]
|
|
||||||
alien-integer-get-template
|
|
||||||
define-intrinsic ;
|
|
||||||
|
|
||||||
: define-unsigned-getter ( word reg -- )
|
|
||||||
[ MOVZX ] define-getter ;
|
|
||||||
|
|
||||||
: define-signed-getter ( word reg -- )
|
|
||||||
[ MOVSX ] define-getter ;
|
|
||||||
|
|
||||||
: %alien-integer-set ( reg -- )
|
|
||||||
"value" operand "offset" operand = [
|
|
||||||
"value" operand %untag-fixnum
|
|
||||||
] unless
|
|
||||||
%prepare-alien-accessor
|
|
||||||
small-reg "offset" operand = [
|
|
||||||
"value" operand "offset" operand XCHG
|
|
||||||
"value" operand [] swap MOV
|
|
||||||
] [
|
|
||||||
small-reg PUSH
|
|
||||||
small-reg "value" operand MOV
|
|
||||||
"offset" operand [] swap MOV
|
|
||||||
small-reg POP
|
|
||||||
] if ; inline
|
|
||||||
|
|
||||||
: alien-integer-set-template
|
|
||||||
T{ template
|
|
||||||
{ input {
|
|
||||||
{ f "value" fixnum }
|
|
||||||
{ unboxed-c-ptr "alien" c-ptr }
|
|
||||||
{ f "offset" fixnum }
|
|
||||||
} }
|
|
||||||
{ clobber { "value" "offset" } }
|
|
||||||
} ;
|
|
||||||
|
|
||||||
: define-setter ( word reg -- )
|
|
||||||
'[ _ %alien-integer-set ]
|
|
||||||
alien-integer-set-template
|
|
||||||
define-intrinsic ;
|
|
||||||
|
|
||||||
\ alien-unsigned-1 small-reg-8 define-unsigned-getter
|
|
||||||
\ set-alien-unsigned-1 small-reg-8 define-setter
|
|
||||||
|
|
||||||
\ alien-signed-1 small-reg-8 define-signed-getter
|
|
||||||
\ set-alien-signed-1 small-reg-8 define-setter
|
|
||||||
|
|
||||||
\ alien-unsigned-2 small-reg-16 define-unsigned-getter
|
|
||||||
\ set-alien-unsigned-2 small-reg-16 define-setter
|
|
||||||
|
|
||||||
\ alien-signed-2 small-reg-16 define-signed-getter
|
|
||||||
\ set-alien-signed-2 small-reg-16 define-setter
|
|
||||||
|
|
||||||
\ alien-cell [
|
|
||||||
%prepare-alien-accessor
|
|
||||||
"value" operand "offset" operand [] MOV
|
|
||||||
] T{ template
|
|
||||||
{ input {
|
|
||||||
{ unboxed-c-ptr "alien" c-ptr }
|
|
||||||
{ f "offset" fixnum }
|
|
||||||
} }
|
|
||||||
{ scratch { { unboxed-alien "value" } } }
|
|
||||||
{ output { "value" } }
|
|
||||||
{ clobber { "offset" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ set-alien-cell [
|
|
||||||
%prepare-alien-accessor
|
|
||||||
"offset" operand [] "value" operand MOV
|
|
||||||
] T{ template
|
|
||||||
{ input {
|
|
||||||
{ unboxed-c-ptr "value" pinned-c-ptr }
|
|
||||||
{ unboxed-c-ptr "alien" c-ptr }
|
|
||||||
{ f "offset" fixnum }
|
|
||||||
} }
|
|
||||||
{ clobber { "offset" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
||||||
|
|
@ -1,115 +0,0 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: alien alien.accessors arrays generic kernel
|
|
||||||
kernel.private math math.private memory namespaces sequences
|
|
||||||
words math.floats.private layouts quotations locals fry
|
|
||||||
system compiler.constants compiler.codegen compiler.cfg.templates
|
|
||||||
compiler.cfg.registers compiler.cfg.builder cpu.architecture
|
|
||||||
cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics ;
|
|
||||||
IN: cpu.x86.sse2
|
|
||||||
|
|
||||||
M: x86 %spill-float ( src n -- )
|
|
||||||
spill-float@ swap MOVSD ;
|
|
||||||
|
|
||||||
M: x86 %reload-float ( dst n -- )
|
|
||||||
spill-float@ MOVSD ;
|
|
||||||
|
|
||||||
M: x86 %copy-float MOVSD ;
|
|
||||||
|
|
||||||
M:: x86 %box-float ( dst src temp -- )
|
|
||||||
dst 16 float float temp %allot
|
|
||||||
dst 8 float tag-number - [+] src MOVSD ;
|
|
||||||
|
|
||||||
M: x86 %unbox-float ( dst src -- )
|
|
||||||
float-offset [+] MOVSD ;
|
|
||||||
|
|
||||||
: define-float-op ( word op -- )
|
|
||||||
[ "x" operand "y" operand ] swap suffix T{ template
|
|
||||||
{ input { { float "x" } { float "y" } } }
|
|
||||||
{ output { "x" } }
|
|
||||||
} define-intrinsic ;
|
|
||||||
|
|
||||||
{
|
|
||||||
{ float+ ADDSD }
|
|
||||||
{ float- SUBSD }
|
|
||||||
{ float* MULSD }
|
|
||||||
{ float/f DIVSD }
|
|
||||||
} [
|
|
||||||
first2 define-float-op
|
|
||||||
] each
|
|
||||||
|
|
||||||
: define-float-jump ( word op -- )
|
|
||||||
[ "x" operand "y" operand UCOMISD ] swap suffix
|
|
||||||
{ { float "x" } { float "y" } } define-if-intrinsic ;
|
|
||||||
|
|
||||||
{
|
|
||||||
{ float< JB }
|
|
||||||
{ float<= JBE }
|
|
||||||
{ float> JA }
|
|
||||||
{ float>= JAE }
|
|
||||||
{ float= JE }
|
|
||||||
} [
|
|
||||||
first2 define-float-jump
|
|
||||||
] each
|
|
||||||
|
|
||||||
\ float>fixnum [
|
|
||||||
"out" operand "in" operand CVTTSD2SI
|
|
||||||
"out" operand tag-bits get SHL
|
|
||||||
] T{ template
|
|
||||||
{ input { { float "in" } } }
|
|
||||||
{ scratch { { f "out" } } }
|
|
||||||
{ output { "out" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ fixnum>float [
|
|
||||||
"in" operand %untag-fixnum
|
|
||||||
"out" operand "in" operand CVTSI2SD
|
|
||||||
] T{ template
|
|
||||||
{ input { { f "in" } } }
|
|
||||||
{ scratch { { float "out" } } }
|
|
||||||
{ output { "out" } }
|
|
||||||
{ clobber { "in" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
: alien-float-get-template
|
|
||||||
T{ template
|
|
||||||
{ input {
|
|
||||||
{ unboxed-c-ptr "alien" c-ptr }
|
|
||||||
{ f "offset" fixnum }
|
|
||||||
} }
|
|
||||||
{ scratch { { float "value" } } }
|
|
||||||
{ output { "value" } }
|
|
||||||
{ clobber { "offset" } }
|
|
||||||
} ;
|
|
||||||
|
|
||||||
: alien-float-set-template
|
|
||||||
T{ template
|
|
||||||
{ input {
|
|
||||||
{ float "value" float }
|
|
||||||
{ unboxed-c-ptr "alien" c-ptr }
|
|
||||||
{ f "offset" fixnum }
|
|
||||||
} }
|
|
||||||
{ clobber { "offset" } }
|
|
||||||
} ;
|
|
||||||
|
|
||||||
: define-float-getter ( word get-quot -- )
|
|
||||||
'[
|
|
||||||
%prepare-alien-accessor
|
|
||||||
"value" operand "offset" operand [] @
|
|
||||||
]
|
|
||||||
alien-float-get-template
|
|
||||||
define-intrinsic ;
|
|
||||||
|
|
||||||
: define-float-setter ( word set-quot -- )
|
|
||||||
'[
|
|
||||||
%prepare-alien-accessor
|
|
||||||
"offset" operand [] "value" operand @
|
|
||||||
]
|
|
||||||
alien-float-set-template
|
|
||||||
define-intrinsic ;
|
|
||||||
|
|
||||||
\ alien-double [ MOVSD ] define-float-getter
|
|
||||||
\ set-alien-double [ MOVSD ] define-float-setter
|
|
||||||
|
|
||||||
\ alien-float [ dupd MOVSS dup CVTSS2SD ] define-float-getter
|
|
||||||
\ set-alien-float [ dup dup CVTSD2SS MOVSS ] define-float-setter
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
SSE2 floating point intrinsics for Pentium 4 and above
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
||||||
Loading…
Reference in New Issue