From 480e6a8b2b438426547c45bef50dd7d53d7f56d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Sep 2007 17:30:34 -0400 Subject: [PATCH] Clean up generator.registers a bit --- core/alien/compiler/compiler.factor | 19 +++ core/compiler/test/templates-early.factor | 4 +- core/generator/generator.factor | 14 +- core/generator/registers/registers.factor | 175 +++++++++++----------- 4 files changed, 114 insertions(+), 98 deletions(-) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 864af9af3e..aa46271fed 100644 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -62,6 +62,25 @@ GENERIC: alien-node-abi ( node -- str ) call f set-stack-frame ; inline +GENERIC: reg-size ( register-class -- n ) + +M: int-regs reg-size drop cell ; + +M: float-regs reg-size float-regs-size ; + +GENERIC: inc-reg-class ( register-class -- ) + +: (inc-reg-class) + dup class inc + fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; + +M: int-regs inc-reg-class + (inc-reg-class) ; + +M: float-regs inc-reg-class + dup (inc-reg-class) + fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ; + : reg-class-full? ( class -- ? ) dup class get swap param-regs length >= ; diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index 5f6ece5d68..8286d0cda4 100644 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -8,7 +8,7 @@ namespaces sequences words kernel math effects ; [ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test - [ ] [ 0 phantom-d get phantom-push ] unit-test + [ ] [ 0 phantom-push ] unit-test [ ] [ compute-free-vregs ] unit-test @@ -17,7 +17,7 @@ namespaces sequences words kernel math effects ; [ f ] [ [ copy-templates - 1 phantom-d get phantom-push + 1 phantom-push compute-free-vregs 1 T{ int-regs } free-vregs member? ] with-scope diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 0417049983..fd82135651 100644 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -228,7 +228,7 @@ M: #dispatch generate-node "true" resolve-label t "if-scratch" get load-literal "end" resolve-label - "if-scratch" get phantom-d get phantom-push ; inline + "if-scratch" get phantom-push ; inline : define-if>boolean-intrinsics ( word intrinsics -- ) [ @@ -281,26 +281,20 @@ M: #call-label generate-node node-param generate-call ; UNION: immediate fixnum POSTPONE: f ; M: #push generate-node - node-out-d phantom-d get phantom-append iterate-next ; + node-out-d [ phantom-push ] each iterate-next ; ! #shuffle -: phantom-shuffle ( shuffle -- ) - [ effect-in length phantom-d get phantom-input ] keep - shuffle* phantom-d get phantom-append ; - M: #shuffle generate-node node-shuffle phantom-shuffle iterate-next ; M: #>r generate-node node-in-d length - phantom-d get phantom-input - phantom-r get phantom-append + phantom->r iterate-next ; M: #r> generate-node node-out-d length - phantom-r get phantom-input - phantom-d get phantom-append + phantom-r> iterate-next ; ! #return diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index c77ec056cc..4797d68b39 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -2,10 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes classes.private combinators cpu.architecture generator.fixup generic hashtables -inference.dataflow kernel kernel.private layouts math memory -namespaces quotations sequences system vectors words ; +inference.dataflow inference.stack kernel kernel.private layouts +math memory namespaces quotations sequences system vectors words +effects ; IN: generator.registers +SYMBOL: +input+ +SYMBOL: +output+ +SYMBOL: +scratch+ +SYMBOL: +clobber+ +SYMBOL: known-tag + ! A scratch register for computations TUPLE: vreg n ; @@ -24,45 +31,8 @@ TUPLE: temp-reg ; : temp-reg T{ temp-reg T{ int-regs } } ; -: %move ( dst src -- ) - 2dup = [ - 2drop - ] [ - 2dup [ delegate class ] 2apply 2array { - { { int-regs int-regs } [ %move-int>int ] } - { { float-regs int-regs } [ %move-int>float ] } - { { int-regs float-regs } [ %move-float>int ] } - } case - ] if ; - -GENERIC: reg-size ( register-class -- n ) - -GENERIC: inc-reg-class ( register-class -- ) - -M: int-regs reg-size drop cell ; - -: (inc-reg-class) - dup class inc - fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; - -M: int-regs inc-reg-class - (inc-reg-class) ; - -M: float-regs reg-size float-regs-size ; - -M: float-regs inc-reg-class - dup (inc-reg-class) - fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ; - M: vreg v>operand dup vreg-n swap vregs nth ; -: reg-spec>class ( spec -- class ) - float eq? - T{ float-regs f 8 } T{ int-regs } ? ; - -SYMBOL: phantom-d -SYMBOL: phantom-r - ! A data stack location. TUPLE: ds-loc n ; @@ -73,10 +43,18 @@ TUPLE: rs-loc n ; C: rs-loc + ( class -- stack ) >r V{ } clone 0 @@ -84,10 +62,6 @@ TUPLE: phantom-stack height ; phantom-stack construct r> construct-delegate ; -GENERIC: finalize-height ( stack -- ) - -GENERIC: ( n stack -- loc ) - : (loc) #! Utility for methods on phantom-stack-height - ; @@ -102,6 +76,8 @@ GENERIC: ( n stack -- loc ) 0 ] keep set-phantom-stack-height ; inline +GENERIC: ( n stack -- loc ) + TUPLE: phantom-datastack ; : phantom-datastack ; @@ -137,17 +113,14 @@ M: phantom-retainstack finalize-height : adjust-phantom ( n phantom -- ) [ phantom-stack-height + ] keep set-phantom-stack-height ; -: phantom-push ( obj stack -- ) - 1 over adjust-phantom push ; - -: phantom-append ( seq stack -- ) - over length over adjust-phantom push-all ; - GENERIC: cut-phantom ( n phantom -- seq ) M: phantom-stack cut-phantom [ delegate cut* swap ] keep set-delegate ; +: phantom-append ( seq stack -- ) + over length over adjust-phantom push-all ; + : phantom-input ( n phantom -- seq ) [ 2dup length <= [ @@ -160,6 +133,26 @@ M: phantom-stack cut-phantom ] if ] 2keep >r neg r> adjust-phantom ; +PRIVATE> + +: phantom-push ( obj -- ) + 1 phantom-d get adjust-phantom + phantom-d get push ; + +: phantom-shuffle ( shuffle -- ) + [ effect-in length phantom-d get phantom-input ] keep + shuffle* phantom-d get phantom-append ; + +: phantom->r ( n -- ) + phantom-d get phantom-input + phantom-r get phantom-append ; + +: phantom-r> ( n -- ) + phantom-r get phantom-input + phantom-d get phantom-append ; + +assoc \ free-vregs set drop ; -: init-templates ( -- ) - #! Initialize register allocator. - V{ } clone fresh-objects set - phantom-d set - phantom-r set - compute-free-vregs ; - -: copy-templates ( -- ) - #! Copies register allocator state, used when compiling - #! branches. - fresh-objects [ clone ] change - phantom-d [ clone ] change - phantom-r [ clone ] change - compute-free-vregs ; +: reg-spec>class ( spec -- class ) + float eq? + T{ float-regs f 8 } T{ int-regs } ? ; ! Copying vregs to stacks : alloc-vreg ( spec -- vreg ) reg-spec>class free-vregs pop ; +: %move ( dst src -- ) + 2dup = [ + 2drop + ] [ + 2dup [ delegate class ] 2apply 2array { + { { int-regs int-regs } [ %move-int>int ] } + { { float-regs int-regs } [ %move-int>float ] } + { { int-regs float-regs } [ %move-float>int ] } + } case + ] if ; + : vreg>vreg ( vreg spec -- vreg ) alloc-vreg dup rot %move ; @@ -382,13 +371,6 @@ M: object template-rhs ; %prepare-alien-invoke "simple_gc" f %alien-invoke ; -: end-basic-block ( -- ) - #! Commit all deferred stacking shuffling, and ensure the - #! in-memory data and retain stacks are up to date with - #! respect to the compiler's current picture. - finalize-contents finalize-heights - fresh-objects get dup empty? swap delete-all [ %gc ] unless ; - ! Loading stacks to vregs : free-vregs# ( -- int# float# ) T{ int-regs } T{ float-regs f 8 } @@ -433,11 +415,6 @@ M: object template-rhs ; dup length phantom-d get phantom-input swap lazy-load ] if ; -SYMBOL: +input+ -SYMBOL: +output+ -SYMBOL: +scratch+ -SYMBOL: +clobber+ - : output-vregs ( -- seq seq ) +output+ +clobber+ [ get [ get ] map ] 2apply ; @@ -489,11 +466,6 @@ SYMBOL: +clobber+ : template-outputs ( -- ) +output+ get [ get ] map phantom-d get phantom-append ; -: with-template ( quot hash -- ) - clone [ template-inputs call template-outputs ] bind - compute-free-vregs ; - inline - : value-matches? ( value spec -- ? ) #! If the spec is a quotation and the value is a literal #! fixnum, see if the quotation yields true when applied @@ -519,8 +491,6 @@ SYMBOL: +clobber+ dup length 1 = [ first tag-number ] [ drop f ] if ] if ; -SYMBOL: known-tag - : class-match? ( actual expected -- ? ) { { f [ drop t ] } @@ -545,6 +515,39 @@ SYMBOL: known-tag #! Depends on node@ [ second template-matches? ] find nip ; +PRIVATE> + +: end-basic-block ( -- ) + #! Commit all deferred stacking shuffling, and ensure the + #! in-memory data and retain stacks are up to date with + #! respect to the compiler's current picture. + finalize-contents finalize-heights + fresh-objects get dup empty? swap delete-all [ %gc ] unless ; + +: with-template ( quot hash -- ) + clone [ template-inputs call template-outputs ] bind + compute-free-vregs ; + inline + +: fresh-object ( obj -- ) fresh-objects get push ; + +: fresh-object? ( obj -- ? ) fresh-objects get memq? ; + +: init-templates ( -- ) + #! Initialize register allocator. + V{ } clone fresh-objects set + phantom-d set + phantom-r set + compute-free-vregs ; + +: copy-templates ( -- ) + #! Copies register allocator state, used when compiling + #! branches. + fresh-objects [ clone ] change + phantom-d [ clone ] change + phantom-r [ clone ] change + compute-free-vregs ; + : find-template ( templates -- pair/f ) #! Pair has shape { quot hash } #! Depends on node@