## partition-machcode-controlflow-graph-and-allot-registers-by-partition-g.pkg
# Partition a cluster into multiple smaller clusters for region-based
# register allocation.
### "All profoundly original work looks ugly at first."
###
### -- Clement Greenberg
stipulate
package lem = lowhalf_error_message; # lowhalf_error_message is from src/lib/compiler/back/low/control/lowhalf-error-message.pkg package rkj = registerkinds_junk; # registerkinds_junk is from src/lib/compiler/back/low/code/registerkinds-junk.pkgherein
generic package partition_machcode_controlflow_graph_and_allot_registers_by_partition_g (
# ========================================================================
#
package flowgraph: FLOWGRAPH
package machcode_universals
: Machcode_Universals
sharing flowgraph::I = machcode_universals::I
)
: Partition_Machcode_Controlflow_Graph_And_Allot_Registers_By_Partition
# Partition_Machcode_Controlflow_Graph_And_Allot_Registers_By_Partition is from src/lib/compiler/back/low/regor/partition-machcode-controlflow-graph-and-allot-registers-by-partition.api {
package f = flowgraph
package i = f::I
package c = i::C
package pq = priority_queue
package liveness = liveness (flowgraph)
package a = rw_vector
type flowgraph = f::cluster
debug = TRUE
fun error msg = lem::error("ClusterPartitioner", msg)
maxSize = LowhalfControl::getInt "ra-max-region-size"
maxSize := 300
fun numberOfBlocks (f::CLUSTER { blkCounter, ... } ) = *blkCounter
# Partition the cluster into a set of clusters so that each can
# be allocated independently.
fun partition_machcode_controlflow_graph_and_allot_registers_by_partition
(f::CLUSTER { blkCounter, blocks, entry, exit,
annotations, ... } )
registerkind processRegion =
# Number of basic blocks
let N = *blkCounter
if debug then
print("[region based register allocation: " $
int::to_string N$"]\n")
else ()
maxSize = *maxSize
# Perform global liveness analysis first.
# Unfortunately, I know of no way of avoiding this step because
# we have to know which values are live across regions.
liveness::liveness { blocks=blocks,
defUse=machcode_universals::defUse registerkind,
getRegister=c::getRegistersByKind registerkind,
updateRegister=c::updateRegistersByKind registerkind
}
my f::ENTRY { next=entrySucc, ... } = entry
my f::EXIT { prior=exitPred, ... } = exit
initTrail = [(entrySucc,*entrySucc), (exitPred, *exitPred)]
# Priority queue of basic blocks in non-increasing order
# of execution frequency
fun higherFreq (f::BBLOCK { freq=a, ... }, f::BBLOCK { freq=b, ... } ) = *a > *b
| higherFreq _ = error "higherFreq"
blocks = list::fold_backward (\\ (b as f::BBLOCK _, l) => b . l | (_, l) => l)
[] blocks
seedQueue = pq::from_list higherFreq blocks
# Current region id
regionCounter = REF 0
fun newRegionId() =
let regionId = *regionCounter
in regionCounter := *regionCounter + 1; regionId end
# Has the block been included in any region?
# Non-negative means yes. The number is the region id in which
# the block belongs.
processed = a::rw_vector (N, -1)
fun hasBeenProcessed n = a::sub (processed, n) >= 0
fun markAsProcessed (n, regionId) = a::update (processed, n, regionId)
# Get an unprocessed seed block from the queue
fun getSeedBlock (regionId) =
case pq::deleteMin seedQueue of
block as f::BBLOCK { blknum, instructions, ... } =>
if hasBeenProcessed blknum then getSeedBlock (regionId)
else block
| _ => error "getSeedBlock"
fun resetTrail [] = ()
| resetTrail((r, x) . trail) = (r := x; resetTrail trail)
# Grow a region. Currently, region growth is limited only by size.
# Note that we only select nodes with one out edges as possible
# region cut points. We also try not to make a region too small
# as it will waste initialization time. It's a delicate balance.
fun growRegion() =
let regionId = newRegionId()
fun add ([], Q) = Q
| add((b as f::BBLOCK { blknum, ... }, _) . bs, Q) =
if hasBeenProcessed blknum then add (bs, Q)
else add (bs, b . Q)
| add(_ . bs, Q) = add (bs, Q)
fun grow ((b as f::BBLOCK { blknum, next, prior, instructions, ... } ) . F, B,
size, blks, m) =
if hasBeenProcessed blknum
then grow (F, B, size, blks, m)
else
let n = length *instructions
newSize = size + n
in if m > 0 and newSize > maxSize and length(*next) == 1
then grow (F, B, size, blks, m)
else (markAsProcessed (blknum, regionId);
grow (F, add(*prior, add(*next, B)), newSize,
b . blks, m+1)
)
end
| grow([], [], size, blks, m) = (size, blks, m)
| grow([], B, size, blks, m) = grow (reverse B, [], size, blks, m)
| grow _ = error "grow"
# Find a seed block
seed = getSeedBlock (regionId)
# Grow until we reach some limit
my (totalSize, blocks, blockCount) = grow([seed], [], 0, [], 0)
# Now create a cluster with only these blocks
# We have to update the edges so that region-entry edges
# are made into entry edges and region-exit edges are
# made into exit edges.
fun makeSubgraph (blocks) =
let fun inSubgraph (y) = a::sub (processed, y) = regionId
fun processSucc (b, x, (e as (f::BBLOCK { blknum=y, ... }, freq)) . es,
es', exit, exitFreq) =
if inSubgraph (y) then
processSucc (b, x, es, e . es', exit, exitFreq)
else processSucc (b, x, es, es', TRUE, exitFreq + *freq)
| processSucc (b, x, (e as (f::EXIT { blknum=y, ... }, freq)) . es, es',
exit, exitFreq) =
processSucc (b, x, es, es', TRUE, exitFreq + *freq)
| processSucc (b, x,[], es', TRUE, exitFreq) =
let w = REF exitFreq
in exitPred := (b, w) . *exitPred;
((exit, w) . es', TRUE)
end
| processSucc (b, x,[], es', FALSE, exitFreq) = (es', FALSE)
| processSucc _ = error "processSucc"
fun processPred (b, x, (e as (f::BBLOCK { blknum=y, ... }, freq)) . es,
es', entry, entryFreq) =
if inSubgraph (y) then
processPred (b, x, es, e . es', entry, entryFreq)
else processPred (b, x, es, es', TRUE, entryFreq + *freq)
| processPred (b, x, (e as (f::ENTRY { blknum=y, ... }, freq)) . es, es',
entry, entryFreq) =
processPred (b, x, es, es', TRUE, entryFreq + *freq)
| processPred (b, x,[], es', TRUE, entryFreq) =
let w = REF entryFreq
in entrySucc := (b, w) . *entrySucc;
((entry, w) . es', TRUE)
end
| processPred (b, x,[], es', FALSE, entryFreq) = (es', FALSE)
| processPred _ = error "processPred"
fun processNodes([], trail) = trail
| processNodes(
(b as f::BBLOCK { blknum=n, liveIn, liveOut, next, prior, ... } )
. nodes, trail) =
let my (next', exit) = processSucc (b, n,*next,[], FALSE, 0)
trail = if exit then (next, *next) . trail else trail
my (prior', entry) = processPred (b, n,*prior,[], FALSE, 0)
trail = if entry then (prior, *prior) . trail else trail
in next := next';
prior := prior';
# To save space, clear liveIn and
# liveOut information (if it is not an exit)
liveIn := rkj::Registerset::empty;
if exit then () else liveOut := rkj::Registerset::empty;
processNodes (nodes, trail)
end
| processNodes _ = error "processNodes"
entrySucc := []
exitPred := []
trail = processNodes (blocks, initTrail)
in trail
end
# Make a subgraph with the appropriate edges
trail = makeSubgraph (blocks)
region =
f::CLUSTER { blkCounter = blkCounter,
blocks = blocks,
entry = entry,
exit = exit,
annotations = annotations
}
in (regionId, region, trail, blockCount)
end
# Extract a new region to compile. Raises pq::EMPTY_PRIORITY_QUEUE if
# everything is finished.
fun iterate () =
let my (id, region, trail, blockCount) = growRegion() # get a region
in if debug then
print("[region "$int::to_string id$" has "$int::to_string blockCount $
" blocks]\n")
processRegion region; # Allocate this region
resetTrail trail; # reset the flowgraph
iterate() # process next region
end
in # Repeat until the entire flowgraph has been processed
iterate() except pq::EMPTY_PRIORITY_QUEUE => ();
if debug then print "[region based register allocation done]\n" else ()
end
};
end;