Backend updates
Slava Pestov
parent
e69278b8fc
commit
e6e313eba9
|
|
@ -5,12 +5,15 @@ memory namespaces make sequences layouts system hashtables
|
|||
classes alien byte-arrays combinators words sets ;
|
||||
IN: cpu.architecture
|
||||
|
||||
! Register classes
|
||||
SINGLETON: int-regs
|
||||
SINGLETON: single-float-regs
|
||||
SINGLETON: double-float-regs
|
||||
UNION: float-regs single-float-regs double-float-regs ;
|
||||
UNION: reg-class int-regs float-regs ;
|
||||
! Labels
|
||||
TUPLE: label offset ;
|
||||
|
||||
: <label> ( -- label ) label new ;
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
|
||||
|
||||
! Mapping from register class to machine registers
|
||||
HOOK: machine-registers cpu ( -- assoc )
|
||||
|
||||
! A pseudo-register class for parameters spilled on the stack
|
||||
SINGLETON: stack-params
|
||||
|
|
@ -29,7 +32,7 @@ M: object param-reg param-regs nth ;
|
|||
GENERIC: vregs ( register-class -- regs )
|
||||
|
||||
! Load a literal (immediate or indirect)
|
||||
GENERIC# load-literal 1 ( obj vreg -- )
|
||||
GENERIC# load-literal 1 ( obj reg -- )
|
||||
|
||||
HOOK: load-indirect cpu ( obj reg -- )
|
||||
|
||||
|
|
@ -40,21 +43,9 @@ TUPLE: stack-frame total-size size params return ;
|
|||
! Set up caller stack frame
|
||||
HOOK: %prologue cpu ( n -- )
|
||||
|
||||
: %prologue-later ( -- ) \ %prologue-later , ;
|
||||
|
||||
! Tear down stack frame
|
||||
HOOK: %epilogue cpu ( n -- )
|
||||
|
||||
: %epilogue-later ( -- ) \ %epilogue-later , ;
|
||||
|
||||
! Store word XT in stack frame
|
||||
HOOK: %save-word-xt cpu ( -- )
|
||||
|
||||
! Store dispatch branch XT in stack frame
|
||||
HOOK: %save-dispatch-xt cpu ( -- )
|
||||
|
||||
M: object %save-dispatch-xt %save-word-xt ;
|
||||
|
||||
! Call another word
|
||||
HOOK: %call cpu ( word -- )
|
||||
|
||||
|
|
@ -103,7 +94,7 @@ HOOK: small-enough? cpu ( n -- ? )
|
|||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: struct-small-enough? cpu ( heap-size -- ? )
|
||||
|
||||
! Do we pass explode value structs?
|
||||
! Do we pass value structs by value or hidden reference?
|
||||
HOOK: value-structs? cpu ( -- ? )
|
||||
|
||||
! If t, fp parameters are shadowed by dummy int parameters
|
||||
|
|
@ -158,12 +149,6 @@ M: stack-params param-reg drop ;
|
|||
|
||||
M: stack-params param-regs drop f ;
|
||||
|
||||
GENERIC: v>operand ( obj -- operand )
|
||||
|
||||
M: integer v>operand tag-fixnum ;
|
||||
|
||||
M: f v>operand drop \ f tag-number ;
|
||||
|
||||
M: object load-literal v>operand load-indirect ;
|
||||
|
||||
PREDICATE: small-slot < integer cells small-enough? ;
|
||||
|
|
@ -207,8 +192,3 @@ HOOK: %write-barrier cpu ( src temp -- )
|
|||
|
||||
! GC check
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
||||
: operand ( var -- op ) get v>operand ; inline
|
||||
|
||||
: unique-operands ( operands quot -- )
|
||||
>r [ operand ] map prune r> each ; inline
|
||||
|
|
|
|||
|
|
@ -20,8 +20,6 @@ M: x86.32 stack-reg ESP ;
|
|||
M: x86.32 temp-reg-1 EAX ;
|
||||
M: x86.32 temp-reg-2 ECX ;
|
||||
|
||||
M: temp-reg v>operand drop EBX ;
|
||||
|
||||
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
|
|
|
|||
|
|
@ -15,8 +15,6 @@ M: x86.64 stack-reg RSP ;
|
|||
M: x86.64 temp-reg-1 RAX ;
|
||||
M: x86.64 temp-reg-2 RCX ;
|
||||
|
||||
M: temp-reg v>operand drop RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
|
||||
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
|
|
|
|||
|
|
@ -7,118 +7,6 @@ compiler.generator.registers system layouts alien locals
|
|||
compiler.constants ;
|
||||
IN: cpu.x86.allot
|
||||
|
||||
: allot-reg ( -- reg )
|
||||
#! We temporarily use the datastack register, since it won't
|
||||
#! be accessed inside the quotation given to %allot in any
|
||||
#! case.
|
||||
ds-reg ;
|
||||
|
||||
: (object@) ( n -- operand ) allot-reg swap [+] ;
|
||||
|
||||
: object@ ( n -- operand ) cells (object@) ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
#! Load pointer to start of zone array
|
||||
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
||||
|
||||
: load-allot-ptr ( -- )
|
||||
allot-reg load-zone-ptr
|
||||
allot-reg PUSH
|
||||
allot-reg dup cell [+] MOV ;
|
||||
|
||||
: inc-allot-ptr ( n -- )
|
||||
allot-reg POP
|
||||
allot-reg cell [+] swap 8 align ADD ;
|
||||
|
||||
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
|
||||
0 frame-required
|
||||
%prepare-alien-invoke
|
||||
"minor_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
|
||||
: store-header ( header -- )
|
||||
0 object@ swap type-number tag-fixnum MOV ;
|
||||
|
||||
: %allot ( header size quot -- )
|
||||
allot-reg PUSH
|
||||
swap >r >r
|
||||
load-allot-ptr
|
||||
store-header
|
||||
r> call
|
||||
r> inc-allot-ptr
|
||||
allot-reg POP ; inline
|
||||
|
||||
: %store-tagged ( reg tag -- )
|
||||
>r dup fresh-object v>operand r>
|
||||
allot-reg swap tag-number OR
|
||||
allot-reg MOV ;
|
||||
|
||||
M: x86 %box-float ( dst src -- )
|
||||
#! Only called by pentium4 backend, uses SSE2 instruction
|
||||
#! dest is a loc or a vreg
|
||||
float 16 [
|
||||
8 (object@) swap v>operand MOVSD
|
||||
float %store-tagged
|
||||
] %allot ;
|
||||
|
||||
: %allot-bignum-signed-1 ( outreg inreg -- )
|
||||
#! 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
|
||||
dup v>operand 0 CMP ! is it zero?
|
||||
"nonzero" get JNE
|
||||
0 >bignum pick load-literal ! this is our result
|
||||
"end" get JMP
|
||||
"nonzero" resolve-label
|
||||
bignum 4 cells [
|
||||
! Write length
|
||||
1 object@ 2 v>operand MOV
|
||||
! Test sign
|
||||
dup v>operand 0 CMP
|
||||
"positive" get JGE
|
||||
2 object@ 1 MOV ! negative sign
|
||||
dup v>operand NEG
|
||||
"store" get JMP
|
||||
"positive" resolve-label
|
||||
2 object@ 0 MOV ! positive sign
|
||||
"store" resolve-label
|
||||
3 object@ swap v>operand MOV
|
||||
! Store tagged ptr in reg
|
||||
bignum %store-tagged
|
||||
] %allot
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M: x86 %box-alien ( dst src -- )
|
||||
[
|
||||
{ "end" "f" } [ define-label ] each
|
||||
dup v>operand 0 CMP
|
||||
"f" get JE
|
||||
alien 4 cells [
|
||||
1 object@ f v>operand MOV
|
||||
2 object@ f v>operand MOV
|
||||
! Store src in alien-offset slot
|
||||
3 object@ swap v>operand MOV
|
||||
! Store tagged ptr in dst
|
||||
dup object %store-tagged
|
||||
] %allot
|
||||
"end" get JMP
|
||||
"f" resolve-label
|
||||
f [ v>operand ] bi@ MOV
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: x86 %write-barrier ( src temp -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
! Mark the card
|
||||
|
|
@ -131,24 +19,86 @@ M:: x86 %write-barrier ( src temp -- )
|
|||
"decks_offset" f temp %alien-global
|
||||
temp temp [+] 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 ( temp -- )
|
||||
! [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
|
||||
!
|
||||
! : inc-allot-ptr ( n temp -- )
|
||||
! [ POP ] [ cell [+] swap 8 align ADD ] bi ;
|
||||
!
|
||||
! : store-header ( temp type -- )
|
||||
! [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||
!
|
||||
! : store-tagged ( dst temp tag -- )
|
||||
! dupd tag-number OR MOV ;
|
||||
!
|
||||
! M:: x86 %allot ( dst size type tag temp -- )
|
||||
! temp load-allot-ptr
|
||||
! temp type store-header
|
||||
! temp size inc-allot-ptr
|
||||
! dst temp store-tagged ;
|
||||
: load-zone-ptr ( reg -- )
|
||||
#! Load pointer to start of zone array
|
||||
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
||||
|
||||
: load-allot-ptr ( temp -- )
|
||||
[ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
|
||||
|
||||
: inc-allot-ptr ( n temp -- )
|
||||
[ POP ] [ cell [+] swap 8 align ADD ] bi ;
|
||||
|
||||
: store-header ( temp type -- )
|
||||
[ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||
|
||||
: store-tagged ( dst temp tag -- )
|
||||
dupd tag-number OR MOV ;
|
||||
|
||||
M:: x86 %allot ( dst size type tag temp -- )
|
||||
temp load-allot-ptr
|
||||
temp type store-header
|
||||
temp size inc-allot-ptr
|
||||
dst temp store-tagged ;
|
||||
|
||||
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 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
|
||||
\ f tag-number MOV
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -22,8 +22,10 @@ HOOK: stack-reg cpu ( -- reg )
|
|||
|
||||
: reg-stack ( n reg -- op ) swap cells neg [+] ;
|
||||
|
||||
M: ds-loc v>operand n>> ds-reg reg-stack ;
|
||||
M: rs-loc v>operand n>> rs-reg reg-stack ;
|
||||
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 %load-param-reg drop swap stack@ MOV ;
|
||||
|
|
@ -49,7 +51,11 @@ HOOK: fixnum>slot@ cpu ( op -- )
|
|||
|
||||
HOOK: prepare-division cpu ( -- )
|
||||
|
||||
M: immediate load-literal v>operand swap v>operand MOV ;
|
||||
M: f load-literal
|
||||
\ f tag-number MOV drop ;
|
||||
|
||||
M: fixnum load-literal
|
||||
swap tag-fixnum MOV ;
|
||||
|
||||
: align-stack ( n -- n' )
|
||||
os macosx? cpu x86.64? or [ 16 align ] when ;
|
||||
|
|
@ -57,16 +63,16 @@ M: immediate load-literal v>operand swap v>operand MOV ;
|
|||
M: x86 stack-frame-size ( n -- i )
|
||||
3 cells + align-stack ;
|
||||
|
||||
M: x86 %save-word-xt ( -- )
|
||||
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
|
||||
M: x86 %save-word-xt ( -- ) ;
|
||||
|
||||
: decr-stack-reg ( n -- )
|
||||
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
|
||||
|
||||
M: x86 %prologue ( n -- )
|
||||
dup PUSH
|
||||
temp-reg v>operand PUSH
|
||||
3 cells - decr-stack-reg ;
|
||||
temp-reg-1 0 MOV rc-absolute-cell rel-this
|
||||
dup cell + PUSH
|
||||
temp-reg-1 PUSH
|
||||
stack-reg swap 2 cells - SUB ;
|
||||
|
||||
: incr-stack-reg ( n -- )
|
||||
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
|
||||
|
|
@ -79,21 +85,21 @@ 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
|
||||
#! all roots.
|
||||
"stack_chain" f temp-reg v>operand %alien-global
|
||||
temp-reg v>operand [] stack-reg MOV
|
||||
temp-reg v>operand [] cell SUB
|
||||
temp-reg v>operand 2 cells [+] ds-reg MOV
|
||||
temp-reg v>operand 3 cells [+] rs-reg MOV ;
|
||||
"stack_chain" f temp-reg-1 %alien-global
|
||||
temp-reg-1 [] stack-reg MOV
|
||||
temp-reg-1 [] cell SUB
|
||||
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 -- )
|
||||
"flag" operand f v>operand CMP JE ;
|
||||
M: x86 %jump-f ( label vreg -- )
|
||||
\ f tag-number CMP JE ;
|
||||
|
||||
M: x86 %jump-t ( label -- )
|
||||
"flag" operand f v>operand CMP JNE ;
|
||||
M: x86 %jump-t ( label vreg -- )
|
||||
\ f tag-number CMP JNE ;
|
||||
|
||||
: code-alignment ( -- n )
|
||||
building get length dup cell align swap - ;
|
||||
|
|
@ -126,14 +132,9 @@ M: x86 %dispatch ( -- )
|
|||
M: x86 %dispatch-label ( word -- )
|
||||
0 cell, rc-absolute-cell rel-word ;
|
||||
|
||||
M: x86 %unbox-float ( dst src -- )
|
||||
[ v>operand ] bi@ float-offset [+] MOVSD ;
|
||||
M: x86 %peek loc>operand MOV ;
|
||||
|
||||
M: x86 %peek [ v>operand ] bi@ MOV ;
|
||||
|
||||
M: x86 %replace swap %peek ;
|
||||
|
||||
M: x86 %copy [ v>operand ] bi@ MOV ;
|
||||
M: x86 %replace loc>operand swap MOV ;
|
||||
|
||||
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
|
||||
|
||||
|
|
@ -158,13 +159,13 @@ M: x86 %return ( -- ) 0 %unwind ;
|
|||
|
||||
! Alien intrinsics
|
||||
M: x86 %unbox-byte-array ( dst src -- )
|
||||
[ v>operand ] bi@ byte-array-offset [+] LEA ;
|
||||
byte-array-offset [+] LEA ;
|
||||
|
||||
M: x86 %unbox-alien ( dst src -- )
|
||||
[ v>operand ] bi@ alien-offset [+] MOV ;
|
||||
alien-offset [+] MOV ;
|
||||
|
||||
M: x86 %unbox-f ( dst src -- )
|
||||
drop v>operand 0 MOV ;
|
||||
drop 0 MOV ;
|
||||
|
||||
M: x86 %unbox-any-c-ptr ( dst src -- )
|
||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||
|
|
@ -173,11 +174,11 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
|
|||
ds-reg 0 MOV
|
||||
! Object is stored in ds-reg
|
||||
rs-reg PUSH
|
||||
rs-reg swap v>operand MOV
|
||||
rs-reg swap MOV
|
||||
! We come back here with displaced aliens
|
||||
"start" resolve-label
|
||||
! Is the object f?
|
||||
rs-reg f v>operand CMP
|
||||
rs-reg \ f tag-number CMP
|
||||
"end" get JE
|
||||
! Is the object an alien?
|
||||
rs-reg header-offset [+] alien type-number tag-fixnum CMP
|
||||
|
|
@ -194,7 +195,7 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
|
|||
ds-reg byte-array-offset ADD
|
||||
"end" resolve-label
|
||||
! Done, store address in destination register
|
||||
v>operand ds-reg MOV
|
||||
ds-reg MOV
|
||||
! Restore rs-reg
|
||||
rs-reg POP
|
||||
! Restore ds-reg
|
||||
|
|
|
|||
|
|
@ -1,103 +1,74 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.accessors arrays cpu.x86.assembler
|
||||
cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
|
||||
kernel.private math math.private namespaces quotations sequences
|
||||
words generic byte-arrays hashtables hashtables.private
|
||||
sequences.private sbufs sbufs.private
|
||||
vectors vectors.private layouts system strings.private
|
||||
slots.private
|
||||
compiler.constants
|
||||
compiler.intrinsics
|
||||
compiler.generator
|
||||
compiler.generator.fixup
|
||||
compiler.generator.registers ;
|
||||
USING: accessors arrays byte-arrays alien.accessors
|
||||
compiler.backend kernel kernel.private math memory namespaces
|
||||
make sequences words system layouts combinators math.order
|
||||
math.private alien alien.c-types slots.private cpu.x86.assembler
|
||||
cpu.x86.assembler.private locals compiler.backend
|
||||
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
|
||||
] H{
|
||||
{ +input+ { { f "in" } } }
|
||||
{ +output+ { "in" } }
|
||||
] T{ template
|
||||
{ input { { f "in" } } }
|
||||
{ output { "in" } }
|
||||
} define-intrinsic
|
||||
|
||||
! Slots
|
||||
: %slot-literal-known-tag ( -- op )
|
||||
"obj" operand
|
||||
"n" get cells
|
||||
"obj" get operand-tag - [+] ;
|
||||
|
||||
: %slot-literal-any-tag ( -- op )
|
||||
"obj" operand %untag
|
||||
"obj" operand "n" get cells [+] ;
|
||||
|
||||
: %slot-any ( -- op )
|
||||
"obj" operand %untag
|
||||
"n" operand fixnum>slot@
|
||||
"obj" operand "n" operand [+] ;
|
||||
|
||||
\ slot {
|
||||
! Slot number is literal and the tag is known
|
||||
{
|
||||
[ "val" operand %slot-literal-known-tag MOV ] H{
|
||||
{ +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
|
||||
{ +scratch+ { { f "val" } } }
|
||||
{ +output+ { "val" } }
|
||||
[ "val" operand %slot-literal-known-tag MOV ] T{ template
|
||||
{ input { { f "obj" known-tag } { small-slot "n" } } }
|
||||
{ scratch { { f "val" } } }
|
||||
{ output { "val" } }
|
||||
}
|
||||
}
|
||||
! Slot number is literal
|
||||
{
|
||||
[ "obj" operand %slot-literal-any-tag MOV ] H{
|
||||
{ +input+ { { f "obj" } { [ small-slot? ] "n" } } }
|
||||
{ +output+ { "obj" } }
|
||||
[ "obj" operand %slot-literal-any-tag MOV ] T{ template
|
||||
{ input { { f "obj" } { small-slot "n" } } }
|
||||
{ output { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number in a register
|
||||
{
|
||||
[ "obj" operand %slot-any MOV ] H{
|
||||
{ +input+ { { f "obj" } { f "n" } } }
|
||||
{ +output+ { "obj" } }
|
||||
{ +clobber+ { "n" } }
|
||||
[ "obj" operand %slot-any MOV ] T{ template
|
||||
{ input { { f "obj" } { f "n" } } }
|
||||
{ output { "obj" } }
|
||||
{ clobber { "n" } }
|
||||
}
|
||||
}
|
||||
} define-intrinsics
|
||||
|
||||
: generate-write-barrier ( -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
"val" get operand-immediate? "obj" get fresh-object? or [
|
||||
! Mark the card
|
||||
"obj" operand card-bits SHR
|
||||
"cards_offset" f temp-reg v>operand %alien-global
|
||||
temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
|
||||
|
||||
! Mark the card deck
|
||||
"obj" operand deck-bits card-bits - SHR
|
||||
"decks_offset" f temp-reg v>operand %alien-global
|
||||
temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
|
||||
] unless ;
|
||||
|
||||
\ set-slot {
|
||||
\ (set-slot) {
|
||||
! Slot number is literal and the tag is known
|
||||
{
|
||||
[ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] H{
|
||||
{ +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
|
||||
{ +clobber+ { "obj" } }
|
||||
[ %slot-literal-known-tag "val" operand MOV ] T{ template
|
||||
{ input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number is literal
|
||||
{
|
||||
[ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] H{
|
||||
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
|
||||
{ +clobber+ { "obj" } }
|
||||
[ %slot-literal-any-tag "val" operand MOV ] T{ template
|
||||
{ input { { f "val" } { f "obj" } { small-slot "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number in a register
|
||||
{
|
||||
[ %slot-any "val" operand MOV generate-write-barrier ] H{
|
||||
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
|
||||
{ +clobber+ { "obj" "n" } }
|
||||
[ %slot-any "val" operand MOV ] T{ template
|
||||
{ input { { f "val" } { f "obj" } { f "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" "n" } }
|
||||
}
|
||||
}
|
||||
} define-intrinsics
|
||||
|
|
@ -117,15 +88,15 @@ IN: cpu.x86.intrinsics
|
|||
>r [ "x" operand "y" operand ] swap suffix r> 2array ;
|
||||
|
||||
: fixnum-value-op ( op -- pair )
|
||||
H{
|
||||
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
|
||||
{ +output+ { "x" } }
|
||||
T{ template
|
||||
{ input { { f "x" } { small-tagged "y" } } }
|
||||
{ output { "x" } }
|
||||
} fixnum-op ;
|
||||
|
||||
: fixnum-register-op ( op -- pair )
|
||||
H{
|
||||
{ +input+ { { f "x" } { f "y" } } }
|
||||
{ +output+ { "x" } }
|
||||
T{ template
|
||||
{ input { { f "x" } { f "y" } } }
|
||||
{ output { "x" } }
|
||||
} fixnum-op ;
|
||||
|
||||
: define-fixnum-op ( word op -- )
|
||||
|
|
@ -145,28 +116,28 @@ IN: cpu.x86.intrinsics
|
|||
\ fixnum-bitnot [
|
||||
"x" operand NOT
|
||||
"x" operand tag-mask get XOR
|
||||
] H{
|
||||
{ +input+ { { f "x" } } }
|
||||
{ +output+ { "x" } }
|
||||
] T{ template
|
||||
{ input { { f "x" } } }
|
||||
{ output { "x" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ fixnum*fast {
|
||||
{
|
||||
[
|
||||
"x" operand "y" get IMUL2
|
||||
] H{
|
||||
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
|
||||
{ +output+ { "x" } }
|
||||
] T{ template
|
||||
{ input { { f "x" } { [ small-tagged? ] "y" } } }
|
||||
{ output { "x" } }
|
||||
}
|
||||
} {
|
||||
[
|
||||
"out" operand "x" operand MOV
|
||||
"out" operand %untag-fixnum
|
||||
"y" operand "out" operand IMUL2
|
||||
] H{
|
||||
{ +input+ { { f "x" } { f "y" } } }
|
||||
{ +scratch+ { { f "out" } } }
|
||||
{ +output+ { "out" } }
|
||||
] T{ template
|
||||
{ input { { f "x" } { f "y" } } }
|
||||
{ scratch { { f "out" } } }
|
||||
{ output { "out" } }
|
||||
}
|
||||
}
|
||||
} define-intrinsics
|
||||
|
|
@ -179,9 +150,9 @@ IN: cpu.x86.intrinsics
|
|||
dup 0 < [ neg SAR ] [ SHL ] if
|
||||
! Mask off low bits
|
||||
"x" operand %untag
|
||||
] H{
|
||||
{ +input+ { { f "x" } { [ ] "y" } } }
|
||||
{ +output+ { "x" } }
|
||||
] T{ template
|
||||
{ input { { f "x" } { [ ] "y" } } }
|
||||
{ output { "x" } }
|
||||
} define-intrinsic
|
||||
|
||||
: overflow-check ( word -- )
|
||||
|
|
@ -194,15 +165,16 @@ IN: cpu.x86.intrinsics
|
|||
! There was an overflow. Recompute the original operand.
|
||||
{ "y" "x" } %untag-fixnums
|
||||
"x" operand "y" operand rot execute
|
||||
"z" get "x" get %allot-bignum-signed-1
|
||||
"z" operand "x" operand "y" operand %allot-bignum-signed-1
|
||||
"end" resolve-label ; inline
|
||||
|
||||
: overflow-template ( word insn -- )
|
||||
[ overflow-check ] curry H{
|
||||
{ +input+ { { f "x" } { f "y" } } }
|
||||
{ +scratch+ { { f "z" } } }
|
||||
{ +output+ { "z" } }
|
||||
{ +clobber+ { "x" "y" } }
|
||||
[ overflow-check ] curry T{ template
|
||||
{ input { { f "x" } { f "y" } } }
|
||||
{ scratch { { f "z" } } }
|
||||
{ output { "z" } }
|
||||
{ clobber { "x" "y" } }
|
||||
{ gc t }
|
||||
} define-intrinsic ;
|
||||
|
||||
\ fixnum+ \ ADD overflow-template
|
||||
|
|
@ -222,21 +194,23 @@ IN: cpu.x86.intrinsics
|
|||
2array define-if-intrinsics ;
|
||||
|
||||
{
|
||||
{ fixnum< JGE }
|
||||
{ fixnum<= JG }
|
||||
{ fixnum> JLE }
|
||||
{ fixnum>= JL }
|
||||
{ eq? JNE }
|
||||
{ fixnum< JL }
|
||||
{ fixnum<= JLE }
|
||||
{ fixnum> JG }
|
||||
{ fixnum>= JGE }
|
||||
{ eq? JE }
|
||||
} [
|
||||
first2 define-fixnum-jump
|
||||
] each
|
||||
|
||||
\ fixnum>bignum [
|
||||
"x" operand %untag-fixnum
|
||||
"x" get dup %allot-bignum-signed-1
|
||||
] H{
|
||||
{ +input+ { { f "x" } } }
|
||||
{ +output+ { "x" } }
|
||||
"x" operand dup "scratch" operand %allot-bignum-signed-1
|
||||
] T{ template
|
||||
{ input { { f "x" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ output { "x" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ bignum>fixnum [
|
||||
|
|
@ -247,7 +221,7 @@ IN: cpu.x86.intrinsics
|
|||
"y" operand "x" operand cell [+] MOV
|
||||
! if the length is 1, its just the sign and nothing else,
|
||||
! so output 0
|
||||
"y" operand 1 v>operand CMP
|
||||
"y" operand 1 tag-fixnum CMP
|
||||
"nonzero" get JNE
|
||||
"y" operand 0 MOV
|
||||
"end" get JMP
|
||||
|
|
@ -263,11 +237,11 @@ IN: cpu.x86.intrinsics
|
|||
"positive" resolve-label
|
||||
"y" operand 3 SHL
|
||||
"end" resolve-label
|
||||
] H{
|
||||
{ +input+ { { f "x" } } }
|
||||
{ +scratch+ { { f "y" } } }
|
||||
{ +clobber+ { "x" } }
|
||||
{ +output+ { "y" } }
|
||||
] T{ template
|
||||
{ input { { f "x" } } }
|
||||
{ scratch { { f "y" } } }
|
||||
{ clobber { "x" } }
|
||||
{ output { "y" } }
|
||||
} define-intrinsic
|
||||
|
||||
! User environment
|
||||
|
|
@ -279,96 +253,18 @@ IN: cpu.x86.intrinsics
|
|||
|
||||
\ getenv [
|
||||
%userenv "n" operand dup [] MOV
|
||||
] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "x" } } }
|
||||
{ +output+ { "n" } }
|
||||
] T{ template
|
||||
{ input { { f "n" } } }
|
||||
{ scratch { { f "x" } } }
|
||||
{ output { "n" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ setenv [
|
||||
%userenv "n" operand [] "val" operand MOV
|
||||
] H{
|
||||
{ +input+ { { f "val" } { f "n" } } }
|
||||
{ +scratch+ { { f "x" } } }
|
||||
{ +clobber+ { "n" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (tuple) [
|
||||
tuple "layout" get size>> 2 + cells [
|
||||
! Store layout
|
||||
"layout" get "scratch" get load-literal
|
||||
1 object@ "scratch" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ ] "layout" } } }
|
||||
{ +scratch+ { { f "tuple" } { f "scratch" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (array) [
|
||||
array "n" get 2 + cells [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (byte-array) [
|
||||
byte-array "n" get 2 cells + [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <ratio> [
|
||||
ratio 3 cells [
|
||||
1 object@ "numerator" operand MOV
|
||||
2 object@ "denominator" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"ratio" get ratio %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { f "numerator" } { f "denominator" } } }
|
||||
{ +scratch+ { { f "ratio" } } }
|
||||
{ +output+ { "ratio" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <complex> [
|
||||
complex 3 cells [
|
||||
1 object@ "real" operand MOV
|
||||
2 object@ "imaginary" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"complex" get complex %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { f "real" } { f "imaginary" } } }
|
||||
{ +scratch+ { { f "complex" } } }
|
||||
{ +output+ { "complex" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <wrapper> [
|
||||
wrapper 2 cells [
|
||||
1 object@ "obj" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"wrapper" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { f "obj" } } }
|
||||
{ +scratch+ { { f "wrapper" } } }
|
||||
{ +output+ { "wrapper" } }
|
||||
] T{ template
|
||||
{ input { { f "val" } { f "n" } } }
|
||||
{ scratch { { f "x" } } }
|
||||
{ clobber { "n" } }
|
||||
} define-intrinsic
|
||||
|
||||
! Alien intrinsics
|
||||
|
|
@ -385,14 +281,14 @@ IN: cpu.x86.intrinsics
|
|||
small-reg POP ; inline
|
||||
|
||||
: alien-integer-get-template
|
||||
H{
|
||||
{ +input+ {
|
||||
T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { f "value" } } }
|
||||
{ +output+ { "value" } }
|
||||
{ +clobber+ { "offset" } }
|
||||
{ scratch { { f "value" } } }
|
||||
{ output { "value" } }
|
||||
{ clobber { "offset" } }
|
||||
} ;
|
||||
|
||||
: define-getter ( word quot reg -- )
|
||||
|
|
@ -414,13 +310,13 @@ IN: cpu.x86.intrinsics
|
|||
small-reg POP ; inline
|
||||
|
||||
: alien-integer-set-template
|
||||
H{
|
||||
{ +input+ {
|
||||
T{ template
|
||||
{ input {
|
||||
{ f "value" fixnum }
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +clobber+ { "value" "offset" } }
|
||||
{ clobber { "value" "offset" } }
|
||||
} ;
|
||||
|
||||
: define-setter ( word reg -- )
|
||||
|
|
@ -443,23 +339,23 @@ IN: cpu.x86.intrinsics
|
|||
|
||||
\ alien-cell [
|
||||
"value" operand [ MOV ] %alien-accessor
|
||||
] H{
|
||||
{ +input+ {
|
||||
] T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { unboxed-alien "value" } } }
|
||||
{ +output+ { "value" } }
|
||||
{ +clobber+ { "offset" } }
|
||||
{ scratch { { unboxed-alien "value" } } }
|
||||
{ output { "value" } }
|
||||
{ clobber { "offset" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ set-alien-cell [
|
||||
"value" operand [ swap MOV ] %alien-accessor
|
||||
] H{
|
||||
{ +input+ {
|
||||
] T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "value" pinned-c-ptr }
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +clobber+ { "offset" } }
|
||||
{ clobber { "offset" } }
|
||||
} define-intrinsic
|
||||
|
|
|
|||
|
|
@ -8,7 +8,14 @@ cpu.architecture math.floats.private layouts quotations
|
|||
system ;
|
||||
IN: cpu.x86.sse2
|
||||
|
||||
M: x86 %copy-float [ v>operand ] bi@ 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 H{
|
||||
|
|
|
|||
|
|
@ -1,189 +0,0 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs arrays generic kernel kernel.private
|
||||
math memory namespaces make sequences layouts system hashtables
|
||||
classes alien byte-arrays combinators words ;
|
||||
IN: compiler.backend
|
||||
|
||||
! Labels
|
||||
TUPLE: label offset ;
|
||||
|
||||
: <label> ( -- label ) label new ;
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
|
||||
|
||||
! Mapping from register class to machine registers
|
||||
HOOK: machine-registers cpu ( -- assoc )
|
||||
|
||||
! A pseudo-register class for parameters spilled on the stack
|
||||
SINGLETON: stack-params
|
||||
|
||||
! Return values of this class go here
|
||||
GENERIC: return-reg ( register-class -- reg )
|
||||
|
||||
! Sequence of registers used for parameter passing in class
|
||||
GENERIC: param-regs ( register-class -- regs )
|
||||
|
||||
GENERIC: param-reg ( n register-class -- reg )
|
||||
|
||||
M: object param-reg param-regs nth ;
|
||||
|
||||
! Load a literal (immediate or indirect)
|
||||
GENERIC# load-literal 1 ( obj reg -- )
|
||||
|
||||
HOOK: load-indirect cpu ( obj reg -- )
|
||||
|
||||
HOOK: stack-frame-size cpu ( frame-size -- n )
|
||||
|
||||
! Set up caller stack frame
|
||||
HOOK: %prologue cpu ( n -- )
|
||||
|
||||
! Tear down stack frame
|
||||
HOOK: %epilogue cpu ( n -- )
|
||||
|
||||
! Call another word
|
||||
HOOK: %call cpu ( word -- )
|
||||
|
||||
! Local jump for branches
|
||||
HOOK: %jump-label cpu ( label -- )
|
||||
|
||||
! Test if vreg is 'f' or not
|
||||
HOOK: %jump-f cpu ( label reg -- )
|
||||
|
||||
! Test if vreg is 't' or not
|
||||
HOOK: %jump-t cpu ( label reg -- )
|
||||
|
||||
HOOK: %dispatch cpu ( -- )
|
||||
|
||||
HOOK: %dispatch-label cpu ( word -- )
|
||||
|
||||
! Return to caller
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
! Change datastack height
|
||||
HOOK: %inc-d cpu ( n -- )
|
||||
|
||||
! Change callstack height
|
||||
HOOK: %inc-r cpu ( n -- )
|
||||
|
||||
! Load stack into vreg
|
||||
HOOK: %peek cpu ( reg loc -- )
|
||||
|
||||
! Store vreg to stack
|
||||
HOOK: %replace cpu ( reg loc -- )
|
||||
|
||||
! Copy values between vregs
|
||||
HOOK: %copy cpu ( dst src -- )
|
||||
HOOK: %copy-float cpu ( dst src -- )
|
||||
|
||||
! Box and unbox floats
|
||||
HOOK: %unbox-float cpu ( dst src -- )
|
||||
HOOK: %box-float cpu ( dst src -- )
|
||||
|
||||
! FFI stuff
|
||||
|
||||
! Is this integer small enough to appear in value template
|
||||
! slots?
|
||||
HOOK: small-enough? cpu ( n -- ? )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: struct-small-enough? cpu ( heap-size -- ? )
|
||||
|
||||
! Do we pass explode value structs?
|
||||
HOOK: value-structs? cpu ( -- ? )
|
||||
|
||||
! If t, fp parameters are shadowed by dummy int parameters
|
||||
HOOK: fp-shadows-int? cpu ( -- ? )
|
||||
|
||||
HOOK: %prepare-unbox cpu ( -- )
|
||||
|
||||
HOOK: %unbox cpu ( n reg-class func -- )
|
||||
|
||||
HOOK: %unbox-long-long cpu ( n func -- )
|
||||
|
||||
HOOK: %unbox-small-struct cpu ( c-type -- )
|
||||
|
||||
HOOK: %unbox-large-struct cpu ( n c-type -- )
|
||||
|
||||
HOOK: %box cpu ( n reg-class func -- )
|
||||
|
||||
HOOK: %box-long-long cpu ( n func -- )
|
||||
|
||||
HOOK: %prepare-box-struct cpu ( size -- )
|
||||
|
||||
HOOK: %box-small-struct cpu ( c-type -- )
|
||||
|
||||
HOOK: %box-large-struct cpu ( n c-type -- )
|
||||
|
||||
GENERIC: %save-param-reg ( stack reg reg-class -- )
|
||||
|
||||
GENERIC: %load-param-reg ( stack reg reg-class -- )
|
||||
|
||||
HOOK: %prepare-alien-invoke cpu ( -- )
|
||||
|
||||
HOOK: %prepare-var-args cpu ( -- )
|
||||
|
||||
M: object %prepare-var-args ;
|
||||
|
||||
HOOK: %alien-invoke cpu ( function library -- )
|
||||
|
||||
HOOK: %cleanup cpu ( alien-node -- )
|
||||
|
||||
HOOK: %alien-callback cpu ( quot -- )
|
||||
|
||||
HOOK: %callback-value cpu ( ctype -- )
|
||||
|
||||
! Return to caller with stdcall unwinding (only for x86)
|
||||
HOOK: %unwind cpu ( n -- )
|
||||
|
||||
HOOK: %prepare-alien-indirect cpu ( -- )
|
||||
|
||||
HOOK: %alien-indirect cpu ( -- )
|
||||
|
||||
M: stack-params param-reg drop ;
|
||||
|
||||
M: stack-params param-regs drop f ;
|
||||
|
||||
M: object load-literal load-indirect ;
|
||||
|
||||
PREDICATE: small-slot < integer cells small-enough? ;
|
||||
|
||||
PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
|
||||
|
||||
: if-small-struct ( n size true false -- ? )
|
||||
[ over not over struct-small-enough? and ] 2dip
|
||||
[ [ nip ] prepose ] dip if ;
|
||||
inline
|
||||
|
||||
: %unbox-struct ( n c-type -- )
|
||||
[
|
||||
%unbox-small-struct
|
||||
] [
|
||||
%unbox-large-struct
|
||||
] if-small-struct ;
|
||||
|
||||
: %box-struct ( n c-type -- )
|
||||
[
|
||||
%box-small-struct
|
||||
] [
|
||||
%box-large-struct
|
||||
] if-small-struct ;
|
||||
|
||||
! Alien accessors
|
||||
HOOK: %unbox-byte-array cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-alien cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-f cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
||||
|
||||
HOOK: %box-alien cpu ( dst src -- )
|
||||
|
||||
! Allocation
|
||||
HOOK: %allot cpu ( dst size type tag temp -- )
|
||||
|
||||
HOOK: %write-barrier cpu ( src temp -- )
|
||||
|
||||
! GC check
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
|
@ -1,318 +0,0 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types arrays kernel kernel.private math
|
||||
namespaces sequences stack-checker.known-words system layouts
|
||||
combinators command-line io vocabs.loader accessors init
|
||||
compiler compiler.units compiler.constants compiler.codegen
|
||||
compiler.cfg.builder compiler.alien compiler.codegen.fixup
|
||||
cpu.x86 compiler.backend compiler.backend.x86 ;
|
||||
IN: compiler.backend.x86.32
|
||||
|
||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||
! OS X requires that the stack be 16-byte aligned, and we do
|
||||
! this on all platforms, sacrificing some stack space for
|
||||
! code simplicity.
|
||||
|
||||
M: x86.32 machine-registers
|
||||
{
|
||||
{ int-regs { EAX ECX EDX EBP EBX } }
|
||||
{ double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
|
||||
} ;
|
||||
|
||||
M: x86.32 ds-reg ESI ;
|
||||
M: x86.32 rs-reg EDI ;
|
||||
M: x86.32 stack-reg ESP ;
|
||||
M: x86.32 stack-save-reg EDX ;
|
||||
M: x86.32 temp-reg-1 EAX ;
|
||||
M: x86.32 temp-reg-2 ECX ;
|
||||
|
||||
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
|
||||
M: x86.32 struct-small-enough? ( size -- ? )
|
||||
heap-size { 1 2 4 8 } member?
|
||||
os { linux netbsd solaris } member? not and ;
|
||||
|
||||
! On x86, parameters are never passed in registers.
|
||||
M: int-regs return-reg drop EAX ;
|
||||
M: int-regs param-regs drop { } ;
|
||||
M: int-regs push-return-reg return-reg PUSH ;
|
||||
: load/store-int-return ( n reg-class -- src dst )
|
||||
return-reg stack-reg rot [+] ;
|
||||
M: int-regs load-return-reg load/store-int-return MOV ;
|
||||
M: int-regs store-return-reg load/store-int-return swap MOV ;
|
||||
|
||||
M: float-regs param-regs drop { } ;
|
||||
|
||||
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
|
||||
|
||||
M: float-regs push-return-reg
|
||||
stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
|
||||
|
||||
: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
|
||||
|
||||
: load/store-float-return ( n reg-class -- op size )
|
||||
[ stack@ ] [ reg-size ] bi* ;
|
||||
M: float-regs load-return-reg load/store-float-return FLD ;
|
||||
M: float-regs store-return-reg load/store-float-return FSTP ;
|
||||
|
||||
: align-sub ( n -- )
|
||||
dup 16 align swap - ESP swap SUB ;
|
||||
|
||||
: align-add ( n -- )
|
||||
16 align ESP swap ADD ;
|
||||
|
||||
: with-aligned-stack ( n quot -- )
|
||||
swap dup align-sub slip align-add ; inline
|
||||
|
||||
M: x86.32 fixnum>slot@ 1 SHR ;
|
||||
|
||||
M: x86.32 prepare-division CDQ ;
|
||||
|
||||
M: x86.32 load-indirect
|
||||
0 [] MOV rc-absolute-cell rel-literal ;
|
||||
|
||||
M: object %load-param-reg 3drop ;
|
||||
|
||||
M: object %save-param-reg 3drop ;
|
||||
|
||||
: box@ ( n reg-class -- stack@ )
|
||||
#! Used for callbacks; we want to box the values given to
|
||||
#! us by the C function caller. Computes stack location of
|
||||
#! nth parameter; note that we must go back one more stack
|
||||
#! frame, since %box sets one up to call the one-arg boxer
|
||||
#! function. The size of this stack frame so far depends on
|
||||
#! the reg-class of the boxer's arg.
|
||||
reg-size neg + stack-frame* + 20 + ;
|
||||
|
||||
: (%box) ( n reg-class -- )
|
||||
#! If n is f, push the return register onto the stack; we
|
||||
#! are boxing a return value of a C function. If n is an
|
||||
#! integer, push [ESP+n] on the stack; we are boxing a
|
||||
#! parameter being passed to a callback from C.
|
||||
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
|
||||
push-return-reg ;
|
||||
|
||||
M: x86.32 %box ( n reg-class func -- )
|
||||
over reg-size [
|
||||
>r (%box) r> f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
: (%box-long-long) ( n -- )
|
||||
#! If n is f, push the return registers onto the stack; we
|
||||
#! are boxing a return value of a C function. If n is an
|
||||
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
|
||||
#! boxing a parameter being passed to a callback from C.
|
||||
[
|
||||
int-regs box@
|
||||
EDX over stack@ MOV
|
||||
EAX swap cell - stack@ MOV
|
||||
] when*
|
||||
EDX PUSH
|
||||
EAX PUSH ;
|
||||
|
||||
M: x86.32 %box-long-long ( n func -- )
|
||||
8 [
|
||||
[ (%box-long-long) ] [ f %alien-invoke ] bi*
|
||||
] with-aligned-stack ;
|
||||
|
||||
: struct-return@ ( size n -- n )
|
||||
[ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
|
||||
|
||||
M: x86.32 %box-large-struct ( n c-type -- )
|
||||
! Compute destination address
|
||||
heap-size
|
||||
[ swap struct-return@ ] keep
|
||||
ECX ESP roll [+] LEA
|
||||
8 [
|
||||
! Push struct size
|
||||
PUSH
|
||||
! Push destination address
|
||||
ECX PUSH
|
||||
! Copy the struct from the C stack
|
||||
"box_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %prepare-box-struct ( size -- )
|
||||
! Compute target address for value struct return
|
||||
EAX ESP rot f struct-return@ [+] LEA
|
||||
! Store it as the first parameter
|
||||
ESP [] EAX MOV ;
|
||||
|
||||
M: x86.32 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
|
||||
12 [
|
||||
heap-size PUSH
|
||||
EDX PUSH
|
||||
EAX PUSH
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %prepare-unbox ( -- )
|
||||
#! Move top of data stack to EAX.
|
||||
EAX ESI [] MOV
|
||||
ESI 4 SUB ;
|
||||
|
||||
: (%unbox) ( func -- )
|
||||
4 [
|
||||
! Push parameter
|
||||
EAX PUSH
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %unbox ( n reg-class func -- )
|
||||
#! The value being unboxed must already be in EAX.
|
||||
#! If n is f, we're unboxing a return value about to be
|
||||
#! returned by the callback. Otherwise, we're unboxing
|
||||
#! a parameter to a C function about to be called.
|
||||
(%unbox)
|
||||
! Store the return value on the C stack
|
||||
over [ store-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.32 %unbox-long-long ( n func -- )
|
||||
(%unbox)
|
||||
! Store the return value on the C stack
|
||||
[
|
||||
dup stack@ EAX MOV
|
||||
cell + stack@ EDX MOV
|
||||
] when* ;
|
||||
|
||||
: %unbox-struct-1 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
4 [
|
||||
EAX PUSH
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
|
||||
: %unbox-struct-2 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
4 [
|
||||
EAX PUSH
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
EDX EAX 4 [+] MOV
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86 %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
heap-size cell align cell /i {
|
||||
{ 1 [ %unbox-struct-1 ] }
|
||||
{ 2 [ %unbox-struct-2 ] }
|
||||
} case ;
|
||||
|
||||
M: x86.32 %unbox-large-struct ( n c-type -- )
|
||||
#! Alien must be in EAX.
|
||||
heap-size
|
||||
! Compute destination address
|
||||
ECX ESP roll [+] LEA
|
||||
12 [
|
||||
! Push struct size
|
||||
PUSH
|
||||
! Push destination address
|
||||
ECX PUSH
|
||||
! Push source address
|
||||
EAX PUSH
|
||||
! Copy the struct to the stack
|
||||
"to_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
cell temp@ EAX MOV ;
|
||||
|
||||
M: x86.32 %alien-indirect ( -- )
|
||||
cell temp@ CALL ;
|
||||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
4 [
|
||||
EAX load-indirect
|
||||
EAX PUSH
|
||||
"c_to_factor" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %callback-value ( ctype -- )
|
||||
! Align C stack
|
||||
ESP 12 SUB
|
||||
! Save top of data stack
|
||||
%prepare-unbox
|
||||
EAX PUSH
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
! Place top of data stack in EAX
|
||||
EAX POP
|
||||
! Restore C stack
|
||||
ESP 12 ADD
|
||||
! Unbox EAX
|
||||
unbox-return ;
|
||||
|
||||
M: x86.32 %cleanup ( alien-node -- )
|
||||
#! a) If we just called an stdcall function in Windows, it
|
||||
#! cleaned up the stack frame for us. But we don't want that
|
||||
#! so we 'undo' the cleanup since we do that in %epilogue.
|
||||
#! b) If we just called a function returning a struct, we
|
||||
#! have to fix ESP.
|
||||
{
|
||||
{
|
||||
[ dup abi>> "stdcall" = ]
|
||||
[ alien-stack-frame ESP swap SUB ]
|
||||
} {
|
||||
[ dup return>> large-struct? ]
|
||||
[ drop EAX PUSH ]
|
||||
}
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: x86.32 %unwind ( n -- ) RET ;
|
||||
|
||||
os windows? [
|
||||
cell "longlong" c-type (>>align)
|
||||
cell "ulonglong" c-type (>>align)
|
||||
4 "double" c-type (>>align)
|
||||
] unless
|
||||
|
||||
: (sse2?) ( -- ? ) "Intrinsic" throw ;
|
||||
|
||||
<<
|
||||
|
||||
\ (sse2?) [
|
||||
{ EAX EBX ECX EDX } [ PUSH ] each
|
||||
EAX 1 MOV
|
||||
CPUID
|
||||
EDX 26 SHR
|
||||
EDX 1 AND
|
||||
{ EAX EBX ECX EDX } [ POP ] each
|
||||
JE
|
||||
] { } define-if-intrinsic
|
||||
|
||||
\ (sse2?) { } { object } define-primitive
|
||||
|
||||
>>
|
||||
|
||||
: sse2? ( -- ? ) (sse2?) ;
|
||||
|
||||
"-no-sse2" cli-args member? [
|
||||
"Checking if your CPU supports SSE2..." print flush
|
||||
[ optimized-recompile-hook ] recompile-hook [
|
||||
[ sse2? ] compile-call
|
||||
] with-variable
|
||||
[
|
||||
" - yes" print
|
||||
"compiler.backend.x86.sse2" require
|
||||
[
|
||||
sse2? [
|
||||
"This image was built to use SSE2, which your CPU does not support." print
|
||||
"You will need to bootstrap Factor again." print
|
||||
flush
|
||||
1 exit
|
||||
] unless
|
||||
] "compiler.backend.x86" add-init-hook
|
||||
] [
|
||||
" - no" print
|
||||
] if
|
||||
] unless
|
||||
|
|
@ -1,226 +0,0 @@
|
|||
! 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 compiler.codegen compiler.constants
|
||||
compiler.codegen.fixup compiler.cfg.registers compiler.backend
|
||||
compiler.backend.x86 compiler.backend.x86.sse2 ;
|
||||
IN: compiler.backend.x86.64
|
||||
|
||||
M: x86.64 machine-registers
|
||||
{
|
||||
{ int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
|
||||
{ double-float-regs {
|
||||
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
|
||||
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
|
||||
} }
|
||||
} ;
|
||||
|
||||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
M: x86.64 stack-save-reg RSI ;
|
||||
M: x86.64 temp-reg-1 RAX ;
|
||||
M: x86.64 temp-reg-2 RCX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
|
||||
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 -- )
|
||||
0 [] MOV rc-relative rel-literal ;
|
||||
|
||||
M: stack-params %load-param-reg
|
||||
drop
|
||||
>r R11 swap stack@ MOV
|
||||
r> stack@ R11 MOV ;
|
||||
|
||||
M: stack-params %save-param-reg
|
||||
>r stack-frame* + cell + swap r> %load-param-reg ;
|
||||
|
||||
: with-return-regs ( quot -- )
|
||||
[
|
||||
V{ RDX RAX } clone int-regs set
|
||||
V{ XMM1 XMM0 } clone float-regs set
|
||||
call
|
||||
] 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) >>
|
||||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
[ type>> ] [ offset>> ] bi 2array
|
||||
] map ;
|
||||
|
||||
: split-struct ( pairs -- seq )
|
||||
[
|
||||
[ 8 mod zero? [ t , ] when , ] assoc-each
|
||||
] { } make { t } split harvest ;
|
||||
|
||||
: flatten-small-struct ( c-type -- seq )
|
||||
struct-types&offset split-struct [
|
||||
[ c-type c-type-reg-class ] map
|
||||
int-regs swap member? "void*" "double" ? c-type
|
||||
] map ;
|
||||
|
||||
: flatten-large-struct ( c-type -- seq )
|
||||
heap-size cell align
|
||||
cell /i "__stack_value" c-type <repetition> ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- seq )
|
||||
dup heap-size 16 > [
|
||||
flatten-large-struct
|
||||
] [
|
||||
flatten-small-struct
|
||||
] if ;
|
||||
|
||||
M: x86.64 %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
RDI R14 [] MOV
|
||||
R14 cell SUB ;
|
||||
|
||||
M: x86.64 %unbox ( n reg-class func -- )
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
! Store the return value on the C stack
|
||||
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.64 %unbox-long-long ( n func -- )
|
||||
int-regs swap %unbox ;
|
||||
|
||||
: %unbox-struct-field ( c-type i -- )
|
||||
! Alien must be in RDI.
|
||||
RDI swap cells [+] swap reg-class>> {
|
||||
{ int-regs [ int-regs get pop swap MOV ] }
|
||||
{ double-float-regs [ float-regs get pop swap MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 %unbox-small-struct ( c-type -- )
|
||||
! Alien must be in RDI.
|
||||
"alien_offset" f %alien-invoke
|
||||
! Move alien_offset() return value to RDI so that we don't
|
||||
! clobber it.
|
||||
RDI RAX MOV
|
||||
[
|
||||
flatten-small-struct [ %unbox-struct-field ] each-index
|
||||
] with-return-regs ;
|
||||
|
||||
M: x86.64 %unbox-large-struct ( n c-type -- )
|
||||
! Source is in RDI
|
||||
heap-size
|
||||
! Load destination address
|
||||
RSI RSP roll [+] LEA
|
||||
! Load structure size
|
||||
RDX swap MOV
|
||||
! Copy the struct to the C stack
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
: load-return-value ( reg-class -- )
|
||||
0 over param-reg swap return-reg
|
||||
2dup eq? [ 2drop ] [ MOV ] if ;
|
||||
|
||||
M: x86.64 %box ( n reg-class func -- )
|
||||
rot [
|
||||
rot [ 0 swap param-reg ] keep %load-param-reg
|
||||
] [
|
||||
swap load-return-value
|
||||
] if*
|
||||
f %alien-invoke ;
|
||||
|
||||
M: x86.64 %box-long-long ( n func -- )
|
||||
int-regs swap %box ;
|
||||
|
||||
M: x86.64 struct-small-enough? ( size -- ? )
|
||||
heap-size 2 cells <= ;
|
||||
|
||||
: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
|
||||
|
||||
: %box-struct-field ( c-type i -- )
|
||||
box-struct-field@ swap reg-class>> {
|
||||
{ int-regs [ int-regs get pop MOV ] }
|
||||
{ double-float-regs [ float-regs get pop MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 16-byte struct.
|
||||
[
|
||||
[ flatten-small-struct [ %box-struct-field ] each-index ]
|
||||
[ RDX swap heap-size MOV ] bi
|
||||
RDI 0 box-struct-field@ MOV
|
||||
RSI 1 box-struct-field@ MOV
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-return-regs ;
|
||||
|
||||
: struct-return@ ( size n -- n )
|
||||
[ ] [ \ stack-frame get swap - ] ?if ;
|
||||
|
||||
M: x86.64 %box-large-struct ( n c-type -- )
|
||||
! Struct size is parameter 2
|
||||
heap-size
|
||||
RSI over MOV
|
||||
! Compute destination address
|
||||
swap struct-return@ RDI RSP rot [+] LEA
|
||||
! Copy the struct from the C stack
|
||||
"box_value_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %prepare-box-struct ( size -- )
|
||||
! Compute target address for value struct return
|
||||
RAX RSP rot f struct-return@ [+] LEA
|
||||
RSP 0 [+] RAX MOV ;
|
||||
|
||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||
|
||||
M: x86.64 %alien-global
|
||||
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
|
||||
|
||||
M: x86.64 %alien-invoke
|
||||
R11 0 MOV
|
||||
rc-absolute-cell rel-dlsym
|
||||
R11 CALL ;
|
||||
|
||||
M: x86.64 %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
cell temp@ RAX MOV ;
|
||||
|
||||
M: x86.64 %alien-indirect ( -- )
|
||||
cell temp@ CALL ;
|
||||
|
||||
M: x86.64 %alien-callback ( quot -- )
|
||||
RDI load-indirect "c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
%prepare-unbox
|
||||
! Put former top of data stack in RDI
|
||||
cell temp@ RDI MOV
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
! Put former top of data stack in RDI
|
||||
RDI cell temp@ MOV
|
||||
! Unbox former top of data stack to return registers
|
||||
unbox-return ;
|
||||
|
||||
M: x86.64 %cleanup ( alien-node -- ) drop ;
|
||||
|
||||
M: x86.64 %unwind ( n -- ) drop 0 RET ;
|
||||
|
||||
USE: cpu.x86.intrinsics
|
||||
|
||||
! On 64-bit systems, the result of reading 4 bytes from memory
|
||||
! is a fixnum.
|
||||
\ alien-unsigned-4 small-reg-32 define-unsigned-getter
|
||||
\ set-alien-unsigned-4 small-reg-32 define-setter
|
||||
|
||||
\ alien-signed-4 small-reg-32 define-signed-getter
|
||||
\ set-alien-signed-4 small-reg-32 define-setter
|
||||
|
|
@ -1,106 +0,0 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.accessors arrays generic kernel system
|
||||
kernel.private math math.private memory namespaces sequences
|
||||
words math.floats.private layouts quotations locals cpu.x86
|
||||
compiler.codegen compiler.cfg.templates compiler.cfg.builder
|
||||
compiler.cfg.registers compiler.constants compiler.backend
|
||||
compiler.backend.x86 ;
|
||||
IN: compiler.backend.x86.sse2
|
||||
|
||||
M:: x86 %box-float ( dst src temp -- )
|
||||
#! Only called by pentium4 backend, uses SSE2 instruction
|
||||
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< JAE }
|
||||
{ float<= JA }
|
||||
{ float> JBE }
|
||||
{ float>= JB }
|
||||
{ float= JNE }
|
||||
} [
|
||||
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-alien-float-intrinsics ( word get-quot word set-quot -- )
|
||||
[ "value" operand swap %alien-accessor ] curry
|
||||
alien-float-set-template
|
||||
define-intrinsic
|
||||
[ "value" operand swap %alien-accessor ] curry
|
||||
alien-float-get-template
|
||||
define-intrinsic ;
|
||||
|
||||
\ alien-double
|
||||
[ MOVSD ]
|
||||
\ set-alien-double
|
||||
[ swap MOVSD ]
|
||||
define-alien-float-intrinsics
|
||||
|
||||
\ alien-float
|
||||
[ dupd MOVSS dup CVTSS2SD ]
|
||||
\ set-alien-float
|
||||
[ swap dup dup CVTSD2SS MOVSS ]
|
||||
define-alien-float-intrinsics
|
||||
|
|
@ -1,643 +0,0 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays byte-arrays alien.accessors
|
||||
compiler.backend kernel kernel.private math memory namespaces
|
||||
make sequences words system layouts combinators math.order
|
||||
math.private alien alien.c-types slots.private cpu.x86
|
||||
cpu.x86.private locals compiler.backend compiler.codegen.fixup
|
||||
compiler.constants compiler.intrinsics compiler.cfg.builder
|
||||
compiler.cfg.registers compiler.cfg.stacks
|
||||
compiler.cfg.templates compiler.codegen ;
|
||||
IN: compiler.backend.x86
|
||||
|
||||
HOOK: ds-reg cpu ( -- reg )
|
||||
HOOK: rs-reg cpu ( -- reg )
|
||||
HOOK: stack-reg cpu ( -- reg )
|
||||
HOOK: stack-save-reg cpu ( -- reg )
|
||||
|
||||
: stack@ ( n -- op ) stack-reg swap [+] ;
|
||||
|
||||
: 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: int-regs %save-param-reg drop >r stack@ r> MOV ;
|
||||
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 ;
|
||||
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
|
||||
|
||||
GENERIC: push-return-reg ( reg-class -- )
|
||||
GENERIC: load-return-reg ( stack@ reg-class -- )
|
||||
GENERIC: store-return-reg ( stack@ 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: f load-literal
|
||||
\ f tag-number MOV drop ;
|
||||
|
||||
M: fixnum load-literal
|
||||
swap tag-fixnum MOV ;
|
||||
|
||||
M: x86 stack-frame ( n -- i )
|
||||
3 cells + 16 align cell - ;
|
||||
|
||||
: factor-area-size ( -- n ) 4 cells ;
|
||||
|
||||
M: x86 %prologue ( n -- )
|
||||
temp-reg-1 0 MOV rc-absolute-cell rel-this
|
||||
dup cell + PUSH
|
||||
temp-reg-1 PUSH
|
||||
stack-reg swap 2 cells - SUB ;
|
||||
|
||||
M: x86 %epilogue ( n -- )
|
||||
stack-reg swap ADD ;
|
||||
|
||||
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
|
||||
#! all roots.
|
||||
"stack_chain" f temp-reg-1 %alien-global
|
||||
temp-reg-1 [] stack-reg MOV
|
||||
temp-reg-1 [] cell SUB
|
||||
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 vreg -- ) \ f tag-number CMP JE ;
|
||||
|
||||
M: x86 %jump-t ( label vreg -- ) \ 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 fp-shadows-int? ( -- ? ) f ;
|
||||
|
||||
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 ;
|
||||
|
||||
: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
|
||||
|
||||
M: x86 %return ( -- ) 0 %unwind ;
|
||||
|
||||
! 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 %write-barrier ( src temp -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
! Mark the card
|
||||
src card-bits SHR
|
||||
"cards_offset" f temp %alien-global
|
||||
temp temp [+] card-mark <byte> MOV
|
||||
|
||||
! Mark the card deck
|
||||
temp deck-bits card-bits - SHR
|
||||
"decks_offset" f temp %alien-global
|
||||
temp temp [+] 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 ( temp -- )
|
||||
[ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
|
||||
|
||||
: inc-allot-ptr ( n temp -- )
|
||||
[ POP ] [ cell [+] swap 8 align ADD ] bi ;
|
||||
|
||||
: store-header ( temp type -- )
|
||||
[ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||
|
||||
: store-tagged ( dst temp tag -- )
|
||||
dupd tag-number OR MOV ;
|
||||
|
||||
M:: x86 %allot ( dst size type tag temp -- )
|
||||
temp load-allot-ptr
|
||||
temp type store-header
|
||||
temp size inc-allot-ptr
|
||||
dst temp store-tagged ;
|
||||
|
||||
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 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
|
||||
\ f tag-number MOV
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
! Type checks
|
||||
\ tag [
|
||||
"in" operand tag-mask get AND
|
||||
"in" operand %tag-fixnum
|
||||
] T{ template
|
||||
{ input { { f "in" } } }
|
||||
{ output { "in" } }
|
||||
} define-intrinsic
|
||||
|
||||
! Slots
|
||||
: %slot-literal-known-tag ( -- op )
|
||||
"obj" operand
|
||||
"n" get cells
|
||||
"obj" operand-tag - [+] ;
|
||||
|
||||
: %slot-literal-any-tag ( -- op )
|
||||
"obj" operand %untag
|
||||
"obj" operand "n" get cells [+] ;
|
||||
|
||||
: %slot-any ( -- op )
|
||||
"obj" operand %untag
|
||||
"n" operand fixnum>slot@
|
||||
"obj" operand "n" operand [+] ;
|
||||
|
||||
\ slot {
|
||||
! Slot number is literal and the tag is known
|
||||
{
|
||||
[ "val" operand %slot-literal-known-tag MOV ] T{ template
|
||||
{ input { { f "obj" known-tag } { small-slot "n" } } }
|
||||
{ scratch { { f "val" } } }
|
||||
{ output { "val" } }
|
||||
}
|
||||
}
|
||||
! Slot number is literal
|
||||
{
|
||||
[ "obj" operand %slot-literal-any-tag MOV ] T{ template
|
||||
{ input { { f "obj" } { small-slot "n" } } }
|
||||
{ output { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number in a register
|
||||
{
|
||||
[ "obj" operand %slot-any MOV ] T{ template
|
||||
{ input { { f "obj" } { f "n" } } }
|
||||
{ output { "obj" } }
|
||||
{ clobber { "n" } }
|
||||
}
|
||||
}
|
||||
} define-intrinsics
|
||||
|
||||
\ (set-slot) {
|
||||
! Slot number is literal and the tag is known
|
||||
{
|
||||
[ %slot-literal-known-tag "val" operand MOV ] T{ template
|
||||
{ input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number is literal
|
||||
{
|
||||
[ %slot-literal-any-tag "val" operand MOV ] T{ template
|
||||
{ input { { f "val" } { f "obj" } { small-slot "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number in a register
|
||||
{
|
||||
[ %slot-any "val" operand MOV ] T{ template
|
||||
{ input { { f "val" } { f "obj" } { f "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" "n" } }
|
||||
}
|
||||
}
|
||||
} define-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 = RBX EBX ? ; inline
|
||||
: small-reg-8 BL ; inline
|
||||
: small-reg-16 BX ; inline
|
||||
: small-reg-32 EBX ; inline
|
||||
|
||||
! 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" get 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
|
||||
|
||||
: %untag-fixnums ( seq -- )
|
||||
[ %untag-fixnum ] unique-operands ;
|
||||
|
||||
\ fixnum-shift-fast [
|
||||
"x" operand "y" get
|
||||
dup 0 < [ neg SAR ] [ SHL ] if
|
||||
! Mask off low bits
|
||||
"x" operand %untag
|
||||
] T{ template
|
||||
{ input { { f "x" } { [ ] "y" } } }
|
||||
{ output { "x" } }
|
||||
} define-intrinsic
|
||||
|
||||
: 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-fixnums
|
||||
"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 ] curry 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-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 ] keep fixnum-register-jump
|
||||
2array define-if-intrinsics ;
|
||||
|
||||
{
|
||||
{ fixnum< JL }
|
||||
{ fixnum<= JLE }
|
||||
{ fixnum> JG }
|
||||
{ fixnum>= JGE }
|
||||
{ eq? JE }
|
||||
} [
|
||||
first2 define-fixnum-jump
|
||||
] each
|
||||
|
||||
\ fixnum>bignum [
|
||||
"x" operand %untag-fixnum
|
||||
"x" operand dup "scratch" operand %allot-bignum-signed-1
|
||||
] T{ template
|
||||
{ input { { f "x" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ output { "x" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ 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
|
||||
: %alien-accessor ( quot -- )
|
||||
"offset" operand %untag-fixnum
|
||||
"offset" operand "alien" operand ADD
|
||||
"offset" operand [] swap call ; inline
|
||||
|
||||
: %alien-integer-get ( quot reg -- )
|
||||
small-reg PUSH
|
||||
swap %alien-accessor
|
||||
"value" operand small-reg MOV
|
||||
"value" operand %tag-fixnum
|
||||
small-reg POP ; 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 quot reg -- )
|
||||
[ %alien-integer-get ] 2curry
|
||||
alien-integer-get-template
|
||||
define-intrinsic ;
|
||||
|
||||
: define-unsigned-getter ( word reg -- )
|
||||
[ small-reg dup XOR MOV ] swap define-getter ;
|
||||
|
||||
: define-signed-getter ( word reg -- )
|
||||
[ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
|
||||
|
||||
: %alien-integer-set ( quot reg -- )
|
||||
small-reg PUSH
|
||||
small-reg "value" operand MOV
|
||||
small-reg %untag-fixnum
|
||||
swap %alien-accessor
|
||||
small-reg POP ; 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 -- )
|
||||
[ swap MOV ] swap
|
||||
[ %alien-integer-set ] 2curry
|
||||
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 [
|
||||
"value" operand [ MOV ] %alien-accessor
|
||||
] 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 [
|
||||
"value" operand [ swap MOV ] %alien-accessor
|
||||
] T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "value" pinned-c-ptr }
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ clobber { "offset" } }
|
||||
} define-intrinsic
|
||||
Loading…
Reference in New Issue