compiler backend now dispatches on the os
parent
d736a8660d
commit
7cb3fdcfec
|
@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien
|
||||||
byte-arrays bit-arrays float-arrays combinators words ;
|
byte-arrays bit-arrays float-arrays combinators words ;
|
||||||
IN: cpu.architecture
|
IN: cpu.architecture
|
||||||
|
|
||||||
SYMBOL: compiler-backend
|
|
||||||
|
|
||||||
! A pseudo-register class for parameters spilled on the stack
|
! A pseudo-register class for parameters spilled on the stack
|
||||||
TUPLE: stack-params ;
|
TUPLE: stack-params ;
|
||||||
|
|
||||||
|
@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs )
|
||||||
! Load a literal (immediate or indirect)
|
! Load a literal (immediate or indirect)
|
||||||
GENERIC# load-literal 1 ( obj vreg -- )
|
GENERIC# load-literal 1 ( obj vreg -- )
|
||||||
|
|
||||||
HOOK: load-indirect compiler-backend ( obj reg -- )
|
HOOK: load-indirect cpu ( obj reg -- )
|
||||||
|
|
||||||
HOOK: stack-frame compiler-backend ( frame-size -- n )
|
HOOK: stack-frame cpu ( frame-size -- n )
|
||||||
|
|
||||||
: stack-frame* ( -- n )
|
: stack-frame* ( -- n )
|
||||||
\ stack-frame get stack-frame ;
|
\ stack-frame get stack-frame ;
|
||||||
|
|
||||||
! Set up caller stack frame
|
! Set up caller stack frame
|
||||||
HOOK: %prologue compiler-backend ( n -- )
|
HOOK: %prologue cpu ( n -- )
|
||||||
|
|
||||||
: %prologue-later \ %prologue-later , ;
|
: %prologue-later \ %prologue-later , ;
|
||||||
|
|
||||||
! Tear down stack frame
|
! Tear down stack frame
|
||||||
HOOK: %epilogue compiler-backend ( n -- )
|
HOOK: %epilogue cpu ( n -- )
|
||||||
|
|
||||||
: %epilogue-later \ %epilogue-later , ;
|
: %epilogue-later \ %epilogue-later , ;
|
||||||
|
|
||||||
! Store word XT in stack frame
|
! Store word XT in stack frame
|
||||||
HOOK: %save-word-xt compiler-backend ( -- )
|
HOOK: %save-word-xt cpu ( -- )
|
||||||
|
|
||||||
! Store dispatch branch XT in stack frame
|
! Store dispatch branch XT in stack frame
|
||||||
HOOK: %save-dispatch-xt compiler-backend ( -- )
|
HOOK: %save-dispatch-xt cpu ( -- )
|
||||||
|
|
||||||
M: object %save-dispatch-xt %save-word-xt ;
|
M: object %save-dispatch-xt %save-word-xt ;
|
||||||
|
|
||||||
! Call another word
|
! Call another word
|
||||||
HOOK: %call compiler-backend ( word -- )
|
HOOK: %call cpu ( word -- )
|
||||||
|
|
||||||
! Local jump for branches
|
! Local jump for branches
|
||||||
HOOK: %jump-label compiler-backend ( label -- )
|
HOOK: %jump-label cpu ( label -- )
|
||||||
|
|
||||||
! Test if vreg is 'f' or not
|
! Test if vreg is 'f' or not
|
||||||
HOOK: %jump-t compiler-backend ( label -- )
|
HOOK: %jump-t cpu ( label -- )
|
||||||
|
|
||||||
HOOK: %dispatch compiler-backend ( -- )
|
HOOK: %dispatch cpu ( -- )
|
||||||
|
|
||||||
HOOK: %dispatch-label compiler-backend ( word -- )
|
HOOK: %dispatch-label cpu ( word -- )
|
||||||
|
|
||||||
! Return to caller
|
! Return to caller
|
||||||
HOOK: %return compiler-backend ( -- )
|
HOOK: %return cpu ( -- )
|
||||||
|
|
||||||
! Change datastack height
|
! Change datastack height
|
||||||
HOOK: %inc-d compiler-backend ( n -- )
|
HOOK: %inc-d cpu ( n -- )
|
||||||
|
|
||||||
! Change callstack height
|
! Change callstack height
|
||||||
HOOK: %inc-r compiler-backend ( n -- )
|
HOOK: %inc-r cpu ( n -- )
|
||||||
|
|
||||||
! Load stack into vreg
|
! Load stack into vreg
|
||||||
HOOK: %peek compiler-backend ( vreg loc -- )
|
HOOK: %peek cpu ( vreg loc -- )
|
||||||
|
|
||||||
! Store vreg to stack
|
! Store vreg to stack
|
||||||
HOOK: %replace compiler-backend ( vreg loc -- )
|
HOOK: %replace cpu ( vreg loc -- )
|
||||||
|
|
||||||
! Box and unbox floats
|
! Box and unbox floats
|
||||||
HOOK: %unbox-float compiler-backend ( dst src -- )
|
HOOK: %unbox-float cpu ( dst src -- )
|
||||||
HOOK: %box-float compiler-backend ( dst src -- )
|
HOOK: %box-float cpu ( dst src -- )
|
||||||
|
|
||||||
! FFI stuff
|
! FFI stuff
|
||||||
|
|
||||||
! Is this integer small enough to appear in value template
|
! Is this integer small enough to appear in value template
|
||||||
! slots?
|
! slots?
|
||||||
HOOK: small-enough? compiler-backend ( n -- ? )
|
HOOK: small-enough? cpu ( n -- ? )
|
||||||
|
|
||||||
! Is this structure small enough to be returned in registers?
|
! Is this structure small enough to be returned in registers?
|
||||||
HOOK: struct-small-enough? compiler-backend ( size -- ? )
|
HOOK: struct-small-enough? cpu ( size -- ? )
|
||||||
|
|
||||||
! Do we pass explode value structs?
|
! Do we pass explode value structs?
|
||||||
HOOK: value-structs? compiler-backend ( -- ? )
|
HOOK: value-structs? cpu ( -- ? )
|
||||||
|
|
||||||
! If t, fp parameters are shadowed by dummy int parameters
|
! If t, fp parameters are shadowed by dummy int parameters
|
||||||
HOOK: fp-shadows-int? compiler-backend ( -- ? )
|
HOOK: fp-shadows-int? cpu ( -- ? )
|
||||||
|
|
||||||
HOOK: %prepare-unbox compiler-backend ( -- )
|
HOOK: %prepare-unbox cpu ( -- )
|
||||||
|
|
||||||
HOOK: %unbox compiler-backend ( n reg-class func -- )
|
HOOK: %unbox cpu ( n reg-class func -- )
|
||||||
|
|
||||||
HOOK: %unbox-long-long compiler-backend ( n func -- )
|
HOOK: %unbox-long-long cpu ( n func -- )
|
||||||
|
|
||||||
HOOK: %unbox-small-struct compiler-backend ( size -- )
|
HOOK: %unbox-small-struct cpu ( size -- )
|
||||||
|
|
||||||
HOOK: %unbox-large-struct compiler-backend ( n size -- )
|
HOOK: %unbox-large-struct cpu ( n size -- )
|
||||||
|
|
||||||
HOOK: %box compiler-backend ( n reg-class func -- )
|
HOOK: %box cpu ( n reg-class func -- )
|
||||||
|
|
||||||
HOOK: %box-long-long compiler-backend ( n func -- )
|
HOOK: %box-long-long cpu ( n func -- )
|
||||||
|
|
||||||
HOOK: %prepare-box-struct compiler-backend ( size -- )
|
HOOK: %prepare-box-struct cpu ( size -- )
|
||||||
|
|
||||||
HOOK: %box-small-struct compiler-backend ( size -- )
|
HOOK: %box-small-struct cpu ( size -- )
|
||||||
|
|
||||||
HOOK: %box-large-struct compiler-backend ( n size -- )
|
HOOK: %box-large-struct cpu ( n size -- )
|
||||||
|
|
||||||
GENERIC: %save-param-reg ( stack reg reg-class -- )
|
GENERIC: %save-param-reg ( stack reg reg-class -- )
|
||||||
|
|
||||||
GENERIC: %load-param-reg ( stack reg reg-class -- )
|
GENERIC: %load-param-reg ( stack reg reg-class -- )
|
||||||
|
|
||||||
HOOK: %prepare-alien-invoke compiler-backend ( -- )
|
HOOK: %prepare-alien-invoke cpu ( -- )
|
||||||
|
|
||||||
HOOK: %prepare-var-args compiler-backend ( -- )
|
HOOK: %prepare-var-args cpu ( -- )
|
||||||
|
|
||||||
M: object %prepare-var-args ;
|
M: object %prepare-var-args ;
|
||||||
|
|
||||||
HOOK: %alien-invoke compiler-backend ( function library -- )
|
HOOK: %alien-invoke cpu ( function library -- )
|
||||||
|
|
||||||
HOOK: %cleanup compiler-backend ( alien-node -- )
|
HOOK: %cleanup cpu ( alien-node -- )
|
||||||
|
|
||||||
HOOK: %alien-callback compiler-backend ( quot -- )
|
HOOK: %alien-callback cpu ( quot -- )
|
||||||
|
|
||||||
HOOK: %callback-value compiler-backend ( ctype -- )
|
HOOK: %callback-value cpu ( ctype -- )
|
||||||
|
|
||||||
! Return to caller with stdcall unwinding (only for x86)
|
! Return to caller with stdcall unwinding (only for x86)
|
||||||
HOOK: %unwind compiler-backend ( n -- )
|
HOOK: %unwind cpu ( n -- )
|
||||||
|
|
||||||
HOOK: %prepare-alien-indirect compiler-backend ( -- )
|
HOOK: %prepare-alien-indirect cpu ( -- )
|
||||||
|
|
||||||
HOOK: %alien-indirect compiler-backend ( -- )
|
HOOK: %alien-indirect cpu ( -- )
|
||||||
|
|
||||||
M: stack-params param-reg drop ;
|
M: stack-params param-reg drop ;
|
||||||
|
|
||||||
|
@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ;
|
||||||
] if-small-struct ;
|
] if-small-struct ;
|
||||||
|
|
||||||
! Alien accessors
|
! Alien accessors
|
||||||
HOOK: %unbox-byte-array compiler-backend ( dst src -- )
|
HOOK: %unbox-byte-array cpu ( dst src -- )
|
||||||
|
|
||||||
HOOK: %unbox-alien compiler-backend ( dst src -- )
|
HOOK: %unbox-alien cpu ( dst src -- )
|
||||||
|
|
||||||
HOOK: %unbox-f compiler-backend ( dst src -- )
|
HOOK: %unbox-f cpu ( dst src -- )
|
||||||
|
|
||||||
HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
|
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
||||||
|
|
||||||
HOOK: %box-alien compiler-backend ( dst src -- )
|
HOOK: %box-alien cpu ( dst src -- )
|
||||||
|
|
||||||
: operand ( var -- op ) get v>operand ; inline
|
: operand ( var -- op ) get v>operand ; inline
|
||||||
|
|
||||||
|
|
|
@ -32,7 +32,7 @@ IN: cpu.ppc.allot
|
||||||
12 11 float tag-number ORI
|
12 11 float tag-number ORI
|
||||||
f fresh-object ;
|
f fresh-object ;
|
||||||
|
|
||||||
M: ppc-backend %box-float ( dst src -- )
|
M: ppc %box-float ( dst src -- )
|
||||||
[ v>operand ] bi@ %allot-float 12 MR ;
|
[ v>operand ] bi@ %allot-float 12 MR ;
|
||||||
|
|
||||||
: %allot-bignum ( #digits -- )
|
: %allot-bignum ( #digits -- )
|
||||||
|
@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- )
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
M: ppc-backend %box-alien ( dst src -- )
|
M: ppc %box-alien ( dst src -- )
|
||||||
{ "end" "f" } [ define-label ] each
|
{ "end" "f" } [ define-label ] each
|
||||||
0 over v>operand 0 CMPI
|
0 over v>operand 0 CMPI
|
||||||
"f" get BEQ
|
"f" get BEQ
|
||||||
|
|
|
@ -7,8 +7,6 @@ layouts classes words.private alien combinators
|
||||||
compiler.constants ;
|
compiler.constants ;
|
||||||
IN: cpu.ppc.architecture
|
IN: cpu.ppc.architecture
|
||||||
|
|
||||||
TUPLE: ppc-backend ;
|
|
||||||
|
|
||||||
! PowerPC register assignments
|
! PowerPC register assignments
|
||||||
! r3-r10, r16-r31: integer vregs
|
! r3-r10, r16-r31: integer vregs
|
||||||
! f0-f13: float vregs
|
! f0-f13: float vregs
|
||||||
|
@ -44,7 +42,7 @@ TUPLE: ppc-backend ;
|
||||||
|
|
||||||
: xt-save ( n -- i ) 2 cells - ;
|
: xt-save ( n -- i ) 2 cells - ;
|
||||||
|
|
||||||
M: ppc-backend stack-frame ( n -- i )
|
M: ppc stack-frame ( n -- i )
|
||||||
local@ factor-area-size + 4 cells align ;
|
local@ factor-area-size + 4 cells align ;
|
||||||
|
|
||||||
M: temp-reg v>operand drop 11 ;
|
M: temp-reg v>operand drop 11 ;
|
||||||
|
@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
|
||||||
M: immediate load-literal
|
M: immediate load-literal
|
||||||
[ v>operand ] bi@ LOAD ;
|
[ v>operand ] bi@ LOAD ;
|
||||||
|
|
||||||
M: ppc-backend load-indirect ( obj reg -- )
|
M: ppc load-indirect ( obj reg -- )
|
||||||
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
|
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
|
||||||
dup 0 LWZ ;
|
dup 0 LWZ ;
|
||||||
|
|
||||||
M: ppc-backend %save-word-xt ( -- )
|
M: ppc %save-word-xt ( -- )
|
||||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
|
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
|
||||||
|
|
||||||
M: ppc-backend %prologue ( n -- )
|
M: ppc %prologue ( n -- )
|
||||||
0 MFLR
|
0 MFLR
|
||||||
1 1 pick neg ADDI
|
1 1 pick neg ADDI
|
||||||
11 1 pick xt-save STW
|
11 1 pick xt-save STW
|
||||||
|
@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- )
|
||||||
11 1 pick next-save STW
|
11 1 pick next-save STW
|
||||||
0 1 rot lr-save + STW ;
|
0 1 rot lr-save + STW ;
|
||||||
|
|
||||||
M: ppc-backend %epilogue ( n -- )
|
M: ppc %epilogue ( n -- )
|
||||||
#! At the end of each word that calls a subroutine, we store
|
#! At the end of each word that calls a subroutine, we store
|
||||||
#! the previous link register value in r0 by popping it off
|
#! the previous link register value in r0 by popping it off
|
||||||
#! the stack, set the link register to the contents of r0,
|
#! the stack, set the link register to the contents of r0,
|
||||||
|
@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- )
|
||||||
: %load-dlsym ( symbol dll register -- )
|
: %load-dlsym ( symbol dll register -- )
|
||||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||||
|
|
||||||
M: ppc-backend %call ( label -- ) BL ;
|
M: ppc %call ( label -- ) BL ;
|
||||||
|
|
||||||
M: ppc-backend %jump-label ( label -- ) B ;
|
M: ppc %jump-label ( label -- ) B ;
|
||||||
|
|
||||||
M: ppc-backend %jump-t ( label -- )
|
M: ppc %jump-t ( label -- )
|
||||||
0 "flag" operand f v>operand CMPI BNE ;
|
0 "flag" operand f v>operand CMPI BNE ;
|
||||||
|
|
||||||
M: ppc-backend %dispatch ( -- )
|
M: ppc %dispatch ( -- )
|
||||||
[
|
[
|
||||||
%epilogue-later
|
%epilogue-later
|
||||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
|
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
|
||||||
|
@ -124,25 +122,25 @@ M: ppc-backend %dispatch ( -- )
|
||||||
{ +scratch+ { { f "offset" } } }
|
{ +scratch+ { { f "offset" } } }
|
||||||
} with-template ;
|
} with-template ;
|
||||||
|
|
||||||
M: ppc-backend %dispatch-label ( word -- )
|
M: ppc %dispatch-label ( word -- )
|
||||||
0 , rc-absolute-cell rel-word ;
|
0 , rc-absolute-cell rel-word ;
|
||||||
|
|
||||||
M: ppc-backend %return ( -- ) %epilogue-later BLR ;
|
M: ppc %return ( -- ) %epilogue-later BLR ;
|
||||||
|
|
||||||
M: ppc-backend %unwind drop %return ;
|
M: ppc %unwind drop %return ;
|
||||||
|
|
||||||
M: ppc-backend %peek ( vreg loc -- )
|
M: ppc %peek ( vreg loc -- )
|
||||||
>r v>operand r> loc>operand LWZ ;
|
>r v>operand r> loc>operand LWZ ;
|
||||||
|
|
||||||
M: ppc-backend %replace
|
M: ppc %replace
|
||||||
>r v>operand r> loc>operand STW ;
|
>r v>operand r> loc>operand STW ;
|
||||||
|
|
||||||
M: ppc-backend %unbox-float ( dst src -- )
|
M: ppc %unbox-float ( dst src -- )
|
||||||
[ v>operand ] bi@ float-offset LFD ;
|
[ v>operand ] bi@ float-offset LFD ;
|
||||||
|
|
||||||
M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
|
M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
|
||||||
|
|
||||||
M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
|
M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
|
||||||
|
|
||||||
M: int-regs %save-param-reg drop 1 rot local@ STW ;
|
M: int-regs %save-param-reg drop 1 rot local@ STW ;
|
||||||
|
|
||||||
|
@ -166,19 +164,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- )
|
||||||
0 1 rot param@ stack-frame* + LWZ
|
0 1 rot param@ stack-frame* + LWZ
|
||||||
0 1 rot local@ STW ;
|
0 1 rot local@ STW ;
|
||||||
|
|
||||||
M: ppc-backend %prepare-unbox ( -- )
|
M: ppc %prepare-unbox ( -- )
|
||||||
! First parameter is top of stack
|
! First parameter is top of stack
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
ds-reg dup cell SUBI ;
|
ds-reg dup cell SUBI ;
|
||||||
|
|
||||||
M: ppc-backend %unbox ( n reg-class func -- )
|
M: ppc %unbox ( n reg-class func -- )
|
||||||
! Value must be in r3
|
! Value must be in r3
|
||||||
! Call the unboxer
|
! Call the unboxer
|
||||||
f %alien-invoke
|
f %alien-invoke
|
||||||
! Store the return value on the C stack
|
! Store the return value on the C stack
|
||||||
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
|
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
|
||||||
|
|
||||||
M: ppc-backend %unbox-long-long ( n func -- )
|
M: ppc %unbox-long-long ( n func -- )
|
||||||
! Value must be in r3:r4
|
! Value must be in r3:r4
|
||||||
! Call the unboxer
|
! Call the unboxer
|
||||||
f %alien-invoke
|
f %alien-invoke
|
||||||
|
@ -188,7 +186,7 @@ M: ppc-backend %unbox-long-long ( n func -- )
|
||||||
4 1 rot cell + local@ STW
|
4 1 rot cell + local@ STW
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
||||||
M: ppc-backend %unbox-large-struct ( n size -- )
|
M: ppc %unbox-large-struct ( n size -- )
|
||||||
! Value must be in r3
|
! Value must be in r3
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
4 1 roll local@ ADDI
|
4 1 roll local@ ADDI
|
||||||
|
@ -197,7 +195,7 @@ M: ppc-backend %unbox-large-struct ( n size -- )
|
||||||
! Call the function
|
! Call the function
|
||||||
"to_value_struct" f %alien-invoke ;
|
"to_value_struct" f %alien-invoke ;
|
||||||
|
|
||||||
M: ppc-backend %box ( n reg-class func -- )
|
M: ppc %box ( n reg-class func -- )
|
||||||
! If the source is a stack location, load it into freg #0.
|
! If the source is a stack location, load it into freg #0.
|
||||||
! If the source is f, then we assume the value is already in
|
! If the source is f, then we assume the value is already in
|
||||||
! freg #0.
|
! freg #0.
|
||||||
|
@ -205,7 +203,7 @@ M: ppc-backend %box ( n reg-class func -- )
|
||||||
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
|
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
|
||||||
r> f %alien-invoke ;
|
r> f %alien-invoke ;
|
||||||
|
|
||||||
M: ppc-backend %box-long-long ( n func -- )
|
M: ppc %box-long-long ( n func -- )
|
||||||
>r [
|
>r [
|
||||||
3 1 pick local@ LWZ
|
3 1 pick local@ LWZ
|
||||||
4 1 rot cell + local@ LWZ
|
4 1 rot cell + local@ LWZ
|
||||||
|
@ -215,12 +213,12 @@ M: ppc-backend %box-long-long ( n func -- )
|
||||||
|
|
||||||
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
|
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
|
||||||
|
|
||||||
M: ppc-backend %prepare-box-struct ( size -- )
|
M: ppc %prepare-box-struct ( size -- )
|
||||||
#! Compute target address for value struct return
|
#! Compute target address for value struct return
|
||||||
3 1 rot f struct-return@ ADDI
|
3 1 rot f struct-return@ ADDI
|
||||||
3 1 0 local@ STW ;
|
3 1 0 local@ STW ;
|
||||||
|
|
||||||
M: ppc-backend %box-large-struct ( n size -- )
|
M: ppc %box-large-struct ( n size -- )
|
||||||
#! If n = f, then we're boxing a returned struct
|
#! If n = f, then we're boxing a returned struct
|
||||||
[ swap struct-return@ ] keep
|
[ swap struct-return@ ] keep
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
|
@ -230,7 +228,7 @@ M: ppc-backend %box-large-struct ( n size -- )
|
||||||
! Call the function
|
! Call the function
|
||||||
"box_value_struct" f %alien-invoke ;
|
"box_value_struct" f %alien-invoke ;
|
||||||
|
|
||||||
M: ppc-backend %prepare-alien-invoke
|
M: ppc %prepare-alien-invoke
|
||||||
#! Save Factor stack pointers in case the C code calls a
|
#! Save Factor stack pointers in case the C code calls a
|
||||||
#! callback which does a GC, which must reliably trace
|
#! callback which does a GC, which must reliably trace
|
||||||
#! all roots.
|
#! all roots.
|
||||||
|
@ -240,20 +238,20 @@ M: ppc-backend %prepare-alien-invoke
|
||||||
ds-reg 11 8 STW
|
ds-reg 11 8 STW
|
||||||
rs-reg 11 12 STW ;
|
rs-reg 11 12 STW ;
|
||||||
|
|
||||||
M: ppc-backend %alien-invoke ( symbol dll -- )
|
M: ppc %alien-invoke ( symbol dll -- )
|
||||||
11 %load-dlsym (%call) ;
|
11 %load-dlsym (%call) ;
|
||||||
|
|
||||||
M: ppc-backend %alien-callback ( quot -- )
|
M: ppc %alien-callback ( quot -- )
|
||||||
3 load-indirect "c_to_factor" f %alien-invoke ;
|
3 load-indirect "c_to_factor" f %alien-invoke ;
|
||||||
|
|
||||||
M: ppc-backend %prepare-alien-indirect ( -- )
|
M: ppc %prepare-alien-indirect ( -- )
|
||||||
"unbox_alien" f %alien-invoke
|
"unbox_alien" f %alien-invoke
|
||||||
3 1 cell temp@ STW ;
|
3 1 cell temp@ STW ;
|
||||||
|
|
||||||
M: ppc-backend %alien-indirect ( -- )
|
M: ppc %alien-indirect ( -- )
|
||||||
11 1 cell temp@ LWZ (%call) ;
|
11 1 cell temp@ LWZ (%call) ;
|
||||||
|
|
||||||
M: ppc-backend %callback-value ( ctype -- )
|
M: ppc %callback-value ( ctype -- )
|
||||||
! Save top of data stack
|
! Save top of data stack
|
||||||
3 ds-reg 0 LWZ
|
3 ds-reg 0 LWZ
|
||||||
3 1 0 local@ STW
|
3 1 0 local@ STW
|
||||||
|
@ -264,7 +262,7 @@ M: ppc-backend %callback-value ( ctype -- )
|
||||||
! Unbox former top of data stack to return registers
|
! Unbox former top of data stack to return registers
|
||||||
unbox-return ;
|
unbox-return ;
|
||||||
|
|
||||||
M: ppc-backend %cleanup ( alien-node -- ) drop ;
|
M: ppc %cleanup ( alien-node -- ) drop ;
|
||||||
|
|
||||||
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
|
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
|
||||||
|
|
||||||
|
@ -272,34 +270,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
|
||||||
|
|
||||||
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
|
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
|
||||||
|
|
||||||
M: ppc-backend value-structs?
|
M: ppc value-structs?
|
||||||
#! On Linux/PPC, value structs are passed in the same way
|
#! On Linux/PPC, value structs are passed in the same way
|
||||||
#! as reference structs, we just have to make a copy first.
|
#! as reference structs, we just have to make a copy first.
|
||||||
linux? not ;
|
linux? not ;
|
||||||
|
|
||||||
M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
|
M: ppc fp-shadows-int? ( -- ? ) macosx? ;
|
||||||
|
|
||||||
M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ;
|
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||||
|
|
||||||
M: ppc-backend struct-small-enough? ( size -- ? ) drop f ;
|
M: ppc struct-small-enough? ( size -- ? ) drop f ;
|
||||||
|
|
||||||
M: ppc-backend %box-small-struct
|
M: ppc %box-small-struct
|
||||||
drop "No small structs" throw ;
|
drop "No small structs" throw ;
|
||||||
|
|
||||||
M: ppc-backend %unbox-small-struct
|
M: ppc %unbox-small-struct
|
||||||
drop "No small structs" throw ;
|
drop "No small structs" throw ;
|
||||||
|
|
||||||
! Alien intrinsics
|
! Alien intrinsics
|
||||||
M: ppc-backend %unbox-byte-array ( dst src -- )
|
M: ppc %unbox-byte-array ( dst src -- )
|
||||||
[ v>operand ] bi@ byte-array-offset ADDI ;
|
[ v>operand ] bi@ byte-array-offset ADDI ;
|
||||||
|
|
||||||
M: ppc-backend %unbox-alien ( dst src -- )
|
M: ppc %unbox-alien ( dst src -- )
|
||||||
[ v>operand ] bi@ alien-offset LWZ ;
|
[ v>operand ] bi@ alien-offset LWZ ;
|
||||||
|
|
||||||
M: ppc-backend %unbox-f ( dst src -- )
|
M: ppc %unbox-f ( dst src -- )
|
||||||
drop 0 swap v>operand LI ;
|
drop 0 swap v>operand LI ;
|
||||||
|
|
||||||
M: ppc-backend %unbox-any-c-ptr ( dst src -- )
|
M: ppc %unbox-any-c-ptr ( dst src -- )
|
||||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||||
! Address is computed in R12
|
! Address is computed in R12
|
||||||
0 12 LI
|
0 12 LI
|
||||||
|
|
|
@ -12,8 +12,6 @@ namespaces alien.c-types kernel system combinators ;
|
||||||
] }
|
] }
|
||||||
} cond
|
} cond
|
||||||
|
|
||||||
T{ ppc-backend } compiler-backend set-global
|
|
||||||
|
|
||||||
macosx? [
|
macosx? [
|
||||||
4 "double" c-type set-c-type-align
|
4 "double" c-type set-c-type-align
|
||||||
] when
|
] when
|
||||||
|
|
|
@ -8,23 +8,20 @@ alien.compiler combinators command-line
|
||||||
compiler compiler.units io vocabs.loader accessors ;
|
compiler compiler.units io vocabs.loader accessors ;
|
||||||
IN: cpu.x86.32
|
IN: cpu.x86.32
|
||||||
|
|
||||||
PREDICATE: x86-32-backend < x86-backend
|
|
||||||
x86-backend-cell 4 = ;
|
|
||||||
|
|
||||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||||
! OS X requires that the stack be 16-byte aligned, and we do
|
! OS X requires that the stack be 16-byte aligned, and we do
|
||||||
! this on all platforms, sacrificing some stack space for
|
! this on all platforms, sacrificing some stack space for
|
||||||
! code simplicity.
|
! code simplicity.
|
||||||
|
|
||||||
M: x86-32-backend ds-reg ESI ;
|
M: x86.32 ds-reg ESI ;
|
||||||
M: x86-32-backend rs-reg EDI ;
|
M: x86.32 rs-reg EDI ;
|
||||||
M: x86-32-backend stack-reg ESP ;
|
M: x86.32 stack-reg ESP ;
|
||||||
M: x86-32-backend xt-reg ECX ;
|
M: x86.32 xt-reg ECX ;
|
||||||
M: x86-32-backend stack-save-reg EDX ;
|
M: x86.32 stack-save-reg EDX ;
|
||||||
|
|
||||||
M: temp-reg v>operand drop EBX ;
|
M: temp-reg v>operand drop EBX ;
|
||||||
|
|
||||||
M: x86-32-backend %alien-invoke ( symbol dll -- )
|
M: x86.32 %alien-invoke ( symbol dll -- )
|
||||||
(CALL) rel-dlsym ;
|
(CALL) rel-dlsym ;
|
||||||
|
|
||||||
! On x86, parameters are never passed in registers.
|
! On x86, parameters are never passed in registers.
|
||||||
|
@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
|
||||||
|
|
||||||
! On x86, we can always use an address as an operand
|
! On x86, we can always use an address as an operand
|
||||||
! directly.
|
! directly.
|
||||||
M: x86-32-backend address-operand ;
|
M: x86.32 address-operand ;
|
||||||
|
|
||||||
M: x86-32-backend fixnum>slot@ 1 SHR ;
|
M: x86.32 fixnum>slot@ 1 SHR ;
|
||||||
|
|
||||||
M: x86-32-backend prepare-division CDQ ;
|
M: x86.32 prepare-division CDQ ;
|
||||||
|
|
||||||
M: x86-32-backend load-indirect
|
M: x86.32 load-indirect
|
||||||
0 [] MOV rc-absolute-cell rel-literal ;
|
0 [] MOV rc-absolute-cell rel-literal ;
|
||||||
|
|
||||||
M: object %load-param-reg 3drop ;
|
M: object %load-param-reg 3drop ;
|
||||||
|
|
||||||
M: object %save-param-reg 3drop ;
|
M: object %save-param-reg 3drop ;
|
||||||
|
|
||||||
M: x86-32-backend %prepare-unbox ( -- )
|
M: x86.32 %prepare-unbox ( -- )
|
||||||
#! Move top of data stack to EAX.
|
#! Move top of data stack to EAX.
|
||||||
EAX ESI [] MOV
|
EAX ESI [] MOV
|
||||||
ESI 4 SUB ;
|
ESI 4 SUB ;
|
||||||
|
@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- )
|
||||||
f %alien-invoke
|
f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
M: x86-32-backend %unbox ( n reg-class func -- )
|
M: x86.32 %unbox ( n reg-class func -- )
|
||||||
#! The value being unboxed must already be in EAX.
|
#! The value being unboxed must already be in EAX.
|
||||||
#! If n is f, we're unboxing a return value about to be
|
#! If n is f, we're unboxing a return value about to be
|
||||||
#! returned by the callback. Otherwise, we're unboxing
|
#! returned by the callback. Otherwise, we're unboxing
|
||||||
|
@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- )
|
||||||
! Store the return value on the C stack
|
! Store the return value on the C stack
|
||||||
over [ store-return-reg ] [ 2drop ] if ;
|
over [ store-return-reg ] [ 2drop ] if ;
|
||||||
|
|
||||||
M: x86-32-backend %unbox-long-long ( n func -- )
|
M: x86.32 %unbox-long-long ( n func -- )
|
||||||
(%unbox)
|
(%unbox)
|
||||||
! Store the return value on the C stack
|
! Store the return value on the C stack
|
||||||
[
|
[
|
||||||
|
@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- )
|
||||||
cell + stack@ EDX MOV
|
cell + stack@ EDX MOV
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
||||||
M: x86-32-backend %unbox-struct-2
|
M: x86.32 %unbox-struct-2
|
||||||
#! Alien must be in EAX.
|
#! Alien must be in EAX.
|
||||||
4 [
|
4 [
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
|
@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2
|
||||||
EAX EAX [] MOV
|
EAX EAX [] MOV
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
M: x86-32-backend %unbox-large-struct ( n size -- )
|
M: x86.32 %unbox-large-struct ( n size -- )
|
||||||
#! Alien must be in EAX.
|
#! Alien must be in EAX.
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
ECX ESP roll [+] LEA
|
ECX ESP roll [+] LEA
|
||||||
|
@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- )
|
||||||
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
|
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
|
||||||
push-return-reg ;
|
push-return-reg ;
|
||||||
|
|
||||||
M: x86-32-backend %box ( n reg-class func -- )
|
M: x86.32 %box ( n reg-class func -- )
|
||||||
over reg-size [
|
over reg-size [
|
||||||
>r (%box) r> f %alien-invoke
|
>r (%box) r> f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- )
|
||||||
EDX PUSH
|
EDX PUSH
|
||||||
EAX PUSH ;
|
EAX PUSH ;
|
||||||
|
|
||||||
M: x86-32-backend %box-long-long ( n func -- )
|
M: x86.32 %box-long-long ( n func -- )
|
||||||
8 [
|
8 [
|
||||||
>r (%box-long-long) r> f %alien-invoke
|
>r (%box-long-long) r> f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
M: x86-32-backend %box-large-struct ( n size -- )
|
M: x86.32 %box-large-struct ( n size -- )
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
[ swap struct-return@ ] keep
|
[ swap struct-return@ ] keep
|
||||||
ECX ESP roll [+] LEA
|
ECX ESP roll [+] LEA
|
||||||
|
@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- )
|
||||||
"box_value_struct" f %alien-invoke
|
"box_value_struct" f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
M: x86-32-backend %prepare-box-struct ( size -- )
|
M: x86.32 %prepare-box-struct ( size -- )
|
||||||
! Compute target address for value struct return
|
! Compute target address for value struct return
|
||||||
EAX ESP rot f struct-return@ [+] LEA
|
EAX ESP rot f struct-return@ [+] LEA
|
||||||
! Store it as the first parameter
|
! Store it as the first parameter
|
||||||
ESP [] EAX MOV ;
|
ESP [] EAX MOV ;
|
||||||
|
|
||||||
M: x86-32-backend %unbox-struct-1
|
M: x86.32 %unbox-struct-1
|
||||||
#! Alien must be in EAX.
|
#! Alien must be in EAX.
|
||||||
4 [
|
4 [
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
|
@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1
|
||||||
EAX EAX [] MOV
|
EAX EAX [] MOV
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
M: x86-32-backend %box-small-struct ( size -- )
|
M: x86.32 %box-small-struct ( size -- )
|
||||||
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
|
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
|
||||||
12 [
|
12 [
|
||||||
PUSH
|
PUSH
|
||||||
|
@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- )
|
||||||
"box_small_struct" f %alien-invoke
|
"box_small_struct" f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
M: x86-32-backend %prepare-alien-indirect ( -- )
|
M: x86.32 %prepare-alien-indirect ( -- )
|
||||||
"unbox_alien" f %alien-invoke
|
"unbox_alien" f %alien-invoke
|
||||||
cell temp@ EAX MOV ;
|
cell temp@ EAX MOV ;
|
||||||
|
|
||||||
M: x86-32-backend %alien-indirect ( -- )
|
M: x86.32 %alien-indirect ( -- )
|
||||||
cell temp@ CALL ;
|
cell temp@ CALL ;
|
||||||
|
|
||||||
M: x86-32-backend %alien-callback ( quot -- )
|
M: x86.32 %alien-callback ( quot -- )
|
||||||
4 [
|
4 [
|
||||||
EAX load-indirect
|
EAX load-indirect
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
"c_to_factor" f %alien-invoke
|
"c_to_factor" f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
M: x86-32-backend %callback-value ( ctype -- )
|
M: x86.32 %callback-value ( ctype -- )
|
||||||
! Align C stack
|
! Align C stack
|
||||||
ESP 12 SUB
|
ESP 12 SUB
|
||||||
! Save top of data stack
|
! Save top of data stack
|
||||||
|
@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- )
|
||||||
! Unbox EAX
|
! Unbox EAX
|
||||||
unbox-return ;
|
unbox-return ;
|
||||||
|
|
||||||
M: x86-32-backend %cleanup ( alien-node -- )
|
M: x86.32 %cleanup ( alien-node -- )
|
||||||
#! a) If we just called an stdcall function in Windows, it
|
#! a) If we just called an stdcall function in Windows, it
|
||||||
#! cleaned up the stack frame for us. But we don't want that
|
#! cleaned up the stack frame for us. But we don't want that
|
||||||
#! so we 'undo' the cleanup since we do that in %epilogue.
|
#! so we 'undo' the cleanup since we do that in %epilogue.
|
||||||
|
@ -254,7 +251,7 @@ M: x86-32-backend %cleanup ( alien-node -- )
|
||||||
}
|
}
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ;
|
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
|
||||||
|
|
||||||
windows? [
|
windows? [
|
||||||
cell "longlong" c-type set-c-type-align
|
cell "longlong" c-type set-c-type-align
|
||||||
|
@ -265,8 +262,6 @@ windows? [
|
||||||
4 "double" c-type set-c-type-align
|
4 "double" c-type set-c-type-align
|
||||||
] unless
|
] unless
|
||||||
|
|
||||||
T{ x86-backend f 4 } compiler-backend set-global
|
|
||||||
|
|
||||||
: sse2? "Intrinsic" throw ;
|
: sse2? "Intrinsic" throw ;
|
||||||
|
|
||||||
\ sse2? [
|
\ sse2? [
|
||||||
|
|
|
@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots
|
||||||
splitting assocs ;
|
splitting assocs ;
|
||||||
IN: cpu.x86.64
|
IN: cpu.x86.64
|
||||||
|
|
||||||
PREDICATE: amd64-backend < x86-backend
|
M: x86.64 ds-reg R14 ;
|
||||||
x86-backend-cell 8 = ;
|
M: x86.64 rs-reg R15 ;
|
||||||
|
M: x86.64 stack-reg RSP ;
|
||||||
M: amd64-backend ds-reg R14 ;
|
M: x86.64 xt-reg RCX ;
|
||||||
M: amd64-backend rs-reg R15 ;
|
M: x86.64 stack-save-reg RSI ;
|
||||||
M: amd64-backend stack-reg RSP ;
|
|
||||||
M: amd64-backend xt-reg RCX ;
|
|
||||||
M: amd64-backend stack-save-reg RSI ;
|
|
||||||
|
|
||||||
M: temp-reg v>operand drop RBX ;
|
M: temp-reg v>operand drop RBX ;
|
||||||
|
|
||||||
|
@ -34,18 +31,18 @@ M: float-regs vregs
|
||||||
M: float-regs param-regs
|
M: float-regs param-regs
|
||||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||||
|
|
||||||
M: amd64-backend address-operand ( address -- operand )
|
M: x86.64 address-operand ( address -- operand )
|
||||||
#! On AMD64, we have to load 64-bit addresses into a
|
#! On AMD64, we have to load 64-bit addresses into a
|
||||||
#! scratch register first. The usage of R11 here is a hack.
|
#! scratch register first. The usage of R11 here is a hack.
|
||||||
#! This word can only be called right before a subroutine
|
#! This word can only be called right before a subroutine
|
||||||
#! call, where all vregs have been flushed anyway.
|
#! call, where all vregs have been flushed anyway.
|
||||||
temp-reg v>operand [ swap MOV ] keep ;
|
temp-reg v>operand [ swap MOV ] keep ;
|
||||||
|
|
||||||
M: amd64-backend fixnum>slot@ drop ;
|
M: x86.64 fixnum>slot@ drop ;
|
||||||
|
|
||||||
M: amd64-backend prepare-division CQO ;
|
M: x86.64 prepare-division CQO ;
|
||||||
|
|
||||||
M: amd64-backend load-indirect ( literal reg -- )
|
M: x86.64 load-indirect ( literal reg -- )
|
||||||
0 [] MOV rc-relative rel-literal ;
|
0 [] MOV rc-relative rel-literal ;
|
||||||
|
|
||||||
M: stack-params %load-param-reg
|
M: stack-params %load-param-reg
|
||||||
|
@ -56,27 +53,27 @@ M: stack-params %load-param-reg
|
||||||
M: stack-params %save-param-reg
|
M: stack-params %save-param-reg
|
||||||
>r stack-frame* + cell + swap r> %load-param-reg ;
|
>r stack-frame* + cell + swap r> %load-param-reg ;
|
||||||
|
|
||||||
M: amd64-backend %prepare-unbox ( -- )
|
M: x86.64 %prepare-unbox ( -- )
|
||||||
! First parameter is top of stack
|
! First parameter is top of stack
|
||||||
RDI R14 [] MOV
|
RDI R14 [] MOV
|
||||||
R14 cell SUB ;
|
R14 cell SUB ;
|
||||||
|
|
||||||
M: amd64-backend %unbox ( n reg-class func -- )
|
M: x86.64 %unbox ( n reg-class func -- )
|
||||||
! Call the unboxer
|
! Call the unboxer
|
||||||
f %alien-invoke
|
f %alien-invoke
|
||||||
! Store the return value on the C stack
|
! Store the return value on the C stack
|
||||||
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
|
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
|
||||||
|
|
||||||
M: amd64-backend %unbox-long-long ( n func -- )
|
M: x86.64 %unbox-long-long ( n func -- )
|
||||||
T{ int-regs } swap %unbox ;
|
T{ int-regs } swap %unbox ;
|
||||||
|
|
||||||
M: amd64-backend %unbox-struct-1 ( -- )
|
M: x86.64 %unbox-struct-1 ( -- )
|
||||||
#! Alien must be in RDI.
|
#! Alien must be in RDI.
|
||||||
"alien_offset" f %alien-invoke
|
"alien_offset" f %alien-invoke
|
||||||
! Load first cell
|
! Load first cell
|
||||||
RAX RAX [] MOV ;
|
RAX RAX [] MOV ;
|
||||||
|
|
||||||
M: amd64-backend %unbox-struct-2 ( -- )
|
M: x86.64 %unbox-struct-2 ( -- )
|
||||||
#! Alien must be in RDI.
|
#! Alien must be in RDI.
|
||||||
"alien_offset" f %alien-invoke
|
"alien_offset" f %alien-invoke
|
||||||
! Load second cell
|
! Load second cell
|
||||||
|
@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- )
|
||||||
! Load first cell
|
! Load first cell
|
||||||
RAX RAX [] MOV ;
|
RAX RAX [] MOV ;
|
||||||
|
|
||||||
M: amd64-backend %unbox-large-struct ( n size -- )
|
M: x86.64 %unbox-large-struct ( n size -- )
|
||||||
! Source is in RDI
|
! Source is in RDI
|
||||||
! Load destination address
|
! Load destination address
|
||||||
RSI RSP roll [+] LEA
|
RSI RSP roll [+] LEA
|
||||||
|
@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- )
|
||||||
0 over param-reg swap return-reg
|
0 over param-reg swap return-reg
|
||||||
2dup eq? [ 2drop ] [ MOV ] if ;
|
2dup eq? [ 2drop ] [ MOV ] if ;
|
||||||
|
|
||||||
M: amd64-backend %box ( n reg-class func -- )
|
M: x86.64 %box ( n reg-class func -- )
|
||||||
rot [
|
rot [
|
||||||
rot [ 0 swap param-reg ] keep %load-param-reg
|
rot [ 0 swap param-reg ] keep %load-param-reg
|
||||||
] [
|
] [
|
||||||
|
@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- )
|
||||||
] if*
|
] if*
|
||||||
f %alien-invoke ;
|
f %alien-invoke ;
|
||||||
|
|
||||||
M: amd64-backend %box-long-long ( n func -- )
|
M: x86.64 %box-long-long ( n func -- )
|
||||||
T{ int-regs } swap %box ;
|
T{ int-regs } swap %box ;
|
||||||
|
|
||||||
M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ;
|
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
|
||||||
|
|
||||||
M: amd64-backend %box-small-struct ( size -- )
|
M: x86.64 %box-small-struct ( size -- )
|
||||||
#! Box a <= 16-byte struct returned in RAX:RDX.
|
#! Box a <= 16-byte struct returned in RAX:RDX.
|
||||||
RDI RAX MOV
|
RDI RAX MOV
|
||||||
RSI RDX MOV
|
RSI RDX MOV
|
||||||
RDX swap MOV
|
RDX swap MOV
|
||||||
"box_small_struct" f %alien-invoke ;
|
"box_small_struct" f %alien-invoke ;
|
||||||
|
|
||||||
M: amd64-backend %box-large-struct ( n size -- )
|
M: x86.64 %box-large-struct ( n size -- )
|
||||||
! Struct size is parameter 2
|
! Struct size is parameter 2
|
||||||
RSI over MOV
|
RSI over MOV
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
|
@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- )
|
||||||
! Copy the struct from the C stack
|
! Copy the struct from the C stack
|
||||||
"box_value_struct" f %alien-invoke ;
|
"box_value_struct" f %alien-invoke ;
|
||||||
|
|
||||||
M: amd64-backend %prepare-box-struct ( size -- )
|
M: x86.64 %prepare-box-struct ( size -- )
|
||||||
! Compute target address for value struct return
|
! Compute target address for value struct return
|
||||||
RAX RSP rot f struct-return@ [+] LEA
|
RAX RSP rot f struct-return@ [+] LEA
|
||||||
RSP 0 [+] RAX MOV ;
|
RSP 0 [+] RAX MOV ;
|
||||||
|
|
||||||
M: amd64-backend %prepare-var-args RAX RAX XOR ;
|
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||||
|
|
||||||
M: amd64-backend %alien-invoke ( symbol dll -- )
|
M: x86.64 %alien-invoke ( symbol dll -- )
|
||||||
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
|
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
|
||||||
|
|
||||||
M: amd64-backend %prepare-alien-indirect ( -- )
|
M: x86.64 %prepare-alien-indirect ( -- )
|
||||||
"unbox_alien" f %alien-invoke
|
"unbox_alien" f %alien-invoke
|
||||||
cell temp@ RAX MOV ;
|
cell temp@ RAX MOV ;
|
||||||
|
|
||||||
M: amd64-backend %alien-indirect ( -- )
|
M: x86.64 %alien-indirect ( -- )
|
||||||
cell temp@ CALL ;
|
cell temp@ CALL ;
|
||||||
|
|
||||||
M: amd64-backend %alien-callback ( quot -- )
|
M: x86.64 %alien-callback ( quot -- )
|
||||||
RDI load-indirect "c_to_factor" f %alien-invoke ;
|
RDI load-indirect "c_to_factor" f %alien-invoke ;
|
||||||
|
|
||||||
M: amd64-backend %callback-value ( ctype -- )
|
M: x86.64 %callback-value ( ctype -- )
|
||||||
! Save top of data stack
|
! Save top of data stack
|
||||||
%prepare-unbox
|
%prepare-unbox
|
||||||
! Put former top of data stack in RDI
|
! Put former top of data stack in RDI
|
||||||
|
@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- )
|
||||||
! Unbox former top of data stack to return registers
|
! Unbox former top of data stack to return registers
|
||||||
unbox-return ;
|
unbox-return ;
|
||||||
|
|
||||||
M: amd64-backend %cleanup ( alien-node -- ) drop ;
|
M: x86.64 %cleanup ( alien-node -- ) drop ;
|
||||||
|
|
||||||
M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ;
|
M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
|
||||||
|
|
||||||
USE: cpu.x86.intrinsics
|
USE: cpu.x86.intrinsics
|
||||||
|
|
||||||
|
@ -171,8 +168,6 @@ USE: cpu.x86.intrinsics
|
||||||
\ alien-signed-4 small-reg-32 define-signed-getter
|
\ alien-signed-4 small-reg-32 define-signed-getter
|
||||||
\ set-alien-signed-4 small-reg-32 define-setter
|
\ set-alien-signed-4 small-reg-32 define-setter
|
||||||
|
|
||||||
T{ x86-backend f 8 } compiler-backend set-global
|
|
||||||
|
|
||||||
! The ABI for passing structs by value is pretty messed up
|
! The ABI for passing structs by value is pretty messed up
|
||||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
<< "void*" c-type clone "__stack_value" define-primitive-type
|
||||||
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
|
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
|
||||||
|
|
|
@ -46,7 +46,7 @@ IN: cpu.x86.allot
|
||||||
allot-reg swap tag-number OR
|
allot-reg swap tag-number OR
|
||||||
allot-reg MOV ;
|
allot-reg MOV ;
|
||||||
|
|
||||||
M: x86-backend %box-float ( dst src -- )
|
M: x86 %box-float ( dst src -- )
|
||||||
#! Only called by pentium4 backend, uses SSE2 instruction
|
#! Only called by pentium4 backend, uses SSE2 instruction
|
||||||
#! dest is a loc or a vreg
|
#! dest is a loc or a vreg
|
||||||
float 16 [
|
float 16 [
|
||||||
|
@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- )
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
M: x86-backend %box-alien ( dst src -- )
|
M: x86 %box-alien ( dst src -- )
|
||||||
[
|
[
|
||||||
{ "end" "f" } [ define-label ] each
|
{ "end" "f" } [ define-label ] each
|
||||||
dup v>operand 0 CMP
|
dup v>operand 0 CMP
|
||||||
|
|
|
@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers
|
||||||
generator.fixup system layouts combinators compiler.constants ;
|
generator.fixup system layouts combinators compiler.constants ;
|
||||||
IN: cpu.x86.architecture
|
IN: cpu.x86.architecture
|
||||||
|
|
||||||
TUPLE: x86-backend cell ;
|
HOOK: ds-reg cpu
|
||||||
|
HOOK: rs-reg cpu
|
||||||
HOOK: ds-reg compiler-backend
|
HOOK: stack-reg cpu
|
||||||
HOOK: rs-reg compiler-backend
|
HOOK: xt-reg cpu
|
||||||
HOOK: stack-reg compiler-backend
|
HOOK: stack-save-reg cpu
|
||||||
HOOK: xt-reg compiler-backend
|
|
||||||
HOOK: stack-save-reg compiler-backend
|
|
||||||
|
|
||||||
: stack@ stack-reg swap [+] ;
|
: stack@ stack-reg swap [+] ;
|
||||||
|
|
||||||
|
@ -33,34 +31,34 @@ GENERIC: push-return-reg ( reg-class -- )
|
||||||
GENERIC: load-return-reg ( stack@ reg-class -- )
|
GENERIC: load-return-reg ( stack@ reg-class -- )
|
||||||
GENERIC: store-return-reg ( stack@ reg-class -- )
|
GENERIC: store-return-reg ( stack@ reg-class -- )
|
||||||
|
|
||||||
HOOK: address-operand compiler-backend ( address -- operand )
|
HOOK: address-operand cpu ( address -- operand )
|
||||||
|
|
||||||
HOOK: fixnum>slot@ compiler-backend
|
HOOK: fixnum>slot@ cpu
|
||||||
|
|
||||||
HOOK: prepare-division compiler-backend
|
HOOK: prepare-division cpu
|
||||||
|
|
||||||
M: immediate load-literal v>operand swap v>operand MOV ;
|
M: immediate load-literal v>operand swap v>operand MOV ;
|
||||||
|
|
||||||
M: x86-backend stack-frame ( n -- i )
|
M: x86 stack-frame ( n -- i )
|
||||||
3 cells + 16 align cell - ;
|
3 cells + 16 align cell - ;
|
||||||
|
|
||||||
M: x86-backend %save-word-xt ( -- )
|
M: x86 %save-word-xt ( -- )
|
||||||
xt-reg 0 MOV rc-absolute-cell rel-this ;
|
xt-reg 0 MOV rc-absolute-cell rel-this ;
|
||||||
|
|
||||||
: factor-area-size 4 cells ;
|
: factor-area-size 4 cells ;
|
||||||
|
|
||||||
M: x86-backend %prologue ( n -- )
|
M: x86 %prologue ( n -- )
|
||||||
dup cell + PUSH
|
dup cell + PUSH
|
||||||
xt-reg PUSH
|
xt-reg PUSH
|
||||||
stack-reg swap 2 cells - SUB ;
|
stack-reg swap 2 cells - SUB ;
|
||||||
|
|
||||||
M: x86-backend %epilogue ( n -- )
|
M: x86 %epilogue ( n -- )
|
||||||
stack-reg swap ADD ;
|
stack-reg swap ADD ;
|
||||||
|
|
||||||
: %alien-global ( symbol dll register -- )
|
: %alien-global ( symbol dll register -- )
|
||||||
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
|
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
|
||||||
|
|
||||||
M: x86-backend %prepare-alien-invoke
|
M: x86 %prepare-alien-invoke
|
||||||
#! Save Factor stack pointers in case the C code calls a
|
#! Save Factor stack pointers in case the C code calls a
|
||||||
#! callback which does a GC, which must reliably trace
|
#! callback which does a GC, which must reliably trace
|
||||||
#! all roots.
|
#! all roots.
|
||||||
|
@ -70,11 +68,11 @@ M: x86-backend %prepare-alien-invoke
|
||||||
temp-reg v>operand 2 cells [+] ds-reg MOV
|
temp-reg v>operand 2 cells [+] ds-reg MOV
|
||||||
temp-reg v>operand 3 cells [+] rs-reg MOV ;
|
temp-reg v>operand 3 cells [+] rs-reg MOV ;
|
||||||
|
|
||||||
M: x86-backend %call ( label -- ) CALL ;
|
M: x86 %call ( label -- ) CALL ;
|
||||||
|
|
||||||
M: x86-backend %jump-label ( label -- ) JMP ;
|
M: x86 %jump-label ( label -- ) JMP ;
|
||||||
|
|
||||||
M: x86-backend %jump-t ( label -- )
|
M: x86 %jump-t ( label -- )
|
||||||
"flag" operand f v>operand CMP JNE ;
|
"flag" operand f v>operand CMP JNE ;
|
||||||
|
|
||||||
: code-alignment ( -- n )
|
: code-alignment ( -- n )
|
||||||
|
@ -83,7 +81,7 @@ M: x86-backend %jump-t ( label -- )
|
||||||
: align-code ( n -- )
|
: align-code ( n -- )
|
||||||
0 <repetition> % ;
|
0 <repetition> % ;
|
||||||
|
|
||||||
M: x86-backend %dispatch ( -- )
|
M: x86 %dispatch ( -- )
|
||||||
[
|
[
|
||||||
%epilogue-later
|
%epilogue-later
|
||||||
! Load jump table base. We use a temporary register
|
! Load jump table base. We use a temporary register
|
||||||
|
@ -105,27 +103,27 @@ M: x86-backend %dispatch ( -- )
|
||||||
{ +clobber+ { "n" } }
|
{ +clobber+ { "n" } }
|
||||||
} with-template ;
|
} with-template ;
|
||||||
|
|
||||||
M: x86-backend %dispatch-label ( word -- )
|
M: x86 %dispatch-label ( word -- )
|
||||||
0 cell, rc-absolute-cell rel-word ;
|
0 cell, rc-absolute-cell rel-word ;
|
||||||
|
|
||||||
M: x86-backend %unbox-float ( dst src -- )
|
M: x86 %unbox-float ( dst src -- )
|
||||||
[ v>operand ] bi@ float-offset [+] MOVSD ;
|
[ v>operand ] bi@ float-offset [+] MOVSD ;
|
||||||
|
|
||||||
M: x86-backend %peek [ v>operand ] bi@ MOV ;
|
M: x86 %peek [ v>operand ] bi@ MOV ;
|
||||||
|
|
||||||
M: x86-backend %replace swap %peek ;
|
M: x86 %replace swap %peek ;
|
||||||
|
|
||||||
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
|
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
|
||||||
|
|
||||||
M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ;
|
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
|
||||||
|
|
||||||
M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ;
|
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
|
||||||
|
|
||||||
M: x86-backend fp-shadows-int? ( -- ? ) f ;
|
M: x86 fp-shadows-int? ( -- ? ) f ;
|
||||||
|
|
||||||
M: x86-backend value-structs? t ;
|
M: x86 value-structs? t ;
|
||||||
|
|
||||||
M: x86-backend small-enough? ( n -- ? )
|
M: x86 small-enough? ( n -- ? )
|
||||||
HEX: -80000000 HEX: 7fffffff between? ;
|
HEX: -80000000 HEX: 7fffffff between? ;
|
||||||
|
|
||||||
: %untag ( reg -- ) tag-mask get bitnot AND ;
|
: %untag ( reg -- ) tag-mask get bitnot AND ;
|
||||||
|
@ -143,34 +141,34 @@ M: x86-backend small-enough? ( n -- ? )
|
||||||
\ stack-frame get swap -
|
\ stack-frame get swap -
|
||||||
] ?if ;
|
] ?if ;
|
||||||
|
|
||||||
HOOK: %unbox-struct-1 compiler-backend ( -- )
|
HOOK: %unbox-struct-1 cpu ( -- )
|
||||||
|
|
||||||
HOOK: %unbox-struct-2 compiler-backend ( -- )
|
HOOK: %unbox-struct-2 cpu ( -- )
|
||||||
|
|
||||||
M: x86-backend %unbox-small-struct ( size -- )
|
M: x86 %unbox-small-struct ( size -- )
|
||||||
#! Alien must be in EAX.
|
#! Alien must be in EAX.
|
||||||
cell align cell /i {
|
cell align cell /i {
|
||||||
{ 1 [ %unbox-struct-1 ] }
|
{ 1 [ %unbox-struct-1 ] }
|
||||||
{ 2 [ %unbox-struct-2 ] }
|
{ 2 [ %unbox-struct-2 ] }
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
M: x86-backend struct-small-enough? ( size -- ? )
|
M: x86 struct-small-enough? ( size -- ? )
|
||||||
{ 1 2 4 8 } member?
|
{ 1 2 4 8 } member?
|
||||||
os { "linux" "netbsd" "solaris" } member? not and ;
|
os { "linux" "netbsd" "solaris" } member? not and ;
|
||||||
|
|
||||||
M: x86-backend %return ( -- ) 0 %unwind ;
|
M: x86 %return ( -- ) 0 %unwind ;
|
||||||
|
|
||||||
! Alien intrinsics
|
! Alien intrinsics
|
||||||
M: x86-backend %unbox-byte-array ( dst src -- )
|
M: x86 %unbox-byte-array ( dst src -- )
|
||||||
[ v>operand ] bi@ byte-array-offset [+] LEA ;
|
[ v>operand ] bi@ byte-array-offset [+] LEA ;
|
||||||
|
|
||||||
M: x86-backend %unbox-alien ( dst src -- )
|
M: x86 %unbox-alien ( dst src -- )
|
||||||
[ v>operand ] bi@ alien-offset [+] MOV ;
|
[ v>operand ] bi@ alien-offset [+] MOV ;
|
||||||
|
|
||||||
M: x86-backend %unbox-f ( dst src -- )
|
M: x86 %unbox-f ( dst src -- )
|
||||||
drop v>operand 0 MOV ;
|
drop v>operand 0 MOV ;
|
||||||
|
|
||||||
M: x86-backend %unbox-any-c-ptr ( dst src -- )
|
M: x86 %unbox-any-c-ptr ( dst src -- )
|
||||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||||
! Address is computed in ds-reg
|
! Address is computed in ds-reg
|
||||||
ds-reg PUSH
|
ds-reg PUSH
|
||||||
|
|
|
@ -13,14 +13,14 @@ SINGLETON: x86.64
|
||||||
SINGLETON: arm
|
SINGLETON: arm
|
||||||
SINGLETON: ppc
|
SINGLETON: ppc
|
||||||
|
|
||||||
|
UNION: x86 x86.32 x86.64 ;
|
||||||
|
|
||||||
: cpu ( -- class ) \ cpu get ;
|
: cpu ( -- class ) \ cpu get ;
|
||||||
|
|
||||||
! SINGLETON: winnt
|
! SINGLETON: winnt
|
||||||
! SINGLETON: wince
|
! SINGLETON: wince
|
||||||
|
|
||||||
! MIXIN: windows
|
! UNION: windows winnt wince ;
|
||||||
! INSTANCE: winnt windows
|
|
||||||
! INSTANCE: wince windows
|
|
||||||
|
|
||||||
! SINGLETON: freebsd
|
! SINGLETON: freebsd
|
||||||
! SINGLETON: netbsd
|
! SINGLETON: netbsd
|
||||||
|
@ -29,11 +29,23 @@ SINGLETON: ppc
|
||||||
! SINGLETON: macosx
|
! SINGLETON: macosx
|
||||||
! SINGLETON: linux
|
! SINGLETON: linux
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: string>cpu ( str -- class )
|
||||||
|
H{
|
||||||
|
{ "x86.32" x86.32 }
|
||||||
|
{ "x86.64" x86.64 }
|
||||||
|
{ "arm" arm }
|
||||||
|
{ "ppc" ppc }
|
||||||
|
} at ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
! : os ( -- class ) \ os get ;
|
! : os ( -- class ) \ os get ;
|
||||||
|
|
||||||
[
|
[
|
||||||
8 getenv "system" lookup \ cpu set-global
|
8 getenv string>cpu \ cpu set-global
|
||||||
! 9 getenv "system" lookup \ os set-global
|
! 9 getenv string>os \ os set-global
|
||||||
] "system" add-init-hook
|
] "system" add-init-hook
|
||||||
|
|
||||||
: image ( -- path ) 13 getenv ;
|
: image ( -- path ) 13 getenv ;
|
||||||
|
|
Loading…
Reference in New Issue