From daa1837df7b2f38c4f891ef734414f05a70bc5cb Mon Sep 17 00:00:00 2001 From: slava Date: Tue, 11 Apr 2006 06:45:24 +0000 Subject: [PATCH] Register allocator fixes --- library/compiler/intrinsics.factor | 10 +- library/compiler/linearizer.factor | 4 +- library/compiler/ppc/stack.factor | 12 ++- library/compiler/templates.factor | 124 ++++++++++++++---------- library/test/compiler/intrinsics.factor | 4 - library/test/compiler/stack.factor | 3 - library/test/compiler/templates.factor | 19 ++++ library/test/test.factor | 2 +- 8 files changed, 109 insertions(+), 69 deletions(-) create mode 100644 library/test/compiler/templates.factor diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index c7cec72b3f..5826084f08 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -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 diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index 81bfc41ae0..6a47323dfa 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -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" } } { } [ diff --git a/library/compiler/ppc/stack.factor b/library/compiler/ppc/stack.factor index 3e81215eeb..abba554663 100644 --- a/library/compiler/ppc/stack.factor +++ b/library/compiler/ppc/stack.factor @@ -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 ; diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor index 1dd68fd9e5..27aa2bc08d 100644 --- a/library/compiler/templates.factor +++ b/library/compiler/templates.factor @@ -49,9 +49,6 @@ M: phantom-callstack (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 ] 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-d set 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> [ 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 diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor index 3bdc393f75..a24d9bc4a4 100644 --- a/library/test/compiler/intrinsics.factor +++ b/library/test/compiler/intrinsics.factor @@ -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 diff --git a/library/test/compiler/stack.factor b/library/test/compiler/stack.factor index 463515b022..ed3d27bf2b 100644 --- a/library/test/compiler/stack.factor +++ b/library/test/compiler/stack.factor @@ -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 diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor new file mode 100644 index 0000000000..068c2df2e7 --- /dev/null +++ b/library/test/compiler/templates.factor @@ -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 diff --git a/library/test/test.factor b/library/test/test.factor index e3fb9d955a..9e6c67657e 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -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"