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

Scheduling doesn't have such redundant data structures anymore

db4
Daniel Ehrenberg 2010-02-11 21:21:22 -06:00
parent a6f255a985
commit 5a3d0fb883
2 changed files with 16 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
basis/compiler/cfg/dependence/dependence.factor
View File

@ -12,11 +12,13 @@ SYMBOL: roots
SYMBOL: node-number SYMBOL: node-number
SYMBOL: nodes SYMBOL: nodes
SYMBOL: +data+
SYMBOL: +control+
! Nodes in the dependency graph ! Nodes in the dependency graph
! These need to be numbered so that the same instruction ! These need to be numbered so that the same instruction
! will get distinct nodes if it occurs multiple times ! will get distinct nodes if it occurs multiple times
TUPLE: node TUPLE: node
precedes-data precedes-control
number insn precedes follows number insn precedes follows
children parent children parent
registers parent-index ; registers parent-index ;
@ -30,22 +32,15 @@ M: node hashcode* nip number>> ;
node-number counter >>number node-number counter >>number
swap >>insn swap >>insn
H{ } clone >>precedes H{ } clone >>precedes
H{ } clone >>precedes-data
H{ } clone >>precedes-control
H{ } clone >>follows ; H{ } clone >>follows ;
: ready? ( node -- ? ) precedes>> assoc-empty? ; : ready? ( node -- ? ) precedes>> assoc-empty? ;
: precedes ( first second -- ) : spin ( a b c -- c b a )
swap precedes>> conjoin ; [ 2nip ] [ drop nip ] [ 2drop ] 3tri ;
: precedes-data ( first second -- ) : precedes ( first second how -- )
[ precedes ] spin precedes>> set-at ;
[ swap precedes-data>> conjoin ] 2bi ;
: precedes-control ( first second -- )
[ precedes ]
[ swap precedes-control>> conjoin ] 2bi ;
:: add-data-edges ( nodes -- ) :: add-data-edges ( nodes -- )
! This builds up def-use information on the fly, since ! This builds up def-use information on the fly, since
@ -53,11 +48,11 @@ M: node hashcode* nip number>> ;
H{ } clone :> definers H{ } clone :> definers
nodes [| node | nodes [| node |
node insn>> defs-vreg [ node swap definers set-at ] when* node insn>> defs-vreg [ node swap definers set-at ] when*
node insn>> uses-vregs [ definers at [ node precedes-data ] when* ] each node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each
] each ; ] each ;
: make-chain ( nodes -- ) : make-chain ( nodes -- )
[ dup rest-slice [ precedes-control ] 2each ] unless-empty ; [ dup rest-slice [ +control+ precedes ] 2each ] unless-empty ;
: instruction-chain ( nodes quot -- ) : instruction-chain ( nodes quot -- )
'[ insn>> @ ] filter make-chain ; inline '[ insn>> @ ] filter make-chain ; inline
@ -107,7 +102,7 @@ UNION: alien-call-insn
: set-follows ( nodes -- ) : set-follows ( nodes -- )
[ [
dup precedes>> values [ dup precedes>> keys [
follows>> conjoin follows>> conjoin
] with each ] with each
] each ; ] each ;
@ -140,11 +135,14 @@ UNION: alien-call-insn
[ >>parent drop ] [ >>parent drop ]
[ [ ?push ] change-children drop ] 2bi ; [ [ ?push ] change-children drop ] 2bi ;
: keys-for ( assoc value -- keys )
'[ nip _ = ] assoc-filter keys ;
: choose-parent ( node -- ) : choose-parent ( node -- )
! If a node has control dependences, it has to be a root ! If a node has control dependences, it has to be a root
! Otherwise, choose one of the data dependences for a parent ! Otherwise, choose one of the data dependences for a parent
dup precedes-control>> assoc-empty? [ dup precedes>> +control+ keys-for empty? [
dup precedes-data>> values [ drop ] [ dup precedes>> +data+ keys-for [ drop ] [
first attach-parent first attach-parent
] if-empty ] if-empty
] [ drop ] if ; ] [ drop ] if ;

2
basis/compiler/cfg/scheduling/scheduling.factor
View File

@ -26,7 +26,7 @@ ERROR: bad-delete-at key assoc ;
'[ _ >>parent-index drop ] each ; '[ _ >>parent-index drop ] each ;
: remove-node ( node -- ) : remove-node ( node -- )
[ follows>> values ] keep [ follows>> keys ] keep
'[ [ precedes>> _ swap check-delete-at ] each ] '[ [ precedes>> _ swap check-delete-at ] each ]
[ [ ready? ] filter roots get push-all ] bi ; [ [ ready? ] filter roots get push-all ] bi ;