[m-rev.] for post-commit review: more training_cars_full compilation speedups
Zoltan Somogyi
zs at unimelb.edu.au
Tue Jun 19 17:19:12 AEST 2012
For post-commit review by anyone.
Zoltan.
A bunch of individually small changes to speed up the compiler when compiling
training_cars_full.m. Altogether, the changes speed up the compiler on that
task by a bit more than 11% when the target grade is asm_fast.gc, and by a bit
more than 7% when the target grade is hlc.gc. (Several of the changes affect
the code that optimizes the LLDS; we don't have corresponding optimizers
for the MLDS.)
compiler/c_util.m:
Specialize the code that prints out quoted strings for the target
language. We don't want to check the target language during
the conversion of EVERY SINGLE CHARACTER.
compiler/dead_proc_elim.m:
When we analyze the module for inlining, we are only after the
use counts of procedures. We do not need to traverse ground structures
to get those counts.
compiler/dupelim.m:
Do the search and insertion in the standardized code sequence map
in one pass.
compiler/global_data.m:
compiler/ml_global_data.m:
Do the search and insertion in the scalar data map in one pass.
library/bimap.m:
Add a search_insert predicate to make possible the changes in
{ml_,}global_data.m.
NEWS:
Mention the new predicate in bimap.m.
compiler/inst_match.m:
Do searches and insertions in sets of expansions in one pass.
Highlight discrepancies between comments on the declarations
of two predicates and comments on their code.
compiler/llds_out_global.m:
compiler/post_typecheck.m:
Reorder the bodies of some test conditions to put the cheaper and
more-frequently-failing tests first.
compiler/labelopt.m:
compiler/opt_util.m:
Do not require opt_util to return a list of code addresses that
labelopt then throws away; allow opt_util.m not to gather those
addresses in the first place (if the unused_args optimization
is applied to it, which it is by default.)
In opt_util.m, make an unnecessarily-exported predicate private.
compiler/prog_data.m:
Use predicates in varset.m that do directly what we want, instead
of using a different predicate and then post-processing its output.
(The code was originally written before the directly useful predicate
in varset.m was available.)
compiler/type_util.m:
Specialize the frequently occurring case of no typeclass constraints
at all.
compiler/typecheck_info.m:
Give the field names of some types identifying prefixes.
Make a function symbol's name more meaningful.
compiler/typecheck.m:
compiler/typecheck_errors.m:
Conform to the changes in typecheck_info.m.
cvs diff: Diffing .
Index: NEWS
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/NEWS,v
retrieving revision 1.613
diff -u -b -r1.613 NEWS
--- NEWS 18 Jun 2012 07:58:25 -0000 1.613
+++ NEWS 19 Jun 2012 07:07:56 -0000
@@ -17,9 +17,9 @@
a sorted list of items from a map or varset, and can do so faster than
usual by exploiting the order.
-* The map and tree234 modules each have a new predicate that does a search,
- and if the search is unsuccessful, does an insertion during the *same*
- traversal.
+* The map, bimap and tree234 modules each have a new predicate that does
+ a search, and if the search is unsuccessful, does an insertion during
+ the *same* traversal.
* The argument order of the following predicates has been changed so as to
make them more conducive to the use of state variable notation:
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/extra
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/extra
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/libatomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops/doc
cvs diff: Diffing boehm_gc/libatomic_ops/src
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/armcc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops/tests
cvs diff: Diffing boehm_gc/libatomic_ops-1.2
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/m4
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/c_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/c_util.m,v
retrieving revision 1.53
diff -u -b -r1.53 c_util.m
--- compiler/c_util.m 8 Dec 2011 23:24:13 -0000 1.53
+++ compiler/c_util.m 19 Jun 2012 07:07:56 -0000
@@ -79,8 +79,11 @@
% As above, but for the specified language.
%
-:- pred output_quoted_string_lang(literal_language::in, string::in,
- io::di, io::uo) is det.
+:- pred output_quoted_string_lang(literal_language, string, io, io).
+:- mode output_quoted_string_lang(in(bound(literal_c)), in, di, uo) is det.
+:- mode output_quoted_string_lang(in(bound(literal_java)), in, di, uo) is det.
+:- mode output_quoted_string_lang(in(bound(literal_csharp)), in, di, uo) is det.
+:- mode output_quoted_string_lang(in, in, di, uo) is det.
% output_quoted_multi_string is like list.foldl(output_quoted_string)
% except that a null character will be written between each string
@@ -318,6 +321,8 @@
output_quoted_string(S, !IO) :-
output_quoted_string_lang(literal_c, S, !IO).
+:- pragma inline(output_quoted_string_lang/4).
+
output_quoted_string_lang(Lang, S, !IO) :-
(
Lang = literal_c,
@@ -363,8 +368,11 @@
output_quoted_char(Char, !IO) :-
output_quoted_char_lang(literal_c, Char, !IO).
-:- pred output_quoted_char_lang(literal_language::in, char::in, io::di, io::uo)
- is det.
+:- pred output_quoted_char_lang(literal_language, char, io, io).
+:- mode output_quoted_char_lang(in(bound(literal_c)), in, di, uo) is det.
+:- mode output_quoted_char_lang(in(bound(literal_java)), in, di, uo) is det.
+:- mode output_quoted_char_lang(in(bound(literal_csharp)), in, di, uo) is det.
+:- mode output_quoted_char_lang(in, in, di, uo) is det.
output_quoted_char_lang(Lang, Char, !IO) :-
EscapedCharStr = quote_char_lang(Lang, Char),
@@ -373,20 +381,27 @@
quote_char(Char) = quote_char_lang(literal_c, Char).
:- func quote_char_lang(literal_language, char) = string.
+:- mode quote_char_lang(in(bound(literal_c)), in) = out is det.
+:- mode quote_char_lang(in(bound(literal_java)), in) = out is det.
+:- mode quote_char_lang(in(bound(literal_csharp)), in) = out is det.
+:- mode quote_char_lang(in, in) = out is det.
quote_char_lang(Lang, Char) = QuotedCharStr :-
quote_one_char(Lang, Char, [], RevQuotedCharStr),
string.from_rev_char_list(RevQuotedCharStr, QuotedCharStr).
quote_string(String) = QuotedString :-
- Lang = literal_c,
- string.foldl(quote_one_char(Lang), String, [], RevQuotedChars),
+ string.foldl(quote_one_char_c, String, [], RevQuotedChars),
string.from_rev_char_list(RevQuotedChars, QuotedString).
-:- pred quote_one_char(literal_language::in, char::in,
- list(char)::in, list(char)::out) is det.
+:- pred quote_one_char(literal_language, char, list(char), list(char)).
+:- mode quote_one_char(in(bound(literal_c)), in, in, out) is det.
+:- mode quote_one_char(in(bound(literal_java)), in, in, out) is det.
+:- mode quote_one_char(in(bound(literal_csharp)), in, in, out) is det.
+:- mode quote_one_char(in, in, in, out) is det.
quote_one_char(Lang, Char, RevChars0, RevChars) :-
+ % quote_one_char_c is a specialized version of this code.
(
Lang = literal_java,
java_escape_special_char(Char, RevEscapeChars)
@@ -444,6 +459,43 @@
reverse_append(EscapeChars, RevChars0, RevChars)
).
+:- pred quote_one_char_c(char::in, list(char)::in, list(char)::out) is det.
+
+quote_one_char_c(Char, RevChars0, RevChars) :-
+ % This is a specialized version of quote_one_char.
+ (
+ escape_special_char(Char, EscapeChar)
+ ->
+ RevChars = [EscapeChar, '\\' | RevChars0]
+ ;
+ Char = '?'
+ ->
+ % Avoid trigraphs by escaping the question marks.
+ RevChars = ['?', '\\' | RevChars0]
+ ;
+ is_c_source_char(Char)
+ ->
+ RevChars = [Char | RevChars0]
+ ;
+ char.to_int(Char, 0)
+ ->
+ RevChars = ['0', '\\' | RevChars0]
+ ;
+ Int = char.to_int(Char),
+ Int >= 0x80
+ ->
+ ( char.to_utf8(Char, CodeUnits) ->
+ list.map(octal_escape_any_int, CodeUnits, EscapeCharss),
+ list.condense(EscapeCharss, EscapeChars),
+ reverse_append(EscapeChars, RevChars0, RevChars)
+ ;
+ unexpected($module, $pred, "invalid Unicode code point")
+ )
+ ;
+ octal_escape_any_char(Char, EscapeChars),
+ reverse_append(EscapeChars, RevChars0, RevChars)
+ ).
+
:- pred java_escape_special_char(char::in, list(char)::out) is semidet.
java_escape_special_char('\a', ['7', '0', '0', '\\']).
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.147
diff -u -b -r1.147 dead_proc_elim.m
--- compiler/dead_proc_elim.m 11 Jun 2012 03:13:20 -0000 1.147
+++ compiler/dead_proc_elim.m 19 Jun 2012 07:07:56 -0000
@@ -133,16 +133,26 @@
:- type entity_queue == queue(entity).
:- type examined_set == set_tree234(entity).
+dead_proc_analyze(!ModuleInfo, !:Needed) :-
+ do_dead_proc_analyze(!ModuleInfo, analyze_procs, !:Needed).
+
dead_proc_elim(ElimOptImported, !ModuleInfo, Specs) :-
- dead_proc_analyze(!ModuleInfo, Needed),
+ do_dead_proc_analyze(!ModuleInfo, analyze_all, Needed),
dead_proc_eliminate(ElimOptImported, Needed, !ModuleInfo, Specs).
%-----------------------------------------------------------------------------%
-dead_proc_analyze(!ModuleInfo, !:Needed) :-
+:- type analyze_what
+ ---> analyze_procs
+ ; analyze_all.
+
+:- pred do_dead_proc_analyze(module_info::in, module_info::out,
+ analyze_what::in, needed_map::out) is det.
+
+do_dead_proc_analyze(!ModuleInfo, AnalyeWhat, !:Needed) :-
Examined0 = set_tree234.init,
dead_proc_initialize(!ModuleInfo, Queue0, !:Needed),
- dead_proc_examine(Queue0, Examined0, !.ModuleInfo, !Needed).
+ dead_proc_examine(Queue0, Examined0, AnalyeWhat, !.ModuleInfo, !Needed).
% Add all exported entities to the queue and map.
% NOTE: changes here are likely to require changes to dead_pred_elim
@@ -316,16 +326,13 @@
%-----------------------------------------------------------------------------%
:- pred dead_proc_examine(entity_queue::in, examined_set::in,
- module_info::in, needed_map::in, needed_map::out) is det.
+ analyze_what::in, module_info::in, needed_map::in, needed_map::out) is det.
-dead_proc_examine(!.Queue, !.Examined, ModuleInfo, !Needed) :-
+dead_proc_examine(!.Queue, !.Examined, AnalyzeWhat, ModuleInfo, !Needed) :-
% See if the queue is empty.
( queue.get(Entity, !Queue) ->
% See if the next element has been examined before.
- ( set_tree234.contains(!.Examined, Entity) ->
- dead_proc_examine(!.Queue, !.Examined, ModuleInfo, !Needed)
- ;
- set_tree234.insert(Entity, !Examined),
+ ( set_tree234.insert_new(Entity, !Examined) ->
(
Entity = entity_proc(PredId, ProcId),
PredProcId = proc(PredId, ProcId),
@@ -335,15 +342,28 @@
% Nothing further to examine.
;
Entity = entity_type_ctor(Module, Type, Arity),
+ (
+ AnalyzeWhat = analyze_procs
+ ;
+ AnalyzeWhat = analyze_all,
dead_proc_examine_type_ctor_info(Module, Type, Arity,
ModuleInfo, !Queue, !Needed)
+ )
;
Entity = entity_const_struct(ConstNum),
+ (
+ AnalyzeWhat = analyze_procs
+ ;
+ AnalyzeWhat = analyze_all,
dead_proc_examine_const_struct(ModuleInfo, ConstNum,
!Queue, !Needed)
- ),
- dead_proc_examine(!.Queue, !.Examined, ModuleInfo, !Needed)
)
+ )
+ ;
+ true
+ ),
+ dead_proc_examine(!.Queue, !.Examined, AnalyzeWhat,
+ ModuleInfo, !Needed)
;
true
).
Index: compiler/dupelim.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dupelim.m,v
retrieving revision 1.104
diff -u -b -r1.104 dupelim.m
--- compiler/dupelim.m 17 Oct 2011 04:31:28 -0000 1.104
+++ compiler/dupelim.m 19 Jun 2012 07:07:56 -0000
@@ -126,10 +126,12 @@
BlockInfo = block_info(_, _, Instrs, NumInstrs, _, _, MaybeFallThrough),
( NumInstrs < std_block_size_limit ->
standardize_instr_block(Instrs, MaybeFallThrough, StdInstrs),
- ( map.search(!.StdMap, StdInstrs, Cluster) ->
- map.det_update(StdInstrs, [Label | Cluster], !StdMap)
+ map.search_insert(StdInstrs, [Label], MaybeOldCluster, !StdMap),
+ (
+ MaybeOldCluster = no
;
- map.det_insert(StdInstrs, [Label], !StdMap)
+ MaybeOldCluster = yes(OldCluster),
+ map.det_update(StdInstrs, [Label | OldCluster], !StdMap)
)
;
true
Index: compiler/global_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/global_data.m,v
retrieving revision 1.56
diff -u -b -r1.56 global_data.m
--- compiler/global_data.m 19 Jun 2012 05:37:04 -0000 1.56
+++ compiler/global_data.m 19 Jun 2012 07:07:56 -0000
@@ -390,6 +390,8 @@
some [!CellGroup] (
TypeNumMap0 = !.Info ^ sci_cell_type_num_map,
CellGroupMap0 = !.Info ^ sci_scalar_cell_group_map,
+ % We do not want to use bimap.search_insert here, since this search
+ % usually succeeds.
( bimap.search(TypeNumMap0, CellType, OldTypeNum) ->
TypeNum = OldTypeNum,
( map.search(CellGroupMap0, TypeNum, !:CellGroup) ->
@@ -408,6 +410,35 @@
!:CellGroup = init_scalar_cell_group
),
+
+ InsertCommonData = !.Info ^ sci_sub_info ^ scsi_common_data,
+ (
+ InsertCommonData = yes,
+ MembersMap0 = !.CellGroup ^ scalar_cell_group_members,
+ CellNumCounter0 = !.CellGroup ^ scalar_cell_counter,
+ counter.allocate(CellNum, CellNumCounter0, CellNumCounter),
+ NewDataId = scalar_common_data_id(TypeNum, CellNum),
+
+ bimap.search_insert(Args, NewDataId, MaybeOldDataId,
+ MembersMap0, MembersMap),
+ (
+ MaybeOldDataId = yes(OldDataId),
+ % We cannot get here if !.CellGroup wasn't found in
+ % CellGroupMap0.
+ DataId = OldDataId
+ ;
+ MaybeOldDataId = no,
+ DataId = NewDataId,
+ !CellGroup ^ scalar_cell_counter := CellNumCounter,
+ !CellGroup ^ scalar_cell_group_members := MembersMap,
+ RevArray0 = !.CellGroup ^ scalar_cell_rev_array,
+ RevArray = [CellValue | RevArray0],
+ !CellGroup ^ scalar_cell_rev_array := RevArray,
+ map.set(TypeNum, !.CellGroup, CellGroupMap0, CellGroupMap),
+ !Info ^ sci_scalar_cell_group_map := CellGroupMap
+ )
+ ;
+ InsertCommonData = no,
MembersMap0 = !.CellGroup ^ scalar_cell_group_members,
( bimap.search(MembersMap0, Args, DataIdPrime) ->
DataId = DataIdPrime
@@ -419,20 +450,13 @@
RevArray0 = !.CellGroup ^ scalar_cell_rev_array,
RevArray = [CellValue | RevArray0],
!CellGroup ^ scalar_cell_rev_array := RevArray,
- InsertCommonData = !.Info ^ sci_sub_info ^ scsi_common_data,
- (
- InsertCommonData = yes,
- bimap.det_insert(Args, DataId, MembersMap0, MembersMap),
- !CellGroup ^ scalar_cell_group_members := MembersMap
- ;
- InsertCommonData = no
% With --no-common-data, we never insert any cell into
% CellGroupMap, ensuring that it stays empty. This can
% be useful when comparing the LLDS and MLDS backends.
- ),
map.set(TypeNum, !.CellGroup, CellGroupMap0, CellGroupMap),
!Info ^ sci_scalar_cell_group_map := CellGroupMap
)
+ )
).
:- func init_scalar_cell_group = scalar_cell_group.
Index: compiler/inst_match.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_match.m,v
retrieving revision 1.99
diff -u -b -r1.99 inst_match.m
--- compiler/inst_match.m 23 Apr 2012 03:34:47 -0000 1.99
+++ compiler/inst_match.m 19 Jun 2012 07:07:56 -0000
@@ -205,10 +205,19 @@
% Succeed if the inst is `mostly_unique' or `unique'.
%
+ % XXX The documentation on the code used to say: " inst_is_mostly_unique
+ % succeeds iff the inst passed is unique, mostly_unique, or free.
+ % Abstract insts are not considered unique.". The part about free is
+ % dubious.
+ %
:- pred inst_is_mostly_unique(module_info::in, mer_inst::in) is semidet.
% Succeed if the inst is `unique'.
%
+ % XXX The documentation on the code used to say: "inst_is_unique succeeds
+ % iff the inst passed is unique or free. Abstract insts are not considered
+ % unique.". The part about free is dubious.
+ %
:- pred inst_is_unique(module_info::in, mer_inst::in) is semidet.
% Succeed if the inst is not `mostly_unique' or `unique'.
@@ -350,18 +359,14 @@
expansion_init = set_tree234.init.
-:- pred expansion_member(inst_match_inputs::in, expansions::in) is semidet.
-:- pragma inline(expansion_member/2).
-
-expansion_member(E, S) :-
- set_tree234.is_member(S, E) = yes.
+:- pred expansion_insert_new(inst_match_inputs::in,
+ expansions::in, expansions::out) is semidet.
+:- pragma inline(expansion_insert_new/3).
-:- pred expansion_insert(inst_match_inputs::in,
- expansions::in, expansions::out) is det.
-:- pragma inline(expansion_insert/3).
+expansion_insert_new(E, S0, S) :-
+ set_tree234.insert_new(E, S0, S).
-expansion_insert(E, S0, S) :-
- set_tree234.insert(E, S0, S).
+%-----------------------------------------------------------------------------%
inst_expand(ModuleInfo, !Inst) :-
( !.Inst = defined_inst(InstName) ->
@@ -595,15 +600,14 @@
inst_matches_initial_mt(InstA, InstB, MaybeType, !Info) :-
ThisExpansion = inst_match_inputs(InstA, InstB, MaybeType),
Expansions0 = !.Info ^ imi_expansions,
- ( expansion_member(ThisExpansion, Expansions0) ->
- true
- ;
+ ( expansion_insert_new(ThisExpansion, Expansions0, Expansions) ->
+ !Info ^ imi_expansions := Expansions,
inst_expand(!.Info ^ imi_module_info, InstA, ExpandedInstA),
inst_expand(!.Info ^ imi_module_info, InstB, ExpandedInstB),
- expansion_insert(ThisExpansion, Expansions0, Expansions),
- !Info ^ imi_expansions := Expansions,
handle_inst_var_subs(inst_matches_initial_mt, inst_matches_initial_4,
ExpandedInstA, ExpandedInstB, MaybeType, !Info)
+ ;
+ true
).
:- pred inst_matches_initial_4(mer_inst::in, mer_inst::in, maybe(mer_type)::in,
@@ -1045,17 +1049,19 @@
inst_matches_final_mt(InstA, InstB, MaybeType, !Info) :-
ThisExpansion = inst_match_inputs(InstA, InstB, MaybeType),
Expansions0 = !.Info ^ imi_expansions,
- ( expansion_member(ThisExpansion, Expansions0) ->
- true
- ; InstA = InstB ->
+ ( InstA = InstB ->
true
;
+ Expansions0 = !.Info ^ imi_expansions,
+ ( expansion_insert_new(ThisExpansion, Expansions0, Expansions) ->
+ !Info ^ imi_expansions := Expansions,
inst_expand(!.Info ^ imi_module_info, InstA, ExpandedInstA),
inst_expand(!.Info ^ imi_module_info, InstB, ExpandedInstB),
- expansion_insert(ThisExpansion, Expansions0, Expansions),
- !Info ^ imi_expansions := Expansions,
handle_inst_var_subs(inst_matches_final_mt, inst_matches_final_3,
ExpandedInstA, ExpandedInstB, MaybeType, !Info)
+ ;
+ true
+ )
).
:- pred inst_matches_final_3(mer_inst::in, mer_inst::in, maybe(mer_type)::in,
@@ -1248,16 +1254,15 @@
inst_matches_binding_mt(InstA, InstB, MaybeType, !Info) :-
ThisExpansion = inst_match_inputs(InstA, InstB, MaybeType),
Expansions0 = !.Info ^ imi_expansions,
- ( expansion_member(ThisExpansion, Expansions0) ->
- true
- ;
+ ( expansion_insert_new(ThisExpansion, Expansions0, Expansions) ->
+ !Info ^ imi_expansions := Expansions,
inst_expand_and_remove_constrained_inst_vars(!.Info ^ imi_module_info,
InstA, ExpandedInstA),
inst_expand_and_remove_constrained_inst_vars(!.Info ^ imi_module_info,
InstB, ExpandedInstB),
- expansion_insert(ThisExpansion, Expansions0, Expansions),
- !Info ^ imi_expansions := Expansions,
inst_matches_binding_3(ExpandedInstA, ExpandedInstB, MaybeType, !Info)
+ ;
+ true
).
:- pred inst_matches_binding_3(mer_inst::in, mer_inst::in, maybe(mer_type)::in,
@@ -1787,18 +1792,14 @@
inst_is_ground_or_any_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
- ( set.member(Inst, !.Expansions) ->
- true
- ;
- set.insert(Inst, !Expansions),
+ ( set.insert_new(Inst, !Expansions) ->
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_ground_or_any_2(ModuleInfo, NextInst, !Expansions)
+ ;
+ true
)
).
- % inst_is_unique succeeds iff the inst passed is unique or free.
- % Abstract insts are not considered unique.
- %
inst_is_unique(ModuleInfo, Inst) :-
set.init(Expansions0),
inst_is_unique_2(ModuleInfo, Inst, Expansions0, _Expansions).
@@ -1841,18 +1842,14 @@
inst_is_unique_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
- ( set.member(Inst, !.Expansions) ->
- true
- ;
- set.insert(Inst, !Expansions),
+ ( set.insert_new(Inst, !Expansions) ->
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_unique_2(ModuleInfo, NextInst, !Expansions)
+ ;
+ true
)
).
- % inst_is_mostly_unique succeeds iff the inst passed is unique,
- % mostly_unique, or free. Abstract insts are not considered unique.
- %
inst_is_mostly_unique(ModuleInfo, Inst) :-
set.init(Expansions0),
inst_is_mostly_unique_2(ModuleInfo, Inst, Expansions0, _Expansions).
@@ -1894,12 +1891,11 @@
inst_is_mostly_unique_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
- ( set.member(Inst, !.Expansions) ->
- true
- ;
- set.insert(Inst, !Expansions),
+ ( set.insert_new(Inst, !Expansions) ->
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_mostly_unique_2(ModuleInfo, NextInst, !Expansions)
+ ;
+ true
)
;
Inst = abstract_inst(_, _),
@@ -1950,12 +1946,11 @@
inst_is_not_partly_unique_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
- ( set.member(Inst, !.Expansions) ->
- true
- ;
- set.insert(Inst, !Expansions),
+ ( set.insert_new(Inst, !Expansions) ->
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_not_partly_unique_2(ModuleInfo, NextInst, !Expansions)
+ ;
+ true
)
;
Inst = abstract_inst(_, _),
@@ -2012,12 +2007,11 @@
inst_is_not_fully_unique_2(ModuleInfo, SubInst, !Expansions)
;
Inst = defined_inst(InstName),
- ( set.member(Inst, !.Expansions) ->
- true
- ;
- set.insert(Inst, !Expansions),
+ ( set.insert_new(Inst, !Expansions) ->
inst_lookup(ModuleInfo, InstName, NextInst),
inst_is_not_fully_unique_2(ModuleInfo, NextInst, !Expansions)
+ ;
+ true
)
;
Inst = abstract_inst(_, _),
Index: compiler/labelopt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/labelopt.m,v
retrieving revision 1.40
diff -u -b -r1.40 labelopt.m
--- compiler/labelopt.m 24 Apr 2012 04:43:31 -0000 1.40
+++ compiler/labelopt.m 19 Jun 2012 07:07:56 -0000
@@ -67,7 +67,7 @@
build_useset([], !Useset).
build_useset([Instr | Instructions], !Useset) :-
Instr = llds_instr(Uinstr, _Comment),
- opt_util.instr_labels(Uinstr, Labels, _CodeAddresses),
+ opt_util.instr_labels_only(Uinstr, Labels),
set_tree234.insert_list(Labels, !Useset),
build_useset(Instructions, !Useset).
Index: compiler/llds_out_global.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds_out_global.m,v
retrieving revision 1.7
diff -u -b -r1.7 llds_out_global.m
--- compiler/llds_out_global.m 8 Jun 2012 15:46:20 -0000 1.7
+++ compiler/llds_out_global.m 19 Jun 2012 07:07:56 -0000
@@ -575,8 +575,8 @@
output_cons_args(Info, [TypedRval | TypedRvals], !IO) :-
TypedRval = typed_rval(Rval, Type),
(
- direct_field_int_constant(Type) = yes,
- Rval = const(llconst_int(N))
+ Rval = const(llconst_int(N)),
+ direct_field_int_constant(Type) = yes
->
output_int_const(N, Type, !IO)
;
@@ -600,8 +600,8 @@
Group = common_cell_grouped_args(Type, _, Rvals),
io.write_string("{\n", !IO),
(
- direct_field_int_constant(Type) = yes,
- list.map(project_int_constant, Rvals, Ints)
+ list.map(project_int_constant, Rvals, Ints),
+ direct_field_int_constant(Type) = yes
->
Check = check_int_const_sizes,
(
@@ -618,8 +618,8 @@
;
Group = common_cell_ungrouped_arg(Type, Rval),
(
- direct_field_int_constant(Type) = yes,
- project_int_constant(Rval, Int)
+ project_int_constant(Rval, Int),
+ direct_field_int_constant(Type) = yes
->
output_int_const(Int, Type, !IO)
;
Index: compiler/ml_global_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_global_data.m,v
retrieving revision 1.15
diff -u -b -r1.15 ml_global_data.m
--- compiler/ml_global_data.m 11 Jun 2012 03:13:21 -0000 1.15
+++ compiler/ml_global_data.m 19 Jun 2012 07:07:56 -0000
@@ -441,26 +441,30 @@
InitArraySize, counter.init(0), bimap.init, cord.empty)
),
+ RowCounter0 = !.CellGroup ^ mscg_counter,
+ counter.allocate(RowNum, RowCounter0, RowCounter),
MembersMap0 = !.CellGroup ^ mscg_members,
- ( bimap.search(MembersMap0, Initializer, OldCommon) ->
+ NewCommon =
+ ml_scalar_common(MLDS_ModuleName, ConstType, TypeNum, RowNum),
+ bimap.search_insert(Initializer, NewCommon, MaybeOldCommon,
+ MembersMap0, MembersMap),
+ (
+ MaybeOldCommon = yes(OldCommon),
+ % We cannot get here if !.CellGroup wasn't found in CellGroupMap0.
Common = OldCommon
;
- RowCounter0 = !.CellGroup ^ mscg_counter,
- counter.allocate(RowNum, RowCounter0, RowCounter),
+ MaybeOldCommon = no,
+ Common = NewCommon,
!CellGroup ^ mscg_counter := RowCounter,
-
- Common = ml_scalar_common(MLDS_ModuleName, ConstType, TypeNum,
- RowNum),
+ !CellGroup ^ mscg_members := MembersMap,
Rows0 = !.CellGroup ^ mscg_rows,
Rows = cord.snoc(Rows0, Initializer),
!CellGroup ^ mscg_rows := Rows,
- bimap.det_insert(Initializer, Common, MembersMap0, MembersMap),
- !CellGroup ^ mscg_members := MembersMap
- ),
map.set(TypeNum, !.CellGroup, CellGroupMap0, CellGroupMap),
!GlobalData ^ mgd_scalar_cell_group_map := CellGroupMap
+ )
).
:- pred ml_gen_plain_static_defn(string::in, mlds_type::in,
Index: compiler/opt_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.181
diff -u -b -r1.181 opt_util.m
--- compiler/opt_util.m 21 Oct 2011 00:16:21 -0000 1.181
+++ compiler/opt_util.m 19 Jun 2012 07:07:56 -0000
@@ -207,12 +207,7 @@
% in both output arguments.
%
:- pred instr_labels(instr::in, list(label)::out, list(code_addr)::out) is det.
-
- % Determine all the labels and code addresses which are referenced
- % by a list of instructions.
- %
-:- pred instr_list_labels(list(instruction)::in,
- list(label)::out, list(code_addr)::out) is det.
+:- pred instr_labels_only(instr::in, list(label)::out) is det.
% Given an instruction, find the set of labels and other code addresses
% to which it can cause control to transfer. In the case of calls, this
@@ -1272,6 +1267,9 @@
CodeAddrs = CodeAddrs1 ++ CodeAddrs2 ++ CodeAddrs3,
find_label_code_addrs(CodeAddrs, Labels0, Labels).
+instr_labels_only(Instr, Labels) :-
+ instr_labels(Instr, Labels, _CodeAddrs).
+
% Determine all the labels and code_addresses that are directly referenced
% by an instruction (not counting ones referenced indirectly via rvals or
% lvals).
@@ -1506,6 +1504,12 @@
MaybeDefLabel = no
).
+ % Determine all the labels and code addresses which are referenced
+ % by a list of instructions.
+ %
+:- pred instr_list_labels(list(instruction)::in,
+ list(label)::out, list(code_addr)::out) is det.
+
instr_list_labels([], [], []).
instr_list_labels([llds_instr(Uinstr, _) | Instrs], Labels, CodeAddrs) :-
instr_labels(Uinstr, HeadLabels, HeadCodeAddrs),
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.158
diff -u -b -r1.158 post_typecheck.m
--- compiler/post_typecheck.m 8 Jun 2012 15:37:00 -0000 1.158
+++ compiler/post_typecheck.m 19 Jun 2012 07:07:56 -0000
@@ -1065,6 +1065,12 @@
% specified name and arity (and module, if module-qualified)
ConsId0 = cons(PredName, _, _),
+ pred_info_get_markers(!.PredInfo, Markers),
+ module_info_get_predicate_table(ModuleInfo, PredTable),
+ % This search will usually fail, so do it first.
+ predicate_table_search_func_sym_arity(PredTable,
+ calls_are_fully_qualified(Markers), PredName, Arity, PredIds),
+
% We don't do this for compiler-generated predicates; they are assumed
% to have been generated with all functions already expanded. If we did
% this check for compiler-generated predicates, it would cause the
@@ -1079,11 +1085,6 @@
% unifications below.
\+ pred_info_is_field_access_function(ModuleInfo, !.PredInfo),
- pred_info_get_markers(!.PredInfo, Markers),
- module_info_get_predicate_table(ModuleInfo, PredTable),
- predicate_table_search_func_sym_arity(PredTable,
- calls_are_fully_qualified(Markers), PredName, Arity, PredIds),
-
% Check if any of the candidate functions have argument/return types
% which subsume the actual argument/return types of this function call,
% and which have universal constraints consistent with what we expect.
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.242
diff -u -b -r1.242 prog_data.m
--- compiler/prog_data.m 11 Jun 2012 03:13:21 -0000 1.242
+++ compiler/prog_data.m 19 Jun 2012 07:07:57 -0000
@@ -1972,19 +1972,10 @@
:- implementation.
tvarset_merge_renaming(TVarSetA, TVarSetB, TVarSet, Renaming) :-
- varset.merge_subst(TVarSetA, TVarSetB, TVarSet, Subst),
- map.map_values_only(convert_subst_term_to_tvar, Subst, Renaming).
+ varset.merge_renaming(TVarSetA, TVarSetB, TVarSet, Renaming).
tvarset_merge_renaming_without_names(TVarSetA, TVarSetB, TVarSet, Renaming) :-
- varset.merge_subst_without_names(TVarSetA, TVarSetB, TVarSet, Subst),
- map.map_values_only(convert_subst_term_to_tvar, Subst, Renaming).
-
-:- pred convert_subst_term_to_tvar(term(tvar_type)::in, tvar::out)
- is det.
-
-convert_subst_term_to_tvar(variable(TVar, _), TVar).
-convert_subst_term_to_tvar(functor(_, _, _), _) :-
- unexpected($module, $pred, "non-variable found in renaming").
+ varset.merge_renaming_without_names(TVarSetA, TVarSetB, TVarSet, Renaming).
%-----------------------------------------------------------------------------%
%
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.216
diff -u -b -r1.216 type_util.m
--- compiler/type_util.m 8 Jun 2012 15:37:01 -0000 1.216
+++ compiler/type_util.m 19 Jun 2012 07:07:57 -0000
@@ -1236,22 +1236,45 @@
apply_variable_renaming_to_constraints(Renaming, !Constraints) :-
!.Constraints = hlds_constraints(Unproven0, Assumed0,
Redundant0, Ancestors0),
- apply_variable_renaming_to_constraint_list(Renaming, Unproven0, Unproven),
- apply_variable_renaming_to_constraint_list(Renaming, Assumed0, Assumed),
+ % Most of the time, !.Constraints contains nothing. Even when some
+ % of its fields are not empty, some others may be.
+ (
+ Unproven0 = [],
+ Assumed0 = [],
+ map.is_empty(Redundant0),
+ map.is_empty(Ancestors0)
+ ->
+ true
+ ;
+ apply_variable_renaming_to_constraint_list(Renaming,
+ Unproven0, Unproven),
+ apply_variable_renaming_to_constraint_list(Renaming,
+ Assumed0, Assumed),
+ ( map.is_empty(Redundant0) ->
+ Redundant = Redundant0
+ ;
Pred = (pred(C0::in, C::out) is det :-
set.to_sorted_list(C0, L0),
apply_variable_renaming_to_constraint_list(Renaming, L0, L),
set.list_to_set(L, C)
),
- map.map_values_only(Pred, Redundant0, Redundant),
+ map.map_values_only(Pred, Redundant0, Redundant)
+ ),
+ ( map.is_empty(Ancestors0) ->
+ Ancestors = Ancestors0
+ ;
map.keys(Ancestors0, AncestorsKeys0),
map.values(Ancestors0, AncestorsValues0),
- apply_variable_renaming_to_prog_constraint_list(Renaming, AncestorsKeys0,
- AncestorsKeys),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ AncestorsKeys0, AncestorsKeys),
list.map(apply_variable_renaming_to_prog_constraint_list(Renaming),
AncestorsValues0, AncestorsValues),
- map.from_corresponding_lists(AncestorsKeys, AncestorsValues, Ancestors),
- !:Constraints = hlds_constraints(Unproven, Assumed, Redundant, Ancestors).
+ map.from_corresponding_lists(AncestorsKeys, AncestorsValues,
+ Ancestors)
+ ),
+ !:Constraints =
+ hlds_constraints(Unproven, Assumed, Redundant, Ancestors)
+ ).
apply_subst_to_constraints(Subst, !Constraints) :-
!.Constraints = hlds_constraints(Unproven0, Assumed0,
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.468
diff -u -b -r1.468 typecheck.m
--- compiler/typecheck.m 14 Jun 2012 07:08:29 -0000 1.468
+++ compiler/typecheck.m 19 Jun 2012 07:07:57 -0000
@@ -1745,7 +1745,8 @@
type_assign_set_head_type_params(HeadTypeParams, TypeAssign1, TypeAssign),
% Save the results and recurse.
- NewArgTypeAssign = args(TypeAssign, ParentArgTypes, ParentConstraints),
+ NewArgTypeAssign =
+ args_type_assign(TypeAssign, ParentArgTypes, ParentConstraints),
!:ArgTypeAssigns = [NewArgTypeAssign | !.ArgTypeAssigns],
rename_apart(TypeAssigns0, PredTypeVarSet, PredExistQVars,
PredArgTypes, PredConstraints, !ArgTypeAssigns).
@@ -1807,7 +1808,7 @@
skip_arg([], []).
skip_arg([ArgTypeAssign0 | ArgTypeAssigns0],
[ArgTypeAssign | ArgTypeAssigns]) :-
- ArgTypeAssign0 = args(TypeAssign, Args0, Constraints),
+ ArgTypeAssign0 = args_type_assign(TypeAssign, Args0, Constraints),
(
Args0 = [_ | Args]
;
@@ -1815,7 +1816,7 @@
% this should never happen
unexpected($module, $pred, "skip_arg")
),
- ArgTypeAssign = args(TypeAssign, Args, Constraints),
+ ArgTypeAssign = args_type_assign(TypeAssign, Args, Constraints),
skip_arg(ArgTypeAssigns0, ArgTypeAssigns).
:- pred typecheck_var_has_arg_type_2(args_type_assign_set::in, prog_var::in,
@@ -1824,7 +1825,7 @@
typecheck_var_has_arg_type_2([], _, !ArgTypeAssignSet).
typecheck_var_has_arg_type_2([ArgsTypeAssign | ArgsTypeAssignSets], Var,
!ArgsTypeAssignSet) :-
- ArgsTypeAssign = args(TypeAssign0, ArgTypes0, ClassContext),
+ ArgsTypeAssign = args_type_assign(TypeAssign0, ArgTypes0, ClassContext),
arg_type_assign_var_has_type(TypeAssign0, ArgTypes0,
Var, ClassContext, !ArgsTypeAssignSet),
typecheck_var_has_arg_type_2(ArgsTypeAssignSets, Var,
@@ -1846,7 +1847,8 @@
type_assign_unify_type(TypeAssign0, OldVarType, Type,
TypeAssign1)
->
- NewTypeAssign = args(TypeAssign1, ArgTypes, ClassContext),
+ NewTypeAssign =
+ args_type_assign(TypeAssign1, ArgTypes, ClassContext),
!:ArgTypeAssignSet = [NewTypeAssign | !.ArgTypeAssignSet]
;
true
@@ -1854,7 +1856,8 @@
;
MaybeOldVarType = no,
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
- NewTypeAssign = args(TypeAssign, ArgTypes, ClassContext),
+ NewTypeAssign =
+ args_type_assign(TypeAssign, ArgTypes, ClassContext),
!:ArgTypeAssignSet = [NewTypeAssign | !.ArgTypeAssignSet]
)
;
@@ -2246,7 +2249,7 @@
typecheck_functor_arg_types([], _, _, !TypeAssignSet).
typecheck_functor_arg_types([ConsTypeAssign | ConsTypeAssigns], Args, Info,
!TypeAssignSet) :-
- ConsTypeAssign = args(TypeAssign, ArgTypes, _),
+ ConsTypeAssign = args_type_assign(TypeAssign, ArgTypes, _),
type_assign_var_has_type_list(Args, ArgTypes, TypeAssign, Info,
!TypeAssignSet),
typecheck_functor_arg_types(ConsTypeAssigns, Args, Info, !TypeAssignSet).
@@ -2334,7 +2337,8 @@
% The constraints are empty here because none are added by
% unification with a functor.
empty_hlds_constraints(EmptyConstraints),
- ArgsTypeAssign = args(TypeAssign, ArgTypes, EmptyConstraints),
+ ArgsTypeAssign =
+ args_type_assign(TypeAssign, ArgTypes, EmptyConstraints),
!:ArgsTypeAssignSet = [ArgsTypeAssign | !.ArgsTypeAssignSet]
;
true
@@ -2345,7 +2349,8 @@
% unification with a functor.
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
empty_hlds_constraints(EmptyConstraints),
- ArgsTypeAssign = args(TypeAssign, ArgTypes, EmptyConstraints),
+ ArgsTypeAssign =
+ args_type_assign(TypeAssign, ArgTypes, EmptyConstraints),
!:ArgsTypeAssignSet = [ArgsTypeAssign | !.ArgsTypeAssignSet]
).
@@ -2390,7 +2395,7 @@
% Rename apart the type vars in the type of the constructor
% and the types of its arguments.
- % (Optimize the common case of a non-polymorphic type)
+ % (Optimize the common case of a non-polymorphic type.)
(
varset.is_empty(ConsTypeVarSet)
->
Index: compiler/typecheck_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck_errors.m,v
retrieving revision 1.55
diff -u -b -r1.55 typecheck_errors.m
--- compiler/typecheck_errors.m 18 Apr 2012 02:25:00 -0000 1.55
+++ compiler/typecheck_errors.m 19 Jun 2012 07:07:57 -0000
@@ -1897,7 +1897,7 @@
get_arg_type_stuff([], _Var, []).
get_arg_type_stuff([ArgTypeAssign | ArgTypeAssigns], Var, ArgTypeStuffs) :-
- ArgTypeAssign = args(TypeAssign, ArgTypes, _),
+ ArgTypeAssign = args_type_assign(TypeAssign, ArgTypes, _),
get_arg_type_stuff(ArgTypeAssigns, Var, TailArgTypeStuffs),
type_assign_get_head_type_params(TypeAssign, HeadTypeParams),
type_assign_get_type_bindings(TypeAssign, TypeBindings),
Index: compiler/typecheck_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck_info.m,v
retrieving revision 1.39
diff -u -b -r1.39 typecheck_info.m
--- compiler/typecheck_info.m 14 Jun 2012 07:08:29 -0000 1.39
+++ compiler/typecheck_info.m 19 Jun 2012 07:07:57 -0000
@@ -228,23 +228,23 @@
:- type type_assign
---> type_assign(
- var_types :: vartypes,
- type_varset :: tvarset,
+ ta_var_types :: vartypes,
+ ta_type_varset :: tvarset,
% Universally quantified type variables.
- head_type_params :: head_type_params,
+ ta_head_type_params :: head_type_params,
% Type bindings.
- type_bindings :: tsubst,
+ ta_type_bindings :: tsubst,
% The set of class constraints collected so far.
- class_constraints :: hlds_constraints,
+ ta_class_constraints :: hlds_constraints,
% For each constraint found to be redundant, why is it so?
- constraint_proofs :: constraint_proof_map,
+ ta_constraint_proofs :: constraint_proof_map,
% Maps constraint identifiers to the actual constraints.
- constraint_map :: constraint_map
+ ta_constraint_map :: constraint_map
).
%-----------------------------------------------------------------------------%
@@ -291,13 +291,15 @@
:- type args_type_assign_set == list(args_type_assign).
:- type args_type_assign
- ---> args(
- caller_arg_assign :: type_assign,
+ ---> args_type_assign(
% Type assignment.
- callee_arg_types :: list(mer_type),
+ ata_caller_arg_assign :: type_assign,
+
% Types of callee args, renamed apart.
- callee_constraints :: hlds_constraints
+ ata_callee_arg_types :: list(mer_type),
+
% Constraints from callee, renamed apart.
+ ata_callee_constraints :: hlds_constraints
).
:- func get_caller_arg_assign(args_type_assign) = type_assign.
@@ -318,23 +320,22 @@
:- type cons_type_info
---> cons_type_info(
- cti_varset :: tvarset,
% Type variables.
+ cti_varset :: tvarset,
- cti_exit_tvars :: existq_tvars,
% Existentially quantified type vars.
+ cti_exit_tvars :: existq_tvars,
- cti_result_type :: mer_type,
% Constructor type.
+ cti_result_type :: mer_type,
- cti_arg_types :: list(mer_type),
% Types of the arguments.
+ cti_arg_types :: list(mer_type),
+ % Constraints introduced by this constructor (e.g. if it is
+ % actually a function, or if it is an existentially quantified
+ % data constructor).
cti_constraints :: hlds_constraints,
- % Constraints introduced by this
- % constructor (e.g. if it is actually
- % a function, or if it is an existentially
- % quantified data constructor).
cti_source :: cons_type_info_source
).
@@ -676,39 +677,39 @@
%-----------------------------------------------------------------------------%
-type_assign_get_var_types(TA, TA ^ var_types).
-type_assign_get_typevarset(TA, TA ^ type_varset).
-type_assign_get_head_type_params(TA, TA ^ head_type_params).
-type_assign_get_type_bindings(TA, TA ^ type_bindings).
-type_assign_get_typeclass_constraints(TA, TA ^ class_constraints).
-type_assign_get_constraint_proofs(TA, TA ^ constraint_proofs).
-type_assign_get_constraint_map(TA, TA ^ constraint_map).
+type_assign_get_var_types(TA, TA ^ ta_var_types).
+type_assign_get_typevarset(TA, TA ^ ta_type_varset).
+type_assign_get_head_type_params(TA, TA ^ ta_head_type_params).
+type_assign_get_type_bindings(TA, TA ^ ta_type_bindings).
+type_assign_get_typeclass_constraints(TA, TA ^ ta_class_constraints).
+type_assign_get_constraint_proofs(TA, TA ^ ta_constraint_proofs).
+type_assign_get_constraint_map(TA, TA ^ ta_constraint_map).
type_assign_set_var_types(VarTypes, !TA) :-
- !TA ^ var_types := VarTypes.
+ !TA ^ ta_var_types := VarTypes.
type_assign_set_typevarset(TVarSet, !TA) :-
- !TA ^ type_varset := TVarSet.
+ !TA ^ ta_type_varset := TVarSet.
type_assign_set_head_type_params(HeadTypeParams, !TA) :-
- !TA ^ head_type_params := HeadTypeParams.
+ !TA ^ ta_head_type_params := HeadTypeParams.
type_assign_set_type_bindings(TypeBindings, !TA) :-
- !TA ^ type_bindings := TypeBindings.
+ !TA ^ ta_type_bindings := TypeBindings.
type_assign_set_typeclass_constraints(Constraints, !TA) :-
- !TA ^ class_constraints := Constraints.
+ !TA ^ ta_class_constraints := Constraints.
type_assign_set_constraint_proofs(Proofs, !TA) :-
- !TA ^ constraint_proofs := Proofs.
+ !TA ^ ta_constraint_proofs := Proofs.
type_assign_set_constraint_map(ConstraintMap, !TA) :-
- !TA ^ constraint_map := ConstraintMap.
+ !TA ^ ta_constraint_map := ConstraintMap.
type_assign_set_reduce_results(Bindings, TVarSet, Constraints, Proofs,
ConstraintMap, !TA) :-
% This should allocate just one new type_assign, whereas separate calls
% to the predicates above to set each of these fields would allocate
% several.
- !TA ^ type_bindings := Bindings,
- !TA ^ type_varset := TVarSet,
- !TA ^ class_constraints := Constraints,
- !TA ^ constraint_proofs := Proofs,
- !TA ^ constraint_map := ConstraintMap.
+ !TA ^ ta_type_bindings := Bindings,
+ !TA ^ ta_type_varset := TVarSet,
+ !TA ^ ta_class_constraints := Constraints,
+ !TA ^ ta_constraint_proofs := Proofs,
+ !TA ^ ta_constraint_map := ConstraintMap.
%-----------------------------------------------------------------------------%
@@ -720,7 +721,7 @@
convert_args_type_assign_set_check_empty_args([]) = [].
convert_args_type_assign_set_check_empty_args([ArgTypeAssign | ArgTypeAssigns])
= Result :-
- ArgTypeAssign = args(_, Args, _),
+ ArgTypeAssign = args_type_assign(_, Args, _),
(
Args = [],
Result =
@@ -735,7 +736,8 @@
:- func convert_args_type_assign(args_type_assign) = type_assign.
-convert_args_type_assign(args(TypeAssign0, _, Constraints0)) = TypeAssign :-
+convert_args_type_assign(args_type_assign(TypeAssign0, _, Constraints0))
+ = TypeAssign :-
type_assign_get_typeclass_constraints(TypeAssign0, OldConstraints),
type_assign_get_type_bindings(TypeAssign0, Bindings),
apply_rec_subst_to_constraints(Bindings, Constraints0, Constraints),
@@ -743,9 +745,12 @@
type_assign_set_typeclass_constraints(NewConstraints,
TypeAssign0, TypeAssign).
-get_caller_arg_assign(ArgsTypeAssign) = ArgsTypeAssign ^ caller_arg_assign.
-get_callee_arg_types(ArgsTypeAssign) = ArgsTypeAssign ^ callee_arg_types.
-get_callee_constraints(ArgsTypeAssign) = ArgsTypeAssign ^ callee_constraints.
+get_caller_arg_assign(ArgsTypeAssign) =
+ ArgsTypeAssign ^ ata_caller_arg_assign.
+get_callee_arg_types(ArgsTypeAssign) =
+ ArgsTypeAssign ^ ata_callee_arg_types.
+get_callee_constraints(ArgsTypeAssign) =
+ ArgsTypeAssign ^ ata_callee_constraints.
project_cons_type_info_source(CTI) = CTI ^ cti_source.
@@ -776,7 +781,7 @@
write_args_type_assign_set([ArgTypeAssign | ArgTypeAssigns], VarSet, !IO) :-
% XXX Why does this simply pick the TypeAssign part of the ArgTypeAssign,
% instead of invoking convert_args_type_assign?
- ArgTypeAssign = args(TypeAssign, _ArgTypes, _Cnstrs),
+ ArgTypeAssign = args_type_assign(TypeAssign, _ArgTypes, _Cnstrs),
io.write_string("\t", !IO),
write_type_assign(TypeAssign, VarSet, !IO),
io.write_string("\n", !IO),
@@ -787,7 +792,7 @@
VarSet) = Pieces :-
% XXX Why does this simply pick the TypeAssign part of the ArgTypeAssign,
% instead of invoking convert_args_type_assign?
- ArgTypeAssign = args(TypeAssign, _ArgTypes, _Cnstrs),
+ ArgTypeAssign = args_type_assign(TypeAssign, _ArgTypes, _Cnstrs),
Pieces = type_assign_to_pieces(TypeAssign, MaybeSeq, VarSet) ++
args_type_assign_set_to_pieces(ArgTypeAssigns, inc_maybe_seq(MaybeSeq),
VarSet).
cvs diff: Diffing compiler/notes
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/base64
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/fixed
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_allegro
cvs diff: Diffing extras/graphics/mercury_allegro/examples
cvs diff: Diffing extras/graphics/mercury_allegro/samples
cvs diff: Diffing extras/graphics/mercury_allegro/samples/demo
cvs diff: Diffing extras/graphics/mercury_allegro/samples/mandel
cvs diff: Diffing extras/graphics/mercury_allegro/samples/pendulum2
cvs diff: Diffing extras/graphics/mercury_allegro/samples/speed
cvs diff: Diffing extras/graphics/mercury_cairo
cvs diff: Diffing extras/graphics/mercury_cairo/samples
cvs diff: Diffing extras/graphics/mercury_cairo/samples/data
cvs diff: Diffing extras/graphics/mercury_cairo/tutorial
cvs diff: Diffing extras/graphics/mercury_glfw
cvs diff: Diffing extras/graphics/mercury_glfw/samples
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/log4m
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/monte
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/mopenssl
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/net
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/posix/samples
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
Index: library/bimap.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/bimap.m,v
retrieving revision 1.33
diff -u -b -r1.33 bimap.m
--- library/bimap.m 20 May 2011 17:24:32 -0000 1.33
+++ library/bimap.m 19 Jun 2012 07:07:57 -0000
@@ -1,7 +1,8 @@
%---------------------------------------------------------------------------%
% vim: ts=4 sw=4 et tw=0 wm=0 ft=mercury
%---------------------------------------------------------------------------%
-% Copyright (C) 1994-1995, 1997, 1999, 2004-2006, 2008, 2011 The University of Melbourne.
+% Copyright (C) 1994-1995,1997,1999,2004-2006,2008,2011-2012
+% The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------%
@@ -25,6 +26,7 @@
:- import_module assoc_list.
:- import_module list.
:- import_module map.
+:- import_module maybe.
%-----------------------------------------------------------------------------%
@@ -106,6 +108,17 @@
:- pred bimap.det_insert(K::in, V::in, bimap(K, V)::in, bimap(K, V)::out)
is det.
+ % bimap.search_insert(K, V, MaybeOldV, !Bimap):
+ %
+ % Search for the key K in the bimap. If the key is already in the bimap,
+ % with corresponding value OldV, set MaybeOldV to yes(OldV). If it
+ % is not in the bimap, then insert it with value V. The value of V
+ % should be guaranteed to be different to all the values already
+ % in !.Bimap. If it isn't, this predicate will abort.
+ %
+:- pred bimap.search_insert(K::in, V::in, maybe(V)::out,
+ bimap(K, V)::in, bimap(K, V)::out) is det.
+
% Update the key and value if already present, otherwise insert the
% new key and value.
%
@@ -398,9 +411,26 @@
bimap.det_insert(!.BM, K, V) = !:BM :-
bimap.det_insert(K, V, !BM).
-bimap.det_insert(K, V, bimap(!.Forward, !.Reverse), bimap(!:Forward, !:Reverse)) :-
- map.det_insert(K, V, !Forward),
- map.det_insert(V, K, !Reverse).
+bimap.det_insert(K, V, !Bimap) :-
+ !.Bimap = bimap(Forward0, Reverse0),
+ map.det_insert(K, V, Forward0, Forward),
+ map.det_insert(V, K, Reverse0, Reverse),
+ !:Bimap = bimap(Forward, Reverse).
+
+bimap.search_insert(K, V, MaybeOldV, !Bimap) :-
+ !.Bimap = bimap(Forward0, Reverse0),
+ map.search_insert(K, V, MaybeOldV, Forward0, Forward),
+ (
+ MaybeOldV = yes(_)
+ % No insertion or any other modification takes place in this case;
+ % leave !Bimap alone.
+ ;
+ MaybeOldV = no,
+ % We just inserted K->V into Forward, so now we insert V->K into
+ % Reverse.
+ map.det_insert(V, K, Reverse0, Reverse),
+ !:Bimap = bimap(Forward, Reverse)
+ ).
bimap.set(!.BM, K, V) = !:BM :-
bimap.set(K, V, !BM).
cvs diff: Diffing m4
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/appengine
cvs diff: Diffing samples/appengine/war
cvs diff: Diffing samples/appengine/war/WEB-INF
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/standalone_c
cvs diff: Diffing samples/concurrency
cvs diff: Diffing samples/concurrency/dining_philosophers
cvs diff: Diffing samples/concurrency/midimon
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/java_interface
cvs diff: Diffing samples/java_interface/java_calls_mercury
cvs diff: Diffing samples/java_interface/mercury_calls_java
cvs diff: Diffing samples/lazy_list
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/solver_types
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing ssdb
cvs diff: Diffing tests
cvs diff: Diffing tests/analysis
cvs diff: Diffing tests/analysis/ctgc
cvs diff: Diffing tests/analysis/excp
cvs diff: Diffing tests/analysis/ext
cvs diff: Diffing tests/analysis/sharing
cvs diff: Diffing tests/analysis/table
cvs diff: Diffing tests/analysis/trail
cvs diff: Diffing tests/analysis/unused_args
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/feedback
cvs diff: Diffing tests/feedback/mandelbrot
cvs diff: Diffing tests/feedback/mmc
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/par_conj
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/stm
cvs diff: Diffing tests/stm/orig
cvs diff: Diffing tests/stm/orig/stm-compiler
cvs diff: Diffing tests/stm/orig/stm-compiler/test1
cvs diff: Diffing tests/stm/orig/stm-compiler/test10
cvs diff: Diffing tests/stm/orig/stm-compiler/test2
cvs diff: Diffing tests/stm/orig/stm-compiler/test3
cvs diff: Diffing tests/stm/orig/stm-compiler/test4
cvs diff: Diffing tests/stm/orig/stm-compiler/test5
cvs diff: Diffing tests/stm/orig/stm-compiler/test6
cvs diff: Diffing tests/stm/orig/stm-compiler/test7
cvs diff: Diffing tests/stm/orig/stm-compiler/test8
cvs diff: Diffing tests/stm/orig/stm-compiler/test9
cvs diff: Diffing tests/stm/orig/stm-compiler-par
cvs diff: Diffing tests/stm/orig/stm-compiler-par/bm1
cvs diff: Diffing tests/stm/orig/stm-compiler-par/bm2
cvs diff: Diffing tests/stm/orig/stm-compiler-par/stmqueue
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test1
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test10
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test11
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test2
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test3
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test4
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test5
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test6
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test7
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test8
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test9
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test1
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test2
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test3
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test4
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test5
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test6
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test7
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test8
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test9
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list