## forward-jumps-to-jumps-g.pkg
#
# If a jump just jumps to another jump,
# save an instruction by jumping directly to final destination.
#
# Basically, we run right after block placement # make_final_basic_block_order_list_g is from src/lib/compiler/back/low/block-placement/make-final-basic-block-order-list-g.pkg# and right before jump-squashing. # squash_jumps_and_make_machinecode_bytevector_intel32_g is from src/lib/compiler/back/low/jmp/squash-jumps-and-write-code-to-code-segment-buffer-intel32-g.pkg# # squash_jumps_and_make_machinecode_bytevector_sparc32_g is from src/lib/compiler/back/low/jmp/squash-jumps-and-write-code-to-code-segment-buffer-sparc32-g.pkg# # squash_jumps_and_make_machinecode_bytevector_pwrpc32_g is from src/lib/compiler/back/low/jmp/squash-jumps-and-write-code-to-code-segment-buffer-pwrpc32-g.pkg #
# TODO:
# check for jumps to the next block.
# jump tables (SWITCH edges). XXX BUGGO FIXME
# Compiled by:
# src/lib/compiler/back/low/lib/lowhalf.lib### "He jumped so high..."
### -- Jerry Jeff Walker, "Mr. Bojangles"
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 lbl = codelabel; # codelabel is from src/lib/compiler/back/low/code/codelabel.pkg package lhc = lowhalf_control; # lowhalf_control is from src/lib/compiler/back/low/control/lowhalf-control.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) from:
#
# src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkg #
generic package forward_jumps_to_jumps_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).
# Control flag that when set TRUE allows jumps to labels outside
# of the machcode_controlflow_graph to be chained. Set this FALSE when there are many
# short jumps to a long jump that exits the machcode_controlflow_graph.
#
chain_escapes: Ref( Bool );
# Control flag that when set TRUE allows the direction (forward or
# backward) of conditional jumps to be changed. Set this FALSE
# when the direction of conditional branches is used to predict
# the branch.
#
reverse_direction: Ref( Bool );
)
: (weak) api {
#
package mcg: Machcode_Controlflow_Graph; # Machcode_Controlflow_Graph is from src/lib/compiler/back/low/mcg/machcode-controlflow-graph.api #
forward_jomps_to_jumps
:
(mcg::Machcode_Controlflow_Graph, List(mcg::Node))
->
(mcg::Machcode_Controlflow_Graph, List(mcg::Node));
}
{
# Export to client packages:
#
package mcg = mcg;
stipulate
# Flags:
#
disable_jump_to_jump_forwarding
=
lhc::make_bool
(
"disable_jump_to_jump_forwarding",
"whether jump-to-jump forwarding is disabled"
);
dump_machcode_controlflow_graph_after_jump_to_jump_forwarding
=
lhc::make_bool
(
"dump_machcode_controlflow_graph_after_jump_to_jump_forwarding",
"whether flow graph is shown after jump-to-jump forwarding"
);
dump_strm = lhc::debug_stream;
fun error msg
=
lem::error("forward_jumps_to_jumps_g", msg);
herein
# Here 'nodes' is the final basic-block order list generated by
#
# src/lib/compiler/back/low/block-placement/make-final-basic-block-order-list-g.pkg #
fun forward_jomps_to_jumps (mcg, nodes)
=
(mcg, nodes)
where
mcg -> odg::DIGRAPH { node_info, out_edges, set_out_edges, in_edges, forall_nodes, remove_node, ... };
#
chain_escapes = *chain_escapes;
reverse_direction = *reverse_direction;
# This flag is set to note that
# we need to filter out unreachable
# nodes after jump chaining.
#
need_filter = REF FALSE;
# The exit block:
#
exit_node_id = mcg::exit_node_id_of_graph mcg;
fun label_of blk_id # Map a block ID to a label
=
case (node_info blk_id)
#
mcg::BBLOCK { labels=>REF (lab ! _), ... }
=>
lab;
mcg::BBLOCK { labels, ... }
=>
{ lab = lbl::make_anonymous_codelabel ();
labels := [lab];
lab;
};
esac;
fun jump_label_of instruction
=
case (mu::branch_targets instruction)
#
[mu::LABELLED lab]
=>
lab;
_ => error ("jumpLabelOf");
esac;
# Given a destination block ID,
# check to see if it is a block that
# consists a single jump instruction.
#
# If so, return the block ID and label
# of the block at the end of the jump chain;
# otherwise return NULL.
#
fun follow_chain blk_id
=
case (node_info blk_id)
#
mcg::BBLOCK { ops as REF [i], kind=>mcg::NORMAL, ... }
=>
# A normal block with one instruction
#
case (out_edges blk_id)
#
[e as (_, dst, mcg::EDGE_INFO { kind=>mcg::JUMP, execution_frequency, notes } )]
=>
if (dst != exit_node_id or chain_escapes)
#
# The instruction must be a jump so
# transitively follow it to get the target,
# but be careful to avoid infinite loops.
set_out_edges (blk_id, []);
case (follow_chain dst)
#
NULL =>
{ set_out_edges (blk_id, [e]);
THE (dst, jump_label_of i);
};
(some_lab as THE (dst', lab))
=>
{ ops := [mu::jump lab];
set_out_edges (
blk_id,
[(blk_id, dst', mcg::EDGE_INFO { kind => mcg::JUMP, execution_frequency, notes } )]
);
some_lab;
};
esac;
else
NULL;
fi;
_ => NULL;
esac;
_ => NULL;
esac; # fun follow_chain
# For each normal block,
# check the outgoing edges
# to see if they can be redirected:
#
fun do_block (blk_id, mcg::BBLOCK { ops, kind=>mcg::NORMAL, ... } )
=>
{ fun set_targets labs
=
{ my (jmp, rest)
=
case *ops
#
jmp ! rest => (jmp, rest);
[] => error "set_targets: empty ops";
esac;
new_jmp
=
case labs
#
[lab] => mu::set_jump_target (jmp, lab);
[lab1, lab2] => mu::set_branch_targets { op=>jmp, false=>lab1, true=>lab2 };
_ => error "set_targets";
esac;
need_filter := TRUE;
ops := new_jmp ! rest;
};
case (out_edges blk_id)
#
[ (_, dst, info as mcg::EDGE_INFO { kind => mcg::JUMP, ... } ) ]
=>
case (follow_chain dst)
#
THE (dst', lab)
=>
{ set_targets [lab];
set_out_edges (blk_id, [(blk_id, dst', info)]);
};
NULL => ();
esac;
[ (_, dst1, info as mcg::EDGE_INFO { kind => mcg::BRANCH TRUE, ... } ), e2 ]
=>
case (follow_chain dst1)
#
THE (dst', lab)
=>
{ set_targets [label_of(#2 e2), lab];
set_out_edges (blk_id, [(blk_id, dst', info), e2]);
};
NULL => ();
esac;
[ e1, (_, dst2, info as mcg::EDGE_INFO { kind => mcg::BRANCH TRUE, ... } ) ]
=>
case (follow_chain dst2)
#
THE (dst', lab)
=>
{ set_targets [label_of(#2 e1), lab];
set_out_edges (blk_id, [e1, (blk_id, dst', info)]);
};
NULL => ();
esac;
_ => ();
esac;
};
do_block _
=>
();
end;
entry_node_id = mcg::entry_node_id_of_graph mcg;
# Any basic block without any in-edges can be dropped
# as dead code -- except of course for the ENTRY node:
#
fun keep_block (blk_id, _)
=
if (null (in_edges blk_id)
and blk_id != entry_node_id)
#
remove_node blk_id;
FALSE;
else
TRUE;
fi;
nodes = if *disable_jump_to_jump_forwarding
#
nodes;
else
forall_nodes do_block;
if *need_filter list::filter keep_block nodes;
else nodes;
fi;
fi;
if *dump_machcode_controlflow_graph_after_jump_to_jump_forwarding
#
pr_node = mcg::dump_node (*dump_strm, mcg);
fil::write (*dump_strm, "[ after jump-chain elimination ]\n");
list::apply pr_node nodes;
fi;
end;
end;
};
end;
## COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.