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

compiler.cfg.stacks.local: refactorings on the vocab to try and make it using less dynamic variables

db4
Björn Lindqvist 2015-04-07 15:05:34 +02:00 committed by John Benediktsson
parent 91144c0712
commit 177a356240
8 changed files with 61 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/compiler/cfg/builder/blocks/blocks.factor
View File

@ -8,8 +8,9 @@ SLOT: out-d
IN: compiler.cfg.builder.blocks IN: compiler.cfg.builder.blocks
: set-basic-block ( basic-block -- ) : set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi [ basic-block set ]
begin-local-analysis ; [ instructions>> building set ]
[ begin-local-analysis ] tri ;
: end-basic-block ( -- ) : end-basic-block ( -- )
basic-block get [ end-local-analysis ] when* basic-block get [ end-local-analysis ] when*

6
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -265,7 +265,7 @@ IN: compiler.cfg.builder.tests
{ out-d V{ 2 3 } } { out-d V{ 2 3 } }
} emit-node } emit-node
height-state get height-state get
replace-mapping get replaces get
] cfg-unit-test ] cfg-unit-test
{ 1 } [ { 1 } [
@ -293,7 +293,7 @@ SYMBOL: foo
H{ { D 2 1 } } H{ { D 2 1 } }
} [ } [
T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } } T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
emit-node replace-mapping get emit-node replaces get
] cfg-unit-test ] cfg-unit-test
{ {
@ -303,5 +303,5 @@ SYMBOL: foo
{ in-d { 7 } } { in-d { 7 } }
{ out-d { 55 77 } } { out-d { 55 77 } }
{ mapping { { 55 7 } { 77 7 } } } { mapping { { 55 7 } { 77 7 } } }
} emit-node replace-mapping get } emit-node replaces get
] cfg-unit-test ] cfg-unit-test

6
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators compiler.cfg.builder.blocks USING: accessors arrays combinators compiler.cfg.builder.blocks
compiler.cfg.comparisons compiler.cfg.hats compiler.cfg.comparisons compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stacks compiler.cfg.instructions compiler.cfg.stacks.local compiler.cfg.registers
compiler.tree.propagation.info cpu.architecture fry kernel compiler.cfg.stacks compiler.tree.propagation.info cpu.architecture fry kernel
layouts math math.intervals namespaces sequences ; layouts math math.intervals namespaces sequences ;
IN: compiler.cfg.intrinsics.fixnum IN: compiler.cfg.intrinsics.fixnum
@ -41,7 +41,7 @@ IN: compiler.cfg.intrinsics.fixnum
'[ _ ^^compare-integer ] binary-op ; '[ _ ^^compare-integer ] binary-op ;
: emit-no-overflow-case ( dst -- final-bb ) : emit-no-overflow-case ( dst -- final-bb )
[ ds-drop ds-drop ds-push ] with-branch ; [ D -2 inc-stack ds-push ] with-branch ;
: emit-overflow-case ( word -- final-bb ) : emit-overflow-case ( word -- final-bb )
[ [

7
basis/compiler/cfg/stacks/local/local-docs.factor
View File

@ -2,7 +2,7 @@ USING: assocs compiler.cfg compiler.cfg.instructions compiler.cfg.registers
help.markup help.syntax math sequences ; help.markup help.syntax math sequences ;
IN: compiler.cfg.stacks.local IN: compiler.cfg.stacks.local
HELP: replace-mapping HELP: replaces
{ $var-description "An " { $link assoc } " that maps from stack locations to virtual registers that were put on the stack." } { $var-description "An " { $link assoc } " that maps from stack locations to virtual registers that were put on the stack." }
{ $see-also replace-loc } ; { $see-also replace-loc } ;
@ -15,14 +15,15 @@ HELP: loc>vreg
HELP: replace-loc HELP: replace-loc
{ $values { "vreg" "virtual register" } { "loc" loc } } { $values { "vreg" "virtual register" } { "loc" loc } }
{ $description "Registers that the absolute stack location " { $snippet "loc" } " should be overwritten with the contents of the virtual register." } ; { $description "Registers that the absolute stack location " { $snippet "loc" } " should be overwritten with the contents of the virtual register." }
{ $see-also replaces } ;
HELP: peek-loc HELP: peek-loc
{ $values { "loc" loc } { "vreg" "virtaul register" } } { $values { "loc" loc } { "vreg" "virtaul register" } }
{ $description "Retrieves the virtual register at the given stack location." } ; { $description "Retrieves the virtual register at the given stack location." } ;
HELP: translate-local-loc HELP: translate-local-loc
{ $values { "state" "height state" } { "loc" loc } { "loc'" loc } } { $values { "loc" loc } { "state" "height state" } { "loc'" loc } }
{ $description "Translates an absolute stack location to one that is relative to the given height state." } { $description "Translates an absolute stack location to one that is relative to the given height state." }
{ $examples { $examples
{ $example { $example

36
basis/compiler/cfg/stacks/local/local-tests.factor
View File

@ -17,7 +17,7 @@ IN: compiler.cfg.stacks.local.tests
T{ ##copy { dst 2 } { src 26 } { rep any-rep } } T{ ##copy { dst 2 } { src 26 } { rep any-rep } }
} }
} [ } [
{ { D 0 25 } { R 0 26 } } stack-changes { { D 0 25 } { R 0 26 } } replaces>copy-insns
] cfg-unit-test ] cfg-unit-test
! replace-loc ! replace-loc
@ -32,16 +32,20 @@ IN: compiler.cfg.stacks.local.tests
{ } { }
HS{ } HS{ }
} [ } [
"foo" [ "eh" , end-local-analysis ] V{ } make drop V{ } 137 insns>block
"foo" [ peek-sets ] [ replace-sets ] [ kill-sets ] tri [ get at ] 2tri@ [ 0 0 rot record-stack-heights ]
[ [ "eh" , end-local-analysis ] V{ } make drop ]
[ [ peek-sets ] [ replace-sets ] [ kill-sets ] tri [ get at ] 2tri@ ] tri
] cfg-unit-test ] cfg-unit-test
{ {
{ D 3 } { D 3 }
} [ } [
"foo" [ 3 D 3 replace-loc "eh" , end-local-analysis ] V{ } make drop V{ } 137 insns>block
replace-sets get "foo" of [ 0 0 rot record-stack-heights ]
] unit-test [ [ 3 D 3 replace-loc "eh" , end-local-analysis ] V{ } make drop ]
[ replace-sets get at ] tri
] cfg-unit-test
! remove-redundant-replaces ! remove-redundant-replaces
{ {
@ -49,7 +53,7 @@ IN: compiler.cfg.stacks.local.tests
} [ } [
D 0 loc>vreg D 2 loc>vreg 2drop D 0 loc>vreg D 2 loc>vreg 2drop
2 D 2 replace-loc 7 D 3 replace-loc 2 D 2 replace-loc 7 D 3 replace-loc
replace-mapping get remove-redundant-replaces replaces get remove-redundant-replaces
] cfg-unit-test ] cfg-unit-test
! emit-changes ! emit-changes
@ -58,10 +62,14 @@ IN: compiler.cfg.stacks.local.tests
} [ } [
3 D 0 replace-loc [ 3 D 0 replace-loc [
"eh", "eh",
replace-mapping get height-state get emit-changes replaces get height-state get emit-changes
] V{ } make ] V{ } make
] cfg-unit-test ] cfg-unit-test
{ D 2 } [
D 3 { { 1 2 } { 3 4 } } translate-local-loc
] unit-test
! height-state ! height-state
{ {
{ { 3 3 } { 0 0 } } { { 3 3 } { 0 0 } }
@ -83,22 +91,16 @@ IN: compiler.cfg.stacks.local.tests
] unit-test ] unit-test
{ H{ { D -1 40 } } } [ { H{ { D -1 40 } } } [
D 1 inc-stack 40 D 0 replace-loc replace-mapping get D 1 inc-stack 40 D 0 replace-loc replaces get
] cfg-unit-test ] cfg-unit-test
{ 0 } [ { 0 } [
V{ } 0 insns>block basic-block set V{ } 0 insns>block 0 0 pick record-stack-heights
init-cfg-test
compute-local-kill-set sets:cardinality compute-local-kill-set sets:cardinality
] unit-test ] unit-test
{ HS{ R -4 } } [ { HS{ R -4 } } [
H{ { 77 4 } } [ ds-heights set ] [ rs-heights set ] bi V{ } 0 insns>block 4 4 pick record-stack-heights
{ { 8 0 } { 3 0 } } height-state set { { 8 0 } { 3 0 } } height-state set
77 basic-block set
compute-local-kill-set compute-local-kill-set
] unit-test ] unit-test
{ D 2 } [
{ { 1 2 } { 3 4 } } D 3 translate-local-loc
] unit-test

46
basis/compiler/cfg/stacks/local/local.factor
View File

@ -7,6 +7,9 @@ hash-sets kernel make math math.order namespaces sequences sets ;
FROM: namespaces => set ; FROM: namespaces => set ;
IN: compiler.cfg.stacks.local IN: compiler.cfg.stacks.local
: current-height ( state -- ds rs )
first2 [ first ] bi@ ;
: >loc< ( loc -- n ds? ) : >loc< ( loc -- n ds? )
[ n>> ] [ ds-loc? ] bi ; [ n>> ] [ ds-loc? ] bi ;
@ -23,8 +26,8 @@ IN: compiler.cfg.stacks.local
[ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map [ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map
[ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ; [ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ;
: translate-local-loc ( state loc -- loc' ) : translate-local-loc ( loc state -- loc' )
>loc< [ 0 1 ? rot nth first - ] keep ds-loc rs-loc ? new swap >>n ; [ clone ] dip over >loc< 0 1 ? rot nth first - >>n ;
: clone-height-state ( state -- state' ) : clone-height-state ( state -- state' )
[ clone ] map ; [ clone ] map ;
@ -36,7 +39,7 @@ IN: compiler.cfg.stacks.local
dupd [-] iota [ swap - ] with map ; dupd [-] iota [ swap - ] with map ;
: local-kill-set ( ds-height rs-height state -- set ) : local-kill-set ( ds-height rs-height state -- set )
first2 [ first ] bi@ swapd [ kill-locations ] 2bi@ current-height swapd [ kill-locations ] 2bi@
[ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi* [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
append >hash-set ; append >hash-set ;
@ -48,43 +51,42 @@ SYMBOLS: height-state peek-sets replace-sets kill-sets locs>vregs ;
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ; : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ; : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
SYMBOLS: local-peek-set replace-mapping ; SYMBOLS: local-peek-set replaces ;
: stack-changes ( replace-mapping -- insns ) : replaces>copy-insns ( replaces -- insns )
[ [ loc>vreg ] dip ] assoc-map parallel-copy ; [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
: emit-changes ( replace-mapping height-state -- ) : changes>insns ( replaces height-state -- insns )
building get pop -rot [ stack-changes % ] [ height-state>insns % ] bi* , ; [ replaces>copy-insns ] [ height-state>insns ] bi* append ;
: emit-changes ( replaces height-state -- )
building get pop -rot changes>insns % , ;
: peek-loc ( loc -- vreg ) : peek-loc ( loc -- vreg )
height-state get swap translate-local-loc height-state get translate-local-loc dup replaces get at
dup replace-mapping get at
[ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ; [ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
: replace-loc ( vreg loc -- ) : replace-loc ( vreg loc -- )
height-state get swap translate-local-loc height-state get translate-local-loc replaces get set-at ;
replace-mapping get set-at ;
: compute-local-kill-set ( -- set ) : compute-local-kill-set ( basic-block -- set )
basic-block get [ rs-heights get at ] [ ds-heights get at ] bi [ rs-heights get at ] [ ds-heights get at ] bi
height-state get local-kill-set ; height-state get local-kill-set ;
: begin-local-analysis ( -- ) : begin-local-analysis ( basic-block -- )
height-state get dup reset-emits
current-height rot record-stack-heights
HS{ } clone local-peek-set set HS{ } clone local-peek-set set
H{ } clone replace-mapping set H{ } clone replaces set ;
height-state get
[ reset-emits ] [
first2 [ first ] bi@ basic-block get record-stack-heights
] bi ;
: remove-redundant-replaces ( replace-mapping -- replace-mapping' ) : remove-redundant-replaces ( replaces -- replaces' )
[ [ loc>vreg ] dip = not ] assoc-filter ; [ [ loc>vreg ] dip = not ] assoc-filter ;
: end-local-analysis ( basic-block -- ) : end-local-analysis ( basic-block -- )
[ [
replace-mapping get remove-redundant-replaces replaces get remove-redundant-replaces
dup height-state get emit-changes keys dup height-state get emit-changes keys
swap replace-sets get set-at swap replace-sets get set-at
] ]
[ [ local-peek-set get ] dip peek-sets get set-at ] [ [ local-peek-set get ] dip peek-sets get set-at ]
[ [ compute-local-kill-set ] dip kill-sets get set-at ] tri ; [ [ compute-local-kill-set ] keep kill-sets get set-at ] tri ;

2
basis/compiler/cfg/stacks/stacks-tests.factor
View File

@ -8,7 +8,7 @@ IN: compiler.cfg.stacks.tests
{ { 0 0 } { 0 0 } } { { 0 0 } { 0 0 } }
} [ } [
{ 3 4 5 } ds-loc store-vregs { 3 4 5 } ds-loc store-vregs
replace-mapping get replaces get
height-state get height-state get
] cfg-unit-test ] cfg-unit-test

7
basis/compiler/test/test.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2010 Slava Pestov. ! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays compiler.units kernel sequences USING: accessors arrays compiler.cfg compiler.units kernel sequences
stack-checker tools.test vocabs words ; stack-checker tools.test vocabs words ;
IN: compiler.test IN: compiler.test
@ -22,8 +22,9 @@ USING: compiler.cfg.registers compiler.cfg.stacks compiler.cfg.stacks.local
fry namespaces ; fry namespaces ;
: init-cfg-test ( -- ) : init-cfg-test ( -- )
reset-vreg-counter begin-stack-analysis begin-local-analysis reset-vreg-counter begin-stack-analysis
H{ } clone replace-mapping set ; <basic-block> dup basic-block set begin-local-analysis
H{ } clone replaces set ;
: cfg-unit-test ( result quot -- ) : cfg-unit-test ( result quot -- )
'[ init-cfg-test @ ] unit-test ; inline '[ init-cfg-test @ ] unit-test ; inline