## make-machcode-codebuffer-g.pkg
#
# This is essentially a buffer which builds up
# a machine-code graph driven by client put_*
# commands. In particular we are used by
#
# src/lib/compiler/back/low/intel32/treecode/translate-treecode-to-machcode-intel32-g.pkg# src/lib/compiler/back/low/pwrpc32/treecode/translate-treecode-to-machcode-pwrpc32-g.pkg# src/lib/compiler/back/low/sparc32/treecode/translate-treecode-to-machcode-sparc32-g.pkg#
# to construct instances of
#
# machcode_controlflow_graph_intel32 from src/lib/compiler/back/low/main/intel32/backend-lowhalf-intel32-g.pkg# machcode_controlflow_graph_pwrpc32 from src/lib/compiler/back/low/main/pwrpc32/backend-lowhalf-pwrpc32.pkg# machcode_controlflow_graph_sparc32 from src/lib/compiler/back/low/main/sparc32/backend-lowhalf-sparc32.pkg#
# all of which are generated by
#
# src/lib/compiler/back/low/mcg/machcode-controlflow-graph-g.pkg# per src/lib/compiler/back/low/mcg/machcode-controlflow-graph.api#
#
# This appears to be the live facility described in the
# "Directly from instructions"
# section of
# http://www.cs.nyu.edu/leunga/MLRISC/Doc/html/mlrisc-ir.html
# Compiled by:
# src/lib/compiler/back/low/lib/lowhalf.lib# We are invoked from:
#
# src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkgstipulate
package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkg package lbl = codelabel; # codelabel is from src/lib/compiler/back/low/code/codelabel.pkg package lcn = lowhalf_notes; # lowhalf_notes is from src/lib/compiler/back/low/code/lowhalf-notes.pkg package lem = lowhalf_error_message; # lowhalf_error_message is from src/lib/compiler/back/low/control/lowhalf-error-message.pkg package odg = oop_digraph; # oop_digraph is from src/lib/graph/oop-digraph.pkg package pb = pseudo_op_basis_type; # pseudo_op_basis_type is from src/lib/compiler/back/low/mcg/pseudo-op-basis-type.pkg package ptf = sfprintf; # sfprintf is from src/lib/src/sfprintf.pkgherein
# This generic is invoked (only) in:
#
# src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkg #
generic package make_machcode_codebuffer_g (
# ==========================
#
package mu: Machcode_Universals; # Machcode_Universals is from src/lib/compiler/back/low/code/machcode-universals.api package cst: Codebuffer; # Codebuffer is from src/lib/compiler/back/low/code/codebuffer.api package mcg: Machcode_Controlflow_Graph # Machcode_Controlflow_Graph is from src/lib/compiler/back/low/mcg/machcode-controlflow-graph.api where
mcf == mu::mcf # "mcf" == "machcode_form" (abstract machine code).
also pop == cst::pop; # "pop" == "pseudo_op".
)
: (weak) Make_Machcode_Codebuffer # Make_Machcode_Codebuffer is from src/lib/compiler/back/low/mcg/make-machcode-codebuffer.api {
# Exported for client packages:
#
package mcg = mcg; # "mcg" == "machcode_controlflow_graph".
package pop = mcg::pop; # "pop" == "pseudo_op".
package mcf = mu::mcf; # "mcf" == "machcode_form" (abstract machine code).
package cst = cst; # "cst" == "codestream".
stipulate
# package pop = pseudo_op;
# package ins = machcode;
package mu = mu; # "mu" == "machcode_universals".
herein
exception LABEL_NOT_FOUND;
Codebuffer
=
cst::Codebuffer
(
mcf::Machine_Op,
note::Notes,
mcg::mcf::rgk::Codetemplists,
mcg::Machcode_Controlflow_Graph
);
dump_initial_machcode_controlflow_graph
=
lowhalf_control::make_bool
("dump_initial_machcode_controlflow_graph",
"Dump machcode_controlflow_graph after instruction selection");
#
fun error msg
=
lem::error ("BuildFlowGraph", msg);
hash_label
=
unt::to_int o lbl::codelabel_to_hashcode;
#
fun make_machcode_codebuffer ()
=
{ put_comment,
get_notes,
put_bblock_note,
put_private_label,
put_public_label,
put_pseudo_op,
put_op,
put_fn_liveout_info,
start_new_cccomponent,
get_completed_cccomponent
}
where
(REF (mcg::make_machcode_controlflow_graph ()))
->
mcg as REF (odg::DIGRAPH graph);
block_list = REF ([]: List( mcg::Bblock )); # List of blocks generated so far.
entry_labels = REF ([]: List( lbl::Codelabel )); # List of entry labels to patch successors of ENTRY.
# Block id associated with a label:
#
label_map = iht::make_hashtable { size_hint => 32, not_found_exception => LABEL_NOT_FOUND };
find_label = iht::find label_map;
add_label = iht::set label_map;
# Data in text segment is read-only:
#
Segment_T = TEXT | DATA | RO_DATA | BSS | DECLS;
segment_f = REF DECLS;
block_names = REF []: Ref( note::Notes ); # The block names.
reorder = REF []: Ref( note::Notes ); # Can instructions be reordered?
no_block = mcg::make_bblock { id => -1, execution_frequency => REF 0.0 }; # noblock or invalid block has id of -1
current_bblock = REF no_block; # Current block being built up.
#
fun make_bblock execution_frequency # Add a new basic block; also make it the current block being built up.
=
{ (*mcg) -> odg::DIGRAPH graph;
#
id = graph.allot_node_id ();
(mcg::make_bblock { id, execution_frequency => REF execution_frequency })
->
blk as mcg::BBLOCK { notes, ... };
current_bblock := blk;
notes := *block_names @ *reorder;
block_list := blk ! *block_list;
graph.add_node (id, blk);
blk;
};
#
fun get_current_bblock () # Get current basic block:
=
case *current_bblock
#
mcg::BBLOCK { id=> -1, ... } => make_bblock 1.0;
other => other;
esac;
############################## cccomponent #######################
# Start a new callgraph connected component:
#
fun start_new_cccomponent _
=
{ block_list := [];
entry_labels := [];
block_names := [];
current_bblock := no_block;
iht::clear label_map;
};
#
fun put_op op # Emit an instruction.
=
{ (get_current_bblock ()) -> mcg::BBLOCK { ops, ... };
#
fun terminate ()
=
current_bblock := no_block;
ops := op ! *ops;
case (mu::instruction_kind op)
#
mu::k::JUMP => terminate ();
mu::k::CALL_WITH_CUTS => terminate ();
_ => ();
esac;
};
#
fun put_fn_liveout_info liveout # Make current block an exit block.
=
{ fun set_live_out (mcg::BBLOCK { notes, ... } )
=
notes := mcg::liveout.x_to_note liveout
!
*notes;
case *current_bblock
#
mcg::BBLOCK { id=> -1, ... }
=>
case *block_list
#
[] => error "put_fn_liveout_infos";
#
blk ! _ => set_live_out blk;
esac;
blk => set_live_out blk;
esac;
};
#
fun get_completed_cccomponent given_notes # End of callgraph connected component --- all done:
=
mcg
where
my mcg as odg::DIGRAPH graph
=
(*mcg
then
mcg := mcg::make_machcode_controlflow_graph ()
);
mcg::add_start_node_and_stop_node_to_graph mcg; # Create unique ENTRY/EXIT nodes.
entry = head (graph.entries ());
exit = head (graph.exits ());
#
fun add_edge (from, to, kind)
=
graph.add_edge
( from,
to,
mcg::EDGE_INFO
{ kind,
execution_frequency => REF 0.0,
notes => REF []
}
);
#
fun add_annotated_edge (from, to, kind, notes)
=
graph.add_edge
( from,
to,
mcg::EDGE_INFO
{ kind,
execution_frequency => REF 0.0,
notes => REF notes
}
);
#
fun target label
=
case (iht::find label_map (hash_label label))
#
THE b_id => b_id;
NULL => exit;
esac;
lcn::branch_probability
->
{ get => get_prob, ... };
#
fun jump (from, instruction, blocks)
=
{ fun branch (target_label)
=
{ (mu::get_notes instruction)
->
(_, notes);
branch_probability_notes
=
list::filter
\\ (lcn::BRANCH_PROBABILITY _) => TRUE; _ => FALSE; end
notes;
#
fun next (mcg::BBLOCK { id, ... } ! _) => id;
next [] => error "jump::next";
end;
add_annotated_edge (from, target target_label, mcg::BRANCH TRUE, branch_probability_notes);
add_edge (from, next blocks, mcg::BRANCH FALSE);
};
case (mu::branch_targets instruction)
#
[mu::ESCAPES ] => add_edge (from, exit, mcg::EXIT);
[mu::LABELLED label ] => add_edge (from, target label, mcg::JUMP);
#
[mu::LABELLED label, mu::FALLTHROUGH ] => branch label;
[mu::FALLTHROUGH, mu::LABELLED label] => branch label;
targets
=>
{ list::fold_forward switch 0 targets;
();
}
where
fun switch (mu::LABELLED label, n)
=>
{ add_edge (from, target label, mcg::SWITCH (n));
n+1;
};
switch _ => error "jump::switch";
end;
end;
esac;
}
also
fun falls_thru (id, blks)
=
case blks
#
[] => add_edge (id, exit, mcg::EXIT);
mcg::BBLOCK { id=>next, ... } ! _
=>
add_edge (id, next, mcg::FALLSTHRU);
esac
also
fun add_edges [] => ();
add_edges (mcg::BBLOCK { id, ops=>REF [], ... } ! blocks) => falls_thru (id, blocks);
add_edges (mcg::BBLOCK { id, ops=>REF (instruction ! _), ... } ! blocks)
=>
{ fun do_jmp ()
=
jump (id, instruction, blocks);
case (mu::instruction_kind instruction)
#
mu::k::JUMP => do_jmp ();
mu::k::CALL_WITH_CUTS => do_jmp ();
_ => falls_thru (id, blocks);
esac;
add_edges blocks;
};
end;
add_edges (reverse *block_list);
apply (\\ label = add_edge (entry, target label, mcg::ENTRY))
*entry_labels;
global_graph_notes = mcg::get_global_graph_notes mcg;
global_graph_notes := given_notes @ *global_graph_notes;
if *dump_initial_machcode_controlflow_graph
#
mcg::dump
(
*lowhalf_control::debug_stream,
"after instruction selection",
mcg
);
fi;
end; # where (fun get_completed_cccomponent)
# ------------------------annotations-----------------------
# Bug: EMPTYBLOCK does not really generate an empty block
# but merely terminates the current block. Contradicts the comment
# in code/lowhalf-notes.api.
# It should be (newBlock (1.0); newBlock (1.0); ()) XXX BUGGO FIXME
#
#
fun put_bblock_note note # Add a new annotation.
=
case note
#
lcn::BLOCKNAMES names
=>
{ block_names := names;
make_bblock 1.0;
();
};
lcn::EMPTYBLOCK
=>
{ make_bblock 1.0;
();
};
lcn::EXECUTION_FREQUENCY f
=>
case *current_bblock
#
mcg::BBLOCK { id=> -1, ... }
=>
{ make_bblock (float f);
();
};
mcg::BBLOCK { execution_frequency, ... }
=>
execution_frequency := float f;
esac;
note =>
{ (get_current_bblock ()) -> mcg::BBLOCK { notes, ... };
#
notes := note ! *notes;
};
esac;
fun get_notes () # Get notes associated with machcode controlflow graph.
=
mcg::get_global_graph_notes *mcg;
#
fun put_comment msg # Add a comment annotation to the current basic block.
=
case *segment_f
#
TEXT => put_bblock_note (lcn::comment.x_to_note msg);
_ => { (*mcg) -> odg::DIGRAPH graph;
#
graph.graph_info -> mcg::GRAPH_INFO { dataseg_pseudo_ops, ... };
#
dataseg_pseudo_ops := pb::COMMENT msg ! *dataseg_pseudo_ops;
};
esac;
# -------------------------labels---------------------------
# BUG: Does not respect any ordering between labels and pseudo_ops.
# This could be a problem with jump tables. XXX BUGGO FIXME
#
fun put_pseudo_op pseudo_op
=
{
(*mcg) -> odg::DIGRAPH graph;
graph.graph_info -> mcg::GRAPH_INFO { dataseg_pseudo_ops, decls, ... };
#
fun add_alignment ()
=
case *segment_f
#
DECLS => error "addAlignment: DECLS";
TEXT => { (make_bblock 1.0) -> mcg::BBLOCK { alignment_pseudo_op, ... };
#
alignment_pseudo_op := THE pseudo_op;
};
_ => dataseg_pseudo_ops := pseudo_op ! *dataseg_pseudo_ops;
esac;
#
fun start_segment seg
=
{ dataseg_pseudo_ops := pseudo_op ! *dataseg_pseudo_ops;
#
segment_f := seg;
};
#
fun add_data ()
=
dataseg_pseudo_ops := pseudo_op ! *dataseg_pseudo_ops;
#
fun check_add_data seg
=
{ fun errmsg curr
=
ptf::sprintf' "put_pseudo_op: %s in %s segment" [ptf::STRING seg, ptf::STRING curr];
case *segment_f
#
DECLS => error (errmsg "DECLS");
TEXT => error (errmsg "TEXT");
#
_ => dataseg_pseudo_ops := pseudo_op ! *dataseg_pseudo_ops;
esac;
};
#
fun add_decl ()
=
case *segment_f
#
DECLS => decls := pseudo_op ! *decls;
_ => dataseg_pseudo_ops := pseudo_op ! *dataseg_pseudo_ops;
esac;
case pseudo_op
#
pb::ALIGN_SIZE _ => add_alignment ();
pb::ALIGN_ENTRY => add_alignment ();
pb::ALIGN_LABEL => add_alignment ();
pb::DATA_LABEL _
=>
case *segment_f
#
TEXT => error "add_pseudo_op: DATA_LABEL in TEXT segment";
#
_ => dataseg_pseudo_ops := pseudo_op ! *dataseg_pseudo_ops;
esac;
pb::DATA_READ_ONLY => start_segment RO_DATA;
pb::DATA => start_segment DATA;
pb::TEXT => segment_f := TEXT;
pb::BSS => start_segment (BSS);
pb::SECTION _
=>
case *segment_f
#
TEXT => error "add_pseudo_op: SECTION in TEXT segment";
#
_ => dataseg_pseudo_ops := pseudo_op ! *dataseg_pseudo_ops;
esac;
pb::REORDER
=>
{ reorder := [];
make_bblock 1.0;
();
};
pb::NOREORDER
=>
{ reorder := [ lcn::noreorder.x_to_note () ];
make_bblock 1.0;
();
};
pb::INT _ => check_add_data "INT";
pb::FLOAT _ => check_add_data "FLOAT";
pb::ASCII _ => check_add_data "ASCII";
pb::ASCIIZ _ => check_add_data "ASCIIZ";
pb::SPACE _ => check_add_data "SPACE";
pb::COMMENT _ => add_decl ();
pb::IMPORT _ => add_decl ();
pb::EXPORT _ => add_decl ();
pb::EXT _ => case *segment_f
#
TEXT => error "EXT in TEXT segment";
_ => add_decl ();
esac;
esac;
}; # fun put_pseudo_op
#
fun put_private_label lab
=
case *segment_f
#
TEXT =>
case (find_label (hash_label lab))
#
NULL =>
{ fun make_bblock' ()
=
case *current_bblock
#
mcg::BBLOCK { id => -1, ... } => make_bblock 1.0;
mcg::BBLOCK { ops => REF [], ... } => *current_bblock;
_ => make_bblock 1.0;
esac;
(make_bblock' ()) -> mcg::BBLOCK { id, labels, ... };
labels := lab ! *labels;
add_label (hash_label lab, id);
};
THE _ => error (cat ["multiple definitions of label \"", lbl::codelabel_to_string lab, "\""]);
esac;
_ =>
{ # Non-text segment:
#
(*mcg) -> odg::DIGRAPH graph;
graph.graph_info -> mcg::GRAPH_INFO { dataseg_pseudo_ops, ... };
dataseg_pseudo_ops := pb::DATA_LABEL lab ! *dataseg_pseudo_ops;
};
esac;
#
fun put_public_label label
=
{ put_private_label label;
#
entry_labels := label ! *entry_labels;
};
end; # fun make_machcode_codebuffer
end; # stipulate
}; # generic package make_machcode_codebuffer_g
end; # stipulate