More stack frame refactoring
parent
b0d57ead86
commit
33d775890c
|
@ -13,7 +13,7 @@ TUPLE: frame-required n ;
|
||||||
|
|
||||||
: frame-required ( n -- ) \ frame-required boa , ;
|
: frame-required ( n -- ) \ frame-required boa , ;
|
||||||
|
|
||||||
: stack-frame-size ( code -- n )
|
: compute-stack-frame-size ( code -- n )
|
||||||
no-stack-frame [
|
no-stack-frame [
|
||||||
dup frame-required? [ n>> max ] [ drop ] if
|
dup frame-required? [ n>> max ] [ drop ] if
|
||||||
] reduce ;
|
] reduce ;
|
||||||
|
@ -37,7 +37,7 @@ M: label fixup*
|
||||||
|
|
||||||
: if-stack-frame ( frame-size quot -- )
|
: if-stack-frame ( frame-size quot -- )
|
||||||
swap dup no-stack-frame =
|
swap dup no-stack-frame =
|
||||||
[ 2drop ] [ stack-frame swap call ] if ; inline
|
[ 2drop ] [ stack-frame-size swap call ] if ; inline
|
||||||
|
|
||||||
M: word fixup*
|
M: word fixup*
|
||||||
{
|
{
|
||||||
|
@ -146,7 +146,7 @@ SYMBOL: literal-table
|
||||||
: fixup ( code -- literals relocation labels code )
|
: fixup ( code -- literals relocation labels code )
|
||||||
[
|
[
|
||||||
init-fixup
|
init-fixup
|
||||||
dup stack-frame-size swap [ fixup* ] each drop
|
dup compute-stack-frame-size swap [ fixup* ] each drop
|
||||||
|
|
||||||
literal-table get >array
|
literal-table get >array
|
||||||
relocation-table get >byte-array
|
relocation-table get >byte-array
|
||||||
|
|
|
@ -299,18 +299,17 @@ M: #return-recursive generate-node
|
||||||
dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
|
dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
|
||||||
|
|
||||||
: alien-stack-frame ( params -- n )
|
: alien-stack-frame ( params -- n )
|
||||||
alien-parameters parameter-sizes drop ;
|
stack-frame new
|
||||||
|
swap
|
||||||
|
[ return>> return-size >>return ]
|
||||||
|
[ alien-parameters parameter-sizes drop >>params ] bi
|
||||||
|
dup [ params>> ] [ return>> ] bi + >>size
|
||||||
|
dup size>> stack-frame-size >>total-size ;
|
||||||
|
|
||||||
: alien-invoke-frame ( params -- n )
|
: with-stack-frame ( params quot -- )
|
||||||
[ return>> return-size ] [ alien-stack-frame ] bi + ;
|
swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
|
||||||
|
|
||||||
: set-stack-frame ( n -- )
|
|
||||||
dup [ frame-required ] when* \ stack-frame set ;
|
|
||||||
|
|
||||||
: with-stack-frame ( n quot -- )
|
|
||||||
swap set-stack-frame
|
|
||||||
call
|
call
|
||||||
f set-stack-frame ; inline
|
stack-frame off ; inline
|
||||||
|
|
||||||
GENERIC: reg-size ( register-class -- n )
|
GENERIC: reg-size ( register-class -- n )
|
||||||
|
|
||||||
|
@ -413,8 +412,8 @@ M: long-long-type flatten-value-type ( type -- types )
|
||||||
#! parameters. If the C function is returning a structure,
|
#! parameters. If the C function is returning a structure,
|
||||||
#! the first parameter is an implicit target area pointer,
|
#! the first parameter is an implicit target area pointer,
|
||||||
#! so we need to use a different offset.
|
#! so we need to use a different offset.
|
||||||
return>> dup large-struct?
|
return>> large-struct?
|
||||||
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
|
[ %prepare-box-struct cell ] [ 0 ] if ;
|
||||||
|
|
||||||
: objects>registers ( params -- )
|
: objects>registers ( params -- )
|
||||||
#! Generate code for unboxing a list of C types, then
|
#! Generate code for unboxing a list of C types, then
|
||||||
|
@ -473,7 +472,7 @@ M: no-such-symbol compiler-error-type
|
||||||
|
|
||||||
M: #alien-invoke generate-node
|
M: #alien-invoke generate-node
|
||||||
params>>
|
params>>
|
||||||
dup alien-invoke-frame [
|
dup [
|
||||||
end-basic-block
|
end-basic-block
|
||||||
%prepare-alien-invoke
|
%prepare-alien-invoke
|
||||||
dup objects>registers
|
dup objects>registers
|
||||||
|
@ -487,7 +486,7 @@ M: #alien-invoke generate-node
|
||||||
! #alien-indirect
|
! #alien-indirect
|
||||||
M: #alien-indirect generate-node
|
M: #alien-indirect generate-node
|
||||||
params>>
|
params>>
|
||||||
dup alien-invoke-frame [
|
dup [
|
||||||
! Flush registers
|
! Flush registers
|
||||||
end-basic-block
|
end-basic-block
|
||||||
! Save registers for GC
|
! Save registers for GC
|
||||||
|
@ -553,7 +552,7 @@ TUPLE: callback-context ;
|
||||||
|
|
||||||
: callback-unwind ( params -- n )
|
: callback-unwind ( params -- n )
|
||||||
{
|
{
|
||||||
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
|
{ [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
|
||||||
{ [ dup return>> large-struct? ] [ drop 4 ] }
|
{ [ dup return>> large-struct? ] [ drop 4 ] }
|
||||||
[ drop 0 ]
|
[ drop 0 ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
@ -569,7 +568,7 @@ TUPLE: callback-context ;
|
||||||
dup xt>> dup [
|
dup xt>> dup [
|
||||||
init-templates
|
init-templates
|
||||||
%prologue-later
|
%prologue-later
|
||||||
dup alien-stack-frame [
|
dup [
|
||||||
[ registers>objects ]
|
[ registers>objects ]
|
||||||
[ wrap-callback-quot %alien-callback ]
|
[ wrap-callback-quot %alien-callback ]
|
||||||
[ %callback-return ]
|
[ %callback-return ]
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays generic kernel kernel.private math memory
|
USING: accessors arrays generic kernel kernel.private math
|
||||||
namespaces make sequences layouts system hashtables classes
|
memory namespaces make sequences layouts system hashtables
|
||||||
alien byte-arrays combinators words sets ;
|
classes alien byte-arrays combinators words sets ;
|
||||||
IN: cpu.architecture
|
IN: cpu.architecture
|
||||||
|
|
||||||
! Register classes
|
! Register classes
|
||||||
|
@ -33,10 +33,9 @@ GENERIC# load-literal 1 ( obj vreg -- )
|
||||||
|
|
||||||
HOOK: load-indirect cpu ( obj reg -- )
|
HOOK: load-indirect cpu ( obj reg -- )
|
||||||
|
|
||||||
HOOK: stack-frame cpu ( frame-size -- n )
|
HOOK: stack-frame-size cpu ( frame-size -- n )
|
||||||
|
|
||||||
: stack-frame* ( -- n )
|
TUPLE: stack-frame total-size size params return ;
|
||||||
\ stack-frame get stack-frame ;
|
|
||||||
|
|
||||||
! Set up caller stack frame
|
! Set up caller stack frame
|
||||||
HOOK: %prologue cpu ( n -- )
|
HOOK: %prologue cpu ( n -- )
|
||||||
|
@ -117,7 +116,7 @@ HOOK: %box cpu ( n reg-class func -- )
|
||||||
|
|
||||||
HOOK: %box-long-long cpu ( n func -- )
|
HOOK: %box-long-long cpu ( n func -- )
|
||||||
|
|
||||||
HOOK: %prepare-box-struct cpu ( size -- )
|
HOOK: %prepare-box-struct cpu ( -- )
|
||||||
|
|
||||||
HOOK: %box-small-struct cpu ( c-type -- )
|
HOOK: %box-small-struct cpu ( c-type -- )
|
||||||
|
|
||||||
|
|
|
@ -43,8 +43,8 @@ IN: cpu.ppc.architecture
|
||||||
|
|
||||||
: xt-save ( n -- i ) 2 cells - ;
|
: xt-save ( n -- i ) 2 cells - ;
|
||||||
|
|
||||||
M: ppc stack-frame ( n -- i )
|
M: ppc stack-frame-size ( n -- i )
|
||||||
local@ factor-area-size + cell + 4 cells align ;
|
local@ factor-area-size + 4 cells align ;
|
||||||
|
|
||||||
M: temp-reg v>operand drop 11 ;
|
M: temp-reg v>operand drop 11 ;
|
||||||
|
|
||||||
|
@ -166,7 +166,7 @@ M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
|
||||||
M: stack-params %load-param-reg ( stack reg reg-class -- )
|
M: stack-params %load-param-reg ( stack reg reg-class -- )
|
||||||
drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
|
drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
|
||||||
|
|
||||||
: next-param@ ( n -- x ) param@ stack-frame* + ;
|
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
|
||||||
|
|
||||||
M: stack-params %save-param-reg ( stack reg reg-class -- )
|
M: stack-params %save-param-reg ( stack reg reg-class -- )
|
||||||
#! Funky. Read the parameter from the caller's stack frame.
|
#! Funky. Read the parameter from the caller's stack frame.
|
||||||
|
@ -218,20 +218,18 @@ M: ppc %box-long-long ( n func -- )
|
||||||
4 1 rot cell + local@ LWZ
|
4 1 rot cell + local@ LWZ
|
||||||
] when* r> f %alien-invoke ;
|
] when* r> f %alien-invoke ;
|
||||||
|
|
||||||
: struct-return@ ( size n -- n )
|
: struct-return@ ( n -- n )
|
||||||
[ local@ ] [ stack-frame* factor-area-size - swap - ] ?if ;
|
[ stack-frame get params>> ] unless* local@ ;
|
||||||
|
|
||||||
M: ppc %prepare-box-struct ( size -- )
|
M: ppc %prepare-box-struct ( -- )
|
||||||
#! Compute target address for value struct return
|
#! Compute target address for value struct return
|
||||||
3 1 rot f struct-return@ ADDI
|
3 1 f struct-return@ ADDI
|
||||||
3 1 0 local@ STW ;
|
3 1 0 local@ STW ;
|
||||||
|
|
||||||
M: ppc %box-large-struct ( n c-type -- )
|
M: ppc %box-large-struct ( n c-type -- )
|
||||||
#! If n = f, then we're boxing a returned struct
|
! If n = f, then we're boxing a returned struct
|
||||||
heap-size
|
|
||||||
[ swap struct-return@ ] keep
|
|
||||||
! Compute destination address and load struct size
|
! Compute destination address and load struct size
|
||||||
[ 3 1 rot ADDI ] [ 4 LI ] bi*
|
[ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
|
||||||
! Call the function
|
! Call the function
|
||||||
"box_value_struct" f %alien-invoke ;
|
"box_value_struct" f %alien-invoke ;
|
||||||
|
|
||||||
|
|
|
@ -30,8 +30,8 @@ M: x86.32 struct-small-enough? ( size -- ? )
|
||||||
heap-size { 1 2 4 8 } member?
|
heap-size { 1 2 4 8 } member?
|
||||||
os { linux netbsd solaris } member? not and ;
|
os { linux netbsd solaris } member? not and ;
|
||||||
|
|
||||||
: struct-return@ ( size n -- operand )
|
: struct-return@ ( n -- operand )
|
||||||
[ next-stack@ ] [ \ stack-frame get swap - stack@ ] ?if ;
|
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
|
||||||
|
|
||||||
! On x86, parameters are never passed in registers.
|
! On x86, parameters are never passed in registers.
|
||||||
M: int-regs return-reg drop EAX ;
|
M: int-regs return-reg drop EAX ;
|
||||||
|
@ -63,10 +63,10 @@ M: float-regs store-return-reg
|
||||||
[ stack@ ] [ reg-size ] bi* FSTP ;
|
[ stack@ ] [ reg-size ] bi* FSTP ;
|
||||||
|
|
||||||
: align-sub ( n -- )
|
: align-sub ( n -- )
|
||||||
dup 16 align swap - ESP swap SUB ;
|
[ align-stack ] keep - decr-stack-reg ;
|
||||||
|
|
||||||
: align-add ( n -- )
|
: align-add ( n -- )
|
||||||
16 align ESP swap ADD ;
|
align-stack incr-stack-reg ;
|
||||||
|
|
||||||
: with-aligned-stack ( n quot -- )
|
: with-aligned-stack ( n quot -- )
|
||||||
[ [ align-sub ] [ call ] bi* ]
|
[ [ align-sub ] [ call ] bi* ]
|
||||||
|
@ -113,7 +113,7 @@ M: x86.32 %box-long-long ( n func -- )
|
||||||
|
|
||||||
M:: x86.32 %box-large-struct ( n c-type -- )
|
M:: x86.32 %box-large-struct ( n c-type -- )
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
ECX c-type heap-size n struct-return@ LEA
|
ECX n struct-return@ LEA
|
||||||
8 [
|
8 [
|
||||||
! Push struct size
|
! Push struct size
|
||||||
c-type heap-size PUSH
|
c-type heap-size PUSH
|
||||||
|
@ -123,9 +123,9 @@ M:: x86.32 %box-large-struct ( n c-type -- )
|
||||||
"box_value_struct" f %alien-invoke
|
"box_value_struct" f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
M: x86.32 %prepare-box-struct ( size -- )
|
M: x86.32 %prepare-box-struct ( -- )
|
||||||
! Compute target address for value struct return
|
! Compute target address for value struct return
|
||||||
EAX swap f struct-return@ LEA
|
EAX f struct-return@ LEA
|
||||||
! Store it as the first parameter
|
! Store it as the first parameter
|
||||||
0 stack@ EAX MOV ;
|
0 stack@ EAX MOV ;
|
||||||
|
|
||||||
|
@ -248,7 +248,7 @@ M: x86.32 %cleanup ( alien-node -- )
|
||||||
{
|
{
|
||||||
{
|
{
|
||||||
[ dup abi>> "stdcall" = ]
|
[ dup abi>> "stdcall" = ]
|
||||||
[ alien-stack-frame ESP swap SUB ]
|
[ drop ESP stack-frame get params>> SUB ]
|
||||||
} {
|
} {
|
||||||
[ dup return>> large-struct? ]
|
[ dup return>> large-struct? ]
|
||||||
[ drop EAX PUSH ]
|
[ drop EAX PUSH ]
|
||||||
|
|
|
@ -164,22 +164,21 @@ M: x86.64 %box-small-struct ( c-type -- )
|
||||||
"box_small_struct" f %alien-invoke
|
"box_small_struct" f %alien-invoke
|
||||||
] with-return-regs ;
|
] with-return-regs ;
|
||||||
|
|
||||||
: struct-return@ ( size n -- n )
|
: struct-return@ ( n -- operand )
|
||||||
[ ] [ \ stack-frame get swap - ] ?if stack@ ;
|
[ stack-frame get params>> ] unless* stack@ ;
|
||||||
|
|
||||||
M: x86.64 %box-large-struct ( n c-type -- )
|
M: x86.64 %box-large-struct ( n c-type -- )
|
||||||
! Struct size is parameter 2
|
! Struct size is parameter 2
|
||||||
heap-size
|
RSI swap heap-size MOV
|
||||||
RSI over MOV
|
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
RDI spin struct-return@ LEA
|
RDI swap struct-return@ LEA
|
||||||
! 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: x86.64 %prepare-box-struct ( size -- )
|
M: x86.64 %prepare-box-struct ( -- )
|
||||||
! Compute target address for value struct return, store it
|
! Compute target address for value struct return
|
||||||
! as the first parameter
|
RAX f struct-return@ LEA
|
||||||
RAX swap f struct-return@ LEA
|
! Store it as the first parameter
|
||||||
0 stack@ RAX MOV ;
|
0 stack@ RAX MOV ;
|
||||||
|
|
||||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||||
|
|
|
@ -18,7 +18,7 @@ HOOK: stack-reg cpu ( -- reg )
|
||||||
#! input values to callbacks; the callback has its own
|
#! input values to callbacks; the callback has its own
|
||||||
#! stack frame set up, and we want to read the frame
|
#! stack frame set up, and we want to read the frame
|
||||||
#! set up by the caller.
|
#! set up by the caller.
|
||||||
stack-frame* + stack@ ;
|
stack-frame get total-size>> + stack@ ;
|
||||||
|
|
||||||
: reg-stack ( n reg -- op ) swap cells neg [+] ;
|
: reg-stack ( n reg -- op ) swap cells neg [+] ;
|
||||||
|
|
||||||
|
@ -51,19 +51,27 @@ 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 stack-frame ( n -- i )
|
: align-stack ( n -- n' )
|
||||||
3 cells + 16 align ;
|
os macosx? [ 16 align ] when ;
|
||||||
|
|
||||||
|
M: x86 stack-frame-size ( n -- i )
|
||||||
|
3 cells + align-stack ;
|
||||||
|
|
||||||
M: x86 %save-word-xt ( -- )
|
M: x86 %save-word-xt ( -- )
|
||||||
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
|
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
|
||||||
|
|
||||||
|
: decr-stack-reg ( n -- )
|
||||||
|
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
|
||||||
|
|
||||||
M: x86 %prologue ( n -- )
|
M: x86 %prologue ( n -- )
|
||||||
dup PUSH
|
dup PUSH
|
||||||
temp-reg v>operand PUSH
|
temp-reg v>operand PUSH
|
||||||
stack-reg swap 3 cells - SUB ;
|
3 cells - decr-stack-reg ;
|
||||||
|
|
||||||
M: x86 %epilogue ( n -- )
|
: incr-stack-reg ( n -- )
|
||||||
stack-reg swap cell - ADD ;
|
dup 0 = [ ] [ stack-reg swap ADD ] if ;
|
||||||
|
|
||||||
|
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
||||||
|
|
||||||
HOOK: %alien-global cpu ( symbol dll register -- )
|
HOOK: %alien-global cpu ( symbol dll register -- )
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue