From 940d3307f5b138044051bbc3ba236c308ad68072 Mon Sep 17 00:00:00 2001 From: slava Date: Wed, 5 Apr 2006 06:43:37 +0000 Subject: [PATCH] Changes to templating system, re-enabled shuffle optimizations --- library/compiler/intrinsics.factor | 14 +-- library/compiler/linearizer.factor | 12 +- library/compiler/templates.factor | 140 +++++++++++++----------- library/test/compiler/intrinsics.factor | 2 + 4 files changed, 86 insertions(+), 82 deletions(-) diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index 80180fabb2..c7cec72b3f 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -29,7 +29,7 @@ namespaces sequences words ; \ slot [ dup slot@ [ - { { 0 "obj" } { f "slot" } } { "obj" } [ + { { 0 "obj" } { value "slot" } } { "obj" } [ node get slot@ "obj" get %fast-slot , ] with-template ] [ @@ -42,7 +42,7 @@ namespaces sequences words ; \ set-slot [ dup slot@ [ - { { 0 "val" } { 1 "obj" } { f "slot" } } { } [ + { { 0 "val" } { 1 "obj" } { value "slot" } } { } [ "val" get "obj" get node get slot@ %fast-set-slot , ] with-template ] [ @@ -77,14 +77,14 @@ namespaces sequences words ; ] "intrinsic" set-word-prop \ getenv [ - { { f "env" } } { "out" } [ + { { value "env" } } { "out" } [ T{ vreg f 0 } "out" set "env" get "out" get %getenv , ] with-template ] "intrinsic" set-word-prop \ setenv [ - { { 0 "value" } { f "env" } } { } [ + { { 0 "value" } { value "env" } } { } [ "value" get "env" get %setenv , ] with-template ] "intrinsic" set-word-prop @@ -95,7 +95,7 @@ namespaces sequences words ; : binary-in ( node -- in ) literal-immediate? fixnum-imm? and - { { 0 "x" } { f "y" } } { { 0 "x" } { 1 "y" } } ? ; + { { 0 "x" } { value "y" } } { { 0 "x" } { 1 "y" } } ? ; : (binary-op) ( node in -- ) { "x" } [ @@ -172,7 +172,7 @@ namespaces sequences words ; : slow-shift ( -- ) \ fixnum-shift %call , ; : negative-shift ( n node -- ) - { { 0 "x" } { f "n" } } { "out" } [ + { { 0 "x" } { value "n" } } { "out" } [ dup cell-bits neg <= [ drop T{ vreg f 2 } "out" set @@ -185,7 +185,7 @@ namespaces sequences words ; : fast-shift ( n node -- ) over zero? [ - -1 0 adjust-stacks end-basic-block 2drop + end-basic-block -1 0 adjust-stacks 2drop ] [ over 0 < [ negative-shift diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index 3a8ff3d7a5..ee807e866c 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -38,7 +38,7 @@ SYMBOL: renamed-labels : make-linear ( word quot -- ) [ - 0 { d-height r-height } [ set ] each-with + init-templates swap >r { } make r> linearized get set-hash ] with-node-iterator ; inline @@ -125,17 +125,11 @@ SYMBOL: live-r #! Avoid storing a value into its former position. dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ; -: shuffle-height ( node -- ) - [ dup node-out-d length swap node-in-d length - ] keep - dup node-out-r length swap node-in-r length - - adjust-stacks ; - M: #shuffle linearize* ( #shuffle -- ) 0 vreg-allocator set dup node-in-d over node-out-d live-stores live-d set dup node-in-r over node-out-r live-stores live-r set - dup do-inputs - shuffle-height + do-inputs live-d get live-r get template-outputs iterate-next ; @@ -145,7 +139,7 @@ M: #shuffle linearize* ( #shuffle -- ) M: #if linearize* ( node -- next ) dup ?static-branch [ - -1 0 adjust-stacks + end-basic-block -1 0 adjust-stacks swap node-children nth linearize-child iterate-next ] [ dup { { 0 "flag" } } { } [ diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor index 19326f2e6c..f4c064914e 100644 --- a/library/compiler/templates.factor +++ b/library/compiler/templates.factor @@ -7,30 +7,25 @@ namespaces sequences vectors words ; SYMBOL: d-height SYMBOL: r-height +! Uncomitted values +SYMBOL: phantom-d +SYMBOL: phantom-r + +: init-templates + 0 d-height set 0 r-height set + V{ } clone phantom-d set V{ } clone phantom-r set ; + ! A data stack location. TUPLE: ds-loc n ; - -C: ds-loc ( n -- ds-loc ) - [ >r d-height get - r> set-ds-loc-n ] keep ; +C: ds-loc [ >r d-height get - r> set-ds-loc-n ] keep ; ! A call stack location. TUPLE: cs-loc n ; - -C: cs-loc ( n -- ds-loc ) - [ >r r-height get - r> set-cs-loc-n ] keep ; +C: cs-loc [ >r r-height get - r> set-cs-loc-n ] keep ; : adjust-stacks ( inc-d inc-r -- ) r-height [ + ] change d-height [ + ] change ; -: finalize-stack ( quot symbol -- ) - [ - get dup zero? [ 2drop ] [ swap execute , ] if 0 - ] keep set ; inline - -: end-basic-block ( -- ) - \ %inc-r r-height finalize-stack - \ %inc-d d-height finalize-stack ; - : immediate? ( obj -- ? ) #! fixnums and f have a pointerless representation, and #! are compiled immediately. Everything else can be moved @@ -40,73 +35,86 @@ C: cs-loc ( n -- ds-loc ) : load-literal ( obj vreg -- ) over immediate? [ %immediate ] [ %indirect ] if , ; -GENERIC: stack>vreg* ( vreg loc value -- operand ) +: literal>stack ( value loc -- ) + swap value-literal fixnum-imm? over immediate? and + [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless + swap %replace , ; inline -M: object stack>vreg* ( vreg loc value -- operand ) - drop >r dup r> %peek , ; +G: vreg>stack ( value loc -- ) 1 standard-combination ; -M: value stack>vreg* ( vreg loc value -- operand ) - nip value-literal swap [ load-literal ] keep ; +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 , ; + +M: object vreg>stack ( value loc -- ) + %replace , ; + +: vregs>stack ( values quot literals -- ) + -rot >r [ dup value? rot eq? [ drop f ] unless ] map-with + dup reverse-slice swap length r> map + [ vreg>stack ] 2each ; inline + +: finalize-height ( word symbol -- ) + [ dup zero? [ 2drop ] [ swap execute , ] if 0 ] change ; + inline + +: end-basic-block ( -- ) + \ %inc-d d-height finalize-height + \ %inc-r r-height finalize-height + phantom-d get [ ] f vregs>stack + phantom-r get [ ] f vregs>stack + phantom-d get [ ] t vregs>stack + phantom-r get [ ] t vregs>stack + 0 phantom-d get set-length + 0 phantom-r get set-length ; + +G: stack>vreg ( value vreg loc -- operand ) + 2 standard-combination ; + +M: f stack>vreg ( value vreg loc -- operand ) 2drop ; + +M: object stack>vreg ( value vreg loc -- operand ) + >r dup r> %peek , nip ; + +M: value stack>vreg ( value vreg loc -- operand ) + drop >r value-literal r> dup value eq? + [ drop ] [ [ load-literal ] keep ] if ; SYMBOL: vreg-allocator SYMBOL: any-reg -: alloc-value ( loc value -- operand ) - vreg-allocator [ inc ] keep get -rot stack>vreg* ; +: alloc-reg ( template -- template ) + dup any-reg eq? [ + drop vreg-allocator dup get swap inc + ] when ; -: stack>vreg ( vreg loc value -- operand ) - { - { [ dup not ] [ 3drop f ] } - { [ pick any-reg eq? ] [ alloc-value nip ] } - { [ pick not ] [ 2nip value-literal ] } - { [ t ] [ stack>vreg* ] } - } cond ; +: alloc-regs ( template -- template ) [ alloc-reg ] map ; -: (stack>vregs) ( names values template quot -- inputs ) - >r dup length reverse r> map 3array flip - [ first3 rot stack>vreg ] map swap [ set ] 2each ; inline +: (stack>vregs) ( values template locs -- inputs ) + 3array flip + [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ; : stack>vregs ( stack template quot -- ) - >r unpair -rot r> (stack>vregs) ; inline + >r unpair -rot alloc-regs dup length reverse r> map + (stack>vregs) swap [ set ] 2each ; inline : template-inputs ( stack template stack template -- ) - [ ] stack>vregs [ ] stack>vregs ; + end-basic-block + over >r [ ] stack>vregs + over >r [ ] stack>vregs + r> r> [ length neg ] 2apply adjust-stacks ; -: literal>stack ( value stack-pos -- ) - swap value-literal fixnum-imm? over immediate? and - [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless - swap %replace , ; inline - -: vreg>stack ( value stack-pos -- ) - { - { [ over not ] [ 2drop ] } - { [ over value? ] [ literal>stack ] } - { [ t ] [ >r get r> %replace , ] } - } cond ; - -: vregs>stack ( values quot -- ) - >r dup reverse-slice swap length r> map - [ vreg>stack ] 2each ; inline +: >phantom ( seq stack -- ) + get swap [ dup value? [ get ] unless ] map nappend ; : template-outputs ( stack stack -- ) - [ ] vregs>stack [ ] vregs>stack ; - -SYMBOL: template-height + 2dup [ length ] 2apply adjust-stacks + phantom-r >phantom phantom-d >phantom ; : with-template ( node in out quot -- ) - pick length pick length swap - template-height set - swap >r >r - >r dup node-in-d r> { } { } template-inputs - template-height get 0 adjust-stacks + swap >r >r >r dup node-in-d r> { } { } template-inputs node set r> call r> { } template-outputs ; inline - -: literals/computed ( stack -- literals computed ) - dup [ dup value? [ drop f ] unless ] map - swap [ dup value? [ drop f ] when ] map ; - -: vregs>stacks ( ds cs -- ) - #! We store literals last because storing a literal to a - #! stack slot actually clobbers a vreg. - >r literals/computed r> literals/computed swapd - template-outputs template-outputs ; diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor index 78e686f35b..3bdc393f75 100644 --- a/library/test/compiler/intrinsics.factor +++ b/library/test/compiler/intrinsics.factor @@ -54,6 +54,8 @@ math-internals sequences strings test words ; [ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test [ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test +[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-1 ] unit-test + [ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test [ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test [ 4 ] [ [ 12 7 fixnum-bitand ] compile-1 ] unit-test