Register allocation fixes
parent
0842bd6a01
commit
ac678bceb0
|
@ -17,7 +17,7 @@ namespaces sequences words ;
|
||||||
{ } [
|
{ } [
|
||||||
"obj" get %untag ,
|
"obj" get %untag ,
|
||||||
"val" get "obj" get "slot" get %set-slot ,
|
"val" get "obj" get "slot" get %set-slot ,
|
||||||
end-basic-block
|
finalize-contents
|
||||||
"obj" get %write-barrier ,
|
"obj" get %write-barrier ,
|
||||||
] with-template
|
] with-template
|
||||||
] "intrinsic" set-word-prop
|
] "intrinsic" set-word-prop
|
||||||
|
@ -36,7 +36,7 @@ namespaces sequences words ;
|
||||||
|
|
||||||
\ type [
|
\ type [
|
||||||
{ { any-reg "in" } } { "in" }
|
{ { any-reg "in" } } { "in" }
|
||||||
[ end-basic-block "in" get %type , ] with-template
|
[ finalize-contents "in" get %type , ] with-template
|
||||||
] "intrinsic" set-word-prop
|
] "intrinsic" set-word-prop
|
||||||
|
|
||||||
\ tag [
|
\ tag [
|
||||||
|
@ -46,7 +46,7 @@ namespaces sequences words ;
|
||||||
|
|
||||||
: binary-op ( op -- )
|
: binary-op ( op -- )
|
||||||
{ { 0 "x" } { 1 "y" } } { "x" } [
|
{ { 0 "x" } { 1 "y" } } { "x" } [
|
||||||
end-basic-block >r "y" get "x" get dup r> execute ,
|
finalize-contents >r "y" get "x" get dup r> execute ,
|
||||||
] with-template ; inline
|
] with-template ; inline
|
||||||
|
|
||||||
{
|
{
|
||||||
|
@ -83,7 +83,7 @@ namespaces sequences words ;
|
||||||
! hard-coded to put its output in vreg 2, which happends to
|
! hard-coded to put its output in vreg 2, which happends to
|
||||||
! be EDX there.
|
! be EDX there.
|
||||||
{ { 0 "x" } { 1 "y" } } { "out" } [
|
{ { 0 "x" } { 1 "y" } } { "out" } [
|
||||||
end-basic-block
|
finalize-contents
|
||||||
T{ vreg f 2 } "out" set
|
T{ vreg f 2 } "out" set
|
||||||
"y" get "x" get "out" get %fixnum-mod ,
|
"y" get "x" get "out" get %fixnum-mod ,
|
||||||
] with-template
|
] with-template
|
||||||
|
@ -92,7 +92,7 @@ namespaces sequences words ;
|
||||||
\ fixnum/mod [
|
\ fixnum/mod [
|
||||||
! See the remark on fixnum-mod for vreg usage
|
! See the remark on fixnum-mod for vreg usage
|
||||||
{ { 0 "x" } { 1 "y" } } { "quo" "rem" } [
|
{ { 0 "x" } { 1 "y" } } { "quo" "rem" } [
|
||||||
end-basic-block
|
finalize-contents
|
||||||
T{ vreg f 0 } "quo" set
|
T{ vreg f 0 } "quo" set
|
||||||
T{ vreg f 2 } "rem" set
|
T{ vreg f 2 } "rem" set
|
||||||
"y" get "x" get 2array
|
"y" get "x" get 2array
|
||||||
|
|
|
@ -98,20 +98,6 @@ M: #call linearize* ( node -- next )
|
||||||
M: #call-label linearize* ( node -- next )
|
M: #call-label linearize* ( node -- next )
|
||||||
node-param renamed-label linearize-call ;
|
node-param renamed-label linearize-call ;
|
||||||
|
|
||||||
: ensure-vregs ( n -- )
|
|
||||||
sufficient-vregs?
|
|
||||||
[ end-basic-block compute-free-vregs ] unless ;
|
|
||||||
|
|
||||||
: linearize-push ( node -- )
|
|
||||||
compute-free-vregs
|
|
||||||
>#push< dup length dup ensure-vregs
|
|
||||||
alloc-reg# [ <vreg> ] map
|
|
||||||
[ [ load-literal ] 2each ] keep
|
|
||||||
phantom-d get phantom-append ;
|
|
||||||
|
|
||||||
M: #push linearize* ( #push -- )
|
|
||||||
linearize-push iterate-next ;
|
|
||||||
|
|
||||||
M: #if linearize* ( node -- next )
|
M: #if linearize* ( node -- next )
|
||||||
{ { 0 "flag" } } { } [
|
{ { 0 "flag" } } { } [
|
||||||
end-basic-block
|
end-basic-block
|
||||||
|
|
|
@ -20,18 +20,24 @@ namespaces prettyprint sequences vectors words ;
|
||||||
dup shuffle-in-d length neg phantom-d get adjust-phantom
|
dup shuffle-in-d length neg phantom-d get adjust-phantom
|
||||||
shuffle-in-r length neg phantom-r get adjust-phantom ;
|
shuffle-in-r length neg phantom-r get adjust-phantom ;
|
||||||
|
|
||||||
: sufficient-shuffle-vregs? ( shuffle -- ? )
|
: shuffle-vregs# ( shuffle -- n )
|
||||||
dup shuffle-in-d length phantom-d get length - 0 max
|
dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
|
||||||
over shuffle-in-r length phantom-r get length - 0 max +
|
|
||||||
free-vregs get length <= ;
|
|
||||||
|
|
||||||
: phantom-shuffle ( shuffle -- )
|
: phantom-shuffle ( shuffle -- )
|
||||||
compute-free-vregs sufficient-shuffle-vregs? [
|
dup shuffle-vregs# ensure-vregs
|
||||||
end-basic-block compute-free-vregs
|
|
||||||
] unless
|
|
||||||
[ phantom-shuffle-inputs ] keep
|
[ phantom-shuffle-inputs ] keep
|
||||||
[ shuffle* ] keep adjust-shuffle
|
[ shuffle* ] keep adjust-shuffle
|
||||||
(template-outputs) ;
|
(template-outputs) ;
|
||||||
|
|
||||||
M: #shuffle linearize* ( #shuffle -- )
|
M: #shuffle linearize* ( #shuffle -- )
|
||||||
node-shuffle phantom-shuffle iterate-next ;
|
node-shuffle phantom-shuffle iterate-next ;
|
||||||
|
|
||||||
|
: linearize-push ( node -- )
|
||||||
|
compute-free-vregs
|
||||||
|
>#push< dup length dup ensure-vregs
|
||||||
|
alloc-reg# [ <vreg> ] map
|
||||||
|
[ [ load-literal ] 2each ] keep
|
||||||
|
phantom-d get phantom-append ;
|
||||||
|
|
||||||
|
M: #push linearize* ( #push -- )
|
||||||
|
linearize-push iterate-next ;
|
||||||
|
|
|
@ -127,6 +127,8 @@ SYMBOL: phantom-r
|
||||||
2drop
|
2drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
|
||||||
|
|
||||||
: flush-locs ( phantom phantom -- )
|
: flush-locs ( phantom phantom -- )
|
||||||
[
|
[
|
||||||
2dup live-locs \ live-locs set
|
2dup live-locs \ live-locs set
|
||||||
|
@ -134,8 +136,7 @@ SYMBOL: phantom-r
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
: finalize-contents ( -- )
|
: finalize-contents ( -- )
|
||||||
phantom-d get phantom-r get
|
phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
|
||||||
2dup flush-locs vregs>stack vregs>stack ;
|
|
||||||
|
|
||||||
: end-basic-block ( -- )
|
: end-basic-block ( -- )
|
||||||
finalize-contents finalize-heights ;
|
finalize-contents finalize-heights ;
|
||||||
|
@ -143,8 +144,7 @@ SYMBOL: phantom-r
|
||||||
SYMBOL: any-reg
|
SYMBOL: any-reg
|
||||||
|
|
||||||
: used-vregs ( -- seq )
|
: used-vregs ( -- seq )
|
||||||
phantom-d get phantom-r get append
|
phantoms append [ vreg? ] subset [ vreg-n ] map ;
|
||||||
[ vreg? ] subset [ vreg-n ] map ;
|
|
||||||
|
|
||||||
: compute-free-vregs ( -- )
|
: compute-free-vregs ( -- )
|
||||||
used-vregs vregs length reverse diff
|
used-vregs vregs length reverse diff
|
||||||
|
@ -153,8 +153,6 @@ SYMBOL: any-reg
|
||||||
: requested-vregs ( template -- n )
|
: requested-vregs ( template -- n )
|
||||||
[ any-reg eq? ] subset length ;
|
[ any-reg eq? ] subset length ;
|
||||||
|
|
||||||
: sufficient-vregs? ( n -- ? ) free-vregs get length <= ;
|
|
||||||
|
|
||||||
: template-vreg# ( template template -- n )
|
: template-vreg# ( template template -- n )
|
||||||
[ requested-vregs ] 2apply + ;
|
[ requested-vregs ] 2apply + ;
|
||||||
|
|
||||||
|
@ -164,6 +162,18 @@ SYMBOL: any-reg
|
||||||
: alloc-reg# ( n -- regs )
|
: alloc-reg# ( n -- regs )
|
||||||
free-vregs [ cut ] change ;
|
free-vregs [ cut ] change ;
|
||||||
|
|
||||||
|
: additional-vregs# ( seq seq -- n )
|
||||||
|
2array phantoms 2array [ [ length ] map ] 2apply v-
|
||||||
|
0 [ 0 max + ] reduce ;
|
||||||
|
|
||||||
|
: free-vregs* ( -- n )
|
||||||
|
free-vregs get length
|
||||||
|
phantoms [ [ loc? ] subset length ] 2apply + - ;
|
||||||
|
|
||||||
|
: ensure-vregs ( n -- )
|
||||||
|
compute-free-vregs free-vregs* <=
|
||||||
|
[ finalize-contents compute-free-vregs ] unless ;
|
||||||
|
|
||||||
: lazy-load ( value loc -- value )
|
: lazy-load ( value loc -- value )
|
||||||
over loc?
|
over loc?
|
||||||
[ dupd = [ drop f ] [ stack>new-vreg ] if ] [ drop ] if ;
|
[ dupd = [ drop f ] [ stack>new-vreg ] if ] [ drop ] if ;
|
||||||
|
@ -227,15 +237,12 @@ SYMBOL: any-reg
|
||||||
used-vregs free-vregs [ diff ] change ;
|
used-vregs free-vregs [ diff ] change ;
|
||||||
|
|
||||||
: template-inputs ( template template -- )
|
: template-inputs ( template template -- )
|
||||||
compute-free-vregs
|
2dup additional-vregs# ensure-vregs
|
||||||
match-templates fast-input
|
match-templates fast-input
|
||||||
adjust-free-vregs
|
adjust-free-vregs
|
||||||
finalize-contents
|
finalize-contents
|
||||||
slow-input ;
|
slow-input ;
|
||||||
|
|
||||||
: drop-phantom ( -- )
|
|
||||||
end-basic-block -1 phantom-d get adjust-phantom ;
|
|
||||||
|
|
||||||
: phantom-append ( seq stack -- )
|
: phantom-append ( seq stack -- )
|
||||||
over length over adjust-phantom swap nappend ;
|
over length over adjust-phantom swap nappend ;
|
||||||
|
|
||||||
|
|
|
@ -16,6 +16,8 @@ math-internals namespaces test ;
|
||||||
|
|
||||||
[ 2 3 ] [ 3 [ 2 swap ] compile-1 ] unit-test
|
[ 2 3 ] [ 3 [ 2 swap ] compile-1 ] unit-test
|
||||||
|
|
||||||
|
[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-1 ] unit-test
|
||||||
|
|
||||||
[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test
|
[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test
|
||||||
|
|
||||||
[ { 1 2 3 } { 1 4 3 } 3 3 ]
|
[ { 1 2 3 } { 1 4 3 } 3 3 ]
|
||||||
|
|
Loading…
Reference in New Issue