## check-machcode-block-placement-g.pkg
# Compiled by:
# src/lib/compiler/back/low/lib/lowhalf.lib# This generic implements code to check
# that a block placement is correct.
stipulate
package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkg package odg = oop_digraph; # oop_digraph is from src/lib/graph/oop-digraph.pkg package lem = lowhalf_error_message; # lowhalf_error_message is from src/lib/compiler/back/low/control/lowhalf-error-message.pkgherein
# This generic is invoked (only) in:
#
# src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkg #
generic package check_machcode_block_placement_g (
# ===============================
#
package mcg: Machcode_Controlflow_Graph; # Machcode_Controlflow_Graph is from src/lib/compiler/back/low/mcg/machcode-controlflow-graph.api package mu: Machcode_Universals # Machcode_Universals is from src/lib/compiler/back/low/code/machcode-universals.api where
mcf == mcg::mcf; # "mcf" == "machcode_form" (abstract machine code).
)
: (weak) api {
#
package mcg: Machcode_Controlflow_Graph; # Machcode_Controlflow_Graph is from src/lib/compiler/back/low/mcg/machcode-controlflow-graph.api #
check_machcode_block_placement
:
( mcg::Machcode_Controlflow_Graph,
List(mcg::Node) # Blocks.
)
-> Void;
}
{
# Export to client packages:
#
package mcg = mcg;
dump_strm = lowhalf_control::debug_stream;
fun block_to_string (id', mcg::BBLOCK { id, ... } )
=
cat ["<", int::to_string id', ":", int::to_string id, ">"];
fun check_machcode_block_placement (mcg as odg::DIGRAPH graph, nodes)
=
{
# A rw_vector that maps from block id
# to position in the placement (starting
# from 1).
#
# Nodes that have no placement have index -1.
#
order = { vec = rw_vector::make_rw_vector (graph.capacity (), -1);
fun init ((id, _), i)
=
{ rw_vector::set (vec, id, i);
i+1;
};
ignore (list::fold_forward init 1 nodes);
vec;
};
fun adjacent_nodes (a, b)
=
rw_vector::get (order, a) + 1
==
rw_vector::get (order, b);
saw_errors = REF FALSE;
# Report an error and dump the mcg
#
fun report_error msg
=
{ fun say s
=
fil::write (*dump_strm, s);
if (not *saw_errors)
#
saw_errors := TRUE;
say "********** Bogus block placement **********\n";
fi;
say (cat ("** " ! msg));
};
fun report_not_adjacent (src, dst)
=
{ fun b2s id
=
cat [
int::to_string id, "@", int::to_string (rw_vector::get (order, id))
];
report_error [
"Blocks ", b2s src, " and ", b2s dst,
" are not adjacent\n"
];
};
# Return TRUE if the edge
# must connect adjacent nodes:
#
fun adj_edge (mcg::EDGE_INFO { kind => mcg::FALLSTHRU, ... } ) => TRUE;
adj_edge (mcg::EDGE_INFO { kind => mcg::BRANCH FALSE, ... } ) => TRUE;
adj_edge _ => FALSE;
end;
# Entry and exit nodes:
#
entry_node_id = mcg::entry_node_id_of_graph mcg;
exit_node_id = mcg::exit_node_id_of_graph mcg;
# Get the jump targets from the
# last instruction in a block
#
fun get_jump_targets id
=
case (graph.node_info id)
#
mcg::BBLOCK { ops => REF (i ! _), ... }
=>
case (mu::instruction_kind i)
#
mu::k::JUMP => mu::branch_targets i;
_ => [];
esac;
_ => [];
esac;
# Check that FALLSTHRU and BRANCH FALSE
# edges connect adjacent nodes
#
fun check_edge (src, dst, mcg::EDGE_INFO { kind, ... } )
=
case kind
#
(mcg::FALLSTHRU | mcg::BRANCH FALSE)
=>
if (not (adjacent_nodes (src, dst)))
#
report_not_adjacent (src, dst);
fi;
mcg::BRANCH TRUE
=>
case (get_jump_targets src)
#
[mu::FALLTHROUGH, mu::LABELLED _] => ();
[mu::LABELLED _, mu::FALLTHROUGH] => ();
_ =>
report_error [
"Block ", int::to_string src,
" doesn't end in conditiona branch\n"
];
esac;
mcg::JUMP
=>
case (get_jump_targets src)
#
[mu::LABELLED _] => ();
_ =>
report_error [
"Block ", int::to_string src, " doesn't end in jump\n"
];
esac;
mcg::ENTRY
=>
if (src != entry_node_id)
#
report_error [
"Block ", int::to_string src, " is not ENTRY\n"
];
fi;
mcg::EXIT
=>
if (dst != exit_node_id)
#
report_error [
"Block ", int::to_string dst, " is not EXIT\n"
];
else
case (get_jump_targets src)
#
[mu::ESCAPES] => ();
_ =>
report_error [
"Block ", int::to_string src,
"doesn't end in an escaping jump\n"
];
esac;
fi;
_ => ();
esac; # No checking for SWITCH or FLOWSTO
graph.forall_edges check_edge;
if *saw_errors
#
fun say s = fil::write (*dump_strm, s);
pr_node = mcg::dump_node (*dump_strm, mcg);
say "Block placement order:\n";
list::apply
(\\ b = say (cat [" ", block_to_string b, "\n"]))
nodes;
fil::write (*dump_strm, "[ machcode-controlflow-graph ]\n");
list::apply pr_node nodes;
say "**********\n";
lem::error ("check_machcode_block_placement_g", "bogus placement");
fi;
}; # fun check
}; # generic package check_machcode_block_placement_g
end; # stipulate
## COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.