steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Register allocator fixes

release
slava 2006-04-11 06:45:24 +00:00
parent 4646552254
commit daa1837df7
8 changed files with 109 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
library/compiler/intrinsics.factor
View File

@ -68,12 +68,12 @@ namespaces sequences words ;
] "intrinsic" set-word-prop
\ type [
{ { 0 "in" } } { "in" }
{ { any-reg "in" } } { "in" }
[ end-basic-block "in" get %type , ] with-template
] "intrinsic" set-word-prop
\ tag [
{ { 0 "in" } } { "in" } [ "in" get %tag , ] with-template
{ { any-reg "in" } } { "in" } [ "in" get %tag , ] with-template
] "intrinsic" set-word-prop
\ getenv [
@ -84,7 +84,7 @@ namespaces sequences words ;
] "intrinsic" set-word-prop
\ setenv [
{ { 0 "value" } { value "env" } } { } [
{ { any-reg "value" } { value "env" } } { } [
"value" get "env" get %setenv ,
] with-template
] "intrinsic" set-word-prop
@ -119,7 +119,7 @@ namespaces sequences words ;
] each
: binary-jump ( node label op -- )
rot dup binary-in { } [
rot { { any-reg "x" } { any-reg "y" } } { } [
end-basic-block >r >r "y" get "x" get r> r> execute ,
] with-template ; inline
@ -185,7 +185,7 @@ namespaces sequences words ;
: fast-shift ( n node -- )
over zero? [
end-basic-block -1 0 adjust-stacks 2drop
drop-phantom 2drop
] [
over 0 < [
negative-shift

4
library/compiler/linearizer.factor
View File

@ -111,7 +111,7 @@ M: #call-label linearize* ( node -- next )
template-inputs ;
M: #shuffle linearize* ( #shuffle -- )
0 vreg-allocator set
compute-free-vregs
node-shuffle dup do-inputs
dup shuffle-out-d swap shuffle-out-r template-outputs
iterate-next ;
@ -122,7 +122,7 @@ M: #shuffle linearize* ( #shuffle -- )
M: #if linearize* ( node -- next )
dup ?static-branch [
end-basic-block -1 0 adjust-stacks
end-basic-block drop-phantom
swap node-children nth linearize-child iterate-next
] [
dup { { 0 "flag" } } { } [

12
library/compiler/ppc/stack.factor
View File

@ -9,14 +9,22 @@ GENERIC: loc>operand
M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
: %literal ( quot -- )
0 output vreg? [
0 input 0 output-operand rot call
] [
0 input 11 rot call
11 0 output loc>operand STW
] if ; inline
M: %immediate generate-node ( vop -- )
drop 0 input address 0 output-operand LOAD ;
drop [ >r address r> LOAD ] %literal ;
: load-indirect ( dest literal -- )
add-literal over LOAD32 rel-2/2 rel-address dup 0 LWZ ;
M: %indirect generate-node ( vop -- )
drop 0 output-operand 0 input load-indirect ;
drop [ swap load-indirect ] %literal ;
M: %peek generate-node ( vop -- )
drop 0 output-operand 0 input loc>operand LWZ ;

124
library/compiler/templates.factor
View File

@ -49,9 +49,6 @@ M: phantom-callstack <loc> (loc) <cs-loc> ;
M: phantom-callstack finalize-height
\ %inc-r (finalize-height) ;
: phantom-append ( seq phantom -- )
phantom-stack-elements swap nappend ;
: phantom-locs ( n phantom -- locs )
swap reverse-slice [ swap <loc> ] map-with ;
@ -61,8 +58,10 @@ M: phantom-callstack finalize-height
: adjust-phantom ( n phantom -- )
[ phantom-stack-height + ] keep set-phantom-stack-height ;
: reset-phantom ( phantom -- )
0 swap set-length ;
GENERIC: cut-phantom ( n phantom -- seq )
M: phantom-stack cut-phantom ( n phantom -- seq )
[ delegate cut* swap ] keep set-delegate ;
SYMBOL: phantom-d
SYMBOL: phantom-r
@ -71,17 +70,13 @@ SYMBOL: phantom-r
<phantom-datastack> phantom-d set
<phantom-callstack> phantom-r set ;
: adjust-stacks ( inc-d inc-r -- )
phantom-r get adjust-phantom
phantom-d get adjust-phantom ;
: immediate? ( obj -- ? )
#! fixnums and f have a pointerless representation, and
#! are compiled immediately. Everything else can be moved
#! by GC, and is indexed through a table.
dup fixnum? swap f eq? or ;
: load-literal ( obj vreg -- )
: load-literal ( obj dest -- )
over immediate? [ %immediate ] [ %indirect ] if , ;
G: vreg>stack ( value loc -- ) 1 standard-combination ;
@ -89,27 +84,25 @@ G: vreg>stack ( value loc -- ) 1 standard-combination ;
M: f vreg>stack ( value loc -- ) 2drop ;
M: value vreg>stack ( value loc -- )
swap value-literal fixnum-imm? over immediate? and
[ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
swap %replace , ;
>r value-literal r> load-literal ;
M: object vreg>stack ( value loc -- )
%replace , ;
: vregs>stack ( values? phantom -- )
[
[ dup value? rot eq? [ drop f ] unless ] map-with
] keep phantom-locs* [ vreg>stack ] 2each ;
: vregs>stack ( phantom -- )
dup dup phantom-locs* [ vreg>stack ] 2each
0 swap set-length ;
: finalize-phantom ( phantom -- )
dup finalize-height vregs>stack ;
: end-basic-block ( -- )
phantom-d get finalize-height
phantom-r get finalize-height
f phantom-d get vregs>stack
f phantom-r get vregs>stack
t phantom-d get vregs>stack
t phantom-r get vregs>stack
phantom-d get reset-phantom
phantom-r get reset-phantom ;
phantom-d get finalize-phantom
phantom-r get finalize-phantom ;
: end-basic-block* ( -- )
phantom-d get vregs>stack
phantom-r get vregs>stack ;
G: stack>vreg ( value vreg loc -- operand )
2 standard-combination ;
@ -126,16 +119,26 @@ M: value stack>vreg ( value vreg loc -- operand )
>r value-literal r> <vreg> [ load-literal ] keep
] if ;
SYMBOL: vreg-allocator
SYMBOL: any-reg
: alloc-reg ( template -- template )
dup any-reg eq? [
drop vreg-allocator dup get swap inc
] when ;
SYMBOL: free-vregs
: alloc-regs ( template -- template ) [ alloc-reg ] map ;
: compute-free-vregs ( -- )
phantom-d get [ vreg? ] subset
phantom-r get [ vreg? ] subset append
[ vreg-n ] map vregs length reverse diff
>vector free-vregs set ;
: requested-vregs ( template -- n )
[ any-reg eq? ] subset length ;
: sufficient-vregs? ( template template -- ? )
[ requested-vregs ] 2apply + free-vregs get length <= ;
: alloc-regs ( template -- template )
free-vregs get swap [
dup any-reg eq? [ drop pop ] [ nip ] if
] map-with ;
: (stack>vregs) ( values template locs -- inputs )
3array flip
@ -145,54 +148,71 @@ SYMBOL: any-reg
>r [ dup value? [ value-literal ] when ] map
r> [ second set ] 2each ;
: stack>vregs ( values phantom template -- )
: stack>vregs ( values phantom template -- values )
[
[ first ] map alloc-regs
pick length rot phantom-locs
(stack>vregs)
] keep phantom-vregs ;
] 2keep length neg swap adjust-phantom ;
: compatible-vreg? ( value vreg -- ? )
swap dup value? [ 2drop f ] [ vreg-n = ] if ;
: compatible-values? ( value template -- ? )
{
{ [ dup not ] [ 2drop t ] }
{ [ over not ] [ 2drop f ] }
{ [ dup any-reg eq? ] [ drop vreg? ] }
{ [ dup integer? ] [ compatible-vreg? ] }
{ [ dup value eq? ] [ drop value? ] }
{ [ dup not ] [ 2drop t ] }
} cond ;
: template-match? ( phantom template -- ? )
2dup [ length ] 2apply = [
f [ first compatible-values? and ] 2reduce
: template-match? ( template phantom -- ? )
2dup [ length ] 2apply <= [
>r dup length r> tail-slice*
t [ swap first compatible-values? and ] 2reduce
] [
2drop f
] if ;
: optimized-input ( phantom template -- )
over >r phantom-vregs r> reset-phantom ;
: templates-match? ( template template -- ? )
2dup sufficient-vregs? [
phantom-r get template-match?
>r phantom-d get template-match? r> and
] [
2drop f
] if ;
: optimized-input ( template phantom -- )
over length neg over adjust-phantom
over length over cut-phantom
>r dup empty? [ drop ] [ vregs>stack ] if r>
swap phantom-vregs ;
: template-input ( values template phantom -- )
swap 2dup template-match? [
optimized-input drop
] [
end-basic-block stack>vregs
] if ; inline
dup vregs>stack swap [ stack>vregs ] keep phantom-vregs ;
: template-inputs ( values template values template -- )
over >r phantom-r get template-input
over >r phantom-d get template-input
r> r> [ length neg ] 2apply adjust-stacks ;
pick over templates-match? [
phantom-r get optimized-input drop
phantom-d get optimized-input drop
] [
phantom-r get template-input
phantom-d get template-input
] if ;
: (template-outputs) ( seq stack -- )
: drop-phantom ( -- )
end-basic-block -1 phantom-d get adjust-phantom ;
: template-output ( seq stack -- )
over length over adjust-phantom
swap [ dup value? [ get ] unless ] map nappend ;
: template-outputs ( stack stack -- )
[ [ length ] 2apply adjust-stacks ] 2keep
phantom-r get (template-outputs)
phantom-d get (template-outputs) ;
phantom-r get template-output
phantom-d get template-output ;
: with-template ( node in out quot -- )
compute-free-vregs
swap >r >r >r dup node-in-d r> { } { } template-inputs
node set r> call r> { } template-outputs ; inline

4
library/test/compiler/intrinsics.factor
View File

@ -2,10 +2,6 @@ IN: temporary
USING: arrays compiler kernel kernel-internals lists math
math-internals sequences strings test words ;
! Oops!
[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
[ "hi" ] [ [ "hi" ] compile-1 ] unit-test
! Make sure that intrinsic ops compile to correct code.
[ 1 ] [ [[ 1 2 ]] [ 0 slot ] compile-1 ] unit-test
[ 1 ] [ [ [[ 1 2 ]] 0 slot ] compile-1 ] unit-test

3
library/test/compiler/stack.factor
View File

@ -18,6 +18,3 @@ USING: compiler kernel math-internals test ;
[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test

19
library/test/compiler/templates.factor Normal file
View File

@ -0,0 +1,19 @@
! Black box testing of templater optimization
IN: temporary
USING: compiler kernel kernel-internals math-internals test ;
! Oops!
[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
[ "hi" ] [ [ "hi" ] compile-1 ] unit-test
[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
[ 0 ] [ 3 [ tag ] compile-1 ] unit-test
[ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test
[ { 1 2 3 } { 1 4 3 } 8 8 ]
[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-1 ]
unit-test
! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test

2
library/test/test.factor
View File

@ -101,7 +101,7 @@ SYMBOL: failures
: compiler-tests
{
"io/buffer"
"compiler/simple"
"compiler/simple" "compiler/templates"
"compiler/stack" "compiler/ifte"
"compiler/generic" "compiler/bail-out"
"compiler/linearizer" "compiler/intrinsics"