[m-rev.] For review: Compiler feedback system.
Paul Bone
pbone at csse.unimelb.edu.au
Sun Jul 20 14:39:54 AEST 2008
For review by: Zoltan or Julien
Estimated hours taken: 8
Branches: main
Introduce a feedback system and modify Jerome's implicit parallelism work to
use it. Generic information can now be fed back into the compiler to aid with
optimizations.
mdbcomp/feedback.m:
Created a new module for the feedback system, types representing feedback
information and predicates for reading and writing feedback files, and
manipulating feedback information are defined here.
mdbcomp/mdbcomp.m:
Updated to include the mdbcomp/feedback.m in this library.
mdbcomp/program_representation.m:
Created a new type to describe a call. This is used by the current
implicit parallelism implementation.
deep_profiler/mdprof_feedback.m:
Updated to use the new feedback system. The old feedback file code has
been removed.
--program-name option has been added, a program name must be provided to
be included in the header of the feedback file.
Conform to changes in mdbcomp/program_representation.m
compiler/globals.m:
Added feedback data to globals structure.
Added predicates to get and set the feedback information stored in the
globals structure.
Modified predicates that create the globals structure.
compiler/handle_options.m:
Set feedback information in globals structure when it is created in
postprocess_options.
Read feedback information in from file in check_option_values.
Code added to postprocess_options2 to check the usage of the
--implicit-parallelism option.
compiler/implicit_parallelism.m:
This module no-longer reads the feedback file it's self, this code has
been removed, as has the IO state.
Information from the feedback state is retrieved and used to control
implicit parallelism.
compiler/mercury_compile.m:
No-longer checks options for implicit parallelization, this is now done in
compiler/handle_options.m.
Conform to changes in implicit_parallelism.m
deep_profiler/Mmakefile:
slice/Mmakefile:
Modified to include mdbcomp/feedback.m for compilation in this directory.
Index: compiler/globals.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/globals.m,v
retrieving revision 1.89
diff -u -p -r1.89 globals.m
--- compiler/globals.m 2 Jun 2008 02:27:26 -0000 1.89
+++ compiler/globals.m 20 Jul 2008 04:40:56 -0000
@@ -24,6 +24,7 @@
:- import_module libs.trace_params.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data. % for module_name
+:- import_module mdbcomp.feedback.
:- import_module bool.
:- import_module getopt_io.
@@ -152,7 +153,8 @@
:- pred globals_init(option_table::in, compilation_target::in, gc_method::in,
tags_method::in, termination_norm::in, termination_norm::in,
trace_level::in, trace_suppress_items::in,
- may_be_thread_safe::in, c_compiler_type::in, globals::out) is det.
+ may_be_thread_safe::in, c_compiler_type::in, feedback_state::in,
+ globals::out) is det.
:- pred get_options(globals::in, option_table::out) is det.
:- pred get_target(globals::in, compilation_target::out) is det.
@@ -167,6 +169,7 @@
:- pred get_source_file_map(globals::in, maybe(source_file_map)::out) is det.
:- pred get_maybe_thread_safe(globals::in, may_be_thread_safe::out) is det.
:- pred get_c_compiler_type(globals::in, c_compiler_type::out) is det.
+:- pred get_feedback_state(globals::in, feedback_state::out) is det.
:- pred set_option(option::in, option_data::in, globals::in, globals::out)
is det.
@@ -177,6 +180,8 @@
:- pred set_trace_level_none(globals::in, globals::out) is det.
:- pred set_source_file_map(maybe(source_file_map)::in,
globals::in, globals::out) is det.
+:- pred set_feedback_state(feedback_state::in, globals::in, globals::out)
+ is det.
:- pred lookup_option(globals::in, option::in, option_data::out) is det.
@@ -224,7 +229,8 @@
:- pred globals_io_init(option_table::in, compilation_target::in,
gc_method::in, tags_method::in, termination_norm::in,
termination_norm::in, trace_level::in, trace_suppress_items::in,
- may_be_thread_safe::in, c_compiler_type::in, io::di, io::uo) is det.
+ may_be_thread_safe::in, c_compiler_type::in, feedback_state::in,
+ io::di, io::uo) is det.
:- pred io_get_target(compilation_target::out, io::di, io::uo) is det.
:- pred io_get_backend_foreign_languages(list(foreign_language)::out,
@@ -393,7 +399,8 @@ gc_is_conservative(gc_automatic) = no.
source_file_map :: maybe(source_file_map),
have_printed_usage :: bool,
may_be_thread_safe :: bool,
- c_compiler_type :: c_compiler_type
+ c_compiler_type :: c_compiler_type,
+ feedback :: feedback_state
).
:- mutable(globals, univ, univ(0), ground,
@@ -420,10 +427,10 @@ gc_is_conservative(gc_automatic) = no.
globals_init(Options, Target, GC_Method, TagsMethod,
TerminationNorm, Termination2Norm, TraceLevel, TraceSuppress,
- MaybeThreadSafe, C_CompilerType, Globals) :-
+ MaybeThreadSafe, C_CompilerType, Feedback, Globals) :-
Globals = globals(Options, Target, GC_Method, TagsMethod,
TerminationNorm, Termination2Norm, TraceLevel, TraceSuppress,
- no, no, MaybeThreadSafe, C_CompilerType).
+ no, no, MaybeThreadSafe, C_CompilerType, Feedback).
get_options(Globals, Globals ^ options).
get_target(Globals, Globals ^ target).
@@ -436,6 +443,7 @@ get_trace_suppress(Globals, Globals ^ tr
get_source_file_map(Globals, Globals ^ source_file_map).
get_maybe_thread_safe(Globals, Globals ^ may_be_thread_safe).
get_c_compiler_type(Globals, Globals ^ c_compiler_type).
+get_feedback_state(Globals, Globals ^ feedback).
get_backend_foreign_languages(Globals, ForeignLangs) :-
lookup_accumulating_option(Globals, backend_foreign_languages, LangStrs),
@@ -466,6 +474,9 @@ set_trace_level_none(Globals,
set_source_file_map(SourceFileMap, Globals,
Globals ^ source_file_map := SourceFileMap).
+set_feedback_state(Feedback, Globals,
+ Globals ^ feedback := Feedback).
+
lookup_option(Globals, Option, OptionData) :-
get_options(Globals, OptionTable),
map.lookup(OptionTable, Option, OptionData).
@@ -601,10 +612,10 @@ want_return_var_layouts(Globals, WantRet
globals_io_init(Options, Target, GC_Method, TagsMethod, TerminationNorm,
Termination2Norm, TraceLevel, TraceSuppress, MaybeThreadSafe,
- C_CompilerType, !IO) :-
+ C_CompilerType, Feedback, !IO) :-
globals_init(Options, Target, GC_Method, TagsMethod,
TerminationNorm, Termination2Norm, TraceLevel,
- TraceSuppress, MaybeThreadSafe, C_CompilerType, Globals),
+ TraceSuppress, MaybeThreadSafe, C_CompilerType, Feedback, Globals),
io_set_globals(Globals, !IO),
getopt_io.lookup_bool_option(Options, solver_type_auto_init,
AutoInitSupported),
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.320
diff -u -p -r1.320 handle_options.m
--- compiler/handle_options.m 2 Jun 2008 02:27:26 -0000 1.320
+++ compiler/handle_options.m 20 Jul 2008 04:40:56 -0000
@@ -81,6 +81,8 @@
:- import_module analysis.
:- import_module libs.compiler_util.
:- import_module libs.trace_params.
+:- import_module mdbcomp.
+:- import_module mdbcomp.feedback.
:- import_module parse_tree.
:- import_module parse_tree.error_util.
@@ -187,12 +189,12 @@ postprocess_options(error(ErrorMessage),
postprocess_options(ok(OptionTable0), Errors, !IO) :-
check_option_values(OptionTable0, OptionTable, Target, GC_Method,
TagsMethod, TermNorm, Term2Norm, TraceLevel, TraceSuppress,
- MaybeThreadSafe, C_CompilerType, [], CheckErrors),
+ MaybeThreadSafe, C_CompilerType, FeedbackState, [], CheckErrors, !IO),
(
CheckErrors = [],
postprocess_options_2(OptionTable, Target, GC_Method,
TagsMethod, TermNorm, Term2Norm, TraceLevel,
- TraceSuppress, MaybeThreadSafe, C_CompilerType,
+ TraceSuppress, MaybeThreadSafe, C_CompilerType, FeedbackState,
[], Errors, !IO)
;
CheckErrors = [_ | _],
@@ -203,12 +205,12 @@ postprocess_options(ok(OptionTable0), Er
compilation_target::out, gc_method::out, tags_method::out,
termination_norm::out, termination_norm::out, trace_level::out,
trace_suppress_items::out, may_be_thread_safe::out,
- c_compiler_type::out,
- list(string)::in, list(string)::out) is det.
+ c_compiler_type::out, feedback_state::out,
+ list(string)::in, list(string)::out, io::di, io::uo) is det.
check_option_values(!OptionTable, Target, GC_Method, TagsMethod,
TermNorm, Term2Norm, TraceLevel, TraceSuppress, MaybeThreadSafe,
- C_CompilerType, !Errors) :-
+ C_CompilerType, FeedbackState, !Errors, !IO) :-
map.lookup(!.OptionTable, target, Target0),
(
Target0 = string(TargetStr),
@@ -354,6 +356,23 @@ check_option_values(!OptionTable, Target
add_error("Invalid argument to option " ++
"`--c-compiler-type'\n\t(must be" ++
"`gcc', `lcc', `cl, or `unknown').", !Errors)
+ ),
+ map.lookup(!.OptionTable, feedback_file, FeedbackFile0),
+ (
+ FeedbackFile0 = string(FeedbackFile),
+ FeedbackFile \= ""
+ ->
+ feedback.read(FeedbackFile, FeedbackReadResult, !IO),
+ (
+ FeedbackReadResult = ok(FeedbackState)
+ ;
+ FeedbackReadResult = error(Error),
+ read_error_message_string(FeedbackFile, Error, ErrorMessage),
+ add_error(ErrorMessage, !Errors),
+ FeedbackState = feedback.init % Dummy.
+ )
+ ;
+ FeedbackState = feedback.init % No feedback info.
).
:- pred add_error(string::in, list(string)::in, list(string)::out) is det.
@@ -368,15 +387,15 @@ add_error(Error, Errors0, Errors) :-
:- pred postprocess_options_2(option_table::in, compilation_target::in,
gc_method::in, tags_method::in, termination_norm::in,
termination_norm::in, trace_level::in, trace_suppress_items::in,
- may_be_thread_safe::in, c_compiler_type::in,
+ may_be_thread_safe::in, c_compiler_type::in, feedback_state::in,
list(string)::in, list(string)::out, io::di, io::uo) is det.
postprocess_options_2(OptionTable0, Target, GC_Method, TagsMethod0,
TermNorm, Term2Norm, TraceLevel, TraceSuppress, MaybeThreadSafe,
- C_CompilerType, !Errors, !IO) :-
+ C_CompilerType, FeedbackState, !Errors, !IO) :-
globals_io_init(OptionTable0, Target, GC_Method, TagsMethod0,
TermNorm, Term2Norm, TraceLevel, TraceSuppress, MaybeThreadSafe,
- C_CompilerType, !IO),
+ C_CompilerType, FeedbackState, !IO),
some [!Globals] (
globals.io_get_globals(!:Globals, !IO),
@@ -458,6 +477,53 @@ postprocess_options_2(OptionTable0, Targ
globals.lookup_bool_option(!.Globals,
automatic_intermodule_optimization, AutoIntermodOptimization),
+ % Implicit parallelism requires feedback information.
+ globals.lookup_bool_option(!.Globals, implicit_parallelism,
+ ImplicitParallelism),
+ (
+ ImplicitParallelism = yes,
+ globals.lookup_string_option(!.Globals, feedback_file,
+ FeedbackFile),
+ (
+ FeedbackFile = ""
+ ->
+ add_error("'--implicit-parallelism' requires '--feedback'",
+ !Errors)
+ ;
+ true
+ ),
+ % TODO: should 'implicit_parallism' imply 'parallel'?
+ globals.lookup_bool_option(!.Globals, parallel, Parallel),
+ (
+ Parallel = yes
+ ;
+ Parallel = no,
+ add_error("'--implicit_parallelism' requires '--parallel'",
+ !Errors)
+ ),
+ globals.lookup_bool_option(!.Globals, highlevel_code, HighLevelCode),
+ (
+ HighLevelCode = yes,
+ add_error("'--implicit-parallelism' is not compatible with "
+ ++ "'--highlevel-code'", !Errors)
+ ;
+ HighLevelCode = no
+ ),
+ (
+ Target = target_c
+ ;
+ ( Target = target_il
+ ; Target = target_java
+ ; Target = target_asm
+ ; Target = target_x86_64
+ ; Target = target_erlang ),
+ add_error("'--implicit-parallelism' is not compatible with "
+ ++ "target " ++ string(Target), !Errors)
+ )
+ ;
+ ImplicitParallelism = no
+ ),
+
% Generating IL implies:
% - gc_method `automatic' and no heap reclamation on failure
% Because GC is handled automatically by the .NET CLR
Index: compiler/implicit_parallelism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/implicit_parallelism.m,v
retrieving revision 1.7
diff -u -p -r1.7 implicit_parallelism.m
--- compiler/implicit_parallelism.m 27 Feb 2008 07:23:07 -0000 1.7
+++ compiler/implicit_parallelism.m 20 Jul 2008 04:40:56 -0000
@@ -7,7 +7,7 @@
%-----------------------------------------------------------------------------%
%
% File : implicit_parallelism.m.
-% Author: tannier.
+% Author: tannier, pbone.
%
% This module uses deep profiling feedback information generated by
% mdprof_feedback to introduce parallel conjunctions where it could be
@@ -30,7 +30,7 @@
:- import_module hlds.hlds_module.
-:- import_module io.
+:- import_module maybe.
%-----------------------------------------------------------------------------%
@@ -40,7 +40,7 @@
% feedback file.
%
:- pred apply_implicit_parallelism_transformation(
- module_info::in, module_info::out, string::in, io::di, io::uo) is det.
+ module_info::in, maybe(module_info)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -48,14 +48,17 @@
:- implementation.
:- import_module check_hlds.inst_match.
-:- import_module hlds.hlds_goal.
:- import_module check_hlds.mode_util.
:- import_module hlds.goal_util.
+:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_pred.
:- import_module hlds.instmap.
:- import_module hlds.quantification.
:- import_module libs.compiler_util.
+:- import_module libs.globals.
+:- import_module mdbcomp.feedback.
:- import_module mdbcomp.prim_data.
+:- import_module mdbcomp.program_representation.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module transform_hlds.dep_par_conj.
@@ -65,7 +68,6 @@
:- import_module counter.
:- import_module int.
:- import_module list.
-:- import_module maybe.
:- import_module pair.
:- import_module require.
:- import_module set.
@@ -105,18 +107,71 @@ construct_call_site_kind("callback",
%-----------------------------------------------------------------------------%
-apply_implicit_parallelism_transformation(!ModuleInfo, FeedbackFile, !IO) :-
- parse_feedback_file(FeedbackFile, MaybeCandidateCallSites, !IO),
+apply_implicit_parallelism_transformation(ModuleInfo0, MaybeModuleInfo) :-
+ module_info_get_globals(ModuleInfo0, Globals),
+ globals.get_feedback_state(Globals, FeedbackState),
+ feedback.get(feedback_info_calls_above_threshold_sorted, MaybeFeedbackInfo,
+ FeedbackState),
(
- MaybeCandidateCallSites = error(Error),
- io.stderr_stream(Stderr, !IO),
- io.write_string(Stderr, Error ++ "\n", !IO)
- ;
- MaybeCandidateCallSites = ok(CandidateCallSites),
- module_info_predids(PredIds, !ModuleInfo),
- process_preds_for_implicit_parallelism(PredIds, CandidateCallSites,
- !ModuleInfo)
- ).
+ MaybeFeedbackInfo = yes(FeedbackInfo),
+ some [!ModuleInfo]
+ (
+ !:ModuleInfo = ModuleInfo0,
+ module_info_predids(PredIds, !ModuleInfo),
+ FeedbackInfo =
+ feedback_info_calls_above_threshold_sorted(_, _, Calls),
+ list.map(call_to_call_site, Calls, CandidateCallSites),
+ process_preds_for_implicit_parallelism(PredIds, CandidateCallSites,
+ !ModuleInfo),
+ MaybeModuleInfo = yes(!.ModuleInfo)
+ )
+ ;
+ MaybeFeedbackInfo = no,
+ MaybeModuleInfo = no
+ ).
+
+ % This predicate isn't really necessary as this entire module should use
+ % the call structure defined in mdbcomp.program_representation. However
+ % it's expected that the rest of this module will be replaced in the near
+ % future.
+ %
+:- pred call_to_call_site(call::in, candidate_call_site::out) is det.
+
+call_to_call_site(Call, CallSite) :-
+ Call = call(Caller0, Slot, CallTypeAndCallee),
+ string_proc_label_to_string(Caller0, Caller),
+ (
+ CallTypeAndCallee = plain_call(Callee0),
+ string_proc_label_to_string(Callee0, Callee),
+ CallSiteKind = csk_normal
+ ;
+ (
+ CallTypeAndCallee = callback_call,
+ CallSiteKind = csk_callback
+ ;
+ CallTypeAndCallee = higher_order_call,
+ CallSiteKind = csk_higher_order
+ ;
+ CallTypeAndCallee = method_call,
+ CallSiteKind = csk_method
+ ;
+ CallTypeAndCallee = special_call,
+ CallSiteKind = csk_special
+ ),
+ Callee = ""
+ ),
+ CallSite = candidate_call_site(Caller, Slot, CallSiteKind, Callee).
+
+:- pred string_proc_label_to_string(string_proc_label::in, string::out) is det.
+
+string_proc_label_to_string(ProcLabel, String) :-
+ (
+ ProcLabel = str_ordinary_proc_label(_, Module, _, Name, Arity, Mode)
+ ;
+ ProcLabel = str_special_proc_label(_, _, Module, Name, Arity, Mode)
+ ),
+ string.format("%s.%s/%d-%d", [s(Module), s(Name), i(Arity), i(Mode)],
+ String).
% Process predicates for implicit parallelism.
%
@@ -846,107 +901,6 @@ process_switch_cases_for_implicit_parall
%-----------------------------------------------------------------------------%
- % Parse the feedback file (header and body).
- %
-:- pred parse_feedback_file(string::in,
- maybe_error(list(candidate_call_site))::out, io::di, io::uo) is det.
-
-parse_feedback_file(InputFile, MaybeCandidateCallSites, !IO) :-
- io.open_input(InputFile, Result, !IO),
- (
- Result = io.error(ErrInput),
- MaybeCandidateCallSites = error(io.error_message(ErrInput))
- ;
- Result = ok(Stream),
- io.read_file_as_string(Stream, MaybeFileAsString, !IO),
- (
- MaybeFileAsString = ok(FileAsString),
- Lines = string.words_separator(is_carriage_return, FileAsString),
- process_feedback_file_header(Lines, MaybeBodyLines, !IO),
- (
- MaybeBodyLines = error(HeaderError),
- MaybeCandidateCallSites = error(HeaderError)
- ;
- MaybeBodyLines = ok(BodyLines),
- process_feedback_file_body(BodyLines, MaybeCandidateCallSites)
- )
- ;
- MaybeFileAsString = error(_, ReadError),
- MaybeCandidateCallSites = error(io.error_message(ReadError))
- ),
- io.close_input(Stream, !IO)
- ).
-
-:- pred is_carriage_return(char::in) is semidet.
-
-is_carriage_return(Char) :-
- Char = '\n'.
-
- % Process the header of the feedback file.
- %
-:- pred process_feedback_file_header(list(string)::in,
- maybe_error(list(string))::out, io::di, io::uo) is det.
-
-process_feedback_file_header(Lines, MaybeBodyLines, !IO) :-
- (
- Lines = [IdLine, VersionLine, _MeasureLine, _ThresholdLine
- | BodyLines],
- IdLine = "Profiling feedback file"
- ->
- ( VersionLine = "Version = 1.0" ->
- MaybeBodyLines = ok(BodyLines)
- ;
- MaybeBodyLines = error("Profiling feedback file version incorrect")
- )
- ;
- MaybeBodyLines = error("Not a profiling feedback file")
- ).
-
- % Process the body of the feedback file.
- %
-:- pred process_feedback_file_body(list(string)::in,
- maybe_error(list(candidate_call_site))::out) is det.
-
-process_feedback_file_body(BodyLines, MaybeCandidateCallSites) :-
- ( process_feedback_file_body_2(BodyLines, [], CandidateCallSites) ->
- MaybeCandidateCallSites = ok(CandidateCallSites)
- ;
- MaybeCandidateCallSites =
- error("Profiling feedback file is not well-formed")
- ).
-
-:- pred process_feedback_file_body_2(list(string)::in,
- list(candidate_call_site)::in, list(candidate_call_site)::out) is semidet.
-
-process_feedback_file_body_2([], !CandidateCallSites).
-process_feedback_file_body_2([Line | Lines], !CandidateCallSites) :-
- Words = string.words_separator(is_whitespace, Line),
- Words = [Caller, SlotNumber, KindAsString | WordsTail],
- ( Caller = "Mercury" ->
- true
- ;
- string.to_int(SlotNumber, IntSlotNumber),
- construct_call_site_kind(KindAsString, Kind),
- (
- Kind = csk_normal,
- WordsTail = [Callee]
- ;
- ( Kind = csk_higher_order
- ; Kind = csk_method
- ; Kind = csk_special
- ; Kind = csk_callback
- ),
- WordsTail = [],
- Callee = ""
- ),
- CandidateCallSite = candidate_call_site(Caller, IntSlotNumber,
- Kind, Callee),
- !:CandidateCallSites = [CandidateCallSite | !.CandidateCallSites]
- ),
- process_feedback_file_body_2(Lines, !CandidateCallSites).
-
-%-----------------------------------------------------------------------------%
-
:- func this_file = string.
this_file = "implicit_parallelism.m".
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.475
diff -u -p -r1.475 mercury_compile.m
--- compiler/mercury_compile.m 16 Jul 2008 03:30:27 -0000 1.475
+++ compiler/mercury_compile.m 20 Jul 2008 04:40:56 -0000
@@ -4104,50 +4104,28 @@ maybe_structure_sharing_analysis(Verbose
maybe_implicit_parallelism(Verbose, Stats, !HLDS, !IO) :-
module_info_get_globals(!.HLDS, Globals),
- globals.lookup_bool_option(Globals, parallel, Parallel),
- globals.lookup_bool_option(Globals, highlevel_code, HighLevelCode),
globals.lookup_bool_option(Globals, implicit_parallelism,
ImplicitParallelism),
- globals.lookup_string_option(Globals, feedback_file,
- FeedbackFile),
- ( FeedbackFile = "" ->
- % No feedback file has been specified.
- true
- ;
+ (
+ ImplicitParallelism = yes,
+ maybe_write_string(Verbose, "% Applying implicit " ++
+ "parallelism...\n", !IO),
+ maybe_flush_output(Verbose, !IO),
+ apply_implicit_parallelism_transformation(!.HLDS, MaybeHLDS),
(
- % If this is false, no implicit parallelism is to be introduced.
- Parallel = yes,
-
- % If this is false, then the user hasn't asked for implicit
- % parallelism.
- ImplicitParallelism = yes,
-
- % Our mechanism for implicit parallelism only works for the low
- % level backend.
- HighLevelCode = no
- ->
- globals.get_target(Globals, Target),
- (
- Target = target_c,
- maybe_write_string(Verbose, "% Applying implicit " ++
- "parallelism...\n", !IO),
- maybe_flush_output(Verbose, !IO),
- apply_implicit_parallelism_transformation(!HLDS,
- FeedbackFile, !IO),
- maybe_write_string(Verbose, "% done.\n", !IO),
- maybe_report_stats(Stats, !IO)
- ;
- ( Target = target_il
- ; Target = target_java
- ; Target = target_asm
- ; Target = target_x86_64
- ; Target = target_erlang
- )
- % Leave the HLDS alone. We cannot implement parallelism.
- )
+ MaybeHLDS = yes(!:HLDS)
;
- true
- )
+ MaybeHLDS = no,
+ io.write_string(
+ "Insufficiant feedback information for implicit parallelism.",
+ !IO),
+ io.set_exit_status(1, !IO)
+ ),
+ maybe_write_string(Verbose, "% done.\n", !IO),
+ maybe_report_stats(Stats, !IO)
+ ;
+ % The user hasn't asked for implicit parallelism.
+ ImplicitParallelism = no
).
:- pred maybe_control_granularity(bool::in, bool::in,
Index: deep_profiler/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/Mmakefile,v
retrieving revision 1.28
diff -u -p -r1.28 Mmakefile
--- deep_profiler/Mmakefile 6 Jun 2008 09:03:28 -0000 1.28
+++ deep_profiler/Mmakefile 20 Jul 2008 04:40:56 -0000
@@ -58,6 +58,7 @@ VPATH = $(LIBRARY_DIR) $(SSDB_DIR)
#-----------------------------------------------------------------------------#
MDBCOMP_MODULES = \
+ feedback.m \
mdbcomp.m \
prim_data.m \
program_representation.m \
Index: deep_profiler/mdprof_feedback.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/deep_profiler/mdprof_feedback.m,v
retrieving revision 1.4
diff -u -p -r1.4 mdprof_feedback.m
--- deep_profiler/mdprof_feedback.m 17 Feb 2008 06:48:38 -0000 1.4
+++ deep_profiler/mdprof_feedback.m 20 Jul 2008 04:40:56 -0000
@@ -1,13 +1,13 @@
%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
-% Copyright (C) 2006-2007 The University of Melbourne.
+% Copyright (C) 2006-2008 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% File: mdprof_feedback.m.
-% Author: tannier.
+% Author: tannier, pbone.
%
% This module contains the code for writing to a file the CSSs whose CSDs'
% average/median call sequence counts (own and desc) exceed the given threshold.
@@ -32,6 +32,9 @@
:- import_module conf.
:- import_module dump.
+:- import_module mdbcomp.
+:- import_module mdbcomp.feedback.
+:- import_module mdbcomp.program_representation.
:- import_module measurements.
:- import_module profile.
:- import_module startup.
@@ -59,9 +62,14 @@ main(!IO) :-
MaybeOptions = ok(Options),
lookup_bool_option(Options, help, Help),
lookup_bool_option(Options, version, Version),
+ lookup_string_option(Options, program_name, ProfileProgName0),
+ ProfileProgName = string.strip(ProfileProgName0),
( Version = yes ->
write_version_message(ProgName, !IO)
- ; Help = yes ->
+ ;
+ ( Help = yes
+ ; ProfileProgName = "" )
+ ->
write_help_message(ProgName, !IO)
;
( Args = [Input, Output] ->
@@ -81,8 +89,9 @@ main(!IO) :-
MaybeProfile = ok(Deep),
compute_css_list_above_threshold(0, Deep, Threshold,
MeasureType, [], CSSListAboveThreshold),
- generate_feedback_file(CSSListAboveThreshold, Deep,
- MeasureType, Threshold, Output, !IO)
+ generate_feedback_file(CSSListAboveThreshold, Deep,
+ ProfileProgName, MeasureType, Threshold, Output,
+ !IO)
;
MaybeProfile = error(Error),
io.stderr_stream(Stderr, !IO),
@@ -109,25 +118,32 @@ main(!IO) :-
:- pred write_help_message(string::in, io::di, io::uo) is det.
-write_help_message(ProgName) -->
- io.format("Usage: %s [<options>] <input> <output>\n", [s(ProgName)]),
- io.format("<input> must name a deep profiling data file.\n", []),
- io.format("<output> is the file generated by this program.\n", []),
- io.format("You may specify one of the following options:\n", []),
- io.format("--help Generate this help message.\n", []),
- io.format("--version Report the program's version number.\n", []),
- io.format("--verbose Generate progress messages.\n", []),
- io.format("--threshold <value>\n", []),
- io.format(" Set the threshold to <value>.\n",[]),
- io.format("--measure average|median\n",[]),
- io.format(" average : Write to <output> the call sites\n",[]),
- io.format(" static whose call sites dynamic's average\n",[]),
- io.format(" call sequence counts exceed the given\n",[]),
- io.format(" threshold (default option).\n",[]),
- io.format(" median : Write to <output> the call sites\n",[]),
- io.format(" static whose call sites dynamic's median\n",[]),
- io.format(" call sequence counts exceed the given\n",[]),
- io.format(" threshold.\n",[]).
+write_help_message(ProgName, !IO) :-
+ Message0 = [
+ "Usage: %s --program-name <ProgName> [<options>] <input> <output>",
+ " <input> must name a deep profiling data file.",
+ " <output> is the file generated by this program.",
+ " You may specify the following options:",
+ " --help Generate this help message.",
+ " --version Report the program's version number.",
+ " --verbose Generate progress messages.",
+ " --threshold <value>",
+ " Set the threshold to <value>.",
+ " --measure average|median",
+ " average : Write to <output> the call sites",
+ " static whose call sites dynamic's average",
+ " call sequence counts exceed the given",
+ " threshold (default option).",
+ " median : Write to <output> the call sites",
+ " static whose call sites dynamic's median",
+ " call sequence counts exceed the given",
+ " threshold.",
+ " --program-name <name>",
+ " The name of the program that generated the",
+ " profiling data. This is stored in the",
+ " feedback file"],
+ string.join_list("\n", Message0) = Message,
+ io.format(Message, [s(ProgName)], !IO).
:- pred write_version_message(string::in, io::di, io::uo) is det.
@@ -165,7 +181,7 @@ read_deep_file(Input, Verbose, DumpStage
% exceed the given threshold.
%
:- pred compute_css_list_above_threshold(int::in, deep::in, int::in,
- measure_type::in, list(call_site_static)::in,
+ stat_measure::in, list(call_site_static)::in,
list(call_site_static)::out) is det.
compute_css_list_above_threshold(Index, Deep, Threshold, Measure,
@@ -183,13 +199,13 @@ compute_css_list_above_threshold(Index,
Callseqs = 0
;
(
- Measure = average,
+ Measure = stat_average,
list.foldr(sum_callseqs_csd_ptr(Deep), CSDList,
0, SumCallseqs),
% NOTE: we have checked that NumCSD is not zero above.
Callseqs = SumCallseqs // NumCSD
;
- Measure = median,
+ Measure = stat_median,
list.sort(compare_csd_ptr(Deep), CSDList, CSDListSorted),
IndexMedian = NumCSD // 2,
list.index0_det(CSDListSorted, IndexMedian, MedianPtr),
@@ -232,66 +248,64 @@ compare_csd_ptr(Deep, CSDPtrA, CSDPtrB,
% average/median call sequence counts (own and desc) exceed the given
% threshold.
%
-:- pred generate_feedback_file(list(call_site_static)::in, deep::in,
- measure_type::in, int::in, string::in, io::di, io::uo) is det.
-
-generate_feedback_file(CSSList, Deep, Measure, Threshold, Output, !IO) :-
- io.open_output(Output, Result, !IO),
+:- pred generate_feedback_file(list(call_site_static)::in, deep::in, string::in,
+ stat_measure::in, int::in, string::in, io::di, io::uo) is det.
+
+generate_feedback_file(CSSList, Deep, ProgName, StatMeasure, Threshold, Output,
+ !IO) :-
+ some [!Feedback]
(
- Result = io.error(Err),
- io.stderr_stream(Stderr, !IO),
- io.write_string(Stderr, io.error_message(Err) ++ "\n", !IO)
+ feedback.read_or_create(Output, !:Feedback, !IO),
+ map(css_to_call(Deep), CSSList, Calls),
+ FeedbackInfo = feedback_info_calls_above_threshold_sorted(Threshold,
+ StatMeasure, Calls),
+ FeedbackInfoType = feedback_info_calls_above_threshold_sorted,
+ feedback.put(FeedbackInfoType, FeedbackInfo, !Feedback),
+ feedback.write(Output, ProgName, !.Feedback, WriteResult, !IO)
+ ),
+ (
+ WriteResult = ok
;
- Result = ok(Stream),
- io.write_string(Stream, "Profiling feedback file\n", !IO),
- io.write_string(Stream, "Version = 1.0\n", !IO),
- (
- Measure = average,
- io.write_string(Stream, "Measure = average\n", !IO)
- ;
- Measure = median,
- io.write_string(Stream, "Measure = median\n", !IO)
- ),
- io.format(Stream, "Threshold = %i\n", [i(Threshold)], !IO),
- write_css_list(CSSList, Deep, Stream, !IO),
- io.close_output(Stream, !IO)
+ ( WriteResult = open_error(Error)
+ ; WriteResult = write_error(Error) ),
+ io.error_message(Error, ErrorMessage),
+ io.format("%s: %s\n", [s(Output), s(ErrorMessage)], !IO),
+ io.set_exit_status(1, !IO)
).
% Write to the output the list of CSSs.
%
-:- pred write_css_list(list(call_site_static)::in, deep::in, output_stream::in,
- io::di, io::uo) is det.
+:- pred css_to_call(deep::in, call_site_static::in, call::out) is det.
-write_css_list([], _, _, !IO).
-write_css_list([ CSS | CSSList0 ], Deep, OutStrm, !IO) :-
-
- % Print the caller.
- lookup_proc_statics(Deep ^ proc_statics, CSS ^ css_container, Caller),
- io.write_string(OutStrm, Caller ^ ps_raw_id ++ " ", !IO),
-
- % Print the slot number of the CSS.
- io.write_int(OutStrm, CSS ^ css_slot_num, !IO),
- io.write_string(OutStrm, " ", !IO),
+css_to_call(Deep, CSS, Call) :-
+ % Get the caller.
+ lookup_proc_statics(Deep ^ proc_statics, CSS ^ css_container, CallerPS),
+ Caller = CallerPS ^ ps_id,
+
+ % Get the slot number.
+ Slot = CSS ^ css_slot_num,
- % Print the callee.
+ % Get the Callee and Call Type.
(
CSS ^ css_kind = normal_call_and_callee(PSPtr, _),
- lookup_proc_statics(Deep ^ proc_statics, PSPtr, Callee),
- io.format(OutStrm, "normal_call %s\n", [s(Callee ^ ps_raw_id)], !IO)
+ lookup_proc_statics(Deep ^ proc_statics, PSPtr, CalleePS),
+ CallTypeAndCallee = plain_call(CalleePS ^ ps_id)
;
CSS ^ css_kind = special_call_and_no_callee,
- io.write_string(OutStrm, "special_call\n", !IO)
+ CallTypeAndCallee = special_call
;
CSS ^ css_kind = higher_order_call_and_no_callee,
- io.write_string(OutStrm, "higher_order_call\n", !IO)
+ CallTypeAndCallee = higher_order_call
;
CSS ^ css_kind = method_call_and_no_callee,
- io.write_string(OutStrm, "method_call\n", !IO)
+ CallTypeAndCallee = method_call
;
CSS ^ css_kind = callback_and_no_callee,
- io.write_string(OutStrm, "callback\n", !IO)
+ CallTypeAndCallee = callback_call
),
- write_css_list(CSSList0, Deep, OutStrm, !IO).
+
+ % Build the call datastructure.
+ Call = call(Caller, Slot, CallTypeAndCallee).
%-----------------------------------------------------------------------------%
@@ -301,12 +315,14 @@ write_css_list([ CSS | CSSList0 ], Deep,
; verbose
; version
; measure
+ ; program_name
; dump_stages
; dump_options.
-:- type measure_type
- ---> average
- ; median.
+% XXX: Moved to program_representation.
+%:- type measure_type
+% ---> average
+% ; median.
:- type option_table == option_table(option).
@@ -317,10 +333,10 @@ short('t', threshold).
short('h', help).
short('v', version).
short('m', measure).
+short('p', program_name).
short('d', dump_stages).
short('D', dump_options).
-
:- pred long(string::in, option::out) is semidet.
long("threshold", threshold).
@@ -328,6 +344,7 @@ long("help", help).
long("verbose", verbose).
long("version", version).
long("measure", measure).
+long("program-name", program_name).
long("dump-stages", dump_stages).
long("dump-options", dump_options).
@@ -338,13 +355,14 @@ defaults(help, bool(no)).
defaults(verbose, bool(no)).
defaults(version, bool(no)).
defaults(measure, string("average")).
+defaults(program_name, string("")).
defaults(dump_stages, accumulating([])).
defaults(dump_options, accumulating([])).
-:- pred construct_measure(string::in, measure_type::out) is semidet.
+:- pred construct_measure(string::in, stat_measure::out) is semidet.
-construct_measure("average", average).
-construct_measure("median", median).
+construct_measure("average", stat_average).
+construct_measure("median", stat_median).
%-----------------------------------------------------------------------------%
:- end_module mdprof_feedback.
Index: mdbcomp/feedback.m
===================================================================
RCS file: mdbcomp/feedback.m
diff -N mdbcomp/feedback.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ mdbcomp/feedback.m 20 Jul 2008 04:40:56 -0000
@@ -0,0 +1,416 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2008 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: feedback.m.
+% Main author: pbone.
+%
+% This module defines routines implementing a compiler feedback system. It
+% should be complied into the compiler and any tools that write feedback data
+% for use by the compiler.
+%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module mdbcomp.feedback.
+
+:- interface.
+
+:- import_module mdbcomp.program_representation.
+
+:- import_module int.
+:- import_module io.
+:- import_module list.
+:- import_module maybe.
+:- import_module string.
+
+%-----------------------------------------------------------------------------%
+
+ % Feedback information is stored in this datatype when in memory.
+ %
+:- type feedback_state.
+
+%-----------------------------------------------------------------------------%
+
+ % This type is used as a key for the data that may be fed back into the
+ % complier. When making changes to this structure be sure to increment the
+ % file format version number towards the bottom of this file.
+ %
+:- type feedback_info_type
+ ---> feedback_info_calls_above_threshold_sorted.
+
+%-----------------------------------------------------------------------------%
+
+ % This type stores the data that may be fed back into the compiler. Each
+ % constructor here corrisponds to a value of the above type. When making
+ % changes to this structure or structures in mdbcomp.program_representation
+ % be sure to increment the file format version number towards the bottom of
+ % this file.
+ %
+ % TODO: Somehow need to constrain the instantiations of this type so that
+ % they are always paired with instantitations of the above type, and
+ % hopefuly the complier can assert this.
+ %
+:- type feedback_info
+ ---> feedback_info_calls_above_threshold_sorted(
+ threshold :: int,
+ stat_measure :: stat_measure,
+ calls :: list(call)
+ ).
+
+:- type stat_measure
+ ---> stat_average
+ ; stat_median.
+
+%-----------------------------------------------------------------------------%
+
+ % put(InfoType, Info, !State)
+ %
+ % 'Put' feedback data into the feedback files. Data is stored based on
+ % the type of information being stored.
+ %
+ % Data loaded from file (not added with put) will be removed from the
+ % internal state when data for the same info type is added.
+ %
+:- pred put(feedback_info_type::in, feedback_info::in,
+ feedback_state::in, feedback_state::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+ % get(InfoType, MaybeInfo, State).
+ %
+ % To query the feedback files 'get' will give a value for a given info type
+ % if it exists.
+ %
+:- pred get(feedback_info_type::in, maybe(feedback_info)::out,
+ feedback_state::in) is det.
+
+%-----------------------------------------------------------------------------%
+
+ % read(Path, FeedbackState, !IO)
+ %
+ % This predicate reads in feedback data from a specified file. It should
+ % be called once per compiler invokation, after this the feedback data is
+ % kept in the generated feedback_state variable.
+ %
+:- pred read(string::in, feedback_read_result(feedback_state)::out,
+ io::di, io::uo) is det.
+
+:- type feedback_read_result(T)
+ ---> ok(T)
+ ; error(feedback_read_error).
+
+:- type feedback_read_error
+ ---> open_error(io.error)
+ ; read_error(io.error)
+ ; parse_error(
+ message :: string,
+ line_no :: int)
+ ; unexpected_eof
+ ; incorrect_version
+ ; incorrect_first_line
+ ; incorrect_program_name.
+
+%-----------------------------------------------------------------------------%
+
+ % read_error_message_string(File, Error, Message)
+ %
+ % Create a string describing the read error.
+ %
+:- pred read_error_message_string(string::in, feedback_read_error::in,
+ string::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+ % Try to read in a feedback file, if the file doesn't exist create a new
+ % empty feedback state in memory.
+ %
+:- pred read_or_create(string::in, feedback_state::out, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+ % init = FeedbackState
+ %
+ % Create a new empty feedback state.
+ %
+:- func init = feedback_state.
+
+%-----------------------------------------------------------------------------%
+
+ % write(Path, ProgName, FeedbackState, FeedbackWriteResult, !IO)
+ %
+ % Write out the feedback data to a given file name.
+ %
+:- pred write(string::in, string::in, feedback_state::in,
+ feedback_write_result::out, io::di, io::uo) is det.
+
+:- type feedback_write_result
+ ---> ok
+ ; open_error(io.error)
+ ; write_error(io.error).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module exception.
+:- import_module map.
+:- import_module svmap.
+:- import_module unit.
+:- import_module univ.
+
+%-----------------------------------------------------------------------------%
+
+:- type feedback_state
+ ---> feedback_state(map(feedback_info_type, feedback_info)).
+
+%-----------------------------------------------------------------------------%
+
+get(InfoType, MaybeInfo, State) :-
+ State = feedback_state(Map),
+ (
+ map.search(Map, InfoType, Info)
+ ->
+ MaybeInfo = yes(Info)
+ ;
+ MaybeInfo = no
+ ).
+
+%-----------------------------------------------------------------------------%
+
+put(InfoType, Info, !State) :-
+ some [!Map] (
+ !.State = feedback_state(!:Map),
+ svmap.set(InfoType, Info, !Map),
+ !:State = feedback_state(!.Map)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+read(Path, ReadResultFeedbackState, !IO) :-
+ io.open_input(Path, IOResStream, !IO),
+ (
+ %
+ % Set the data file as the current stream and call read2.
+ %
+ IOResStream = ok(Stream),
+ some [!Result] (
+ %
+ % Read each part of the file and continue reading of this is
+ % succesful. read_cont takes care of this logic.
+ %
+ read_check_line(feedback_first_line, incorrect_first_line, Stream,
+ unit, !:Result, !IO),
+ maybe_read(
+ read_check_line(feedback_version, incorrect_version, Stream),
+ !Result, !IO),
+ maybe_read(
+ read_no_check_line(Stream),
+ !Result, !IO),
+ maybe_read(read_data(Stream), !Result, !IO),
+ ReadResultFeedbackState = !.Result
+ ),
+ io.close_input(Stream, !IO)
+ ;
+ IOResStream = error(ErrorCode),
+ ReadResultFeedbackState = error(open_error(ErrorCode))
+ ).
+
+ % If the result so far is successful, call the colsure and return it's
+ % result. Otherwise return the accumulated result without calling the
+ % colsure.
+ %
+:- pred maybe_read(pred(A, feedback_read_result(B), io, io),
+ feedback_read_result(A), feedback_read_result(B), io, io).
+:- mode maybe_read(pred(in, out, di, uo) is det,
+ in, out, di, uo) is det.
+
+maybe_read(Pred, Result0, Result, !IO) :-
+ (
+ Result0 = ok(Acc),
+ Pred(Acc, Result, !IO)
+ ;
+ Result0 = error(Error),
+ Result = error(Error)
+ ).
+
+ % Read and check a line of the file.
+ %
+:- pred read_check_line(string::in, feedback_read_error::in,
+ io.input_stream::in, unit::in, feedback_read_result(unit)::out,
+ io::di, io::uo) is det.
+
+read_check_line(TestLine, NotMatchError, Stream, _, Result, !IO) :-
+ io.read_line_as_string(Stream, IOResultLine, !IO),
+ (
+ IOResultLine = ok(Line),
+ (
+ ( Line = TestLine
+ ; Line = TestLine ++ "\n")
+ ->
+ Result = ok(unit)
+ ;
+ Result = error(NotMatchError)
+ )
+ ;
+ IOResultLine = eof,
+ Result = error(unexpected_eof)
+ ;
+ IOResultLine = error(Error),
+ Result = error(read_error(Error))
+ ).
+
+ % Read and don't check a line of the file.
+ %
+:- pred read_no_check_line(io.input_stream::in, unit::in,
+ feedback_read_result(unit)::out, io::di, io::uo) is det.
+
+read_no_check_line(Stream, _, Result, !IO) :-
+ io.read_line_as_string(Stream, IOResultLine, !IO),
+ (
+ IOResultLine = ok(_),
+ Result = ok(unit)
+ ;
+ IOResultLine = eof,
+ Result = error(unexpected_eof)
+ ;
+ IOResultLine = error(Error),
+ Result = error(read_error(Error))
+ ).
+
+ % Read the feedback data from the file.
+ %
+:- pred read_data(io.input_stream::in, unit::in,
+ feedback_read_result(feedback_state)::out, io::di, io::uo) is det.
+
+read_data(Stream, _, Result, !IO) :-
+ io.read(Stream, ReadResultDataAssocList, !IO),
+ (
+ ReadResultDataAssocList = ok(DataAssocList),
+ map.det_insert_from_assoc_list(map.init, DataAssocList, Map),
+ Result = ok(feedback_state(Map))
+ ;
+ ReadResultDataAssocList = eof,
+ Result = error(unexpected_eof)
+ ;
+ ReadResultDataAssocList = error(Error, Line),
+ Result = error(parse_error(Error, Line))
+ ).
+
+%-----------------------------------------------------------------------------%
+
+read_or_create(Path, Feedback, !IO) :-
+ read(Path, ReadResultFeedback, !IO),
+ (
+ ReadResultFeedback = ok(Feedback)
+ ;
+ ReadResultFeedback = error(Error),
+ display_read_error(Path, Error, !IO),
+ Feedback = init
+ ).
+
+%-----------------------------------------------------------------------------%
+
+read_error_message_string(File, Error, Message) :-
+ (
+ ( Error = open_error(Code)
+ ; Error = read_error(Code) ),
+ error_message(Code, MessagePart)
+ ;
+ Error = parse_error(ParseMessage, Line),
+ MessagePart = ParseMessage ++ " on line " ++ string(Line)
+ ;
+ Error = unexpected_eof,
+ MessagePart = "Unexpected end of file"
+ ;
+ Error = incorrect_version,
+ MessagePart = "Incorrect file format version"
+ ;
+ Error = incorrect_first_line,
+ MessagePart = "Incorrect file format"
+ ;
+ Error = incorrect_program_name,
+ MessagePart = "Program name didn't match, is this the right feedback file?"
+ ),
+ string.format("%s: %s\n", [s(File), s(MessagePart)], Message).
+
+%-----------------------------------------------------------------------------%
+
+:- pred display_read_error(string::in, feedback_read_error::in,
+ io::di, io::uo) is det.
+
+display_read_error(File, Error, !IO) :-
+ read_error_message_string(File, Error, Message),
+ io.write_string(Message, !IO).
+
+%-----------------------------------------------------------------------------%
+
+init = feedback_state(map.init).
+
+%-----------------------------------------------------------------------------%
+
+write(Path, ProgName, Feedback, Res, !IO) :-
+ io.open_output(Path, OpenRes, !IO),
+ (
+ OpenRes = ok(Stream),
+ promise_equivalent_solutions [!:IO, ExcpRes]
+ try_io(write2(Stream, ProgName, Feedback), ExcpRes, !IO),
+ (
+ ExcpRes = succeeded(_),
+ Res = ok
+ ;
+ ExcpRes = exception(ExcpUniv),
+
+ %
+ % If the exception is not a type we exected then re-throw it.
+ %
+ (
+ univ_to_type(ExcpUniv, Excp)
+ ->
+ Res = write_error(Excp)
+ ;
+ rethrow(ExcpRes)
+ )
+ )
+ ;
+ OpenRes = error(ErrorCode),
+ Res = open_error(ErrorCode)
+ ).
+
+ % Write out the data. This is called by try IO to catch any exceptions
+ % that close_output and other predicates may throw.
+ %
+:- pred write2(output_stream::in, string::in, feedback_state::in, unit::out,
+ io::di, io::uo) is det.
+
+write2(Stream, ProgName, Feedback, unit, !IO) :-
+ io.write_string(Stream, feedback_first_line, !IO),
+ io.nl(Stream, !IO),
+ io.write_string(Stream, feedback_version, !IO),
+ io.nl(Stream, !IO),
+ io.write_string(Stream, ProgName, !IO),
+ io.nl(Stream, !IO),
+ Feedback = feedback_state(Map),
+ map.to_assoc_list(Map, FeedbackList),
+ io.write(Stream, FeedbackList, !IO),
+ io.write_string(Stream, ".\n", !IO),
+ io.close_output(Stream, !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- func feedback_first_line = string.
+
+feedback_first_line = "Mercury Complier Feedback".
+
+:- func feedback_version = string.
+
+feedback_version = "1".
+
+%-----------------------------------------------------------------------------%
+:- end_module mdbcomp.feedback.
+%-----------------------------------------------------------------------------%
Index: mdbcomp/mdbcomp.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/mdbcomp/mdbcomp.m,v
retrieving revision 1.6
diff -u -p -r1.6 mdbcomp.m
--- mdbcomp/mdbcomp.m 22 Sep 2006 03:50:45 -0000 1.6
+++ mdbcomp/mdbcomp.m 20 Jul 2008 04:40:56 -0000
@@ -22,7 +22,9 @@
:- pred mdbcomp.version(string::out) is det.
-% If you add any modules here, you should update the list in slice/Mmakefile.
+% If you add any modules here, you should update the lists in
+% deep_profiler/Mmakefile and slice/Mmakefile.
+:- include_module feedback.
:- include_module prim_data.
:- include_module program_representation.
:- include_module rtti_access.
Index: mdbcomp/program_representation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/mdbcomp/program_representation.m,v
retrieving revision 1.30
diff -u -p -r1.30 program_representation.m
--- mdbcomp/program_representation.m 19 Mar 2008 05:30:00 -0000 1.30
+++ mdbcomp/program_representation.m 20 Jul 2008 04:40:56 -0000
@@ -285,6 +285,30 @@
%-----------------------------------------------------------------------------%
+% These types are used to describe parts of a program. They are used by
+% mdbcomp.feedback
+
+
+ % Describe a call.
+ %
+:- type call
+ ---> call(
+ caller :: string_proc_label,
+ slot :: int,
+ call_type_and_callee :: call_type_and_callee
+ ).
+
+ % The type of call.
+ %
+:- type call_type_and_callee
+ ---> callback_call
+ ; higher_order_call
+ ; method_call
+ ; plain_call(string_proc_label)
+ ; special_call.
+
+%-----------------------------------------------------------------------------%
+
% We can think of the goal that defines a procedure to be a tree, whose leaves
% are primitive goals and whose interior nodes are compound goals. These two
% types describe the position of a goal in this tree. A goal_path_step type
Index: slice/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/slice/Mmakefile,v
retrieving revision 1.15
diff -u -p -r1.15 Mmakefile
--- slice/Mmakefile 8 Dec 2007 15:29:02 -0000 1.15
+++ slice/Mmakefile 20 Jul 2008 04:40:56 -0000
@@ -48,6 +48,7 @@ VPATH = $(LIBRARY_DIR) $(SSDB_DIR)
MDBCOMP_MODULES = \
mdbcomp.m \
+ feedback.m \
prim_data.m \
program_representation.m \
rtti_access.m \
-------------- next part --------------
A non-text attachment was scrubbed...
Name: signature.asc
Type: application/pgp-signature
Size: 189 bytes
Desc: Digital signature
URL: <http://lists.mercurylang.org/archives/reviews/attachments/20080720/4e0496c6/attachment.sig>
More information about the reviews
mailing list