[m-rev.] for post-commit review: Create candidate_parallel_conjunctions data structures within mdbcomp/feedback.m
Paul Bone
pbone at csse.unimelb.edu.au
Tue Sep 30 12:23:56 AEST 2008
For post-commit review by Zoltan.
Estimated hours taken: 2
Branches: main
Add a new structure to the feedback data type,
candidate_parallel_conjunctions, This produces feedback information about
parallel conjunctions that may be parallelised.
This data is not yet collected by the mdprof_feedback tool, or used by the
compiler.
Make changes to the feedback API and on disk format. This makes it easier to
query the feedback_info structure for feedback data.
mdbcomp/feedback.m:
Introduce candidate_parallel_conjunctions feedback information.
Remove type arguments from feedback predicates.
Move feedback_type out of this modules interface.
Use a partially instantiated feedback_data data structure to retrieve
feedback data, A caller of get_feedback_data no-longer needs to use a
switch to check that they received the correct data.
Remove keys from the on disk format, removing the risk that some data
could be stored against an incorrect key.
Increment the feedback data file version number.
compiler/implicit_parallelism.m:
conform to changes in mdbcomp/feedback.m
compiler/options.m:
Added the --implicit-parallelisation-old compiler option, this will enable
the old implicit parallelism implementation.
deep_profiler/mdprof_feedback.m:
Added options for collecting the candidate_parallel_conjunctions feedback
data.
Index: compiler/implicit_parallelism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/implicit_parallelism.m,v
retrieving revision 1.8
diff -u -p -b -r1.8 implicit_parallelism.m
--- compiler/implicit_parallelism.m 23 Jul 2008 23:20:33 -0000 1.8
+++ compiler/implicit_parallelism.m 28 Sep 2008 14:07:56 -0000
@@ -110,10 +110,10 @@ construct_call_site_kind("callback",
apply_implicit_parallelism_transformation(ModuleInfo0, MaybeModuleInfo) :-
module_info_get_globals(ModuleInfo0, Globals),
globals.get_feedback_info(Globals, FeedbackInfo),
- get_feedback_data(feedback_type_calls_above_threshold_sorted,
- MaybeFeedbackData, FeedbackInfo),
(
- MaybeFeedbackData = yes(FeedbackData),
+ FeedbackData = feedback_data_calls_above_threshold_sorted(_, _, _),
+ get_feedback_data(FeedbackInfo, FeedbackData)
+ ->
some [!ModuleInfo]
(
!:ModuleInfo = ModuleInfo0,
@@ -126,7 +126,6 @@ apply_implicit_parallelism_transformatio
MaybeModuleInfo = yes(!.ModuleInfo)
)
;
- MaybeFeedbackData = no,
MaybeModuleInfo = no
).
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.633
diff -u -p -b -r1.633 options.m
--- compiler/options.m 26 Sep 2008 07:06:44 -0000 1.633
+++ compiler/options.m 28 Sep 2008 13:13:43 -0000
@@ -628,6 +628,9 @@
; distance_granularity
; parallelism_target
; implicit_parallelism
+ ; old_implicit_parallelism
+ % implicit_parallelism_old enables Jerome's implementation,
+ % which has been kept for comparison and use in bench marks.
; region_analysis
% Stuff for the CTGC system (structure sharing / structure reuse).
@@ -1464,6 +1467,7 @@ option_defaults_2(optimization_option, [
distance_granularity - int(0),
parallelism_target - int(4),
implicit_parallelism - bool(no),
+ old_implicit_parallelism - bool(no),
region_analysis - bool(no),
% HLDS -> LLDS
@@ -2317,6 +2321,7 @@ long_option("control-granularity", cont
long_option("distance-granularity", distance_granularity).
long_option("parallelism-target", parallelism_target).
long_option("implicit-parallelism", implicit_parallelism).
+long_option("old-implicit-parallelism", old_implicit_parallelism).
% CTGC related options.
long_option("structure-sharing", structure_sharing_analysis).
@@ -4734,6 +4739,8 @@ options_help_hlds_hlds_optimization -->
"\tinformation generated by mdprof_feedback.",
"\tThe profiling feedback file can be specified using the",
"\t--feedback file option."
+% "--old-implicit-parallelism",
+% "\tUse the old implicit parallelism implementation",
% '--region-analysis' is not documented because it is still experimental.
% "--region-analysis",
% "\tEnable the analysis for region-based memory management."
Index: deep_profiler/mdprof_feedback.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/mdprof_feedback.m,v
retrieving revision 1.9
diff -u -p -b -r1.9 mdprof_feedback.m
--- deep_profiler/mdprof_feedback.m 28 Aug 2008 10:26:14 -0000 1.9
+++ deep_profiler/mdprof_feedback.m 30 Sep 2008 02:17:21 -0000
@@ -42,12 +42,14 @@
:- import_module bool.
:- import_module cord.
:- import_module char.
+:- import_module float.
:- import_module getopt.
:- import_module int.
:- import_module library.
:- import_module list.
:- import_module map.
:- import_module maybe.
+:- import_module require.
:- import_module string.
:- import_module svmap.
@@ -77,8 +79,6 @@ main(!IO) :-
->
write_help_message(ProgName, !IO)
;
- % XXX What was the point of this test?
- % ProfileProgName \= "",
Args = [InputFileName, OutputFileName],
check_options(Options, RequestedFeedbackInfo)
->
@@ -91,11 +91,14 @@ main(!IO) :-
% _Progrep will be used bo a later version of this program.
MaybeDeepAndProgrep = deep_and_progrep(Deep, _Progrep)
),
- feedback.read_or_create(OutputFileName, Feedback0, !IO),
+ feedback.read_or_create(OutputFileName, FeedbackReadResult,
+ !IO),
+ (
+ FeedbackReadResult = ok(Feedback0),
process_deep_to_feedback(RequestedFeedbackInfo,
Deep, Feedback0, Feedback),
- write_feedback_file(OutputFileName, ProfileProgName, Feedback,
- WriteResult, !IO),
+ write_feedback_file(OutputFileName, ProfileProgName,
+ Feedback, WriteResult, !IO),
(
WriteResult = ok
;
@@ -103,11 +106,20 @@ main(!IO) :-
; WriteResult = write_error(Error)
),
io.error_message(Error, ErrorMessage),
- io.format("%s: %s\n",
+ io.stderr_stream(Stderr, !IO),
+ io.format(Stderr, "%s: %s\n",
[s(OutputFileName), s(ErrorMessage)], !IO),
io.set_exit_status(1, !IO)
)
;
+ FeedbackReadResult = error(FeedbackReadError),
+ feedback.read_error_message_string(OutputFileName,
+ FeedbackReadError, Message),
+ io.stderr_stream(Stderr, !IO),
+ io.write_string(Stderr, Message, !IO),
+ io.set_exit_status(1, !IO)
+ )
+ ;
MaybeDeepAndProgrep = error(Error),
io.stderr_stream(Stderr, !IO),
io.set_exit_status(1, !IO),
@@ -149,20 +161,38 @@ help_message =
--implicit-parallelism
Generate information that the compiler can use for automatic
parallelization.
+ --desired-parallelism <value>
+ The amount of desired parallelism for implicit parallelism,
+ value must be a floating point number above 1.0.
+ --implicit-parallelism-sparking-cost <value>
+ The cost of creating a spark, measured in the deep profiler's
+ call sequence counts.
+ --implicit-parallelism-locking-cost <value>
+ The cost of maintaining a lock for a single dependant variable
+ in a conjunction, measured in the profiler's call sequence
+ counts.
+ --implicit-parallelism-proc-cost-threshold <value>
+ The cost threshold for procedures to be considered for implicit
+ parallelism, measured on the profiler's call sequence counts.
The following options select specific types of feedback information
and parameterise them
--calls-above-threshold-sorted
- A list of calls whose typical cost (in call sequence counts)
- is above a given threshold. The next two options allow you
- to specify the threshold and what 'typical' means.
- --calls-above-threshold-sorted-threshold <value>
- Set the threshold to <value>.
+ A list of calls whose typical cost (in call sequence counts) is
+ above a given threshold. This option uses the
+ --desired-parallelism option to specify the threshold,
+ --calls-above-threshold-sorted-measure specifies what 'typical'
+ means. This option is deprecated.
--calls-above-threshold-sorted-measure mean|median
mean: Use mean(call site dynamic cost) as the typical cost.
median: Use median(call site dynamic cost) as the typical cost.
The default is 'mean'.
+
+ --candidate-parallel-conjunctions
+ Produce a list of candidate parallel conjunctions for implicit
+ parallelism. This option uses the implicit parallelism
+ settings above.
".
:- pred write_help_message(string::in, io::di, io::uo) is det.
@@ -216,13 +246,21 @@ read_deep_file(Input, Verbose, MaybeDeep
; verbose
; version
- % The calls above threshold sorted feedback information
+ % The calls above threshold sorted feedback information, this is
+ % used for the old implicit parallelism implementation.
; calls_above_threshold_sorted
; calls_above_threshold_sorted_measure
- ; calls_above_threshold_sorted_threshold
+
+ % A list of candidate parallel conjunctions is produced for the new
+ % implicit parallelism implementation.
+ ; candidate_parallel_conjunctions
% Provide suitable feedback information for implicit parallelism
- ; implicit_parallelism.
+ ; implicit_parallelism
+ ; desired_parallelism
+ ; implicit_parallelism_sparking_cost
+ ; implicit_parallelism_locking_cost
+ ; implicit_parallelism_proc_cost_threshold.
:- pred short(char::in, option::out) is semidet.
@@ -241,11 +279,17 @@ long("program-name", program_name
long("calls-above-threshold-sorted", calls_above_threshold_sorted).
long("calls-above-threshold-sorted-measure",
calls_above_threshold_sorted_measure).
-long("calls-above-threshold-sorted-threshold",
- calls_above_threshold_sorted_threshold).
+
+long("candidate-parallel-conjunctions", candidate_parallel_conjunctions).
long("implicit-parallelism", implicit_parallelism).
+long("desired-parallelism", desired_parallelism).
+long("implicit-parallelism-sparking-cost", implicit_parallelism_sparking_cost).
+long("implicit-parallelism-locking-cost", implicit_parallelism_locking_cost).
+long("implicit-parallelism-proc-cost-threshold",
+ implicit_parallelism_proc_cost_threshold).
+
:- pred defaults(option::out, option_data::out) is multi.
defaults(help, bool(no)).
@@ -255,9 +299,16 @@ defaults(version, bool(no)).
defaults(calls_above_threshold_sorted, bool(no)).
defaults(calls_above_threshold_sorted_measure, string("mean")).
-defaults(calls_above_threshold_sorted_threshold, int(100000)).
+
+defaults(candidate_parallel_conjunctions, bool(no)).
defaults(implicit_parallelism, bool(no)).
+defaults(desired_parallelism, string("4.0")).
+% XXX: These values have been chosen arbitrarily, appropriately values should
+% be tested for.
+defaults(implicit_parallelism_sparking_cost, int(100)).
+defaults(implicit_parallelism_locking_cost, int(100)).
+defaults(implicit_parallelism_proc_cost_threshold, int(100000)).
:- pred construct_measure(string::in, stat_measure::out) is semidet.
@@ -271,13 +322,23 @@ construct_measure("median", stat_med
:- type requested_feedback_info
---> requested_feedback_info(
maybe_calls_above_threshold_sorted
- :: maybe(calls_above_threshold_sorted_opts)
+ :: maybe(calls_above_threshold_sorted_opts),
+ maybe_candidate_parallel_conjunctions
+ :: maybe(candidate_parallel_conjunctions_opts)
).
:- type calls_above_threshold_sorted_opts
---> calls_above_threshold_sorted_opts(
- measure :: stat_measure,
- threshold :: int
+ cats_measure :: stat_measure,
+ cats_threshold :: int
+ ).
+
+:- type candidate_parallel_conjunctions_opts
+ ---> candidate_parallel_conjunctions_opts(
+ cpc_desired_parallelism :: float,
+ cpc_sparking_cost :: int,
+ cpc_locking_cost :: int,
+ cpc_threshold :: int
).
% Check all the command line options and return a well-typed representation
@@ -285,12 +346,24 @@ construct_measure("median", stat_med
% those implications are also handled here.
%
:- pred check_options(option_table(option)::in, requested_feedback_info::out)
- is semidet.
+ is det.
check_options(Options0, RequestedFeedbackInfo) :-
% Handle options that imply other options here.
- option_implies(implicit_parallelism, calls_above_threshold_sorted, yes,
- Options0, Options),
+ some [!Options]
+ (
+ !:Options = Options0,
+ lookup_bool_option(!.Options, implicit_parallelism,
+ ImplicitParallelism),
+ (
+ ImplicitParallelism = yes,
+ set_option(calls_above_threshold_sorted, bool(yes), !Options),
+ set_option(candidate_parallel_conjunctions, bool(yes), !Options)
+ ;
+ ImplicitParallelism = no
+ ),
+ Options = !.Options
+ ),
% For each feedback type determine if it is requested and fill in the the
% field in the RequestedFeedbackInfo structure.
@@ -300,12 +373,16 @@ check_options(Options0, RequestedFeedbac
CallsAboveThresholdSorted = yes,
lookup_string_option(Options, calls_above_threshold_sorted_measure,
Measure),
- % TODO: this goal is semidet, but this predicate should be det.
- construct_measure(Measure, MeasureType),
- CallsAboveThresholdSortedOpts ^ measure = MeasureType,
- lookup_int_option(Options, calls_above_threshold_sorted_threshold,
- Threshold),
- CallsAboveThresholdSortedOpts ^ threshold = Threshold,
+ ( construct_measure(Measure, MeasureTypePrime) ->
+ MeasureType = MeasureTypePrime
+ ;
+ error("Invalid value for calls_above_threshold_sorted_measure: " ++
+ Measure)
+ ),
+ CallsAboveThresholdSortedOpts ^ cats_measure = MeasureType,
+ lookup_int_option(Options, implicit_parallelism_proc_cost_threshold,
+ CATSThreshold),
+ CallsAboveThresholdSortedOpts ^ cats_threshold = CATSThreshold,
MaybeCallsAboveThresholdSortedOpts =
yes(CallsAboveThresholdSortedOpts)
;
@@ -313,7 +390,41 @@ check_options(Options0, RequestedFeedbac
MaybeCallsAboveThresholdSortedOpts = no
),
RequestedFeedbackInfo ^ maybe_calls_above_threshold_sorted =
- MaybeCallsAboveThresholdSortedOpts.
+ MaybeCallsAboveThresholdSortedOpts,
+
+ lookup_bool_option(Options, candidate_parallel_conjunctions,
+ CandidateParallelConjunctions),
+ (
+ CandidateParallelConjunctions = yes,
+ lookup_string_option(Options, desired_parallelism,
+ DesiredParallelismStr),
+ (
+ string.to_float(DesiredParallelismStr, DesiredParallelism),
+ DesiredParallelism > 1.0
+ ->
+ CandidateParallelConjunctionsOpts ^ cpc_desired_parallelism =
+ DesiredParallelism
+ ;
+ error("Invalid value for desired_parallelism: " ++
+ DesiredParallelismStr)
+ ),
+ lookup_int_option(Options, implicit_parallelism_sparking_cost,
+ SparkingCost),
+ CandidateParallelConjunctionsOpts ^ cpc_sparking_cost = SparkingCost,
+ lookup_int_option(Options, implicit_parallelism_locking_cost,
+ LockingCost),
+ CandidateParallelConjunctionsOpts ^ cpc_locking_cost = LockingCost,
+ lookup_int_option(Options, implicit_parallelism_proc_cost_threshold,
+ CPCThreshold),
+ CandidateParallelConjunctionsOpts ^ cpc_threshold = CPCThreshold,
+ MaybeCandidateParallelConjunctionsOpts =
+ yes(CandidateParallelConjunctionsOpts)
+ ;
+ CandidateParallelConjunctions = no,
+ MaybeCandidateParallelConjunctionsOpts = no
+ ),
+ RequestedFeedbackInfo ^ maybe_candidate_parallel_conjunctions =
+ MaybeCandidateParallelConjunctionsOpts.
% Adjust command line options when one option implies other options.
%
@@ -322,11 +433,18 @@ check_options(Options0, RequestedFeedbac
option_implies(Option, ImpliedOption, ImpliedValue, !Options) :-
( lookup_bool_option(!.Options, Option, yes) ->
- svmap.set(ImpliedOption, bool(ImpliedValue), !Options)
+ set_option(ImpliedOption, bool(ImpliedValue), !Options)
;
true
).
+ % Manipulate the option table.
+:- pred set_option(option::in, option_data::in,
+ option_table(option)::in, option_table(option)::out) is det.
+
+set_option(Option, Value, !Options) :-
+ svmap.set(Option, Value, !Options).
+
%----------------------------------------------------------------------------%
% process_deep_to_feedback(RequestedFeedbackInfo, Deep, !Feedback)
@@ -365,8 +483,7 @@ css_list_above_threshold(Options, Deep,
list.map(css_to_call(Deep), AboveThresholdCSSs, Calls),
FeedbackData = feedback_data_calls_above_threshold_sorted(Threshold,
MeasureType, Calls),
- FeedbackType = feedback_type_calls_above_threshold_sorted,
- put_feedback_data(FeedbackType, FeedbackData, !Feedback).
+ put_feedback_data(FeedbackData, !Feedback).
% Determine those CSSs whose CSDs' average/median call sequence counts
% exceed the given threshold.
Index: mdbcomp/feedback.m
===================================================================
RCS file: /home/mercury1/repository/mercury/mdbcomp/feedback.m,v
retrieving revision 1.2
diff -u -p -b -r1.2 feedback.m
--- mdbcomp/feedback.m 4 Aug 2008 03:17:54 -0000 1.2
+++ mdbcomp/feedback.m 30 Sep 2008 02:10:15 -0000
@@ -22,6 +22,7 @@
:- import_module mdbcomp.program_representation.
+:- import_module assoc_list.
:- import_module int.
:- import_module io.
:- import_module list.
@@ -36,48 +37,88 @@
%-----------------------------------------------------------------------------%
- % This type is used as a key for the data that may be fed back into the
- % compiler.
- %
- % NOTE: When making changes to this structure, be sure to increment
- % the file format version number towards the bottom of this file.
- %
-:- type feedback_type
- ---> feedback_type_calls_above_threshold_sorted.
- % Feedback data of this type represents a list of call sites
- % sorted in descending order of mean or median call cost where
- % that cost is greater than a given threshold.
-
-%-----------------------------------------------------------------------------%
-
% This type stores the data that may be fed back into the compiler.
% Each constructor here corresponds to a constructor of the feedback_type
% type.
%
- % TODO: We need a mechanism to ensure that the answer for a given query
- % (a value of type feedback_type) is always the corresponding value
- % in this type. The right solution would be to represent a query as
- % a partially instantiated data structure that we later fill in,
- % but Mercury doesn't yet let us do that.
- %
% NOTE: 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.
+ % mdbcomp.program_representation, be sure to:
+ %
+ % - Increment the file format version number towards the bottom of this
+ % file.
+ %
+ % - Update the feedback_data_query instantiation state below.
+ %
+ % - Update the feedback_type structure within this file.
+ %
+ % - Update the feedback_data_type/2 predicate in this file.
%
:- type feedback_data
---> feedback_data_calls_above_threshold_sorted(
+ % Feedback data of this type represents a list of call
+ % sites sorted in descending order of mean or median call
+ % cost where that cost is greater than a given threshold.
+
threshold :: int,
stat_measure :: stat_measure,
calls :: list(call_site)
+ )
+ ; feedback_data_candidate_parallel_conjunctions(
+ % Data of this type represents a list of candidate
+ % conjunctions for implicit parallelism.
+
+ desired_parallelism :: float,
+ % The number of desired busy sparks.
+
+ sparking_cost :: int,
+ % The cost of creating a spark in call sequence counts.
+
+ locking_cost :: int,
+ % The cost of maintaining a lock on a single dependant
+ % variable in call sequence counts.
+
+ conjunctions :: assoc_list(string, assoc_list(
+ string_proc_label,
+ candidate_par_conjunction))
+ % Assoclist of module name and an assoclist of procedure
+ % labels and candidate parallel conjunctions.
).
+:- inst feedback_data_query
+ ---> feedback_data_calls_above_threshold_sorted(free, free, free)
+ ; feedback_data_candidate_parallel_conjunctions(free, free, free,
+ free).
+
:- type stat_measure
---> stat_mean
; stat_median.
+ % A conjunction that is a candidate for parallelisation, it is identified
+ % by a procedure label, goal path to the conjunction and the call sites
+ % within the conjunction that are to be parallelised.
+ %
+:- type candidate_par_conjunction
+ ---> candidate_par_conjunction(
+ goal_path :: goal_path_string,
+ conjuncts :: list(candidate_par_conjunct)
+ ).
+
+:- type candidate_par_conjunct
+ ---> candidate_par_conjunct(
+ callee :: call_type_and_callee,
+ vars :: list(variable_in_par_conjunct),
+ cost :: int
+ ).
+
+:- type variable_in_par_conjunct
+ ---> variable_in_par_conjunct(
+ maybe_name :: maybe(string),
+ cost_before_first_use :: int
+ ).
+
%-----------------------------------------------------------------------------%
- % put_feedback_data(InfoType, Info, !State)
+ % put_feedback_data(Type, Data, !Info)
%
% 'Put' feedback data into the feedback files. Data is stored based on
% the type of information being stored.
@@ -85,22 +126,31 @@
% 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_data(feedback_type::in, feedback_data::in,
+ % This will throw an exception if the feedback_type and feedback_data don't
+ % match.
+ %
+:- pred put_feedback_data(feedback_data::in,
feedback_info::in, feedback_info::out) is det.
%-----------------------------------------------------------------------------%
- % get_feedback_data(InfoType, MaybeInfo, State).
+ % get_feedback_data(Info, Type, MaybeData).
%
% To query the feedback files 'get' will give a value for a given info type
% if it exists.
%
-:- pred get_feedback_data(feedback_type::in, maybe(feedback_data)::out,
- feedback_info::in) is det.
+ % This will throw an exception if the feedback_type and feedback_data
+ % within the Info structure do not match.
+ %
+:- pred get_feedback_data(feedback_info::in,
+ feedback_data::feedback_data_query) is semidet.
+
+:- mode feedback_data_query ==
+ feedback_data_query >> ground.
%-----------------------------------------------------------------------------%
- % read_feedback_file(Path, FeedbackState, !IO)
+ % read_feedback_file(Path, FeedbackInfo, !IO)
%
% This predicate reads in feedback data from a specified file.
% It should be called once per compiler invocation.
@@ -138,19 +188,20 @@
% 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_info::out, io::di, io::uo) is det.
+:- pred read_or_create(string::in, feedback_read_result(feedback_info)::out,
+ io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
- % init_feedback_info = FeedbackState
+ % init_feedback_info = FeedbackInfo
%
- % Create a new empty feedback state.
+ % Create a new empty feedback info structure.
%
:- func init_feedback_info = feedback_info.
%-----------------------------------------------------------------------------%
- % write_feedback_file(Path, ProgName, FeedbackState, FeedbackWriteResult,
+ % write_feedback_file(Path, ProgName, FeedbackInfo, FeedbackWriteResult,
% !IO)
%
% Write out the feedback data to a given file name.
@@ -170,6 +221,7 @@
:- import_module exception.
:- import_module map.
+:- import_module require.
:- import_module svmap.
:- import_module unit.
:- import_module univ.
@@ -179,25 +231,61 @@
:- type feedback_info
---> feedback_info(map(feedback_type, feedback_data)).
+ % This type is used as a key for the data that may be fed back into the
+ % compiler.
+ %
+:- type feedback_type
+ ---> feedback_type_calls_above_threshold_sorted
+ ; feedback_type_candidate_parallel_conjunctions.
+
%-----------------------------------------------------------------------------%
-get_feedback_data(Type, MaybeData, Info) :-
+get_feedback_data(Info, Data) :-
+ feedback_data_type(Type, Data),
Info = feedback_info(Map),
- ( map.search(Map, Type, Data) ->
- MaybeData = yes(Data)
- ;
- MaybeData = no
+ map.search(Map, Type, DataPrime),
+ % This disjunction will either unify Data to DataPrime, or throw an
+ % exception, the impure annotation is required so to avoid a compiler
+ % warning saying that the second disjunct will not succeed, which must be
+ % promised away.
+ promise_pure (
+ Data = DataPrime
+ ;
+ impure impure_true,
+ feedback_data_mismatch_error("get_feedback_data/3: ", Type,
+ DataPrime)
).
%-----------------------------------------------------------------------------%
-put_feedback_data(Type, Data, !Info) :-
+put_feedback_data(Data, !Info) :-
+ feedback_data_type(Type, Data),
some [!Map] (
!.Info = feedback_info(!:Map),
svmap.set(Type, Data, !Map),
!:Info = feedback_info(!.Map)
).
+%----------------------------------------------------------------------------%
+
+:- pred feedback_data_type(feedback_type, feedback_data).
+
+:- mode feedback_data_type(out, in(feedback_data_query)) is det.
+:- mode feedback_data_type(out, in) is det.
+
+feedback_data_type(feedback_type_calls_above_threshold_sorted,
+ feedback_data_calls_above_threshold_sorted(_, _, _)).
+feedback_data_type(feedback_type_candidate_parallel_conjunctions,
+ feedback_data_candidate_parallel_conjunctions(_, _, _, _)).
+
+:- pred feedback_data_mismatch_error(string::in, feedback_type::in,
+ feedback_data::in) is erroneous.
+
+feedback_data_mismatch_error(Predicate, Type, Data) :-
+ error(string.format(
+ "%s: Feedback data doesn't match type\n\tType: %s\n\tData: %s\n",
+ [s(Predicate), s(string(Type)), s(string(Data))])).
+
%-----------------------------------------------------------------------------%
read_feedback_file(Path, ReadResultFeedbackInfo, !IO) :-
@@ -299,8 +387,8 @@ read_no_check_line(Stream, _, Result, !I
read_data(Stream, _, Result, !IO) :-
io.read(Stream, ReadResultDataAssocList, !IO),
(
- ReadResultDataAssocList = ok(DataAssocList),
- map.det_insert_from_assoc_list(map.init, DataAssocList, Map),
+ ReadResultDataAssocList = ok(DataList),
+ list.foldl(det_insert_feedback_data, DataList, map.init, Map),
Result = ok(feedback_info(Map))
;
ReadResultDataAssocList = eof,
@@ -310,16 +398,38 @@ read_data(Stream, _, Result, !IO) :-
Result = error(parse_error(Error, Line))
).
+:- pred det_insert_feedback_data(feedback_data::in, map(feedback_type,
+ feedback_data)::in, map(feedback_type, feedback_data)::out) is det.
+
+det_insert_feedback_data(Data, !Map) :-
+ feedback_data_type(Key, Data),
+ svmap.det_insert(Key, Data, !Map).
+
%-----------------------------------------------------------------------------%
-read_or_create(Path, Feedback, !IO) :-
- read_feedback_file(Path, ReadResultFeedback, !IO),
+read_or_create(Path, ReadResultFeedback, !IO) :-
+ read_feedback_file(Path, ReadResultFeedback1, !IO),
(
- ReadResultFeedback = ok(Feedback)
+ ReadResultFeedback1 = ok(_),
+ ReadResultFeedback = ReadResultFeedback1
;
- ReadResultFeedback = error(Error),
- display_read_error(Path, Error, !IO),
- Feedback = init_feedback_info
+ ReadResultFeedback1 = error(Error),
+ (
+ % XXX: Assume that an open error is probably caused by the file not
+ % existing, (but we can't be sure because io.error is a string
+ % internally, and error messages may change and are not portable).
+ Error = open_error(_),
+ ReadResultFeedback = ok(init_feedback_info)
+ ;
+ ( Error = read_error(_)
+ ; Error = parse_error(_, _)
+ ; Error = unexpected_eof
+ ; Error = incorrect_version
+ ; Error = incorrect_first_line
+ ; Error = incorrect_program_name
+ ),
+ ReadResultFeedback = ReadResultFeedback1
+ )
).
%-----------------------------------------------------------------------------%
@@ -405,7 +515,7 @@ write_feedback_file_2(Stream, ProgName,
io.write_string(Stream, ProgName, !IO),
io.nl(Stream, !IO),
Feedback = feedback_info(Map),
- map.to_assoc_list(Map, FeedbackList),
+ map.values(Map, FeedbackList),
io.write(Stream, FeedbackList, !IO),
io.write_string(Stream, ".\n", !IO),
io.close_output(Stream, !IO).
@@ -418,7 +528,7 @@ feedback_first_line = "Mercury Compiler
:- func feedback_version = string.
-feedback_version = "1".
+feedback_version = "2".
%-----------------------------------------------------------------------------%
:- end_module mdbcomp.feedback.
-------------- 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/20080930/244646fa/attachment.sig>
More information about the reviews
mailing list