Update x86 backend for SSA codegen
Slava Pestov
parent
37cf7d9a9c
commit
508b1f52b8
|
|
@ -1,13 +1,12 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: locals alien.c-types arrays kernel kernel.private math
|
||||
namespaces sequences stack-checker.known-words system layouts io
|
||||
vocabs.loader accessors init combinators command-line
|
||||
cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics
|
||||
cpu.x86.allot cpu.architecture compiler compiler.units
|
||||
USING: locals alien.c-types alien.syntax arrays kernel
|
||||
math namespaces sequences system layouts io vocabs.loader
|
||||
accessors init combinators command-line cpu.x86.assembler
|
||||
cpu.x86.architecture cpu.architecture compiler compiler.units
|
||||
compiler.constants compiler.alien compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.builder
|
||||
compiler.cfg.instructions ;
|
||||
compiler.codegen.fixup compiler.cfg.instructions
|
||||
compiler.cfg.builder compiler.cfg.builder.calls ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
! 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-add ] [ drop ] bi* ] 2bi ; inline
|
||||
|
||||
M: x86.32 fixnum>slot@ 1 SHR ;
|
||||
|
||||
M: x86.32 prepare-division CDQ ;
|
||||
|
||||
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 ;
|
||||
|
||||
|
|
@ -222,7 +217,7 @@ M: x86.32 %alien-indirect ( -- )
|
|||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
4 [
|
||||
EAX load-indirect
|
||||
EAX %load-indirect
|
||||
EAX PUSH
|
||||
"c_to_factor" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
|
@ -279,34 +274,17 @@ os windows? [
|
|||
4 "double" c-type (>>align)
|
||||
] unless
|
||||
|
||||
: (sse2?) ( -- ? ) "Intrinsic" throw ;
|
||||
FUNCTION: bool check_sse2 ( ) ;
|
||||
|
||||
<<
|
||||
|
||||
\ (sse2?) [
|
||||
{ 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?) ;
|
||||
: sse2? ( -- ? )
|
||||
[ optimized-recompile-hook ] recompile-hook
|
||||
[ [ check_sse2 ] compile-call ] with-variable ;
|
||||
|
||||
"-no-sse2" cli-args member? [
|
||||
"Checking if your CPU supports SSE2..." print flush
|
||||
[ optimized-recompile-hook ] recompile-hook [
|
||||
[ sse2? ] compile-call
|
||||
] with-variable
|
||||
[
|
||||
sse2? [
|
||||
" - yes" print
|
||||
"cpu.x86.sse2" require
|
||||
enable-float-intrinsics
|
||||
[
|
||||
sse2? [
|
||||
"This image was built to use SSE2, which your CPU does not support." print
|
||||
|
|
@ -315,7 +293,5 @@ os windows? [
|
|||
1 exit
|
||||
] unless
|
||||
] "cpu.x86" add-init-hook
|
||||
] [
|
||||
" - no" print
|
||||
] if
|
||||
] [ " - no" print ] if
|
||||
] unless
|
||||
|
|
|
|||
|
|
@ -1,13 +1,12 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types arrays kernel kernel.private math
|
||||
namespaces make sequences system
|
||||
layouts alien alien.accessors alien.structs slots splitting
|
||||
assocs combinators cpu.x86.assembler
|
||||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
||||
cpu.x86.allot cpu.architecture compiler.constants
|
||||
compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
|
||||
compiler.cfg.builder ;
|
||||
USING: accessors arrays kernel math namespaces make sequences
|
||||
system layouts alien alien.c-types alien.accessors alien.structs
|
||||
slots splitting assocs combinators cpu.x86.assembler
|
||||
cpu.x86.architecture cpu.architecture compiler.constants
|
||||
compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
compiler.cfg.builder.calls ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
M: x86.64 machine-registers
|
||||
|
|
@ -33,12 +32,8 @@ M: float-regs return-reg drop XMM0 ;
|
|||
M: float-regs param-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
M: x86.64 fixnum>slot@ drop ;
|
||||
|
||||
M: x86.64 prepare-division CQO ;
|
||||
|
||||
M: x86.64 %load-indirect ( literal reg -- )
|
||||
swap 0 [] MOV rc-relative rel-literal ;
|
||||
M: x86.64 %load-indirect
|
||||
0 [] MOV rc-relative rel-literal ;
|
||||
|
||||
M: stack-params %load-param-reg
|
||||
drop
|
||||
|
|
@ -58,8 +53,8 @@ M: stack-params %save-param-reg
|
|||
] with-scope ; inline
|
||||
|
||||
! The ABI for passing structs by value is pretty messed up
|
||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
||||
stack-params "__stack_value" c-type (>>reg-class) >>
|
||||
"void*" c-type clone "__stack_value" define-primitive-type
|
||||
stack-params "__stack_value" c-type (>>reg-class)
|
||||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
|
|
@ -200,7 +195,7 @@ M: x86.64 %alien-indirect ( -- )
|
|||
RBP CALL ;
|
||||
|
||||
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 -- )
|
||||
! 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-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) ( -- )
|
||||
small-reg-32 "offset" operand [] MOV ; inline
|
||||
|
||||
: %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
|
||||
! SSE2 is always available on x86-64.
|
||||
enable-float-intrinsics
|
||||
|
|
|
|||
|
|
@ -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
|
||||
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
|
||||
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.cfg.instructions compiler.codegen
|
||||
compiler.codegen.fixup ;
|
||||
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: 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 )
|
||||
|
||||
: 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 [+] ;
|
||||
|
||||
: spill-integer-base ( stack-frame -- n )
|
||||
|
|
@ -34,19 +434,11 @@ HOOK: stack-reg cpu ( -- reg )
|
|||
stack-frame get spill-float-base
|
||||
+ stack@ ;
|
||||
|
||||
: next-stack@ ( n -- operand )
|
||||
#! nth parameter from the next stack frame. Used to box
|
||||
#! 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@ ;
|
||||
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
|
||||
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
|
||||
|
||||
: 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 %spill-float spill-float@ swap MOVSD ;
|
||||
M: x86 %reload-float spill-float@ MOVSD ;
|
||||
|
||||
M: int-regs %save-param-reg drop >r stack@ r> 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 -- )
|
||||
|
||||
M: single-float-regs MOVSS/D drop MOVSS ;
|
||||
|
||||
M: double-float-regs MOVSS/D drop MOVSD ;
|
||||
|
||||
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: 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
|
||||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! 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 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 value-structs? t ;
|
||||
|
|
@ -163,60 +472,9 @@ M: x86 value-structs? t ;
|
|||
M: x86 small-enough? ( n -- ? )
|
||||
HEX: -80000000 HEX: 7fffffff between? ;
|
||||
|
||||
: %untag ( reg -- ) tag-mask get bitnot AND ;
|
||||
|
||||
: %untag-fixnum ( reg -- ) tag-bits get SAR ;
|
||||
|
||||
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
|
||||
|
||||
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 ;
|
||||
: next-stack@ ( n -- operand )
|
||||
#! nth parameter from the next stack frame. Used to box
|
||||
#! 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@ ;
|
||||
|
|
|
|||
|
|
@ -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