[m-rev.] for post-commit review: speeding up type_table lookups
Zoltan Somogyi
zs at csse.unimelb.edu.au
Fri Sep 4 12:27:09 AEST 2009
Lookups in the map from type_ctors to their definitions are relatively
expensive, due to the cost of repeatedly comparing type_ctors, comparisons
that are relatively expensive. This diff replaces that direct map
with a two-stage map, the first stage being a map on the type constructor name
(a plain string), and the second stage being a map of the full type_ctor.
Most of the job of searching is done by the first map, since the second map
can be expected to have only one entry most of the time.
An earlier diff yielded a reduction of 1.1% in compilation time, as measured
by a version of tools/speedtest which compiles six modules in grade hlc.gc.
The speedup when compiling in grade asm_fast.gc was 0.6%. (The MLDS code
generator does more lookups of type definitions than the LLDS code generator.)
This diff also has some more changes that led to some further speedups, but
I don't have the original basis for comparison anymore.
Note that making the type table's type abstract leads to a slowdown,
but the faster data structure more than compensates for it.
compiler/hlds_data.m:
Make the type table an abstract type, and change its representation
as described above. Provide the operations on it that are needed
by the other modules of the compiler.
compiler/*.m:
Use the operations provided by hlds_data.m instead of operations on
maps to access the type table.
In several cases replace old code that iterated on keys and looked up
the associated values in the map, with new code that iterates on an
association list that puts the value right next to its key (a list
that the old code just threw away).
In other cases, change code that iterated on a list of the keys
to iterating on the whole assoc_list instead, paying attention only
to the keys. This is faster, since it avoids allocating memory
for the list of keys.
compiler/type_ctor_info.m:
This module used to use a roundabout method of generating
type_ctor_gen_infos for the builtin types conceptually defined
in builtin.m. It used to add their type_ctors to the list of
user-defined type_ctors it processed, and the code that processed
each type_ctor would check whether it was one of these, and if yes,
handle them specially.
This diff makes the code handle these builtin type_ctors and
user-defined type_ctors separately, avoiding a whole bunch of tests.
compiler/typecheck_errors.m:
Sort lists of types shown in error messages. The new data type table
would naturally lead to slightly different orders of types in error
messages than the old one; this change neutralizes such effects
for the future.
tests/invalid/ambiguous_overloading.err_exp:
tests/invalid/errors2.err_exp:
tests/warnings/ambiguous_overloading.exp:
Expect sorted types in error messages.
Zoltan.
cvs diff: Diffing .
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/include
cvs diff: Diffing boehm_gc/include/private
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/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing boehm_gc/windows-untested
cvs diff: Diffing boehm_gc/windows-untested/vc60
cvs diff: Diffing boehm_gc/windows-untested/vc70
cvs diff: Diffing boehm_gc/windows-untested/vc71
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.96
diff -u -b -r1.96 add_pragma.m
--- compiler/add_pragma.m 3 Sep 2009 23:07:25 -0000 1.96
+++ compiler/add_pragma.m 3 Sep 2009 23:28:41 -0000
@@ -564,12 +564,12 @@
add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
!Specs) :-
TypeCtor = type_ctor(TypeName, TypeArity),
- module_info_get_type_table(!.ModuleInfo, Types0),
+ module_info_get_type_table(!.ModuleInfo, TypeTable0),
ContextPieces = [
words("In"), quote("pragma reserve_tag"), words("declaration for"),
sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
],
- ( map.search(Types0, TypeCtor, TypeDefn0) ->
+ ( search_type_ctor_defn(TypeTable0, TypeCtor, TypeDefn0) ->
hlds_data.get_type_defn_body(TypeDefn0, TypeBody0),
hlds_data.get_type_defn_status(TypeDefn0, TypeStatus),
(
@@ -620,8 +620,9 @@
EnumDummy, MaybeUserEqComp, ReservedTag, ReservedAddr,
IsForeign),
hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
- map.set(Types0, TypeCtor, TypeDefn, Types),
- module_info_set_type_table(Types, !ModuleInfo)
+ replace_type_ctor_defn(TypeCtor, TypeDefn,
+ TypeTable0, TypeTable),
+ module_info_set_type_table(TypeTable, !ModuleInfo)
;
( TypeBody0 = hlds_eqv_type(_)
; TypeBody0 = hlds_foreign_type(_)
@@ -662,7 +663,7 @@
add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
Overrides, _ImportStatus, Context, !ModuleInfo, !Specs) :-
TypeCtor = type_ctor(TypeName, TypeArity),
- module_info_get_type_table(!.ModuleInfo, TypeDefnTable),
+ module_info_get_type_table(!.ModuleInfo, TypeTable),
ContextPieces = [
words("In"), fixed("`pragma foreign_export_enum'"),
words("declaration for"),
@@ -686,7 +687,7 @@
suffix(".")
]
;
- ( map.search(TypeDefnTable, TypeCtor, TypeDefn) ->
+ ( search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) ->
get_type_defn_body(TypeDefn, TypeBody),
(
( TypeBody = hlds_eqv_type(_)
@@ -1039,13 +1040,12 @@
)
->
MaybeSeverity = yes(severity_error),
- ErrorPieces = [
- words("error: "),
+ ErrorPieces = [words("error: "),
sym_name_and_arity(TypeName / TypeArity),
- words("is an atomic type"),
- suffix(".")
- ]
- ; map.search(TypeTable0, TypeCtor, TypeDefn0) ->
+ words("is an atomic type"), suffix(".")]
+ ;
+ search_type_ctor_defn(TypeTable0, TypeCtor, TypeDefn0)
+ ->
get_type_defn_body(TypeDefn0, TypeBody0),
(
( TypeBody0 = hlds_eqv_type(_)
@@ -1054,12 +1054,9 @@
; TypeBody0 = hlds_foreign_type(_)
),
MaybeSeverity = yes(severity_error),
- ErrorPieces = [
- words("error: "),
+ ErrorPieces = [words("error: "),
sym_name_and_arity(TypeName / TypeArity),
- words("is not an enumeration type"),
- suffix(".")
- ]
+ words("is not an enumeration type"), suffix(".")]
;
TypeBody0 = hlds_du_type(Ctors, OldTagValues, CheaperTagTest,
DuTypeKind0, MaybeUserEq, ReservedTag, ReservedAddr,
@@ -1109,8 +1106,8 @@
CheaperTagTest, DuTypeKind, MaybeUserEq,
ReservedTag, ReservedAddr, IsForeignType),
set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
- svmap.set(TypeCtor, TypeDefn, TypeTable0,
- TypeTable),
+ replace_type_ctor_defn(TypeCtor, TypeDefn,
+ TypeTable0, TypeTable),
module_info_set_type_table(TypeTable, !ModuleInfo)
;
UnmappedCtors = [_ | _],
@@ -1133,11 +1130,9 @@
ErrorPieces = []
;
MaybeSeverity = yes(severity_error),
- ErrorPieces = [
- words("error: "),
+ ErrorPieces = [words("error: "),
sym_name_and_arity(TypeName / TypeArity),
- words("is not defined in this module.")
- ]
+ words("is not defined in this module.")]
)
;
DuTypeKind0 = du_type_kind_foreign_enum(_),
@@ -1146,23 +1141,18 @@
ErrorPieces = []
;
MaybeSeverity = yes(severity_error),
- ErrorPieces = [
- words("error: "),
+ ErrorPieces = [words("error: "),
sym_name_and_arity(TypeName / TypeArity),
- words("has multiple foreign_enum pragmas.")
- ]
+ words("has multiple foreign_enum pragmas.")]
)
;
( DuTypeKind0 = du_type_kind_general
; DuTypeKind0 = du_type_kind_notag(_, _, _)
),
MaybeSeverity = yes(severity_error),
- ErrorPieces = [
- words("error: "),
+ ErrorPieces = [words("error: "),
sym_name_and_arity(TypeName / TypeArity),
- words("is not an enumeration type"),
- suffix(".")
- ]
+ words("is not an enumeration type"), suffix(".")]
)
)
;
Index: compiler/add_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_type.m,v
retrieving revision 1.35
diff -u -b -r1.35 add_type.m
--- compiler/add_type.m 12 Jun 2009 05:21:26 -0000 1.35
+++ compiler/add_type.m 29 Aug 2009 14:27:46 -0000
@@ -86,17 +86,15 @@
list.length(Args, Arity),
TypeCtor = type_ctor(Name, Arity),
convert_type_defn(TypeDefn, TypeCtor, Globals, Body0),
- module_info_get_type_table(!.ModuleInfo, Types0),
(
(
Body0 = hlds_abstract_type(_)
;
Body0 = hlds_du_type(_, _, _, _, _, _, _, _),
string.suffix(term.context_file(Context), ".int2")
- % If the type definition comes from a .int2 file then
- % we need to treat it as abstract. The constructors
- % may only be used by the mode system for comparing
- % `bound' insts to `ground'.
+ % If the type definition comes from a .int2 file then we must
+ % treat it as abstract. The constructors may only be used
+ % by the mode system for comparing `bound' insts to `ground'.
)
->
make_status_abstract(Status0, Status1)
@@ -107,7 +105,7 @@
% Discriminated unions whose definition consists of a single
% zero-arity constructor are dummy types. Dummy types are not allowed
% to have user-defined equality or comparison.
- %
+
TypeDefn = parse_tree_du_type(Ctors, MaybeUserUC),
Ctors = [Constructor],
list.length(Constructor ^ cons_args, 0),
@@ -115,17 +113,13 @@
% Only report errors for types defined in this module.
status_defined_in_this_module(Status0) = yes
->
- DummyMainPieces = [
- words("Error: the type"),
+ DummyMainPieces = [words("Error: the type"),
sym_name_and_arity(Name / Arity),
words("is not allowed to have user-defined equality"),
- words("or comparison.")
- ],
- DummyVerbosePieces = [
- words("Discriminated unions whose body consists of a single"),
- words("zero-arity constructor cannot have user-defined"),
- words("equality or comparison.")
- ],
+ words("or comparison.")],
+ DummyVerbosePieces = [words("Discriminated unions whose body"),
+ words("consists of a single zero-arity constructor"),
+ words("cannot have user-defined equality or comparison.")],
DummyMsg = simple_msg(Context,
[always(DummyMainPieces), verbose_only(DummyVerbosePieces)]),
DummySpec = error_spec(severity_error, phase_parse_tree_to_hlds,
@@ -134,10 +128,11 @@
;
true
),
+ module_info_get_type_table(!.ModuleInfo, TypeTable0),
(
% The type is exported if *any* occurrence is exported,
% even a previous abstract occurrence.
- map.search(Types0, TypeCtor, OldDefn0)
+ search_type_ctor_defn(TypeTable0, TypeCtor, OldDefn0)
->
hlds_data.get_type_defn_status(OldDefn0, OldStatus),
combine_status(Status1, OldStatus, Status),
@@ -169,15 +164,14 @@
% kind system.
map.init(KindMap),
hlds_data.set_type_defn(TVarSet, Args, KindMap, Body, Status, no,
- NeedQual, Context, T),
+ NeedQual, Context, TypeDefn1),
(
MaybeOldDefn = no,
Body = hlds_foreign_type(_)
->
- ForeignDeclPieces = [
- words("Error: type "), sym_name_and_arity(Name / Arity),
- words("defined as foreign_type without being declared.")
- ],
+ ForeignDeclPieces = [words("Error: type "),
+ sym_name_and_arity(Name / Arity),
+ words("defined as foreign_type without being declared.")],
ForeignDeclMsg = simple_msg(Context, [always(ForeignDeclPieces)]),
ForeignDeclSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
[ForeignDeclMsg]),
@@ -191,26 +185,24 @@
status_is_exported_to_non_submodules(OldStatus1) = no,
status_is_exported_to_non_submodules(Status0) = yes
->
- ForeignVisPieces = [
- words("Error: pragma foreign_type "),
+ ForeignVisPieces = [words("Error: pragma foreign_type "),
sym_name_and_arity(Name / Arity),
- words("must have the same visibility as the type declaration.")
- ],
+ words("must have the same visibility as the type declaration.")],
ForeignVisMsg = simple_msg(Context, [always(ForeignVisPieces)]),
ForeignVisSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
[ForeignVisMsg]),
!:Specs = [ForeignVisSpec | !.Specs]
;
% If there was an existing non-abstract definition for the type, ...
- MaybeOldDefn = yes(T2),
- hlds_data.get_type_defn_tvarset(T2, TVarSet_2),
- hlds_data.get_type_defn_tparams(T2, Params_2),
- hlds_data.get_type_defn_kind_map(T2, KindMap_2),
- hlds_data.get_type_defn_body(T2, Body_2),
- hlds_data.get_type_defn_context(T2, OrigContext),
- hlds_data.get_type_defn_status(T2, OrigStatus),
- hlds_data.get_type_defn_in_exported_eqv(T2, OrigInExportedEqv),
- hlds_data.get_type_defn_need_qualifier(T2, OrigNeedQual),
+ MaybeOldDefn = yes(OldDefn2),
+ hlds_data.get_type_defn_tvarset(OldDefn2, TVarSet_2),
+ hlds_data.get_type_defn_tparams(OldDefn2, Params_2),
+ hlds_data.get_type_defn_kind_map(OldDefn2, KindMap_2),
+ hlds_data.get_type_defn_body(OldDefn2, Body_2),
+ hlds_data.get_type_defn_context(OldDefn2, OrigContext),
+ hlds_data.get_type_defn_status(OldDefn2, OrigStatus),
+ hlds_data.get_type_defn_in_exported_eqv(OldDefn2, OrigInExportedEqv),
+ hlds_data.get_type_defn_need_qualifier(OldDefn2, OrigNeedQual),
Body_2 \= hlds_abstract_type(_)
->
globals.get_target(Globals, Target),
@@ -231,9 +223,10 @@
;
hlds_data.set_type_defn(TVarSet_2, Params_2, KindMap_2,
Body_2, Status, OrigInExportedEqv, OrigNeedQual,
- OrigContext, T3),
- map.det_update(Types0, TypeCtor, T3, Types),
- module_info_set_type_table(Types, !ModuleInfo)
+ OrigContext, TypeDefn3),
+ replace_type_ctor_defn(TypeCtor, TypeDefn3,
+ TypeTable0, TypeTable),
+ module_info_set_type_table(TypeTable, !ModuleInfo)
)
;
merge_foreign_type_bodies(Target, MakeOptInt, Body, Body_2,
@@ -241,9 +234,11 @@
->
( check_foreign_type_visibility(OrigStatus, Status1) ->
hlds_data.set_type_defn(TVarSet_2, Params_2, KindMap_2,
- NewBody, Status, OrigInExportedEqv, NeedQual, Context, T3),
- map.det_update(Types0, TypeCtor, T3, Types),
- module_info_set_type_table(Types, !ModuleInfo)
+ NewBody, Status, OrigInExportedEqv, NeedQual, Context,
+ TypeDefn3),
+ replace_type_ctor_defn(TypeCtor, TypeDefn3,
+ TypeTable0, TypeTable),
+ module_info_set_type_table(TypeTable, !ModuleInfo)
;
module_info_incr_errors(!ModuleInfo),
DiffVisPieces = [words("In definition of type"),
@@ -267,8 +262,9 @@
OrigContext, [], !Specs)
)
;
- map.set(Types0, TypeCtor, T, Types),
- module_info_set_type_table(Types, !ModuleInfo),
+ add_or_replace_type_ctor_defn(TypeCtor, TypeDefn1,
+ TypeTable0, TypeTable),
+ module_info_set_type_table(TypeTable, !ModuleInfo),
(
% XXX We can't handle abstract exported polymorphic equivalence
% types with monomorphic bodies, because the compiler stuffs up
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.124
diff -u -b -r1.124 check_typeclass.m
--- compiler/check_typeclass.m 16 Jul 2009 07:27:11 -0000 1.124
+++ compiler/check_typeclass.m 28 Aug 2009 23:09:04 -0000
@@ -124,6 +124,7 @@
:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
+:- import_module assoc_list.
:- import_module bool.
:- import_module int.
:- import_module map.
@@ -1530,9 +1531,8 @@
module_info_predids(PredIds, !ModuleInfo),
list.foldl2(check_pred_constraints, PredIds, !ModuleInfo, !Specs),
module_info_get_type_table(!.ModuleInfo, TypeTable),
- map.keys(TypeTable, TypeCtors),
- list.foldl2(check_ctor_constraints(TypeTable), TypeCtors,
- !ModuleInfo, !Specs).
+ get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
+ list.foldl2(check_ctor_constraints, TypeCtorsDefns, !ModuleInfo, !Specs).
:- pred check_pred_constraints(pred_id::in,
module_info::in, module_info::out,
@@ -1589,12 +1589,11 @@
!:Specs = [Spec | !.Specs]
).
-:- pred check_ctor_constraints(type_table::in, type_ctor::in,
+:- pred check_ctor_constraints(pair(type_ctor, hlds_type_defn)::in,
module_info::in, module_info::out,
list(error_spec)::in, list(error_spec)::out) is det.
-check_ctor_constraints(TypeTable, TypeCtor, !ModuleInfo, !Specs) :-
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+check_ctor_constraints(TypeCtor - TypeDefn, !ModuleInfo, !Specs) :-
get_type_defn_body(TypeDefn, Body),
(
Body = hlds_du_type(Ctors, _, _, _, _, _, _, _),
Index: compiler/code_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.374
diff -u -b -r1.374 code_info.m
--- compiler/code_info.m 3 Sep 2009 23:07:25 -0000 1.374
+++ compiler/code_info.m 3 Sep 2009 23:28:41 -0000
@@ -981,7 +981,7 @@
get_module_info(CI, ModuleInfo),
type_to_ctor_and_args_det(Type, TypeCtor, _),
module_info_get_type_table(ModuleInfo, TypeTable),
- map.search(TypeTable, TypeCtor, TypeDefn).
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn).
lookup_type_defn(CI, Type) = TypeDefn :-
( search_type_defn(CI, Type, TypeDefnPrime) ->
Index: compiler/det_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_util.m,v
retrieving revision 1.49
diff -u -b -r1.49 det_util.m
--- compiler/det_util.m 3 Sep 2009 23:57:24 -0000 1.49
+++ compiler/det_util.m 3 Sep 2009 23:58:01 -0000
@@ -193,9 +193,9 @@
det_lookup_var_type(ModuleInfo, ProcInfo, Var, TypeDefn) :-
proc_info_get_vartypes(ProcInfo, VarTypes),
map.lookup(VarTypes, Var, Type),
- ( type_to_ctor_and_args(Type, TypeCtor, _) ->
+ ( type_to_ctor(Type, TypeCtor) ->
module_info_get_type_table(ModuleInfo, TypeTable),
- map.search(TypeTable, TypeCtor, TypeDefn)
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn)
;
unexpected(this_file, "det_lookup_var_type")
).
Index: compiler/equiv_type_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type_hlds.m,v
retrieving revision 1.56
diff -u -b -r1.56 equiv_type_hlds.m
--- compiler/equiv_type_hlds.m 3 Sep 2009 23:07:26 -0000 1.56
+++ compiler/equiv_type_hlds.m 4 Sep 2009 02:09:50 -0000
@@ -62,16 +62,16 @@
%-----------------------------------------------------------------------------%
replace_in_hlds(!ModuleInfo) :-
- module_info_get_type_table(!.ModuleInfo, Types0),
- map.foldl2(add_type_to_eqv_map, Types0, map.init, EqvMap,
- set.init, EqvExportTypes),
- set.fold(mark_eqv_exported_types, EqvExportTypes, Types0, Types1),
+ module_info_get_type_table(!.ModuleInfo, TypeTable0),
+ foldl2_over_type_ctor_defns(add_type_to_eqv_map, TypeTable0,
+ map.init, EqvMap, set.init, EqvExportTypes),
+ set.fold(mark_eqv_exported_types, EqvExportTypes, TypeTable0, TypeTable1),
module_info_get_maybe_recompilation_info(!.ModuleInfo, MaybeRecompInfo0),
module_info_get_name(!.ModuleInfo, ModuleName),
- map.map_foldl(replace_in_type_defn(ModuleName, EqvMap), Types1, Types,
- MaybeRecompInfo0, MaybeRecompInfo),
- module_info_set_type_table(Types, !ModuleInfo),
+ map_foldl_over_type_ctor_defns(replace_in_type_defn(ModuleName, EqvMap),
+ TypeTable1, TypeTable, MaybeRecompInfo0, MaybeRecompInfo),
+ module_info_set_type_table(TypeTable, !ModuleInfo),
module_info_set_maybe_recompilation_info(MaybeRecompInfo, !ModuleInfo),
module_info_get_inst_table(!.ModuleInfo, Insts0),
@@ -86,6 +86,8 @@
module_info_predids(PredIds, !ModuleInfo),
list.foldl2(replace_in_pred(EqvMap), PredIds, !ModuleInfo, InstCache, _).
+%-----------------------------------------------------------------------------%
+
:- pred add_type_to_eqv_map(type_ctor::in, hlds_type_defn::in,
eqv_map::in, eqv_map::out, set(type_ctor)::in, set(type_ctor)::out)
is det.
@@ -125,13 +127,15 @@
true
).
+%-----------------------------------------------------------------------------%
+
:- pred mark_eqv_exported_types(type_ctor::in, type_table::in, type_table::out)
is det.
mark_eqv_exported_types(TypeCtor, !TypeTable) :-
- ( map.search(!.TypeTable, TypeCtor, Defn0) ->
- set_type_defn_in_exported_eqv(yes, Defn0, Defn),
- svmap.det_update(TypeCtor, Defn, !TypeTable)
+ ( search_type_ctor_defn(!.TypeTable, TypeCtor, TypeDefn0) ->
+ set_type_defn_in_exported_eqv(yes, TypeDefn0, TypeDefn),
+ replace_type_ctor_defn(TypeCtor, TypeDefn, !TypeTable)
;
% We can get here for builtin `types' such as func. Since their unify
% and compare preds are in the runtime system, not generated by the
@@ -139,6 +143,8 @@
true
).
+%-----------------------------------------------------------------------------%
+
:- pred replace_in_type_defn(module_name::in, eqv_map::in, type_ctor::in,
hlds_type_defn::in, hlds_type_defn::out,
maybe(recompilation_info)::in, maybe(recompilation_info)::out) is det.
@@ -180,9 +186,9 @@
Body = Body0,
TVarSet = TVarSet0
),
- equiv_type.finish_recording_expanded_items(
- item_id(type_body_item, TypeCtorItem),
- EquivTypeInfo, !MaybeRecompInfo),
+ ItemId = item_id(type_body_item, TypeCtorItem),
+ equiv_type.finish_recording_expanded_items(ItemId, EquivTypeInfo,
+ !MaybeRecompInfo),
hlds_data.set_type_defn_body(Body, !Defn),
hlds_data.set_type_defn_tvarset(TVarSet, !Defn).
@@ -891,7 +897,7 @@
)
;
GoalExpr0 = unify(Var, _, _, _, _),
- module_info_get_type_table(!.Info ^ module_info, Types),
+ module_info_get_type_table(!.Info ^ module_info, TypeTable),
proc_info_get_vartypes(!.Info ^ proc_info, VarTypes),
proc_info_get_rtti_varmaps(!.Info ^ proc_info, RttiVarMaps),
map.lookup(VarTypes, Var, VarType),
@@ -904,7 +910,7 @@
GoalExpr0 ^ unify_kind = construct(_, ConsId, _, _, _, _, _),
ConsId = type_info_cell_constructor(TypeCtor),
TypeCtorCat = ctor_cat_system(cat_system_type_info),
- map.search(Types, TypeCtor, TypeDefn),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, Body),
Body = hlds_eqv_type(_)
->
@@ -949,7 +955,7 @@
GoalExpr0 ^ unify_kind = construct(_, ConsId, _, _, _, _, _),
ConsId = type_info_cell_constructor(TypeCtor),
TypeCtorCat = ctor_cat_system(cat_system_type_ctor_info),
- map.search(Types, TypeCtor, TypeDefn),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, Body),
Body = hlds_eqv_type(_)
->
Index: compiler/export.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.123
diff -u -b -r1.123 export.m
--- compiler/export.m 11 Jun 2009 07:00:08 -0000 1.123
+++ compiler/export.m 28 Aug 2009 16:27:07 -0000
@@ -820,7 +820,7 @@
ExportedEnumInfo = exported_enum_info(_Lang, Context, TypeCtor,
NameMapping),
module_info_get_type_table(ModuleInfo, TypeTable),
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
get_type_defn_body(TypeDefn, TypeBody),
(
( TypeBody = hlds_eqv_type(_)
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.80
diff -u -b -r1.80 foreign.m
--- compiler/foreign.m 2 Sep 2009 05:48:00 -0000 1.80
+++ compiler/foreign.m 3 Sep 2009 23:28:41 -0000
@@ -539,10 +539,10 @@
non_foreign_type(Type) = exported_type_mercury(Type).
to_exported_type(ModuleInfo, Type) = ExportType :-
- module_info_get_type_table(ModuleInfo, Types),
+ module_info_get_type_table(ModuleInfo, TypeTable),
(
- type_to_ctor_and_args(Type, TypeCtor, _),
- map.search(Types, TypeCtor, TypeDefn)
+ type_to_ctor(Type, TypeCtor),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn)
->
hlds_data.get_type_defn_body(TypeDefn, Body),
(
Index: compiler/hlds_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_code_util.m,v
retrieving revision 1.40
diff -u -b -r1.40 hlds_code_util.m
--- compiler/hlds_code_util.m 12 Jun 2009 05:21:26 -0000 1.40
+++ compiler/hlds_code_util.m 28 Aug 2009 16:35:59 -0000
@@ -116,7 +116,7 @@
;
ConsId = cons(_Name, _Arity, TypeCtor),
module_info_get_type_table(ModuleInfo, TypeTable),
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _, _),
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.126
diff -u -b -r1.126 hlds_data.m
--- compiler/hlds_data.m 26 Aug 2009 16:05:56 -0000 1.126
+++ compiler/hlds_data.m 30 Aug 2009 23:21:58 -0000
@@ -23,6 +23,7 @@
:- import_module mdbcomp.program_representation.
:- import_module parse_tree.prog_data.
+:- import_module assoc_list.
:- import_module bool.
:- import_module list.
:- import_module map.
@@ -129,9 +130,52 @@
:- interface.
- % The symbol table for types.
- %
-:- type type_table == map(type_ctor, hlds_type_defn).
+ % The symbol table for types. Conceptually, it is a map from type_ctors
+ % to hlds_type_defns, but the implementation may be different for
+ % efficiency.
+ %
+:- type type_table.
+
+:- func init_type_table = type_table.
+
+:- pred add_type_ctor_defn(type_ctor::in, hlds_type_defn::in,
+ type_table::in, type_table::out) is det.
+
+:- pred replace_type_ctor_defn(type_ctor::in, hlds_type_defn::in,
+ type_table::in, type_table::out) is det.
+
+:- pred add_or_replace_type_ctor_defn(type_ctor::in, hlds_type_defn::in,
+ type_table::in, type_table::out) is det.
+
+:- pred search_type_ctor_defn(type_table::in, type_ctor::in,
+ hlds_type_defn::out) is semidet.
+:- pred lookup_type_ctor_defn(type_table::in, type_ctor::in,
+ hlds_type_defn::out) is det.
+
+:- pred get_all_type_ctor_defns(type_table::in,
+ assoc_list(type_ctor, hlds_type_defn)::out) is det.
+
+:- pred foldl_over_type_ctor_defns(
+ pred(type_ctor, hlds_type_defn, T, T)::
+ in(pred(in, in, in, out) is det),
+ type_table::in, T::in, T::out) is det.
+
+:- pred foldl2_over_type_ctor_defns(
+ pred(type_ctor, hlds_type_defn, T, T, U, U)::
+ in(pred(in, in, in, out, in, out) is det),
+ type_table::in, T::in, T::out, U::in, U::out) is det.
+
+:- pred foldl3_over_type_ctor_defns(
+ pred(type_ctor, hlds_type_defn, T, T, U, U, V, V)::
+ in(pred(in, in, in, out, in, out, in, out) is det),
+ type_table::in, T::in, T::out, U::in, U::out, V::in, V::out) is det.
+
+:- pred map_foldl_over_type_ctor_defns(
+ pred(type_ctor, hlds_type_defn, hlds_type_defn, T, T)::
+ in(pred(in, in, out, in, out) is det),
+ type_table::in, type_table::out, T::in, T::out) is det.
+
+%-----------------------------------------------------------------------------%
% This is how type, modes and constructors are represented. The parts that
% are not defined here (i.e. type_param, constructor, type, inst and mode)
@@ -514,6 +558,116 @@
CheaperTagTest = no_cheaper_tag_test
).
+%-----------------------------------------------------------------------------%
+
+:- type type_table == map(string, type_ctor_table).
+
+:- type type_ctor_table == map(type_ctor, hlds_type_defn).
+
+init_type_table = map.init.
+
+add_type_ctor_defn(TypeCtor, TypeDefn, !TypeTable) :-
+ TypeCtor = type_ctor(SymName, _Arity),
+ Name = unqualify_name(SymName),
+ ( map.search(!.TypeTable, Name, TypeCtorTable0) ->
+ svmap.det_insert(TypeCtor, TypeDefn, TypeCtorTable0, TypeCtorTable),
+ svmap.det_update(Name, TypeCtorTable, !TypeTable)
+ ;
+ svmap.det_insert(TypeCtor, TypeDefn, map.init, TypeCtorTable),
+ svmap.det_insert(Name, TypeCtorTable, !TypeTable)
+ ).
+
+replace_type_ctor_defn(TypeCtor, TypeDefn, !TypeTable) :-
+ TypeCtor = type_ctor(SymName, _Arity),
+ Name = unqualify_name(SymName),
+ map.lookup(!.TypeTable, Name, TypeCtorTable0),
+ svmap.det_update(TypeCtor, TypeDefn, TypeCtorTable0, TypeCtorTable),
+ svmap.det_update(Name, TypeCtorTable, !TypeTable).
+
+add_or_replace_type_ctor_defn(TypeCtor, TypeDefn, !TypeTable) :-
+ TypeCtor = type_ctor(SymName, _Arity),
+ Name = unqualify_name(SymName),
+ ( map.search(!.TypeTable, Name, TypeCtorTable0) ->
+ svmap.set(TypeCtor, TypeDefn, TypeCtorTable0, TypeCtorTable),
+ svmap.det_update(Name, TypeCtorTable, !TypeTable)
+ ;
+ svmap.det_insert(TypeCtor, TypeDefn, map.init, TypeCtorTable),
+ svmap.det_insert(Name, TypeCtorTable, !TypeTable)
+ ).
+
+search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) :-
+ TypeCtor = type_ctor(SymName, _Arity),
+ Name = unqualify_name(SymName),
+ map.search(TypeTable, Name, TypeCtorTable),
+ map.search(TypeCtorTable, TypeCtor, TypeDefn).
+
+lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) :-
+ TypeCtor = type_ctor(SymName, _Arity),
+ Name = unqualify_name(SymName),
+ map.lookup(TypeTable, Name, TypeCtorTable),
+ map.lookup(TypeCtorTable, TypeCtor, TypeDefn).
+
+get_all_type_ctor_defns(TypeTable, TypeCtorsDefns) :-
+ map.foldl(get_all_type_ctor_defns_2, TypeTable, [], TypeCtorsDefns).
+
+:- pred get_all_type_ctor_defns_2(string::in, type_ctor_table::in,
+ assoc_list(type_ctor, hlds_type_defn)::in,
+ assoc_list(type_ctor, hlds_type_defn)::out) is det.
+
+get_all_type_ctor_defns_2(_Name, TypeCtorTable, !TypeCtorsDefns) :-
+ map.to_assoc_list(TypeCtorTable, NameTypeCtorsDefns),
+ !:TypeCtorsDefns = NameTypeCtorsDefns ++ !.TypeCtorsDefns.
+
+foldl_over_type_ctor_defns(Pred, TypeTable, !Acc) :-
+ map.foldl(foldl_over_type_ctor_defns_2(Pred), TypeTable, !Acc).
+
+:- pred foldl_over_type_ctor_defns_2(
+ pred(type_ctor, hlds_type_defn, T, T)::
+ in(pred(in, in, in, out) is det),
+ string::in, type_ctor_table::in, T::in, T::out) is det.
+
+foldl_over_type_ctor_defns_2(Pred, _Name, TypeCtorTable, !Acc) :-
+ map.foldl(Pred, TypeCtorTable, !Acc).
+
+foldl2_over_type_ctor_defns(Pred, TypeTable, !AccA, !AccB) :-
+ map.foldl2(foldl2_over_type_ctor_defns_2(Pred), TypeTable, !AccA, !AccB).
+
+:- pred foldl2_over_type_ctor_defns_2(
+ pred(type_ctor, hlds_type_defn, T, T, U, U)::
+ in(pred(in, in, in, out, in, out) is det),
+ string::in, type_ctor_table::in, T::in, T::out, U::in, U::out) is det.
+
+foldl2_over_type_ctor_defns_2(Pred, _Name, TypeCtorTable, !AccA, !AccB) :-
+ map.foldl2(Pred, TypeCtorTable, !AccA, !AccB).
+
+foldl3_over_type_ctor_defns(Pred, TypeTable, !AccA, !AccB, !AccC) :-
+ map.foldl3(foldl3_over_type_ctor_defns_2(Pred), TypeTable, !AccA, !AccB,
+ !AccC).
+
+:- pred foldl3_over_type_ctor_defns_2(
+ pred(type_ctor, hlds_type_defn, T, T, U, U, V, V)::
+ in(pred(in, in, in, out, in, out, in, out) is det),
+ string::in, type_ctor_table::in, T::in, T::out, U::in, U::out,
+ V::in, V::out) is det.
+
+foldl3_over_type_ctor_defns_2(Pred, _Name, TypeCtorTable, !AccA, !AccB,
+ !AccC) :-
+ map.foldl3(Pred, TypeCtorTable, !AccA, !AccB, !AccC).
+
+map_foldl_over_type_ctor_defns(Pred, !TypeTable, !Acc) :-
+ map.map_foldl(map_foldl_over_type_ctor_defns_2(Pred), !TypeTable, !Acc).
+
+:- pred map_foldl_over_type_ctor_defns_2(
+ pred(type_ctor, hlds_type_defn, hlds_type_defn, T, T)::
+ in(pred(in, in, out, in, out) is det),
+ string::in, type_ctor_table::in, type_ctor_table::out,
+ T::in, T::out) is det.
+
+map_foldl_over_type_ctor_defns_2(Pred, _Name, !TypeCtorTable, !Acc) :-
+ map.map_foldl(Pred, !TypeCtorTable, !Acc).
+
+%-----------------------------------------------------------------------------%
+
:- type hlds_type_defn
---> hlds_type_defn(
% Note that the first three of these fields are duplicated
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.163
diff -u -b -r1.163 hlds_module.m
--- compiler/hlds_module.m 16 Jul 2009 02:48:51 -0000 1.163
+++ compiler/hlds_module.m 29 Aug 2009 13:57:56 -0000
@@ -894,7 +894,7 @@
predicate_table_init(PredicateTable),
unify_proc.init_requests(Requests),
map.init(UnifyPredMap),
- map.init(Types),
+ TypeTable = init_type_table,
inst_table_init(Insts),
mode_table_init(Modes),
map.init(Ctors),
@@ -905,7 +905,7 @@
map.init(FieldNameTable),
ModuleInfo = module_info(ModuleSubInfo, PredicateTable, Requests,
- UnifyPredMap, QualifierInfo, Types, Insts, Modes, Ctors,
+ UnifyPredMap, QualifierInfo, TypeTable, Insts, Modes, Ctors,
ClassTable, InstanceTable, AssertionTable, ExclusiveTable,
FieldNameTable, RecompInfo).
@@ -1299,9 +1299,7 @@
predicate_table_optimize(Preds0, Preds),
module_info_set_predicate_table(Preds, !ModuleInfo),
- module_info_get_type_table(!.ModuleInfo, Types0),
- map.optimize(Types0, Types),
- module_info_set_type_table(Types, !ModuleInfo),
+ % We could optimize the type table, but now that would a no-op.
module_info_get_inst_table(!.ModuleInfo, InstTable0),
inst_table_get_user_insts(InstTable0, Insts0),
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.471
diff -u -b -r1.471 hlds_out.m
--- compiler/hlds_out.m 3 Sep 2009 23:57:25 -0000 1.471
+++ compiler/hlds_out.m 3 Sep 2009 23:58:02 -0000
@@ -3471,7 +3471,7 @@
write_types(Indent, TypeTable, !IO) :-
write_indent(Indent, !IO),
io.write_string("%-------- Types --------\n", !IO),
- map.to_assoc_list(TypeTable, TypeAssocList),
+ get_all_type_ctor_defns(TypeTable, TypeAssocList),
write_types_2(Indent, TypeAssocList, !IO).
:- pred write_types_2(int::in, assoc_list(type_ctor, hlds_type_defn)::in,
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.254
diff -u -b -r1.254 hlds_pred.m
--- compiler/hlds_pred.m 3 Sep 2009 23:57:25 -0000 1.254
+++ compiler/hlds_pred.m 3 Sep 2009 23:58:02 -0000
@@ -1451,7 +1451,7 @@
module_info_get_type_table(ModuleInfo, TypeTable),
% If the search fails, then TypeCtor must be a builtin type
% constructor, such as the tuple constructor.
- map.search(TypeTable, TypeCtor, TypeDefn),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
get_type_defn_in_exported_eqv(TypeDefn, yes),
(
SpecialId = spec_pred_unify,
Index: compiler/inst_check.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_check.m,v
retrieving revision 1.13
diff -u -b -r1.13 inst_check.m
--- compiler/inst_check.m 21 Jul 2009 04:10:40 -0000 1.13
+++ compiler/inst_check.m 28 Aug 2009 17:18:06 -0000
@@ -65,7 +65,8 @@
inst_table_get_user_insts(InstTable, UserInstTable),
user_inst_table_get_inst_defns(UserInstTable, InstDefs),
module_info_get_type_table(Module, TypeTable),
- AllTypeDefs = map.values(TypeTable),
+ get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
+ AllTypeDefs = assoc_list.values(TypeCtorsDefns),
list.filter(type_is_user_visible(section_implementation), AllTypeDefs,
UserVisibleTypeDefs),
InstIdDefPairs = map.to_assoc_list(InstDefs),
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.248
diff -u -b -r1.248 intermod.m
--- compiler/intermod.m 3 Sep 2009 23:57:26 -0000 1.248
+++ compiler/intermod.m 3 Sep 2009 23:58:02 -0000
@@ -1027,8 +1027,8 @@
gather_types(!Info) :-
intermod_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_type_table(ModuleInfo, Types),
- map.foldl(gather_types_2, Types, !Info).
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ foldl_over_type_ctor_defns(gather_types_2, TypeTable, !Info).
:- pred gather_types_2(type_ctor::in, hlds_type_defn::in,
intermod_info::in, intermod_info::out) is det.
@@ -1247,9 +1247,10 @@
set.empty(Preds),
set.empty(PredDecls),
Instances = [],
- module_info_get_type_table(ModuleInfo, Types),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
\+ (
- map.member(Types, _, TypeDefn),
+ list.member(_TypeCtor - TypeDefn, TypeCtorsDefns),
hlds_data.get_type_defn_status(TypeDefn, Status),
( Status = status_abstract_exported
; Status = status_exported_to_submodules
@@ -2155,17 +2156,16 @@
:- pred adjust_type_status(module_info::in, module_info::out) is det.
adjust_type_status(!ModuleInfo) :-
- module_info_get_type_table(!.ModuleInfo, Types0),
- map.to_assoc_list(Types0, TypesAL0),
- list.map_foldl(adjust_type_status_2, TypesAL0, TypesAL, !ModuleInfo),
- map.from_sorted_assoc_list(TypesAL, Types),
- module_info_set_type_table(Types, !ModuleInfo).
+ module_info_get_type_table(!.ModuleInfo, TypeTable0),
+ map_foldl_over_type_ctor_defns(adjust_type_status_2, TypeTable0, TypeTable,
+ !ModuleInfo),
+ module_info_set_type_table(TypeTable, !ModuleInfo).
-:- pred adjust_type_status_2(pair(type_ctor, hlds_type_defn)::in,
- pair(type_ctor, hlds_type_defn)::out,
+:- pred adjust_type_status_2(type_ctor::in,
+ hlds_type_defn::in, hlds_type_defn::out,
module_info::in, module_info::out) is det.
-adjust_type_status_2(TypeCtor - TypeDefn0, TypeCtor - TypeDefn, !ModuleInfo) :-
+adjust_type_status_2(TypeCtor, TypeDefn0, TypeDefn, !ModuleInfo) :-
module_info_get_name(!.ModuleInfo, ModuleName),
( should_write_type(ModuleName, TypeCtor, TypeDefn0) ->
hlds_data.set_type_defn_status(status_exported, TypeDefn0, TypeDefn),
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.91
diff -u -b -r1.91 make_hlds_passes.m
--- compiler/make_hlds_passes.m 2 Sep 2009 07:12:26 -0000 1.91
+++ compiler/make_hlds_passes.m 3 Sep 2009 23:28:42 -0000
@@ -168,9 +168,9 @@
% may cause a compiler abort.
(
InvalidTypes1 = no,
- module_info_get_type_table(!.ModuleInfo, Types),
- map.foldl3(process_type_defn, Types, no, InvalidTypes2,
- !ModuleInfo, !Specs)
+ module_info_get_type_table(!.ModuleInfo, TypeTable),
+ foldl3_over_type_ctor_defns(process_type_defn, TypeTable,
+ no, InvalidTypes2, !ModuleInfo, !Specs)
;
InvalidTypes1 = yes,
InvalidTypes2 = yes
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.221
diff -u -b -r1.221 ml_code_gen.m
--- compiler/ml_code_gen.m 3 Sep 2009 23:18:22 -0000 1.221
+++ compiler/ml_code_gen.m 3 Sep 2009 23:28:42 -0000
@@ -887,17 +887,18 @@
% For every foreign type determine the import needed to find
% the declaration for that type.
- module_info_get_type_table(ModuleInfo, Types),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
ForeignTypeImports = list.condense(
- list.map(foreign_type_required_imports(Target), map.values(Types))),
+ list.map(foreign_type_required_imports(Target), TypeCtorsDefns)),
MLDS_ImportList = ForeignTypeImports ++
list.map(P, set.to_sorted_list(AllImports)).
-:- func foreign_type_required_imports(compilation_target, hlds_type_defn)
- = list(mlds_import).
+:- func foreign_type_required_imports(compilation_target,
+ pair(type_ctor, hlds_type_defn)) = list(mlds_import).
-foreign_type_required_imports(Target, TypeDefn) = Imports :-
+foreign_type_required_imports(Target, _TypeCtor - TypeDefn) = Imports :-
(
( Target = target_c
; Target = target_java
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.42
diff -u -b -r1.42 ml_switch_gen.m
--- compiler/ml_switch_gen.m 2 Sep 2009 00:30:19 -0000 1.42
+++ compiler/ml_switch_gen.m 2 Sep 2009 00:37:06 -0000
@@ -151,7 +151,8 @@
% reserved addresses.
% The search will fail for builtin types.
module_info_get_type_table(ModuleInfo, TypeTable),
- map.search(TypeTable, SwitchVarTypeCtor, SwitchVarTypeDefn),
+ search_type_ctor_defn(TypeTable, SwitchVarTypeCtor,
+ SwitchVarTypeDefn),
hlds_data.get_type_defn_body(SwitchVarTypeDefn, SwitchVarTypeBody),
SwitchVarTypeBody ^ du_type_reserved_addr = uses_reserved_address
)
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.86
diff -u -b -r1.86 ml_type_gen.m
--- compiler/ml_type_gen.m 2 Sep 2009 00:30:19 -0000 1.86
+++ compiler/ml_type_gen.m 2 Sep 2009 01:00:31 -0000
@@ -127,43 +127,43 @@
%-----------------------------------------------------------------------------%
-ml_gen_types(ModuleInfo, MLDS_TypeDefns) :-
+ml_gen_types(ModuleInfo, Defns) :-
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
globals.get_target(Globals, Target),
(
HighLevelData = yes,
module_info_get_type_table(ModuleInfo, TypeTable),
- map.keys(TypeTable, TypeCtors0),
- list.filter((pred(TypeCtor::in) is semidet :-
+ get_all_type_ctor_defns(TypeTable, TypeCtorsDefns0),
+ list.filter(
+ (pred(TypeCtorDefn::in) is semidet :-
+ TypeCtorDefn = TypeCtor - _TypeDefn,
\+ type_ctor_needs_lowlevel_rep(Target, TypeCtor)
- ), TypeCtors0, TypeCtors),
- list.foldl(ml_gen_type_defn(ModuleInfo, TypeTable), TypeCtors,
- [], MLDS_TypeDefns)
+ ), TypeCtorsDefns0, TypeCtorDefns),
+ list.foldl(ml_gen_type_defn(ModuleInfo), TypeCtorDefns, [], Defns)
;
HighLevelData = no,
- MLDS_TypeDefns = []
+ Defns = []
).
-:- pred ml_gen_type_defn(module_info::in, type_table::in, type_ctor::in,
+:- pred ml_gen_type_defn(module_info::in, pair(type_ctor, hlds_type_defn)::in,
list(mlds_defn)::in, list(mlds_defn)::out) is det.
-ml_gen_type_defn(ModuleInfo, TypeTable, TypeCtor, !Defns) :-
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ml_gen_type_defn(ModuleInfo, TypeCtor - TypeDefn, !Defns) :-
hlds_data.get_type_defn_status(TypeDefn, Status),
DefinedThisModule = status_defined_in_this_module(Status),
(
DefinedThisModule = yes,
- hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- ml_gen_type_2(ModuleInfo, TypeCtor, TypeDefn, TypeBody, !Defns)
+ ml_gen_type_defn_2(ModuleInfo, TypeCtor, TypeDefn, !Defns)
;
DefinedThisModule = no
).
-:- pred ml_gen_type_2(module_info::in, type_ctor::in, hlds_type_defn::in,
- hlds_type_body::in, list(mlds_defn)::in, list(mlds_defn)::out) is det.
+:- pred ml_gen_type_defn_2(module_info::in, type_ctor::in, hlds_type_defn::in,
+ list(mlds_defn)::in, list(mlds_defn)::out) is det.
-ml_gen_type_2(ModuleInfo, TypeCtor, TypeDefn, TypeBody, !Defns) :-
+ml_gen_type_defn_2(ModuleInfo, TypeCtor, TypeDefn, !Defns) :-
+ hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = hlds_abstract_type(_)
;
@@ -1183,7 +1183,7 @@
ml_gen_exported_enum(_ModuleInfo, TypeTable, ExportedEnumInfo,
MLDS_ExportedEnum) :-
ExportedEnumInfo = exported_enum_info(Lang, Context, TypeCtor, Mapping),
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
get_type_defn_body(TypeDefn, TypeBody),
(
( TypeBody = hlds_eqv_type(_)
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.136
diff -u -b -r1.136 ml_unify_gen.m
--- compiler/ml_unify_gen.m 3 Sep 2009 23:20:41 -0000 1.136
+++ compiler/ml_unify_gen.m 3 Sep 2009 23:28:43 -0000
@@ -1916,7 +1916,7 @@
% "tag_type" that is derived from the base class for this type,
% rather than in the base class itself.
module_info_get_type_table(ModuleInfo, TypeTable),
- TypeDefn = map.lookup(TypeTable, TypeCtor),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
(
TypeDefnBody =
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.175
diff -u -b -r1.175 mlds.m
--- compiler/mlds.m 3 Sep 2009 23:07:27 -0000 1.175
+++ compiler/mlds.m 4 Sep 2009 01:31:15 -0000
@@ -1834,8 +1834,8 @@
MLDSRefType = mercury_type_to_mlds_type(ModuleInfo, RefType),
MLDSType = mlds_ptr_type(MLDSRefType)
;
- module_info_get_type_table(ModuleInfo, Types),
- map.search(Types, TypeCtor, TypeDefn),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, Body),
Body = hlds_foreign_type(ForeignTypeBody),
ForeignTypeBody = foreign_type_body(MaybeIL, MaybeC, MaybeJava,
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.211
diff -u -b -r1.211 mode_util.m
--- compiler/mode_util.m 11 Jun 2009 07:00:15 -0000 1.211
+++ compiler/mode_util.m 28 Aug 2009 16:30:26 -0000
@@ -862,7 +862,7 @@
type_to_ctor_and_args(Type, TypeCtor, TypeArgs),
TypeCtor = type_ctor(qualified(TypeModule, _), _),
module_info_get_type_table(ModuleInfo, TypeTable),
- map.search(TypeTable, TypeCtor, TypeDefn),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_tparams(TypeDefn, TypeParams),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
Constructors = TypeBody ^ du_type_ctors
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.383
diff -u -b -r1.383 modes.m
--- compiler/modes.m 3 Sep 2009 23:57:27 -0000 1.383
+++ compiler/modes.m 3 Sep 2009 23:58:03 -0000
@@ -2129,7 +2129,7 @@
mode_info_get_var_types(!.ModeInfo, VarTypes),
map.lookup(VarTypes, Arg1, ArgType1),
type_to_ctor_and_args(ArgType1, ArgTypeCtor1, _),
- map.lookup(TypeTable, ArgTypeCtor1, CtorDefn),
+ lookup_type_ctor_defn(TypeTable, ArgTypeCtor1, CtorDefn),
get_type_defn_body(CtorDefn, Body),
ConsTagValues = Body ^ du_type_cons_tag_values,
map.lookup(ConsTagValues, ConsId, ConsTag),
Index: compiler/passes_aux.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/passes_aux.m,v
retrieving revision 1.92
diff -u -b -r1.92 passes_aux.m
--- compiler/passes_aux.m 21 Jul 2009 04:10:41 -0000 1.92
+++ compiler/passes_aux.m 29 Aug 2009 14:27:17 -0000
@@ -160,6 +160,7 @@
:- implementation.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_out.
:- import_module libs.compiler_util.
:- import_module libs.file_util.
@@ -380,21 +381,15 @@
:- pred report_sizes(module_info::in, io::di, io::uo) is det.
report_sizes(ModuleInfo, !IO) :-
- module_info_preds(ModuleInfo, Preds),
- tree_stats("Pred table", Preds, !IO),
- module_info_get_type_table(ModuleInfo, Types),
- tree_stats("Type table", Types, !IO),
- module_info_get_cons_table(ModuleInfo, Ctors),
- tree_stats("Constructor table", Ctors, !IO).
-
-:- pred tree_stats(string::in, map(_K, _V)::in, io::di, io::uo) is det.
-
-tree_stats(Description, Tree, !IO) :-
- map.count(Tree, Count),
- io.write_string(Description, !IO),
- io.write_string(": count = ", !IO),
- io.write_int(Count, !IO),
- io.write_string("\n", !IO).
+ module_info_preds(ModuleInfo, PredTable),
+ io.format("Pred table size = %d\n", [i(map.count(PredTable))], !IO),
+
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ get_all_type_ctor_defns(TypeTable, TypeCtorDefns),
+ io.format("Type table size = %d\n", [i(list.length(TypeCtorDefns))], !IO),
+
+ module_info_get_cons_table(ModuleInfo, CtorTable),
+ io.format("Constructor table size = %d\n", [i(map.count(CtorTable))], !IO).
%-----------------------------------------------------------------------------%
Index: compiler/post_term_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_term_analysis.m,v
retrieving revision 1.18
diff -u -b -r1.18 post_term_analysis.m
--- compiler/post_term_analysis.m 30 Dec 2007 08:23:54 -0000 1.18
+++ compiler/post_term_analysis.m 28 Aug 2009 18:19:00 -0000
@@ -112,17 +112,16 @@
warn_non_term_user_special_pred(ModuleInfo, TypeTable,
SpecialPredId - TypeCtor, PredId, !IO) :-
- %
- % index predicates cannot be defined by the user and should
- % always terminate by design. Do not perform this
- % check for builtin types that don't have hlds_type_defns.
- %
+ % Index predicates cannot be defined by the user and should always
+ % terminate by design. Do not perform this check for builtin types
+ % that don't have hlds_type_defns.
+
BuiltinTypeCtors = builtin_type_ctors_with_no_hlds_type_defn,
(
SpecialPredId \= spec_pred_index,
not list.member(TypeCtor, BuiltinTypeCtors)
->
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
get_type_defn_status(TypeDefn, ImportStatus),
DefinedThisModule = status_defined_in_this_module(ImportStatus),
(
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.135
diff -u -b -r1.135 post_typecheck.m
--- compiler/post_typecheck.m 19 Aug 2009 07:44:57 -0000 1.135
+++ compiler/post_typecheck.m 29 Aug 2009 14:23:22 -0000
@@ -781,8 +781,8 @@
clauses_info_get_vartypes(ClausesInfo, VarTypes),
map.lookup(VarTypes, Var, Type),
type_to_ctor_det(Type, TypeCtor),
- module_info_get_type_table(ModuleInfo, Types),
- map.lookup(Types, TypeCtor, TypeDefn),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
get_type_defn_status(TypeDefn, TypeStatus),
DefinedInImpl = status_defined_in_impl_section(TypeStatus),
(
@@ -1242,8 +1242,8 @@
ConsArgs, _),
ConsTypeCtor = TypeCtor,
- module_info_get_type_table(ModuleInfo, Types),
- map.search(Types, TypeCtor, TypeDefn),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_tvarset(TypeDefn, TypeTVarSet),
hlds_data.get_type_defn_kind_map(TypeDefn, TypeKindMap),
@@ -1520,8 +1520,8 @@
get_constructor_containing_field(ModuleInfo, TermType, FieldName,
ConsId, FieldNumber) :-
type_to_ctor_det(TermType, TermTypeCtor),
- module_info_get_type_table(ModuleInfo, Types),
- map.lookup(Types, TermTypeCtor, TermTypeDefn),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ lookup_type_ctor_defn(TypeTable, TermTypeCtor, TermTypeDefn),
hlds_data.get_type_defn_body(TermTypeDefn, TermTypeBody),
(
TermTypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _),
@@ -1626,7 +1626,8 @@
check_for_missing_definitions(ModuleInfo, !Specs) :-
module_info_get_type_table(ModuleInfo, TypeTable),
- map.foldl(check_for_missing_definitions_2, TypeTable, !Specs).
+ foldl_over_type_ctor_defns(check_for_missing_definitions_2, TypeTable,
+ !Specs).
:- pred check_for_missing_definitions_2(type_ctor::in, hlds_type_defn::in,
list(error_spec)::in, list(error_spec)::out) is det.
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.113
diff -u -b -r1.113 pragma_c_gen.m
--- compiler/pragma_c_gen.m 6 Jan 2009 03:56:26 -0000 1.113
+++ compiler/pragma_c_gen.m 28 Aug 2009 18:08:06 -0000
@@ -1438,12 +1438,12 @@
get_maybe_foreign_type_info(CI, Type) = MaybeForeignTypeInfo :-
get_module_info(CI, Module),
- module_info_get_type_table(Module, Types),
+ module_info_get_type_table(Module, TypeTable),
(
- type_to_ctor_and_args(Type, TypeId, _SubTypes),
- map.search(Types, TypeId, Defn),
- hlds_data.get_type_defn_body(Defn, Body),
- Body = hlds_foreign_type(
+ type_to_ctor(Type, TypeCtor),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
+ hlds_data.get_type_defn_body(TypeDefn, TypeBody),
+ TypeBody = hlds_foreign_type(
foreign_type_body(_MaybeIL, MaybeC, _MaybeJava, _MaybeErlang))
->
(
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.50
diff -u -b -r1.50 prog_type.m
--- compiler/prog_type.m 3 Sep 2009 23:57:28 -0000 1.50
+++ compiler/prog_type.m 3 Sep 2009 23:58:03 -0000
@@ -749,6 +749,8 @@
%-----------------------------------------------------------------------------%
+ % Every element of this list must be reflected in the code of
+ % builtin_type_ctor in type_ctor_info.m.
builtin_type_ctors_with_no_hlds_type_defn =
[ type_ctor(qualified(mercury_public_builtin_module, "int"), 0),
type_ctor(qualified(mercury_public_builtin_module, "string"), 0),
Index: compiler/recompilation.usage.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.50
diff -u -b -r1.50 recompilation.usage.m
--- compiler/recompilation.usage.m 11 Jun 2009 07:00:18 -0000 1.50
+++ compiler/recompilation.usage.m 28 Aug 2009 18:25:39 -0000
@@ -924,9 +924,9 @@
find_items_used_by_item(type_abstract_item, TypeCtorItem, !Info) :-
ModuleInfo = !.Info ^ module_info,
- module_info_get_type_table(ModuleInfo, Types),
+ module_info_get_type_table(ModuleInfo, TypeTable),
TypeCtor = item_name_to_type_ctor(TypeCtorItem),
- map.lookup(Types, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
( TypeBody = hlds_eqv_type(Type) ->
% If we use an equivalence type we also use the type
@@ -937,9 +937,9 @@
).
find_items_used_by_item(type_body_item, TypeCtorItem, !Info) :-
ModuleInfo = !.Info ^ module_info,
- module_info_get_type_table(ModuleInfo, Types),
+ module_info_get_type_table(ModuleInfo, TypeTable),
TypeCtor = item_name_to_type_ctor(TypeCtorItem),
- map.lookup(Types, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
find_items_used_by_type_body(TypeBody, !Info).
find_items_used_by_item(mode_item, ModeIdItem, !Info):-
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.73
diff -u -b -r1.73 special_pred.m
--- compiler/special_pred.m 12 Jun 2009 05:21:27 -0000 1.73
+++ compiler/special_pred.m 28 Aug 2009 18:07:00 -0000
@@ -196,8 +196,8 @@
; CtorCat = ctor_cat_enum(_)
; is_introduced_type_info_type_category(CtorCat) = yes
),
- module_info_get_type_table(ModuleInfo, Types),
- map.search(Types, TypeCtor, TypeDefn),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, Body),
hlds_data.get_type_defn_status(TypeDefn, Status),
special_pred_is_generated_lazily_2(ModuleInfo, TypeCtor, Body, Status)
Index: compiler/stack_opt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.39
diff -u -b -r1.39 stack_opt.m
--- compiler/stack_opt.m 21 Jul 2009 04:10:42 -0000 1.39
+++ compiler/stack_opt.m 28 Aug 2009 18:08:16 -0000
@@ -393,7 +393,7 @@
type_to_ctor_and_args(Type, TypeCtor, _),
ModuleInfo = IntParams ^ ip_module_info,
module_info_get_type_table(ModuleInfo, TypeTable),
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
ConsTable = TypeBody ^ du_type_cons_tag_values
->
Index: compiler/switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_gen.m,v
retrieving revision 1.111
diff -u -b -r1.111 switch_gen.m
--- compiler/switch_gen.m 25 Aug 2009 23:46:50 -0000 1.111
+++ compiler/switch_gen.m 28 Aug 2009 18:08:46 -0000
@@ -118,7 +118,7 @@
;
module_info_get_type_table(ModuleInfo, TypeTable),
% The search will fail for builtin types.
- map.search(TypeTable, VarTypeCtor, VarTypeDefn),
+ search_type_ctor_defn(TypeTable, VarTypeCtor, VarTypeDefn),
hlds_data.get_type_defn_body(VarTypeDefn, VarTypeBody),
VarTypeBody ^ du_type_reserved_addr = uses_reserved_address
)
@@ -258,7 +258,7 @@
type_to_ctor_det(VarType, TypeCtor),
get_module_info(!.CI, ModuleInfo),
module_info_get_type_table(ModuleInfo, TypeTable),
- ( map.search(TypeTable, TypeCtor, TypeDefn) ->
+ ( search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) ->
get_type_defn_body(TypeDefn, TypeBody),
CheaperTagTest = get_maybe_cheaper_tag_test(TypeBody)
;
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.43
diff -u -b -r1.43 switch_util.m
--- compiler/switch_util.m 25 Aug 2009 23:46:50 -0000 1.43
+++ compiler/switch_util.m 28 Aug 2009 16:28:12 -0000
@@ -502,7 +502,7 @@
Min = 0,
type_to_ctor_det(Type, TypeCtor),
module_info_get_type_table(ModuleInfo, TypeTable),
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _),
@@ -643,7 +643,7 @@
get_ptag_counts(Type, ModuleInfo, MaxPrimary, PtagCountMap) :-
type_to_ctor_det(Type, TypeCtor),
module_info_get_type_table(ModuleInfo, TypeTable),
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _),
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.152
diff -u -b -r1.152 table_gen.m
--- compiler/table_gen.m 3 Sep 2009 23:57:29 -0000 1.152
+++ compiler/table_gen.m 3 Sep 2009 23:58:04 -0000
@@ -2390,8 +2390,8 @@
(
CtorCat = ctor_cat_enum(cat_enum_mercury),
type_to_ctor_det(Type, TypeCtor),
- module_info_get_type_table(ModuleInfo, TypeDefnTable),
- map.lookup(TypeDefnTable, TypeCtor, TypeDefn),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
Ctors = TypeBody ^ du_type_ctors,
Index: compiler/term_norm.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_norm.m,v
retrieving revision 1.29
diff -u -b -r1.29 term_norm.m
--- compiler/term_norm.m 11 Jun 2009 07:00:20 -0000 1.29
+++ compiler/term_norm.m 28 Aug 2009 18:24:35 -0000
@@ -137,9 +137,9 @@
find_weights(ModuleInfo, Weights) :-
module_info_get_type_table(ModuleInfo, TypeTable),
- map.to_assoc_list(TypeTable, TypeList),
+ get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
map.init(Weights0),
- list.foldl(find_weights_for_type, TypeList, Weights0, Weights).
+ list.foldl(find_weights_for_type, TypeCtorsDefns, Weights0, Weights).
:- pred find_weights_for_type(pair(type_ctor, hlds_type_defn)::in,
weight_table::in, weight_table::out) is det.
Index: compiler/type_constraints.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_constraints.m,v
retrieving revision 1.6
diff -u -b -r1.6 type_constraints.m
--- compiler/type_constraints.m 19 Aug 2009 07:44:58 -0000 1.6
+++ compiler/type_constraints.m 28 Aug 2009 16:33:14 -0000
@@ -378,7 +378,7 @@
% Check whether that type is a type for which there is a user-defined
% equality predicate or which is existentially typed.
module_info_get_type_table(ModuleInfo, TypeTable),
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, Body),
special_pred_for_type_needs_typecheck(ModuleInfo, SpecialPredId, Body).
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.99
diff -u -b -r1.99 type_ctor_info.m
--- compiler/type_ctor_info.m 12 Jun 2009 05:21:27 -0000 1.99
+++ compiler/type_ctor_info.m 28 Aug 2009 23:15:15 -0000
@@ -106,43 +106,48 @@
generate_hlds(!ModuleInfo) :-
module_info_get_name(!.ModuleInfo, ModuleName),
module_info_get_type_table(!.ModuleInfo, TypeTable),
- map.keys(TypeTable, TypeCtors0),
+ get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
+ gen_type_ctor_gen_infos(!.ModuleInfo, ModuleName, TypeCtorsDefns,
+ LocalTypeCtorGenInfos),
(
ModuleName = mercury_public_builtin_module,
compiler_generated_rtti_for_builtins(!.ModuleInfo)
->
- TypeCtors = builtin_type_ctors_with_no_hlds_type_defn ++ TypeCtors0
+ gen_builtin_type_ctor_gen_infos(!.ModuleInfo, ModuleName,
+ builtin_type_ctors_with_no_hlds_type_defn,
+ BuiltinTypeCtorGenInfos),
+ AllTypeCtorGenInfos = BuiltinTypeCtorGenInfos ++ LocalTypeCtorGenInfos
;
- TypeCtors = TypeCtors0
+ AllTypeCtorGenInfos = LocalTypeCtorGenInfos
),
- gen_type_ctor_gen_infos(TypeCtors, TypeTable, ModuleName, !.ModuleInfo,
- TypeCtorGenInfos),
- module_info_set_type_ctor_gen_infos(TypeCtorGenInfos, !ModuleInfo).
+ module_info_set_type_ctor_gen_infos(AllTypeCtorGenInfos, !ModuleInfo).
% Given a list of the ids of all the types in the type table, find the
% types defined in this module, and return a type_ctor_gen_info for each.
%
-:- pred gen_type_ctor_gen_infos(list(type_ctor)::in, type_table::in,
- module_name::in, module_info::in, list(type_ctor_gen_info)::out) is det.
+:- pred gen_type_ctor_gen_infos(module_info::in, module_name::in,
+ assoc_list(type_ctor, hlds_type_defn)::in, list(type_ctor_gen_info)::out)
+ is det.
-gen_type_ctor_gen_infos([], _, _, _, []).
-gen_type_ctor_gen_infos([TypeCtor | TypeCtors], TypeTable, ModuleName,
- ModuleInfo, TypeCtorGenInfos) :-
- gen_type_ctor_gen_infos(TypeCtors, TypeTable, ModuleName, ModuleInfo,
- TypeCtorGenInfos1),
+gen_type_ctor_gen_infos(_, _, [], []).
+gen_type_ctor_gen_infos(ModuleInfo, ModuleName, [TypeCtorDefn | TypeCtorDefns],
+ TypeCtorGenInfos) :-
+ gen_type_ctor_gen_infos(ModuleInfo, ModuleName, TypeCtorDefns,
+ TypeCtorGenInfosTail),
+ TypeCtorDefn = TypeCtor - TypeDefn,
TypeCtor = type_ctor(SymName, TypeArity),
(
SymName = qualified(TypeModuleName, TypeName),
(
TypeModuleName = ModuleName,
- create_type_ctor_gen(ModuleInfo, TypeTable, TypeCtor,
+ create_type_ctor_gen(ModuleInfo, TypeCtorDefn,
TypeModuleName, TypeName, TypeArity, TypeDefn)
->
- gen_type_ctor_gen_info(TypeCtor, TypeName, TypeArity, TypeDefn,
- ModuleName, ModuleInfo, TypeCtorGenInfo),
- TypeCtorGenInfos = [TypeCtorGenInfo | TypeCtorGenInfos1]
+ gen_type_ctor_gen_info(ModuleInfo, TypeCtor, TypeModuleName,
+ TypeName, TypeArity, TypeDefn, TypeCtorGenInfo),
+ TypeCtorGenInfos = [TypeCtorGenInfo | TypeCtorGenInfosTail]
;
- TypeCtorGenInfos = TypeCtorGenInfos1
+ TypeCtorGenInfos = TypeCtorGenInfosTail
)
;
SymName = unqualified(TypeName),
@@ -151,7 +156,7 @@
).
% Check if we should generate a type_ctor_info for this type.
- % These are the cases that we have to check:
+ % These are four cases;
%
% - The builtin types which have no hlds_type_defn
% (i.e. no declaration and no definition).
@@ -164,19 +169,15 @@
%
% - All the rest of the types.
%
-:- pred create_type_ctor_gen(module_info::in, type_table::in, type_ctor::in,
- module_name::in, string::in, int::in, hlds_type_defn::out) is semidet.
+ % The first category are handled by gen_builtin_type_ctor_gen_infos;
+ % this predicate handles the other three.
+ %
+:- pred create_type_ctor_gen(module_info::in,
+ pair(type_ctor, hlds_type_defn)::in, module_name::in, string::in, int::in,
+ hlds_type_defn::out) is semidet.
-create_type_ctor_gen(ModuleInfo, TypeTable, TypeCtor, TypeModuleName,
+create_type_ctor_gen(ModuleInfo, TypeCtor - TypeDefn, TypeModuleName,
TypeName, TypeArity, TypeDefn) :-
- ( list.member(TypeCtor, builtin_type_ctors_with_no_hlds_type_defn) ->
- % The builtin types with no type definition.
- compiler_generated_rtti_for_builtins(ModuleInfo),
- TypeModuleName = unqualified(ModuleNameString),
- builtin_type_ctor(ModuleNameString, TypeName, TypeArity, _),
- TypeDefn = builtin_type_defn
- ;
- map.lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
( TypeBody = hlds_abstract_type(_)
@@ -194,7 +195,27 @@
)
;
true
- )
+ ).
+
+:- pred gen_builtin_type_ctor_gen_infos(module_info::in, module_name::in,
+ list(type_ctor)::in, list(type_ctor_gen_info)::out) is det.
+
+gen_builtin_type_ctor_gen_infos(_ModuleInfo, _ModuleName, [], []).
+gen_builtin_type_ctor_gen_infos(ModuleInfo, ModuleName, [TypeCtor | TypeCtors],
+ [TypeCtorGenInfo | TypeCtorGenInfos]) :-
+ gen_builtin_type_ctor_gen_infos(ModuleInfo, ModuleName, TypeCtors,
+ TypeCtorGenInfos),
+ TypeCtor = type_ctor(SymName, TypeArity),
+ (
+ SymName = qualified(TypeModuleName, TypeName),
+ expect(unify(TypeModuleName, ModuleName), this_file,
+ "gen_builtin_type_ctor_gen_infos: module mismatch"),
+ gen_type_ctor_gen_info(ModuleInfo, TypeCtor, TypeModuleName,
+ TypeName, TypeArity, builtin_type_defn, TypeCtorGenInfo)
+ ;
+ SymName = unqualified(TypeName),
+ Msg = "unqualified type " ++ TypeName ++ " in builtin type list",
+ unexpected(this_file, Msg)
).
% Generate a type_defn for the builtin types which don't have one.
@@ -212,12 +233,12 @@
hlds_data.set_type_defn(TVarSet, Params, Kinds, Body, ImportStatus, no,
NeedQualifier, Context, TypeDefn).
-:- pred gen_type_ctor_gen_info(type_ctor::in, string::in, int::in,
- hlds_type_defn::in, module_name::in, module_info::in,
+:- pred gen_type_ctor_gen_info( module_info::in, type_ctor::in,
+ module_name::in, string::in, int::in, hlds_type_defn::in,
type_ctor_gen_info::out) is det.
-gen_type_ctor_gen_info(TypeCtor, TypeName, TypeArity, TypeDefn, ModuleName,
- ModuleInfo, TypeCtorGenInfo) :-
+gen_type_ctor_gen_info(ModuleInfo, TypeCtor, ModuleName, TypeName, TypeArity,
+ TypeDefn, TypeCtorGenInfo) :-
hlds_data.get_type_defn_status(TypeDefn, Status),
module_info_get_globals(ModuleInfo, Globals),
module_info_get_special_pred_map(ModuleInfo, SpecMap),
@@ -415,6 +436,9 @@
:- pred builtin_type_ctor(string::in, string::in, int::in, builtin_ctor::out)
is semidet.
+% Some of these type_ctors are listed in prog_type.m in the function
+% builtin_type_ctors_with_no_hlds_type_defn; any changes here may need
+% to be done there as well.
builtin_type_ctor("builtin", "int", 0, builtin_ctor_int).
builtin_type_ctor("builtin", "string", 0, builtin_ctor_string).
builtin_type_ctor("builtin", "float", 0, builtin_ctor_float).
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.199
diff -u -b -r1.199 type_util.m
--- compiler/type_util.m 3 Sep 2009 23:07:30 -0000 1.199
+++ compiler/type_util.m 3 Sep 2009 23:28:45 -0000
@@ -402,7 +402,7 @@
type_to_type_defn(ModuleInfo, Type, TypeDefn) :-
module_info_get_type_table(ModuleInfo, TypeTable),
type_to_ctor_and_args(Type, TypeCtor, _TypeArgs),
- map.search(TypeTable, TypeCtor, TypeDefn).
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn).
type_to_type_defn_body(ModuleInfo, Type, TypeBody) :-
type_to_type_defn(ModuleInfo, Type, TypeDefn),
@@ -629,7 +629,7 @@
module_info_get_type_table(ModuleInfo, TypeTable),
% This can fail for some builtin type constructors such as func,
% pred, and tuple, none of which are dummy types.
- ( map.search(TypeTable, TypeCtor, TypeDefn) ->
+ ( search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn)->
get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
@@ -764,8 +764,8 @@
->
TypeCategory = ctor_cat_tuple
;
- module_info_get_type_table(ModuleInfo, TypeDefnTable),
- map.lookup(TypeDefnTable, TypeCtor, TypeDefn),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
@@ -858,7 +858,7 @@
CtorArgs, Context)]
;
module_info_get_type_table(ModuleInfo, TypeTable),
- map.search(TypeTable, TypeCtor, TypeDefn),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_tparams(TypeDefn, TypeParams),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
substitute_type_args(TypeParams, TypeArgs, TypeBody ^ du_type_ctors,
@@ -920,7 +920,7 @@
NumFunctors = 1
;
module_info_get_type_table(ModuleInfo, TypeTable),
- map.search(TypeTable, TypeCtor, TypeDefn),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
map.count(TypeBody ^ du_type_cons_tag_values, NumFunctors)
).
@@ -987,8 +987,8 @@
cons_id_arg_types(ModuleInfo, VarType, ConsId, ArgTypes) :-
type_to_ctor_and_args(VarType, TypeCtor, TypeArgs),
- module_info_get_type_table(ModuleInfo, Types),
- map.search(Types, TypeCtor, TypeDefn),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
map.member(TypeDefnBody ^ du_type_cons_tag_values, ConsId, _),
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.442
diff -u -b -r1.442 typecheck.m
--- compiler/typecheck.m 3 Sep 2009 23:57:30 -0000 1.442
+++ compiler/typecheck.m 3 Sep 2009 23:58:04 -0000
@@ -930,7 +930,7 @@
% Check whether that type is a type for which there is a user-defined
% equality predicate, or which is existentially typed.
module_info_get_type_table(ModuleInfo, TypeTable),
- map.lookup(TypeTable, TypeCtor, TypeDefn),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, Body),
special_pred_for_type_needs_typecheck(ModuleInfo, SpecialPredId, Body).
@@ -3038,8 +3038,8 @@
HLDS_ConsDefn = hlds_cons_defn(TypeCtor, ConsTypeVarSet, ConsTypeParams,
ConsTypeKinds, ExistQVars0, ExistProgConstraints, Args, _),
ArgTypes = list.map(func(C) = C ^ arg_type, Args),
- typecheck_info_get_types(Info, Types),
- map.lookup(Types, TypeCtor, TypeDefn),
+ typecheck_info_get_types(Info, TypeTable),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, Body),
% If this type has `:- pragma foreign_type' declarations, we
Index: compiler/typecheck_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck_errors.m,v
retrieving revision 1.45
diff -u -b -r1.45 typecheck_errors.m
--- compiler/typecheck_errors.m 19 Aug 2009 11:18:28 -0000 1.45
+++ compiler/typecheck_errors.m 28 Aug 2009 23:07:36 -0000
@@ -515,7 +515,8 @@
LaterPieces = [words("The predicate symbol"),
simple_call(CallId), words("is also overloaded here.")]
;
- Symbol = overloaded_func(ConsId, Sources),
+ Symbol = overloaded_func(ConsId, Sources0),
+ list.sort(Sources0, Sources),
( ConsId = cons(SymName, Arity, _) ->
ConsIdPiece = sym_name_and_arity(SymName / Arity)
;
@@ -1577,14 +1578,15 @@
:- func type_assign_set_msg_to_pieces(type_assign_set, prog_varset)
= list(format_component).
-type_assign_set_msg_to_pieces(TypeAssignSet, VarSet) = Pieces :-
- ( TypeAssignSet = [_] ->
+type_assign_set_msg_to_pieces(TypeAssignSet0, VarSet) = Pieces :-
+ ( TypeAssignSet0 = [_] ->
FirstWords = "The partial type assignment was:",
MaybeSeq = no
;
FirstWords = "The possible partial type assignments were:",
MaybeSeq = yes(1)
),
+ list.sort(TypeAssignSet0, TypeAssignSet),
LaterPieces = type_assign_set_to_pieces(TypeAssignSet, MaybeSeq, VarSet),
Pieces = [words(FirstWords), nl_indent_delta(1) | LaterPieces] ++
[nl_indent_delta(-1)].
@@ -1599,14 +1601,15 @@
:- func args_type_assign_set_msg_to_pieces(args_type_assign_set, prog_varset)
= list(format_component).
-args_type_assign_set_msg_to_pieces(ArgTypeAssignSet, VarSet) = Pieces :-
- ( ArgTypeAssignSet = [_] ->
+args_type_assign_set_msg_to_pieces(ArgTypeAssignSet0, VarSet) = Pieces :-
+ ( ArgTypeAssignSet0 = [_] ->
FirstWords = "The partial type assignment was:",
MaybeSeq = no
;
FirstWords = "The possible partial type assignments were:",
MaybeSeq = yes(1)
),
+ list.sort(ArgTypeAssignSet0, ArgTypeAssignSet),
LaterPieces = args_type_assign_set_to_pieces(ArgTypeAssignSet, MaybeSeq,
VarSet),
Pieces = [words(FirstWords), nl_indent_delta(1) | LaterPieces] ++
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.207
diff -u -b -r1.207 unify_proc.m
--- compiler/unify_proc.m 3 Sep 2009 23:57:30 -0000 1.207
+++ compiler/unify_proc.m 3 Sep 2009 23:58:05 -0000
@@ -273,7 +273,7 @@
search_mode_num(!.ModuleInfo, TypeCtor, UnifyMode, Determinism, _)
;
module_info_get_type_table(!.ModuleInfo, TypeTable),
- map.search(TypeTable, TypeCtor, TypeDefn),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
TypeCtor = type_ctor(TypeName, _TypeArity),
@@ -497,8 +497,8 @@
tvarset::out, hlds_type_body::out, prog_context::out) is det.
collect_type_defn(ModuleInfo, TypeCtor, Type, TVarSet, TypeBody, Context) :-
- module_info_get_type_table(ModuleInfo, Types),
- map.lookup(Types, TypeCtor, TypeDefn),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_tvarset(TypeDefn, TVarSet),
hlds_data.get_type_defn_tparams(TypeDefn, TypeParams),
hlds_data.get_type_defn_kind_map(TypeDefn, KindMap),
Index: compiler/untupling.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/untupling.m,v
retrieving revision 1.32
diff -u -b -r1.32 untupling.m
--- compiler/untupling.m 11 Jun 2009 07:00:22 -0000 1.32
+++ compiler/untupling.m 28 Aug 2009 18:20:25 -0000
@@ -751,7 +751,7 @@
% Expand a discriminated union type if it has only a
% single functor and the type has no parameters.
type_to_ctor_and_args(Type, TypeCtor, []),
- map.search(TypeTable, TypeCtor, TypeDefn),
+ search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
get_type_defn_tparams(TypeDefn, []),
get_type_defn_body(TypeDefn, TypeBody),
TypeBody ^ du_type_ctors = [SingleCtor],
Index: compiler/unused_imports.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_imports.m,v
retrieving revision 1.21
diff -u -b -r1.21 unused_imports.m
--- compiler/unused_imports.m 19 Aug 2009 07:44:58 -0000 1.21
+++ compiler/unused_imports.m 29 Aug 2009 14:23:57 -0000
@@ -164,7 +164,7 @@
used_modules(ModuleInfo, !UsedModules) :-
module_info_get_type_table(ModuleInfo, TypeTable),
- map.foldl(type_used_modules, TypeTable, !UsedModules),
+ foldl_over_type_ctor_defns(type_used_modules, TypeTable, !UsedModules),
module_info_get_inst_table(ModuleInfo, InstTable),
inst_table_get_user_insts(InstTable, UserInstTable),
@@ -194,7 +194,9 @@
get_type_defn_status(TypeDefn, ImportStatus),
get_type_defn_body(TypeDefn, TypeBody),
- ( status_defined_in_this_module(ImportStatus) = yes ->
+ DefinedInThisModule = status_defined_in_this_module(ImportStatus),
+ (
+ DefinedInThisModule = yes,
Visibility = item_visibility(ImportStatus),
(
TypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _),
@@ -209,7 +211,7 @@
)
)
;
- true
+ DefinedInThisModule = no
).
:- pred ctor_used_modules(item_visibility::in, constructor::in,
@@ -240,7 +242,9 @@
user_inst_used_modules(_InstId, InstDefn, !UsedModules) :-
ImportStatus = InstDefn ^ inst_status,
- ( status_defined_in_this_module(ImportStatus) = yes ->
+ DefinedInThisModule = status_defined_in_this_module(ImportStatus),
+ (
+ DefinedInThisModule = yes,
Visibility = item_visibility(ImportStatus),
InstBody = InstDefn ^ inst_body,
(
@@ -250,7 +254,7 @@
InstBody = abstract_inst
)
;
- true
+ DefinedInThisModule = no
).
%-----------------------------------------------------------------------------%
@@ -261,14 +265,16 @@
mode_used_modules(mode_id(Name, _Arity), ModeDefn, !UsedModules) :-
ImportStatus = ModeDefn ^ mode_status,
- ( status_defined_in_this_module(ImportStatus) = yes ->
+ DefinedInThisModule = status_defined_in_this_module(ImportStatus),
+ (
+ DefinedInThisModule = yes,
Visibility = item_visibility(ImportStatus),
add_sym_name_module(Visibility, Name, !UsedModules),
ModeBody = ModeDefn ^ mody_body,
ModeBody = eqv_mode(Mode),
mer_mode_used_modules(Visibility, Mode, !UsedModules)
;
- true
+ DefinedInThisModule = no
).
%-----------------------------------------------------------------------------%
@@ -279,13 +285,15 @@
class_used_modules(class_id(Name, _Arity), ClassDefn, !UsedModules) :-
ImportStatus = ClassDefn ^ class_status,
- ( status_defined_in_this_module(ImportStatus) = yes ->
+ DefinedInThisModule = status_defined_in_this_module(ImportStatus),
+ (
+ DefinedInThisModule = yes,
Visibility = item_visibility(ImportStatus),
add_sym_name_module(Visibility, Name, !UsedModules),
list.foldl(prog_constraint_used_module(Visibility),
ClassDefn ^ class_supers, !UsedModules)
;
- true
+ DefinedInThisModule = no
).
%-----------------------------------------------------------------------------%
@@ -302,7 +310,9 @@
instance_used_modules_2(class_id(Name, _Arity), InstanceDefn, !UsedModules) :-
ImportStatus = InstanceDefn ^ instance_status,
- ( status_defined_in_this_module(ImportStatus) = yes ->
+ DefinedInThisModule = status_defined_in_this_module(ImportStatus),
+ (
+ DefinedInThisModule = yes,
% The methods of the class are stored in the pred_table and hence
% will be processed by pred_info_used_modules.
% XXX is this true?
@@ -313,7 +323,7 @@
list.foldl(mer_type_used_modules(Visibility),
InstanceDefn ^ instance_types, !UsedModules)
;
- true
+ DefinedInThisModule = no
).
%-----------------------------------------------------------------------------%
@@ -324,7 +334,9 @@
pred_info_used_modules(_PredId, PredInfo, !UsedModules) :-
pred_info_get_import_status(PredInfo, ImportStatus),
- ( status_defined_in_this_module(ImportStatus) = yes ->
+ DefinedInThisModule = status_defined_in_this_module(ImportStatus),
+ (
+ DefinedInThisModule = yes,
Visibility = item_visibility(ImportStatus),
pred_info_get_arg_types(PredInfo, Args),
@@ -343,7 +355,7 @@
pred_info_get_clauses_info(PredInfo, ClausesInfo),
clauses_info_used_modules(ClausesInfo, !UsedModules)
;
- true
+ DefinedInThisModule = no
).
:- pred proc_info_used_modules(item_visibility::in, proc_id::in, proc_info::in,
Index: compiler/xml_documentation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/xml_documentation.m,v
retrieving revision 1.23
diff -u -b -r1.23 xml_documentation.m
--- compiler/xml_documentation.m 11 Jun 2009 07:00:22 -0000 1.23
+++ compiler/xml_documentation.m 29 Aug 2009 14:30:28 -0000
@@ -298,13 +298,15 @@
InterfaceImports),
module_info_get_imported_module_specifiers(ModuleInfo,
ImportedModules0),
- ImportedModules = ImportedModules0 `difference` set(all_builtin_modules),
+ ImportedModules =
+ ImportedModules0 `difference` set(all_builtin_modules),
set.fold(import_documentation(InterfaceImports),
ImportedModules, [], ImportsXml),
ImportXml = elem("imports", [], ImportsXml),
module_info_get_type_table(ModuleInfo, TypeTable),
- map.foldl(type_documentation(Comments), TypeTable, [], TypeXmls),
+ foldl_over_type_ctor_defns(type_documentation(Comments), TypeTable,
+ [], TypeXmls),
TypeXml = elem("types", [], TypeXmls),
module_info_preds(ModuleInfo, PredTable),
@@ -349,8 +351,9 @@
type_documentation(C, type_ctor(TypeName, TypeArity), TypeDefn, !Xmls) :-
get_type_defn_status(TypeDefn, ImportStatus),
-
- ( status_defined_in_this_module(ImportStatus) = yes ->
+ DefinedInThisModule = status_defined_in_this_module(ImportStatus),
+ (
+ DefinedInThisModule = yes,
get_type_defn_body(TypeDefn, TypeBody),
get_type_defn_tvarset(TypeDefn, TVarset),
get_type_defn_context(TypeDefn, Context),
@@ -369,7 +372,7 @@
!:Xmls = [Xml | !.Xmls]
;
- true
+ DefinedInThisModule = no
).
:- func type_xml_tag(hlds_type_body) = string.
@@ -669,7 +672,9 @@
class_documentation(C, PredTable, class_id(Name, Arity), ClassDefn, !Xml) :-
ImportStatus = ClassDefn ^ class_status,
- ( status_defined_in_this_module(ImportStatus) = yes ->
+ DefinedInThisModule = status_defined_in_this_module(ImportStatus),
+ (
+ DefinedInThisModule = yes,
Id = sym_name_and_arity_to_id("class", Name, Arity),
Context = ClassDefn ^ class_context,
@@ -695,7 +700,7 @@
!:Xml = [Xml | !.Xml]
;
- true
+ DefinedInThisModule = no
).
:- func fundep(tvarset, list(tvar), hlds_class_fundep) = xml.
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
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/concurrency
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_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/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
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/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/diff
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/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
Index: tests/invalid/ambiguous_overloading_error.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/ambiguous_overloading_error.err_exp,v
retrieving revision 1.2
diff -u -b -r1.2 ambiguous_overloading_error.err_exp
--- tests/invalid/ambiguous_overloading_error.err_exp 5 Sep 2008 03:57:38 -0000 1.2
+++ tests/invalid/ambiguous_overloading_error.err_exp 28 Aug 2009 23:16:30 -0000
@@ -5,9 +5,9 @@
ambiguous_overloading_error.m:041: The function symbol `f'/0.
ambiguous_overloading_error.m:041: The possible matches are:
ambiguous_overloading_error.m:041: the type constructor
-ambiguous_overloading_error.m:041: `ambiguous_overloading_error.foo'/0,
-ambiguous_overloading_error.m:041: the type constructor
ambiguous_overloading_error.m:041: `ambiguous_overloading_error.bar'/0,
+ambiguous_overloading_error.m:041: the type constructor
+ambiguous_overloading_error.m:041: `ambiguous_overloading_error.foo'/0,
ambiguous_overloading_error.m:041: the builtin type constructor
ambiguous_overloading_error.m:041: `character'.
ambiguous_overloading_error.m:042: The function symbol `f'/0 is also
@@ -19,15 +19,15 @@
ambiguous_overloading_error.m:046: The function symbol `a1'/0.
ambiguous_overloading_error.m:046: The possible matches are:
ambiguous_overloading_error.m:046: the type constructor
-ambiguous_overloading_error.m:046: `ambiguous_overloading_error.qux'/0,
+ambiguous_overloading_error.m:046: `ambiguous_overloading_error.baz'/0,
ambiguous_overloading_error.m:046: the type constructor
-ambiguous_overloading_error.m:046: `ambiguous_overloading_error.baz'/0.
+ambiguous_overloading_error.m:046: `ambiguous_overloading_error.qux'/0.
ambiguous_overloading_error.m:046: The function symbol `a2'/0.
ambiguous_overloading_error.m:046: The possible matches are:
ambiguous_overloading_error.m:046: the type constructor
-ambiguous_overloading_error.m:046: `ambiguous_overloading_error.qux'/0,
+ambiguous_overloading_error.m:046: `ambiguous_overloading_error.baz'/0,
ambiguous_overloading_error.m:046: the type constructor
-ambiguous_overloading_error.m:046: `ambiguous_overloading_error.baz'/0.
+ambiguous_overloading_error.m:046: `ambiguous_overloading_error.qux'/0.
ambiguous_overloading_error.m:100: In clause for predicate `test_lt'/1:
ambiguous_overloading_error.m:100: error: excessively ambiguous overloading.
ambiguous_overloading_error.m:100: The following symbol was overloaded in the
Index: tests/invalid/errors2.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/errors2.err_exp,v
retrieving revision 1.22
diff -u -b -r1.22 errors2.err_exp
--- tests/invalid/errors2.err_exp 14 Aug 2009 20:37:54 -0000 1.22
+++ tests/invalid/errors2.err_exp 28 Aug 2009 23:19:05 -0000
@@ -88,19 +88,19 @@
errors2.m:072: C_5: string
errors2.m:072:
errors2.m:072: Type assignment 2:
-errors2.m:072: Y_1: errors2.foo
-errors2.m:072: Z_2: errors2.bar_2_type
-errors2.m:072: A_3: character
-errors2.m:072: B_4: int
-errors2.m:072: C_5: string
-errors2.m:072:
-errors2.m:072: Type assignment 3:
errors2.m:072: Y_1: character
errors2.m:072: Z_2: errors2.bar_1_type
errors2.m:072: A_3: int
errors2.m:072: B_4: character
errors2.m:072: C_5: string
errors2.m:072:
+errors2.m:072: Type assignment 3:
+errors2.m:072: Y_1: errors2.foo
+errors2.m:072: Z_2: errors2.bar_2_type
+errors2.m:072: A_3: character
+errors2.m:072: B_4: int
+errors2.m:072: C_5: string
+errors2.m:072:
errors2.m:072: Type assignment 4:
errors2.m:072: Y_1: character
errors2.m:072: Z_2: errors2.bar_2_type
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
Index: tests/warnings/ambiguous_overloading.exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/warnings/ambiguous_overloading.exp,v
retrieving revision 1.8
diff -u -b -r1.8 ambiguous_overloading.exp
--- tests/warnings/ambiguous_overloading.exp 5 Sep 2008 03:57:38 -0000 1.8
+++ tests/warnings/ambiguous_overloading.exp 29 Aug 2009 01:14:47 -0000
@@ -5,9 +5,9 @@
ambiguous_overloading.m:041: The function symbol `f'/0.
ambiguous_overloading.m:041: The possible matches are:
ambiguous_overloading.m:041: the type constructor
-ambiguous_overloading.m:041: `ambiguous_overloading.foo'/0,
-ambiguous_overloading.m:041: the type constructor
ambiguous_overloading.m:041: `ambiguous_overloading.bar'/0,
+ambiguous_overloading.m:041: the type constructor
+ambiguous_overloading.m:041: `ambiguous_overloading.foo'/0,
ambiguous_overloading.m:041: the builtin type constructor `character'.
ambiguous_overloading.m:045: In clause for predicate `ambig_overload2'/1:
ambiguous_overloading.m:045: warning: highly ambiguous overloading.
@@ -16,15 +16,15 @@
ambiguous_overloading.m:045: The function symbol `a1'/0.
ambiguous_overloading.m:045: The possible matches are:
ambiguous_overloading.m:045: the type constructor
-ambiguous_overloading.m:045: `ambiguous_overloading.qux'/0,
+ambiguous_overloading.m:045: `ambiguous_overloading.baz'/0,
ambiguous_overloading.m:045: the type constructor
-ambiguous_overloading.m:045: `ambiguous_overloading.baz'/0.
+ambiguous_overloading.m:045: `ambiguous_overloading.qux'/0.
ambiguous_overloading.m:045: The function symbol `a2'/0.
ambiguous_overloading.m:045: The possible matches are:
ambiguous_overloading.m:045: the type constructor
-ambiguous_overloading.m:045: `ambiguous_overloading.qux'/0,
+ambiguous_overloading.m:045: `ambiguous_overloading.baz'/0,
ambiguous_overloading.m:045: the type constructor
-ambiguous_overloading.m:045: `ambiguous_overloading.baz'/0.
+ambiguous_overloading.m:045: `ambiguous_overloading.qux'/0.
ambiguous_overloading.m:056: In clause for predicate `test_lt'/1:
ambiguous_overloading.m:056: warning: highly ambiguous overloading.
ambiguous_overloading.m:056: The following symbol was overloaded in the
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