-USING: compiler.cfg compiler.tree help.markup help.syntax literals math
-multiline quotations ;
+USING: compiler.cfg compiler.cfg.stacks.local compiler.tree help.markup
+help.syntax literals math multiline quotations sequences ;
IN: compiler.cfg.builder.blocks
<<
{ $description "Combinator that emits a trivial block, constructed by calling the supplied quotation." }
{ $examples { $unchecked-example $[ ex-emit-trivial-block ] } } ;
+HELP: end-branch
+{ $values { "pair/f" "two-tuple" } }
+{ $description "pair is { final-bb final-height }" } ;
+
HELP: initial-basic-block
{ $description "Creates an initial empty " { $link basic-block } " and stores it in the basic-block dynamic variable." } ;
HELP: make-kill-block
{ $description "Marks the current " { $link basic-block } " being processed as a kill block." } ;
+
+HELP: set-successors
+{ $values { "successor" basic-block } { "blocks" sequence } }
+{ $description "Set the successor of each block to " { $slot "successor" } "." } ;
+
+HELP: with-branch
+{ $values { "quot" quotation } { "pair/f" "a pair or f" } }
+{ $description "The pair is either " { $link f } " or a two-tuple containing a " { $link basic-block } " and a " { $link height-state } " two-tuple." } ;
--- /dev/null
+USING: accessors compiler.cfg compiler.cfg.builder.blocks kernel sequences
+tools.test ;
+IN: compiler.cfg.builder.blocks.tests
+
+{
+ { "succ" "succ" "succ" }
+} [
+ <basic-block> "succ" >>number 3 [ <basic-block> ] replicate
+ [ set-successors ] keep
+ [ successors>> first number>> ] map
+] unit-test
make-kill-block
] emit-trivial-block ;
-: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
+: begin-branch ( -- )
+ height-state [ clone-height-state ] change
+ (begin-basic-block) ;
: end-branch ( -- pair/f )
- ! pair is { final-bb final-height }
basic-block get dup [
##branch,
end-local-analysis
- current-height get clone 2array
+ height-state get clone-height-state 2array
] when ;
: with-branch ( quot -- pair/f )
[ begin-branch call end-branch ] with-scope ; inline
-: set-successors ( branches -- )
- ! Set the successor of each branch's final basic block to the
- ! current block.
- [ [ [ basic-block get ] dip first successors>> push ] when* ] each ;
+: set-successors ( successor blocks -- )
+ [ successors>> push ] with each ;
: emit-conditional ( branches -- )
! branches is a sequence of pairs as above
end-basic-block
- dup [ ] find nip dup [
- second current-height set
+ sift [
+ dup first second height-state set
begin-basic-block
- set-successors
- ] [ 2drop ] if ;
+ [ basic-block get ] dip [ first ] map set-successors
+ ] unless-empty ;
USING: compiler.cfg.builder compiler.cfg.builder.blocks compiler.cfg.stacks
kernel make prettyprint ;
begin-stack-analysis initial-basic-block \ dummy 3 [ emit-call ] { } make drop
-current-height basic-block [ get . ] bi@ .
-T{ current-height { d 3 } }
+height-state basic-block [ get . ] bi@
+{ { 3 0 } { 0 0 } }
T{ basic-block
- { id 134 }
+ { id 1903165 }
{ successors
V{
T{ basic-block
- { id 135 }
+ { id 1903166 }
{ instructions
V{
T{ ##call { word dummy } }
T{ ##branch }
}
}
- { successors V{ T{ basic-block { id 136 } } } }
+ { successors
+ V{ T{ basic-block { id 1903167 } } }
+ }
{ kill-block? t }
}
}
HELP: emit-call
{ $values { "word" word } { "height" number } }
-{ $description "Emits a call to the given word to the " { $link cfg } " being constructed. \"height\" is the number of items being added to or removed from the data stack. Side effects of the word is that it modifies the \"basic-block\" and " { $link current-height } " variables." }
+{ $description "Emits a call to the given word to the " { $link cfg } " being constructed. \"height\" is the number of items being added to or removed from the data stack. Side effects of the word is that it modifies the \"basic-block\" and " { $link height-state } " variables." }
{ $examples
"In this example, a call to a dummy word is emitted which pushes three items onto the stack."
{ $unchecked-example $[ ex-emit-call ] }
combinators.short-circuit compiler.cfg compiler.cfg.builder compiler.cfg.checker
compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.optimizer
compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.rpo
-compiler.cfg.stacks.local compiler.tree compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.representations fry hashtables kernel
-kernel.private locals make math math.partial-dispatch math.private namespaces
-prettyprint sbufs sequences sequences.private slots.private strings
-strings.private tools.test vectors words ;
+compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities
+compiler.tree compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.representations fry hashtables kernel kernel.private locals make
+math math.partial-dispatch math.private namespaces prettyprint sbufs sequences
+sequences.private slots.private strings strings.private tools.test vectors
+words ;
FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests
{
{ T{ ##load-integer { dst 78 } { val 0 } } }
} [
+ initial-height-state height-state set
77 vreg-counter set-global
- current-height new current-height set
H{ } clone replace-mapping set
[
T{ #push { literal 0 } { out-d { 8537399 } } } emit-node
] unit-test
{
- T{ current-height { d 1 } { emit-d 1 } }
+ { { 1 1 } { 0 0 } }
H{ { D -1 4 } { D 0 4 } }
} [
0 vreg-counter set-global
- current-height new current-height set
+ initial-height-state height-state set
H{ } clone replace-mapping set
4 D 0 replace-loc
T{ #shuffle
{ in-d V{ 4 } }
{ out-d V{ 2 3 } }
} emit-node
-
- current-height get
+ height-state get
replace-mapping get
] unit-test
+
+{ 1 } [
+ V{ } 0 insns>block basic-block set
+ begin-stack-analysis begin-local-analysis
+ V{ } 1 insns>block [ emit-loop-call ] V{ } make drop
+ basic-block get successors>> length
+] unit-test
system tools.test words ;
IN: compiler.cfg.intrinsics.simd.tests
-:: test-node ( rep -- node )
+:: test-node ( rep -- node )
T{ #call
{ in-d { 1 2 3 4 } }
{ out-d { 5 } }
: test-compiler-env ( -- x )
H{ } clone
- T{ basic-block { id 0 } }
- [ \ basic-block pick set-at ]
- [ 0 swap associate \ ds-heights pick set-at ]
- [ 0 swap associate \ rs-heights pick set-at ] tri
- T{ current-height { d 0 } { r 0 } { emit-d 0 } { emit-r 0 } } \ current-height pick set-at
- H{ } clone \ local-peek-set pick set-at
- H{ } clone \ replace-mapping pick set-at
- H{ } <biassoc> \ locs>vregs pick set-at
- H{ } clone \ peek-sets pick set-at
- H{ } clone \ replace-sets pick set-at
- H{ } clone \ kill-sets pick set-at ;
+ T{ basic-block { id 0 } }
+ [ \ basic-block pick set-at ]
+ [ 0 swap associate \ ds-heights pick set-at ]
+ [ 0 swap associate \ rs-heights pick set-at ] tri
+ initial-height-state \ height-state pick set-at
+ H{ } clone \ local-peek-set pick set-at
+ H{ } clone \ replace-mapping pick set-at
+ H{ } <biassoc> \ locs>vregs pick set-at
+ H{ } clone \ peek-sets pick set-at
+ H{ } clone \ replace-sets pick set-at
+ H{ } clone \ kill-sets pick set-at ;
: make-classes ( quot -- seq )
{ } make [ class-of ] map ; inline
[ {
##mul-vector
- ##merge-vector-head ##merge-vector-tail ##add-vector
- ##merge-vector-head ##merge-vector-tail ##add-vector
+ ##merge-vector-head ##merge-vector-tail ##add-vector
+ ##merge-vector-head ##merge-vector-tail ##add-vector
##vector>scalar
} ]
[ simple-ops-cpu float-4-rep [ emit-simd-v. ] test-emit ]
[ simple-ops-cpu 3 [ emit-simd-v+ ] test-emit ]
[ bad-simd-intrinsic? ] must-fail-with
-
-USING: assocs compiler.cfg compiler.cfg.registers help.markup help.syntax math
-sequences ;
+USING: assocs compiler.cfg compiler.cfg.instructions compiler.cfg.registers
+help.markup help.syntax math sequences ;
IN: compiler.cfg.stacks.local
HELP: replace-mapping
{ $var-description "An " { $link assoc } " that maps from stack locations to virtual registers that were put on the stack." }
{ $see-also replace-loc } ;
-HELP: current-height
-{ $class-description "A tuple used to keep track of the heights of the data and retain stacks in a " { $link basic-block } " The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. It has the following slots:"
- { $table
- { { $slot "d" } { "Current datastack height." } }
- { { $slot "r" } { "Current retainstack height." } }
- { { $slot "emit-d" } { "Queued up datastack height change." } }
- { { $slot "emit-r" } { "Queued up retainstack height change." } }
- }
-} ;
+HELP: height-state
+{ $var-description "A two-tuple used to keep track of the heights of the data and retain stacks in a " { $link basic-block } " The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. The first item is the datastacks current height and queued up height change. The second item is the same for the retain stack." } ;
HELP: loc>vreg
{ $values { "loc" loc } { "vreg" "virtual register" } }
HELP: peek-loc
{ $values { "loc" loc } { "vreg" "virtaul register" } }
-{ $description "Retrieves the virtual register and the given stack location." } ;
+{ $description "Retrieves the virtual register at the given stack location." } ;
HELP: translate-local-loc
-{ $values { "loc" loc } { "loc'" loc } }
-{ $description "Translates an absolute stack location to one that is relative to the current stacks height as given in " { $link current-height } "." }
+{ $values { "state" "height state" } { "loc" loc } { "loc'" loc } }
+{ $description "Translates an absolute stack location to one that is relative to the given height state." }
{ $examples
{ $example
"USING: compiler.cfg.stacks.local compiler.cfg.registers compiler.cfg.debugger namespaces prettyprint ;"
- "T{ current-height { d 3 } } current-height set D 7 translate-local-loc ."
+ "{ { 3 0 } { 0 0 } } D 7 translate-local-loc ."
"D 4"
}
-} ;
+}
+{ $see-also height-state } ;
-HELP: height-changes
-{ $values { "current-height" current-height } { "insns" sequence } }
-{ $description "Converts a " { $link current-height } " tuple to 0-2 stack height change instructions." }
+HELP: height-state>insns
+{ $values { "state" sequence } { "insns" sequence } }
+{ $description "Converts a " { $link height-state } " tuple to 0-2 stack height change instructions." }
{ $examples
{ $example
"USING: compiler.cfg.stacks.local prettyprint ;"
- "T{ current-height { emit-d 4 } { emit-r -2 } } height-changes ."
+ "{ { 0 4 } { 0 -2 } } height-state>insns ."
"{ T{ ##inc { loc D 4 } } T{ ##inc { loc R -2 } } }"
}
} ;
HELP: inc-d
{ $values { "n" number } }
-{ $description "Increases or decreases the current datastacks height." } ;
+{ $description "Increases or decreases the current datastacks height. An " { $link ##inc } " instruction will later be inserted." } ;
+
+HELP: inc-r
+{ $values { "n" number } }
+{ $description "Increases or decreases the current retainstacks height. An " { $link ##inc } " instruction will later be inserted." } ;
ARTICLE: "compiler.cfg.stacks.local" "Local stack analysis"
"Local stack analysis. We build three sets for every basic block in the CFG:"
USING: accessors assocs biassocs combinators compiler.cfg
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
-compiler.cfg.stacks.local compiler.cfg.utilities cpu.architecture kernel
-namespaces sequences tools.test ;
+compiler.cfg.stacks.height compiler.cfg.stacks.local compiler.cfg.utilities
+cpu.architecture namespaces kernel tools.test ;
IN: compiler.cfg.stacks.local.tests
-{ T{ current-height f 3 0 3 0 } } [
- current-height new current-height [
- 3 inc-d current-height get
- ] with-variable
+{
+ { { 3 3 } { 0 0 } }
+} [
+ initial-height-state height-state set
+ 3 inc-d height-state get
+] unit-test
+
+{
+ { { 5 3 } { 0 0 } }
+} [
+ { { 2 0 } { 0 0 } } height-state set
+ 3 inc-d height-state get
] unit-test
{
{ T{ ##inc { loc D 4 } } T{ ##inc { loc R -2 } } }
} [
- T{ current-height { emit-d 4 } { emit-r -2 } } height-changes
+ { { 0 4 } { 0 -2 } } height-state>insns
] unit-test
{ 30 } [
] unit-test
{ 80 } [
- current-height new current-height set
+ initial-height-state height-state set
H{ } clone replace-mapping set 80
D 77 replace-loc D 77 peek-loc
] unit-test
begin-stack-analysis begin-local-analysis
compute-local-kill-set assoc-size
] unit-test
+
+{ H{ { R -4 R -4 } } } [
+ H{ { 77 4 } } [ ds-heights set ] [ rs-heights set ] bi
+ { { 8 0 } { 3 0 } } height-state set
+ 77 basic-block set
+ compute-local-kill-set
+] unit-test
+
+{ D 2 } [
+ { { 1 2 } { 3 4 } } D 3 translate-local-loc2
+] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators compiler.cfg
compiler.cfg.instructions compiler.cfg.parallel-copy
-compiler.cfg.registers compiler.cfg.stacks.height kernel make
-math math.order namespaces sequences sets ;
+compiler.cfg.registers compiler.cfg.stacks.height
+kernel make math math.order namespaces sequences sets ;
FROM: namespaces => set ;
IN: compiler.cfg.stacks.local
-SYMBOLS: peek-sets replace-sets kill-sets ;
+: >loc< ( loc -- n ds? )
+ [ n>> ] [ ds-loc? ] bi ;
+
+: modify-height ( state loc -- )
+ >loc< 0 1 ? rot nth [ + ] with map! drop ;
+
+: adjust ( state loc -- )
+ >loc< 0 1 ? rot nth dup first swapd + 0 rot set-nth ;
+
+: reset-emits ( state -- )
+ [ 0 1 rot set-nth ] each ;
+
+: height-state>insns ( state -- insns )
+ [ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map
+ [ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ;
+
+: translate-local-loc ( state loc -- loc' )
+ >loc< [ 0 1 ? rot nth first - ] keep ds-loc rs-loc ? new swap >>n ;
+
+: clone-height-state ( state -- state' )
+ [ clone ] map ;
+
+: initial-height-state ( -- state )
+ { { 0 0 } { 0 0 } } clone-height-state ;
+
+: kill-locations ( saved-height height -- seq )
+ dupd [-] iota [ swap - ] with map ;
+
+: local-kill-set ( ds-height rs-height state -- assoc )
+ first2 [ first ] bi@ swapd [ kill-locations ] 2bi@
+ [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
+ append unique ;
+
+SYMBOLS: height-state peek-sets replace-sets kill-sets ;
SYMBOL: locs>vregs
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
-TUPLE: current-height
-{ d initial: 0 }
-{ r initial: 0 }
-{ emit-d initial: 0 }
-{ emit-r initial: 0 } ;
-
SYMBOLS: local-peek-set local-replace-set replace-mapping ;
-GENERIC: translate-local-loc ( loc -- loc' )
-M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
-M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
-
: stack-changes ( replace-mapping -- insns )
[ [ loc>vreg ] dip ] assoc-map parallel-copy ;
-: height-changes ( current-height -- insns )
- [ emit-d>> <ds-loc> ] [ emit-r>> <rs-loc> ] bi 2array
- [ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ;
-
: emit-changes ( -- )
building get pop
replace-mapping get stack-changes %
- current-height get height-changes %
+ height-state get height-state>insns %
, ;
-! inc-d/inc-r: these emit ##inc to change the stack height later
: inc-d ( n -- )
- current-height get
- [ [ + ] change-emit-d drop ]
- [ [ + ] change-d drop ]
- 2bi ;
+ height-state get swap <ds-loc> modify-height ;
: inc-r ( n -- )
- current-height get
- [ [ + ] change-emit-r drop ]
- [ [ + ] change-r drop ]
- 2bi ;
+ height-state get swap <rs-loc> modify-height ;
: peek-loc ( loc -- vreg )
- translate-local-loc
+ height-state get swap translate-local-loc
dup replace-mapping get at
[ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
: replace-loc ( vreg loc -- )
- translate-local-loc replace-mapping get set-at ;
+ height-state get swap translate-local-loc
+ replace-mapping get set-at ;
: compute-local-kill-set ( -- assoc )
- basic-block get current-height get
- [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
- [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ] 2bi
- append unique ;
+ basic-block get [ rs-heights get at ] [ ds-heights get at ] bi
+ height-state get local-kill-set ;
: begin-local-analysis ( -- )
H{ } clone local-peek-set set
H{ } clone replace-mapping set
- current-height get
- [ 0 >>emit-d 0 >>emit-r drop ]
- [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
+ height-state get
+ [ reset-emits ] [
+ first2 [ first ] bi@ basic-block get record-stack-heights
+ ] bi ;
: remove-redundant-replaces ( -- )
replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
[ [ compute-local-kill-set ] dip kill-sets get set-at ]
} cleave ;
-: clone-current-height ( -- )
- current-height [ clone ] change ;
-
: peek-set ( bb -- assoc ) peek-sets get at ;
: replace-set ( bb -- assoc ) replace-sets get at ;
: kill-set ( bb -- assoc ) kill-sets get at ;
USING: accessors arrays assocs combinators compiler.cfg.dataflow-analysis
-compiler.cfg.instructions compiler.cfg.linearization compiler.cfg.registers fry
-kernel math math.order namespaces sequences ;
+compiler.cfg.instructions compiler.cfg.linearization compiler.cfg.stacks.local
+compiler.cfg.registers fry kernel math math.order namespaces sequences ;
QUALIFIED: sets
IN: compiler.cfg.stacks.map
CONSTANT: initial-state { { 0 { } } { 0 { } } }
-: insn>location ( insn -- n ds? )
- loc>> [ n>> ] [ ds-loc? ] bi ;
-
: mark-location ( state insn -- state' )
- [ first2 ] dip insn>location
+ [ first2 ] dip loc>> >loc<
[ rot register-write swap ] [ swap register-write ] if 2array ;
: fill-vacancies ( state -- state' )
GENERIC: visit-insn ( state insn -- state' )
M: ##inc visit-insn ( state insn -- state' )
- [ first2 ] dip insn>location
+ [ first2 ] dip loc>> >loc<
[ rot adjust-stack swap ] [ swap adjust-stack ] if 2array
! Negative out-of stack locations immediately becomes garbage.
[ first2 [ 0 >= ] filter 2array ] map ;
ERROR: vacant-peek insn ;
: underflowable-peek? ( state peek -- ? )
- 2dup insn>location swap [ 0 1 ? swap nth ] dip classify-read
+ 2dup loc>> >loc< swap [ 0 1 ? swap nth ] dip classify-read
dup 2 = [ drop vacant-peek ] [ 2nip 1 = ] if ;
M: ##peek visit-insn ( state insn -- state' )
HELP: begin-stack-analysis
{ $description "Initializes a set of variables related to stack analysis of Factor words." }
-{ $see-also current-height } ;
+{ $see-also height-state } ;
HELP: end-stack-analysis
{ $description "Ends the stack analysis of the current cfg." } ;
HELP: rs-store
{ $values { "vregs" "a " { $link sequence } " of vregs." } }
-{ $description "Stores one or more virtual register values on the retain stack. This modifies the " { $link current-height } " dynamic variable." } ;
+{ $description "Stores one or more virtual register values on the retain stack. This modifies the " { $link height-state } " dynamic variable." } ;
HELP: 2inputs
{ $values { "vreg1" "a vreg" } { "vreg2" "a vreg" } }
{ H{ { D -2 4 } { D -1 3 } { D -3 5 } } } [
{
- ${ current-height current-height new }
+ ${ height-state initial-height-state }
${ replace-mapping H{ } clone }
} [
{ 3 4 5 } ds-store replace-mapping get
H{ } clone peek-sets set
H{ } clone replace-sets set
H{ } clone kill-sets set
- current-height new current-height set ;
+ initial-height-state height-state set ;
: end-stack-analysis ( -- )
cfg get
: ds-pop ( -- vreg ) ds-peek ds-drop ;
-: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ;
+: ds-push ( vreg -- )
+ 1 inc-d D 0 replace-loc ;
: ds-load ( n -- vregs )
dup 0 =
: unary-op ( quot -- )
[ ds-pop ] dip call ds-push ; inline
-: adjust-d ( n -- ) current-height get [ + ] change-d drop ;
+: adjust-d ( n -- )
+ <ds-loc> height-state get swap adjust ;
projects / factor.git / commitdiff