Update x86 backend for SSA codegen

db4
Slava Pestov 2008-10-20 05:55:57 -05:00
parent 37cf7d9a9c
commit 508b1f52b8
13 changed files with 443 additions and 862 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -1 +0,0 @@
unportable

View File

@ -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@ ;

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -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

View File

@ -1 +0,0 @@
unportable

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -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

View File

@ -1 +0,0 @@
SSE2 floating point intrinsics for Pentium 4 and above

View File

@ -1 +0,0 @@
unportable