[m-rev.] for review: type_ctors in user-defined-functor cons_ids
Zoltan Somogyi
zs at csse.unimelb.edu.au
Tue Jun 9 13:54:31 AEST 2009
I would like to commit this soon, so I can start working on the issues
identified below. For now, I am looking more for a review of the concept;
I can address any detailed comments after commit.
Zoltan.
Include the type_ctor in cons_ids for user-defined types. The intention is
two-fold:
- It prepares for a future in which we allow more than one function symbol to
with the same name to be defined in a module.
- It makes the HLDS code more self-contained. In many places, processing
construction and deconstruction unifications required knowing which type
the cons_id belongs to, but until now, code couldn't know that unless it
kept track of the type of the variable unified with the cons_id.
With this diff, user-defined cons_ids are represented as
cons(SymName, Arity, TypeCtor)
The last field is filled in during post-typecheck. After that time, any module
qualification in the SymName (which may initially be partial) is redundant,
since it is also available in the TypeCtor.
In the future, we could make all those SymNames be just unqualified(_) at that
time. We could also replace the current maps in HLDS type definitions with
full cons_id keys with just name/arity keys (since the module qualifier is a
given for any given type definition), we could also support partially
qualified cons_ids in source code using a map from name/arity pairs to a list
of all the type_ctors that have function symbols with that name/arity, instead
of our current practice of inserting all possible partially module qualified
version of every cons_id into a single giant table, and we could do the same
thing with the field names table.
This diff also separates tuples out from user-defined types, since in many
respects they are different (they don't have a single type_ctor, for starters).
It also separates out character constants, since they were alreay treated
specially in most places, though not in some places where they *ought* to
have been treated specially. Take the opportunity to give some other cons_ids
better names.
compiler/prog_data.m:
Make the change described above, and document it.
Put the implementations of the predicates declared in each part
of this module next to the declarations, instead of keeping all the
code until the very end (where it was usually far from their
declarations).
Remove three predicates with identical definitions from inst_match.m,
inst_util.m and mode_constraints.m, and put the common definition
in prog_data.m.
library/term_io.m:
Add a new predicate that is basically a reversible version of
the existing function espaced_char, since the definition of char_consts
needs reversibilty.
compiler/post_typecheck.m:
For functors of user-defined types, record their type_ctor. For tuples
and char constants, record them as such.
compiler/builtin_lib_types.m:
compiler/parse_tree.m:
compiler/notes/compiler_design.html:
New module to centralize knowledge about builtin types, specially
handled library types, and their function symbols. Previously,
the stuff now in this module used to be in several different places,
including prog_type.m and stm_expand.m, and some of it was duplicated.
mdbcomp/prim_data.m:
Add some predicates now needed by builtin_lib_types.m.
compiler/builtin_ops.m:
Factor out some duplicated code.
compiler/add_type.m:
Include the relevant type_ctors in the cons_ids generated in type
definitions.
compiler/hlds_data.m:
Document an existing type better.
Rename a cons_tag in sync with its corresponding cons_id.
Put some declarations into logical order.
compiler/hlds_out.m:
Rename a misleadingly-named predicate.
compiler/prog_ctgc.m:
compiler/term_constr_build.m:
Add XXXs for questionable existing code.
compiler/add_clause.m:
compiler/add_heap_ops.m:
compiler/add_pragma.m:
compiler/add_pred.m:
compiler/add_trail_ops.m:
compiler/assertion.m:
compiler/bytecode_gen.m:
compiler/closure_analysis.m:
compiler/code_info.m:
compiler/complexity.m:
compiler/ctgc_selector.m:
compiler/dead_proc_elim.m:
compiler/deep_profiling.m:
compiler/delay_partial_inst.m:
compiler/dependency_graph.m:
compiler/det_analysis.m:
compiler/det_report.m:
compiler/distance_granularity.m:
compiler/erl_rtti.m:
compiler/erl_unify_gen.m:
compiler/export.m:
compiler/field_access.m:
compiler/foreign.m:
compiler/format_call.m:
compiler/hhf.m:
compiler/higher_order.m:
compiler/hlds_code_util.m:
compiler/hlds_desc.m:
compiler/hlds_goal.m:
compiler/implementation_defined_literals.m:
compiler/inst_check.m:
compiler/inst_graph.m:
compiler/inst_match.m:
compiler/inst_util.m:
compiler/instmap.m:
compiler/intermod.m:
compiler/interval.m:
compiler/lambda.m:
compiler/lco.m:
compiler/make_tags.m:
compiler/mercury_compile.m:
compiler/mercury_to_mercury.m:
compiler/middle_rec.m:
compiler/ml_closure_gen.m:
compiler/ml_code_gen.m:
compiler/ml_code_util.m:
compiler/ml_switch_gen.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen.m:
compiler/ml_util.m:
compiler/mlds_to_c.m:
compiler/mlds_to_java.m:
compiler/mode_constraints.m:
compiler/mode_errors.m:
compiler/mode_ordering.m:
compiler/mode_util.m:
compiler/modecheck_unify.m:
compiler/modes.m:
compiler/module_qual.m:
compiler/polymorphism.m:
compiler/prog_ctgc.m:
compiler/prog_event.m:
compiler/prog_io_util.m:
compiler/prog_mode.m:
compiler/prog_mutable.m:
compiler/prog_out.m:
compiler/prog_type.m:
compiler/prog_util.m:
compiler/purity.m:
compiler/qual_info.m:
compiler/rbmm.add_rbmm_goal_infos.m:
compiler/rbmm.execution_path.m:
compiler/rbmm.points_to_analysis.m:
compiler/rbmm.region_transformation.m:
compiler/recompilation.usage.m:
compiler/rtti.m:
compiler/rtti_out.m:
compiler/rtti_to_mlds.m:
compiler/simplify.m:
compiler/simplify.m:
compiler/special_pred.m:
compiler/ssdebug.m:
compiler/stack_opt.m:
compiler/stm_expand.m:
compiler/stratify.m:
compiler/structure_reuse.direct.detect_garbagem:
compiler/superhomoegenous.m:
compiler/switch_detection.m:
compiler/switch_gen.m:
compiler/switch_util.m:
compiler/table_gen.m:
compiler/term_constr_build.m:
compiler/term_norm.m:
compiler/try_expand.m:
compiler/type_constraints.m:
compiler/type_ctor_info.m:
compiler/type_util.m:
compiler/typecheck.m:
compiler/typecheck_errors.m:
compiler/unify_gen.m:
compiler/unify_proc.m:
compiler/unify_modes.m:
compiler/untupling.m:
compiler/unused_imports.m:
compiler/xml_documentation.m:
Minor changes, mostly to ignore the type_ctor in cons_ids in places
where it is not needed, take the type_ctor from the cons_id in places
where it is more convenient, conform to the new names of some cons_ids,
conform to the changes in hlds_out.m, and/or add now-needed imports
of builtin_lib_types.m.
In some places, the handling previously applied to cons/2 (which
included tuples and character constants as well as user-defined
function symbols) is now applied only to user-defined function symbols
or to user-defined function symbols and tuples, as appropriate,
with character constants being handled more like the other kinds of
constants.
In inst_match.m, rename a whole bunch of predicates to avoid
ambiguities.
In prog_util.m, remove two predicates that did almost nothing yet were
far too easy to misuse.
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_clause.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_clause.m,v
retrieving revision 1.54
diff -u -r1.54 add_clause.m
--- compiler/add_clause.m 10 Mar 2009 05:00:28 -0000 1.54
+++ compiler/add_clause.m 12 Mar 2009 01:25:45 -0000
@@ -1238,9 +1238,9 @@
InnermostSubContext),
InputTermArgNumber = 1,
InputTermArgContext = ac_functor(Functor, umc_explicit, []),
- ( Functor = cons(FuncName0, FuncArity0) ->
- FuncName = FuncName0,
- FuncArity = FuncArity0
+ ( Functor = cons(FuncNamePrime, FuncArityPrime, _TypeCtor) ->
+ FuncName = FuncNamePrime,
+ FuncArity = FuncArityPrime
;
unexpected(this_file, "transform_dcg_record_syntax_2")
),
@@ -1268,9 +1268,9 @@
InputTermArgNumber = 1,
InputTermArgContext = ac_functor(Functor, umc_explicit, []),
- ( InnermostFunctor = cons(FuncName0, FuncArity0) ->
- FuncName = FuncName0,
- FuncArity = FuncArity0
+ ( InnermostFunctor = cons(FuncNamePrime, FuncArityPrime, _TC) ->
+ FuncName = FuncNamePrime,
+ FuncArity = FuncArityPrime
;
unexpected(this_file, "transform_dcg_record_syntax_2")
),
Index: compiler/add_heap_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_heap_ops.m,v
retrieving revision 1.39
diff -u -r1.39 add_heap_ops.m
--- compiler/add_heap_ops.m 23 Dec 2008 01:37:29 -0000 1.39
+++ compiler/add_heap_ops.m 30 May 2009 05:56:44 -0000
@@ -51,6 +51,7 @@
:- import_module hlds.quantification.
:- import_module libs.compiler_util.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.90
diff -u -r1.90 add_pragma.m
--- compiler/add_pragma.m 27 May 2009 05:48:36 -0000 1.90
+++ compiler/add_pragma.m 30 May 2009 05:54:22 -0000
@@ -166,6 +166,7 @@
:- import_module ml_backend.
:- import_module ml_backend.mlds.
:- import_module ml_backend.mlds_to_c.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_ctgc.
@@ -1264,7 +1265,7 @@
make_foreign_tag(ForeignLanguage, ForeignTagMap, ConsId, _, !ConsTagValues,
!UnmappedCtors) :-
- ( ConsId = cons(ConsSymName0, 0) ->
+ ( ConsId = cons(ConsSymName0, 0, _) ->
ConsSymName = ConsSymName0
;
unexpected(this_file, "non arity zero enumeration constant.")
Index: compiler/add_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pred.m,v
retrieving revision 1.37
diff -u -r1.37 add_pred.m
--- compiler/add_pred.m 29 Apr 2009 03:38:12 -0000 1.37
+++ compiler/add_pred.m 30 May 2009 05:55:09 -0000
@@ -82,6 +82,7 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
Index: compiler/add_trail_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_trail_ops.m,v
retrieving revision 1.51
diff -u -r1.51 add_trail_ops.m
--- compiler/add_trail_ops.m 23 Dec 2008 01:37:29 -0000 1.51
+++ compiler/add_trail_ops.m 30 May 2009 05:56:57 -0000
@@ -77,6 +77,7 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
Index: compiler/add_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_type.m,v
retrieving revision 1.33
diff -u -r1.33 add_type.m
--- compiler/add_type.m 14 Jan 2009 08:38:45 -0000 1.33
+++ compiler/add_type.m 4 Jun 2009 06:56:32 -0000
@@ -371,9 +371,17 @@
module_info_get_cons_table(!.ModuleInfo, Ctors0),
module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
module_info_get_ctor_field_table(!.ModuleInfo, CtorFields0),
- ctors_add(ConsList, TypeCtor, TVarSet, Args, KindMap, NeedQual, PQInfo,
- Context, Status, CtorFields0, CtorFields, Ctors0, Ctors,
- [], CtorAddSpecs),
+ TypeCtor = type_ctor(TypeCtorSymName, _),
+ (
+ TypeCtorSymName = unqualified(_),
+ unexpected(this_file,
+ "process_type_defn: unqualified TypeCtorSymName")
+ ;
+ TypeCtorSymName = qualified(TypeCtorModuleName, _)
+ ),
+ ctors_add(ConsList, TypeCtor, TypeCtorModuleName, TVarSet, Args,
+ KindMap, NeedQual, PQInfo, Context, Status,
+ CtorFields0, CtorFields, Ctors0, Ctors, [], CtorAddSpecs),
module_info_set_cons_table(Ctors, !ModuleInfo),
module_info_set_ctor_field_table(CtorFields, !ModuleInfo),
@@ -461,7 +469,7 @@
VerbosePieces = [words("There are representations for this type"),
words("on other back-ends, but none for this back-end."), nl],
Msg = simple_msg(Context,
- [always(MainPieces),
+ [always(MainPieces),
option_is_set(very_verbose, yes, [always(VerbosePieces)])]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
[Msg]),
@@ -623,8 +631,8 @@
ReservedAddr = does_not_use_reserved_address,
map.to_assoc_list(CtorTagMap, CtorTagList),
CtorTagList = [ConsIdA - ConsTagA, ConsIdB - ConsTagB],
- ConsIdA = cons(_, ArityA),
- ConsIdB = cons(_, ArityB)
+ ConsIdA = cons(_, ArityA, _),
+ ConsIdB = cons(_, ArityB, _)
->
(
ArityB = 0,
@@ -675,18 +683,27 @@
Body = foreign_type_body(no, no, no, yes(Data))
).
-:- pred ctors_add(list(constructor)::in, type_ctor::in, tvarset::in,
- list(type_param)::in, tvar_kind_map::in, need_qualifier::in,
+:- pred ctors_add(list(constructor)::in, type_ctor::in, module_name::in,
+ tvarset::in, list(type_param)::in, tvar_kind_map::in, need_qualifier::in,
partial_qualifier_info::in, prog_context::in,
import_status::in, ctor_field_table::in, ctor_field_table::out,
cons_table::in, cons_table::out,
list(error_spec)::in, list(error_spec)::out) is det.
-ctors_add([], _, _, _, _, _, _, _, _, !FieldNameTable, !Ctors, !Specs).
-ctors_add([Ctor | Rest], TypeCtor, TVarSet, TypeParams, KindMap, NeedQual,
- PQInfo, _Context, ImportStatus, !FieldNameTable, !Ctors, !Specs) :-
+ctors_add([], _, _, _, _, _, _, _, _, _, !FieldNameTable, !Ctors, !Specs).
+ctors_add([Ctor | Rest], TypeCtor, TypeCtorModuleName, TVarSet, TypeParams,
+ KindMap, NeedQual, PQInfo, _Context, ImportStatus, !FieldNameTable,
+ !Ctors, !Specs) :-
Ctor = ctor(ExistQVars, Constraints, Name, Args, Context),
- QualifiedConsId = make_cons_id(Name, Args, TypeCtor),
+ list.length(Args, Arity),
+ BaseName = unqualify_name(Name),
+ QualifiedName = qualified(TypeCtorModuleName, BaseName),
+ UnqualifiedName = unqualified(BaseName),
+ QualifiedConsIdA = cons(QualifiedName, Arity, TypeCtor),
+ QualifiedConsIdB = cons(QualifiedName, Arity, cons_id_dummy_type_ctor),
+ UnqualifiedConsIdA = cons(UnqualifiedName, Arity, TypeCtor),
+ UnqualifiedConsIdB = cons(UnqualifiedName, Arity, cons_id_dummy_type_ctor),
+
ConsDefn = hlds_cons_defn(TypeCtor, TVarSet, TypeParams, KindMap,
ExistQVars, Constraints, Args, Context),
@@ -694,65 +711,72 @@
% Also check that there is at most one definition of a given cons_id
% in each type.
- ( map.search(!.Ctors, QualifiedConsId, QualifiedConsDefns0) ->
- QualifiedConsDefns1 = QualifiedConsDefns0
+ ( map.search(!.Ctors, QualifiedConsIdA, QualifiedConsDefnsA0) ->
+ QualifiedConsDefnsA1 = QualifiedConsDefnsA0
;
- QualifiedConsDefns1 = []
+ QualifiedConsDefnsA1 = []
+ ),
+ ( map.search(!.Ctors, QualifiedConsIdB, QualifiedConsDefnsB0) ->
+ QualifiedConsDefnsB1 = QualifiedConsDefnsB0
+ ;
+ QualifiedConsDefnsB1 = []
),
(
some [OtherConsDefn] (
- list.member(OtherConsDefn, QualifiedConsDefns1),
+ list.member(OtherConsDefn, QualifiedConsDefnsA1),
OtherConsDefn ^ cons_type_ctor = TypeCtor
)
->
- QualifiedConsIdStr = cons_id_to_string(QualifiedConsId),
+ QualifiedConsIdStr = cons_id_and_arity_to_string(QualifiedConsIdA),
TypeCtorStr = type_ctor_to_string(TypeCtor),
Pieces = [words("Error: constructor"), quote(QualifiedConsIdStr),
words("for type"), quote(TypeCtorStr), words("multiply defined.")],
Msg = simple_msg(Context, [always(Pieces)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
!:Specs = [Spec | !.Specs],
- QualifiedConsDefns = QualifiedConsDefns1
+ QualifiedConsDefnsA = QualifiedConsDefnsA1
;
- QualifiedConsDefns = [ConsDefn | QualifiedConsDefns1]
+ QualifiedConsDefnsA = [ConsDefn | QualifiedConsDefnsA1]
),
- svmap.set(QualifiedConsId, QualifiedConsDefns, !Ctors),
-
- ( QualifiedConsId = cons(qualified(Module, ConsName), Arity) ->
- % Add the unqualified version of the cons_id to the cons_table,
- % if appropriate.
- (
- NeedQual = may_be_unqualified,
- UnqualifiedConsId = cons(unqualified(ConsName), Arity),
- svmulti_map.set(UnqualifiedConsId, ConsDefn, !Ctors)
- ;
- NeedQual = must_be_qualified
- ),
-
- % Add partially qualified versions of the cons_id.
- get_partial_qualifiers(Module, PQInfo, PartialQuals),
- list.map_foldl(add_ctor(ConsName, Arity, ConsDefn),
- PartialQuals, _PartiallyQualifiedConsIds, !Ctors),
-
- FieldNames = list.map(func(C) = C ^ arg_field_name, Args),
+ QualifiedConsDefnsB = [ConsDefn | QualifiedConsDefnsB1],
+ svmap.set(QualifiedConsIdA, QualifiedConsDefnsA, !Ctors),
+ svmap.set(QualifiedConsIdB, QualifiedConsDefnsB, !Ctors),
- FirstField = 1,
-
- add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
- QualifiedConsId, Context, ImportStatus, FirstField,
- !FieldNameTable, !Specs)
+ % Add the unqualified version of the cons_id to the cons_table,
+ % if appropriate.
+ (
+ NeedQual = may_be_unqualified,
+ svmulti_map.set(UnqualifiedConsIdA, ConsDefn, !Ctors),
+ svmulti_map.set(UnqualifiedConsIdB, ConsDefn, !Ctors)
;
- unexpected(this_file, "ctors_add: cons_id not qualified")
+ NeedQual = must_be_qualified
),
- ctors_add(Rest, TypeCtor, TVarSet, TypeParams, KindMap, NeedQual,
- PQInfo, Context, ImportStatus, !FieldNameTable, !Ctors, !Specs).
-:- pred add_ctor(string::in, int::in, hlds_cons_defn::in, module_name::in,
- cons_id::out, cons_table::in, cons_table::out) is det.
+ % Add partially qualified versions of the cons_id.
+ get_partial_qualifiers(TypeCtorModuleName, PQInfo, PartialQuals),
+ list.foldl(
+ add_ctor(TypeCtor, BaseName, Arity, ConsDefn),
+ PartialQuals, !Ctors),
+ list.foldl(
+ add_ctor(cons_id_dummy_type_ctor, BaseName, Arity, ConsDefn),
+ PartialQuals, !Ctors),
+
+ FieldNames = list.map(func(C) = C ^ arg_field_name, Args),
+ FirstField = 1,
+ add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
+ QualifiedConsIdA, Context, ImportStatus, FirstField,
+ !FieldNameTable, !Specs),
-add_ctor(ConsName, Arity, ConsDefn, ModuleQual, ConsId, CtorsIn, CtorsOut) :-
- ConsId = cons(qualified(ModuleQual, ConsName), Arity),
- multi_map.set(CtorsIn, ConsId, ConsDefn, CtorsOut).
+ ctors_add(Rest, TypeCtor, TypeCtorModuleName, TVarSet, TypeParams,
+ KindMap, NeedQual, PQInfo, Context, ImportStatus, !FieldNameTable,
+ !Ctors, !Specs).
+
+:- pred add_ctor(type_ctor::in, string::in, int::in, hlds_cons_defn::in,
+ module_name::in, cons_table::in, cons_table::out) is det.
+
+add_ctor(TypeCtor, ConsName, Arity, ConsDefn, ModuleQual, !Ctors) :-
+ ConsId = cons(qualified(ModuleQual, ConsName), Arity, TypeCtor),
+ svmulti_map.set(ConsId, ConsDefn, !Ctors).
:- pred add_ctor_field_names(list(maybe(ctor_field_name))::in,
need_qualifier::in, list(module_name)::in, type_ctor::in, cons_id::in,
@@ -829,7 +853,7 @@
svmulti_map.set(unqualified(UnqualFieldName), FieldDefn,
!FieldNameTable)
;
- NeedQual = must_be_qualified
+ NeedQual = must_be_qualified
),
% Add partially qualified versions of the cons_id
Index: compiler/assertion.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/assertion.m,v
retrieving revision 1.65
diff -u -r1.65 assertion.m
--- compiler/assertion.m 10 Mar 2009 05:00:28 -0000 1.65
+++ compiler/assertion.m 4 Jun 2009 06:22:48 -0000
@@ -400,9 +400,15 @@
%
:- pred single_construction(hlds_goal::in, cons_id::in) is semidet.
-single_construction(hlds_goal(unify(_, UnifyRhs, _, _, _), _),
- cons(QualifiedSymName, Arity)) :-
- UnifyRhs = rhs_functor(cons(UnqualifiedSymName, Arity), _, _),
+single_construction(Goal, ConsId) :-
+ Goal = hlds_goal(GoalExpr, _),
+ GoalExpr = unify(_, UnifyRHS, _, _, _),
+ UnifyRHS = rhs_functor(cons(UnqualifiedSymName, Arity, _TypeCtorA), _, _),
+ ConsId = cons(QualifiedSymName, Arity, _TypeCtorB),
+ % Before post-typecheck, TypeCtorA and TypeCtorB would be dummies,
+ % and would thus match even if the two functors are NOT of the same type.
+ % Note that by insisting on cons, we effectively disallow assertions
+ % about tuples.
match_sym_name(UnqualifiedSymName, QualifiedSymName).
% The side containing the predicate call must be a single call
Index: compiler/builtin_lib_types.m
===================================================================
RCS file: compiler/builtin_lib_types.m
diff -N compiler/builtin_lib_types.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/builtin_lib_types.m 3 Jun 2009 12:45:21 -0000
@@ -0,0 +1,255 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2009 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: builtin_lib_types.m.
+%
+% The function and predicates of this module handle return information about
+% the types and type constructors built into Mercury and defined in modules of
+% the standard Mercury library, as well as the function symbols of those types.
+%
+%-----------------------------------------------------------------------------%
+
+:- module parse_tree.builtin_lib_types.
+:- interface.
+
+:- import_module parse_tree.prog_data.
+
+%-----------------------------------------------------------------------------%
+%
+% Types.
+%
+
+:- func int_type = mer_type.
+:- func float_type = mer_type.
+:- func string_type = mer_type.
+:- func char_type = mer_type.
+:- func void_type = mer_type.
+:- func c_pointer_type = mer_type.
+:- func heap_pointer_type = mer_type.
+:- func sample_type_info_type = mer_type.
+:- func sample_typeclass_info_type = mer_type.
+:- func type_info_type = mer_type.
+:- func type_ctor_info_type = mer_type.
+:- func comparison_result_type = mer_type.
+:- func io_state_type = mer_type.
+:- func io_io_type = mer_type.
+:- func univ_type = mer_type.
+:- func exception_result_type(mer_type) = mer_type.
+:- func stm_atomic_type = mer_type.
+:- func stm_state_type = mer_type.
+:- func stm_valid_result_type = mer_type.
+:- func stm_rollback_exception_type = mer_type.
+:- func stm_dummy_output_type = mer_type.
+:- func region_type = mer_type.
+
+%-----------------------------------------------------------------------------%
+%
+% Type constructors.
+%
+
+:- func int_type_ctor = type_ctor.
+:- func float_type_ctor = type_ctor.
+:- func char_type_ctor = type_ctor.
+:- func string_type_ctor = type_ctor.
+
+:- func poly_type_type_ctor = type_ctor.
+
+:- func list_type_ctor = type_ctor.
+
+:- func exception_result_type_ctor = type_ctor.
+
+:- func stm_valid_result_type_ctor = type_ctor.
+:- func stm_rollback_exception_type_ctor = type_ctor.
+:- func stm_dummy_output_type_ctor = type_ctor.
+
+%-----------------------------------------------------------------------------%
+
+ % Succeed iff the given variable is of region_type.
+ %
+:- pred is_region_var(vartypes::in, prog_var::in) is semidet.
+
+%-----------------------------------------------------------------------------%
+%
+% Functors.
+%
+
+ % The functors of type exception_result_type_ctor.
+ %
+:- func exception_succeeded_functor = cons_id.
+:- func exception_failed_functor = cons_id.
+:- func exception_exception_functor = cons_id.
+
+ % The functors of type stm_valid_result_type_ctor.
+ %
+:- func stm_validres_valid_functor = cons_id.
+:- func stm_validres_invalid_functor = cons_id.
+
+ % The functors of type stm_rollback_exception_type_ctor.
+ %
+:- func stm_rollback_exception_functor = cons_id.
+:- func stm_rollback_retry_functor = cons_id.
+
+ % The functors of type stm_dummy_output_type_ctor.
+ %
+:- func stm_dummy_output_functor = cons_id.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module mdbcomp.prim_data.
+
+:- import_module list.
+:- import_module map.
+
+%-----------------------------------------------------------------------------%
+
+int_type = builtin_type(builtin_type_int).
+
+float_type = builtin_type(builtin_type_float).
+
+string_type = builtin_type(builtin_type_string).
+
+char_type = builtin_type(builtin_type_char).
+
+void_type = defined_type(unqualified("void"), [], kind_star).
+
+c_pointer_type = defined_type(Name, [], kind_star) :-
+ BuiltinModule = mercury_public_builtin_module,
+ Name = qualified(BuiltinModule, "c_pointer").
+
+heap_pointer_type = defined_type(Name, [], kind_star) :-
+ BuiltinModule = mercury_private_builtin_module,
+ Name = qualified(BuiltinModule, "heap_pointer").
+
+sample_type_info_type = defined_type(Name, [], kind_star) :-
+ BuiltinModule = mercury_private_builtin_module,
+ Name = qualified(BuiltinModule, "sample_type_info").
+
+sample_typeclass_info_type = defined_type(Name, [], kind_star) :-
+ BuiltinModule = mercury_private_builtin_module,
+ Name = qualified(BuiltinModule, "sample_typeclass_info").
+
+type_info_type = defined_type(Name, [], kind_star) :-
+ BuiltinModule = mercury_private_builtin_module,
+ Name = qualified(BuiltinModule, "type_info").
+
+type_ctor_info_type = defined_type(Name, [], kind_star) :-
+ BuiltinModule = mercury_private_builtin_module,
+ Name = qualified(BuiltinModule, "type_ctor_info").
+
+comparison_result_type = defined_type(Name, [], kind_star) :-
+ BuiltinModule = mercury_public_builtin_module,
+ Name = qualified(BuiltinModule, "comparison_result").
+
+io_state_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_std_lib_module_name(unqualified("io")),
+ Name = qualified(Module, "state").
+
+io_io_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_std_lib_module_name(unqualified("io")),
+ Name = qualified(Module, "io").
+
+univ_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_univ_module,
+ Name = qualified(Module, "univ").
+
+exception_result_type(SubType) = defined_type(Name, [SubType], kind_star) :-
+ Module = mercury_exception_module,
+ Name = qualified(Module, "exception_result").
+
+stm_atomic_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_std_lib_module_name(unqualified("stm_builtin")),
+ Name = qualified(Module, "stm").
+
+stm_state_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_stm_builtin_module,
+ Name = qualified(Module, "stm").
+
+stm_valid_result_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_stm_builtin_module,
+ Name = qualified(Module, "stm_validation_result").
+
+stm_rollback_exception_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_stm_builtin_module,
+ Name = qualified(Module, "rollback_exception").
+
+stm_dummy_output_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_stm_builtin_module,
+ Name = qualified(Module, "stm_dummy_output").
+
+region_type = defined_type(Name, [], kind_star) :-
+ Module = mercury_region_builtin_module,
+ Name = qualified(Module, "region").
+
+%-----------------------------------------------------------------------------%
+
+int_type_ctor = type_ctor(Name, 0) :-
+ Name = unqualified("int").
+float_type_ctor = type_ctor(Name, 0) :-
+ Name = unqualified("int").
+char_type_ctor = type_ctor(Name, 0) :-
+ Name = unqualified("character").
+string_type_ctor = type_ctor(Name, 0) :-
+ Name = unqualified("string").
+
+poly_type_type_ctor = type_ctor(Name, 0) :-
+ Name = qualified(mercury_string_module, "poly_type").
+
+list_type_ctor = type_ctor(Name, 1) :-
+ Name = qualified(mercury_list_module, "list").
+
+exception_result_type_ctor = type_ctor(Name, 1) :-
+ Name = qualified(mercury_exception_module, "exception_result").
+
+stm_valid_result_type_ctor = type_ctor(Name, 0) :-
+ Name = qualified(mercury_stm_builtin_module, "stm_validation_result").
+stm_rollback_exception_type_ctor = type_ctor(Name, 0) :-
+ Name = qualified(mercury_stm_builtin_module, "rollback_exception").
+stm_dummy_output_type_ctor = type_ctor(Name, 0) :-
+ Name = qualified(mercury_stm_builtin_module, "stm_dummy_output").
+
+%-----------------------------------------------------------------------------%
+
+is_region_var(VarTypes, Var) :-
+ map.lookup(VarTypes, Var, Type),
+ Type = region_type.
+
+%-----------------------------------------------------------------------------%
+
+exception_succeeded_functor = cons(Name, 1, TypeCtor) :-
+ Name = qualified(mercury_exception_module, "succeeded"),
+ TypeCtor = exception_result_type_ctor.
+exception_failed_functor = cons(Name, 0, TypeCtor) :-
+ Name = qualified(mercury_exception_module, "failed"),
+ TypeCtor = exception_result_type_ctor.
+exception_exception_functor = cons(Name, 1, TypeCtor) :-
+ Name = qualified(mercury_exception_module, "exception"),
+ TypeCtor = exception_result_type_ctor.
+
+stm_validres_valid_functor = cons(Name, 0, TypeCtor) :-
+ Name = qualified(mercury_stm_builtin_module, "stm_transaction_valid"),
+ TypeCtor = stm_valid_result_type_ctor.
+stm_validres_invalid_functor = cons(Name, 0, TypeCtor) :-
+ Name = qualified(mercury_stm_builtin_module, "stm_transaction_invalid"),
+ TypeCtor = stm_valid_result_type_ctor.
+
+stm_rollback_exception_functor = cons(Name, 0, TypeCtor) :-
+ Name = qualified(mercury_stm_builtin_module,
+ "rollback_invalid_transaction"),
+ TypeCtor = stm_rollback_exception_type_ctor.
+stm_rollback_retry_functor = cons(Name, 0, TypeCtor) :-
+ Name = qualified(mercury_stm_builtin_module, "rollback_retry"),
+ TypeCtor = stm_rollback_exception_type_ctor.
+
+stm_dummy_output_functor = cons(Name, 0, TypeCtor) :-
+ Name = qualified(mercury_stm_builtin_module, "stm_dummy_output"),
+ TypeCtor = stm_dummy_output_type_ctor.
+
+%-----------------------------------------------------------------------------%
Index: compiler/builtin_ops.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/builtin_ops.m,v
retrieving revision 1.29
diff -u -r1.29 builtin_ops.m
--- compiler/builtin_ops.m 9 Sep 2008 01:37:30 -0000 1.29
+++ compiler/builtin_ops.m 25 Dec 2008 02:10:23 -0000
@@ -166,9 +166,7 @@
translate_builtin(FullyQualifiedModule, PredName, ProcId, Args, Code) :-
proc_id_to_int(ProcId, ProcInt),
- % -- not yet:
- % FullyQualifiedModule = qualified(unqualified("std"), ModuleName),
- FullyQualifiedModule = unqualified(ModuleName),
+ is_std_lib_module_name(FullyQualifiedModule, ModuleName),
builtin_translation(ModuleName, PredName, ProcInt, Args, Code).
:- pred builtin_translation(string::in, string::in, int::in, list(T)::in,
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.121
diff -u -r1.121 bytecode_gen.m
--- compiler/bytecode_gen.m 6 Jan 2009 03:56:24 -0000 1.121
+++ compiler/bytecode_gen.m 5 Feb 2009 07:04:23 -0000
@@ -46,7 +46,7 @@
:- import_module backend_libs.
:- import_module backend_libs.builtin_ops.
-:- import_module check_hlds. % for type_util and mode_util
+:- import_module check_hlds.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
:- import_module hlds.arg_info.
@@ -59,7 +59,7 @@
:- import_module hlds.passes_aux.
:- import_module libs.
:- import_module libs.compiler_util.
-:- import_module ll_backend. % bytecode_gen uses ll_backend__call_gen.m
+:- import_module ll_backend.
:- import_module ll_backend.call_gen. % XXX for arg passing convention
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
@@ -500,7 +500,7 @@
ByteInfo, Code) :-
map_var(ByteInfo, Var, ByteVar),
map_vars(ByteInfo, Args, ByteArgs),
- map_cons_id(ByteInfo, Var, ConsId, ByteConsId),
+ map_cons_id(ByteInfo, ConsId, ByteConsId),
( ByteConsId = byte_pred_const(_, _, _, _, _) ->
Code = singleton(byte_construct(ByteVar, ByteConsId, ByteArgs))
;
@@ -520,7 +520,7 @@
ByteInfo, Code) :-
map_var(ByteInfo, Var, ByteVar),
map_vars(ByteInfo, Args, ByteArgs),
- map_cons_id(ByteInfo, Var, ConsId, ByteConsId),
+ map_cons_id(ByteInfo, ConsId, ByteConsId),
map_uni_modes(UniModes, Args, ByteInfo, Dirs),
( all_dirs_same(Dirs, to_arg) ->
Code = singleton(byte_deconstruct(ByteVar, ByteConsId, ByteArgs))
@@ -687,8 +687,8 @@
gen_switch([], _, _, !ByteInfo, empty).
gen_switch([Case | Cases], Var, EndLabel, !ByteInfo, Code) :-
Case = case(MainConsId, OtherConsIds, Goal),
- map_cons_id(!.ByteInfo, Var, MainConsId, ByteMainConsId),
- list.map(map_cons_id(!.ByteInfo, Var), OtherConsIds, ByteOtherConsIds),
+ map_cons_id(!.ByteInfo, MainConsId, ByteMainConsId),
+ list.map(map_cons_id(!.ByteInfo), OtherConsIds, ByteOtherConsIds),
gen_goal(Goal, !ByteInfo, GoalCode),
gen_switch(Cases, Var, EndLabel, !ByteInfo, CasesCode),
get_next_label(NextLabel, !ByteInfo),
@@ -700,52 +700,31 @@
%---------------------------------------------------------------------------%
-:- pred map_cons_id(byte_info::in, prog_var::in, cons_id::in,
- byte_cons_id::out) is det.
+:- pred map_cons_id(byte_info::in, cons_id::in, byte_cons_id::out) is det.
-map_cons_id(ByteInfo, Var, ConsId, ByteConsId) :-
+map_cons_id(ByteInfo, ConsId, ByteConsId) :-
get_module_info(ByteInfo, ModuleInfo),
(
- ConsId = cons(Functor, Arity),
- get_var_type(ByteInfo, Var, Type),
+ ConsId = cons(Functor, Arity, _TypeCtor),
(
- % Everything other than characters and tuples should
- % be module qualified.
- Functor = unqualified(FunctorName),
- \+ type_is_tuple(Type, _)
- ->
- string.to_char_list(FunctorName, FunctorList),
- ( FunctorList = [Char] ->
- ByteConsId = byte_char_const(Char)
- ;
- unexpected(this_file, "map_cons_id: " ++
- "unqualified cons_id is not a char_const")
- )
+ Functor = qualified(ModuleName, FunctorName)
;
- (
- Functor = unqualified(FunctorName),
- ModuleName = unqualified("builtin")
- ;
- Functor = qualified(ModuleName, FunctorName)
- ),
- ConsTag = cons_id_to_tag(ModuleInfo, Type, ConsId),
- map_cons_tag(ConsTag, ByteConsTag),
- ByteConsId = byte_cons(ModuleName, FunctorName, Arity, ByteConsTag)
- )
- ;
- ConsId = int_const(IntVal),
- ByteConsId = byte_int_const(IntVal)
- ;
- ConsId = string_const(StringVal),
- ByteConsId = byte_string_const(StringVal)
- ;
- ConsId = float_const(FloatVal),
- ByteConsId = byte_float_const(FloatVal)
- ;
- ConsId = implementation_defined_const(_),
- unexpected(this_file, "map_cons_id: implementation_defined_const")
+ Functor = unqualified(_),
+ unexpected(this_file, "map_cons_id: unqualified cons")
+ ),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
+ map_cons_tag(ConsTag, ByteConsTag),
+ ByteConsId = byte_cons(ModuleName, FunctorName, Arity, ByteConsTag)
+ ;
+ ConsId = tuple_cons(Arity),
+ ModuleName = unqualified("builtin"),
+ FunctorName = "{}",
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
+ map_cons_tag(ConsTag, ByteConsTag),
+ % XXX We should have a byte_tuple_cons separate from byte_cons.
+ ByteConsId = byte_cons(ModuleName, FunctorName, Arity, ByteConsTag)
;
- ConsId = pred_const(ShroudedPredProcId, _EvalMethod),
+ ConsId = closure_cons(ShroudedPredProcId, _EvalMethod),
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
predicate_id(ModuleInfo, PredId, ModuleName, PredName, Arity),
@@ -756,6 +735,21 @@
ByteConsId = byte_pred_const(ModuleName, PredName, Arity, IsFunc,
ProcInt)
;
+ ConsId = int_const(IntVal),
+ ByteConsId = byte_int_const(IntVal)
+ ;
+ ConsId = float_const(FloatVal),
+ ByteConsId = byte_float_const(FloatVal)
+ ;
+ ConsId = char_const(CharVal),
+ ByteConsId = byte_char_const(CharVal)
+ ;
+ ConsId = string_const(StringVal),
+ ByteConsId = byte_string_const(StringVal)
+ ;
+ ConsId = impl_defined_const(_),
+ unexpected(this_file, "map_cons_id: impl_defined_const")
+ ;
ConsId = type_ctor_info_const(ModuleName, TypeName, TypeArity),
ByteConsId = byte_type_ctor_info_const(ModuleName, TypeName, TypeArity)
;
@@ -799,9 +793,9 @@
map_cons_tag(float_tag(_), _) :-
unexpected(this_file, "float_tag cons tag " ++
"for non-float_constant cons id").
-map_cons_tag(pred_closure_tag(_, _, _), _) :-
- unexpected(this_file, "pred_closure_tag cons tag " ++
- "for non-pred_const cons id").
+map_cons_tag(closure_tag(_, _, _), _) :-
+ unexpected(this_file, "closure_tag cons tag " ++
+ "for non-closure_cons cons id").
map_cons_tag(type_ctor_info_tag(_, _, _), _) :-
unexpected(this_file, "type_ctor_info_tag cons tag " ++
"for non-type_ctor_info_constant cons id").
Index: compiler/closure_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/closure_analysis.m,v
retrieving revision 1.18
diff -u -r1.18 closure_analysis.m
--- compiler/closure_analysis.m 23 Dec 2008 01:37:29 -0000 1.18
+++ compiler/closure_analysis.m 5 Feb 2009 08:37:06 -0000
@@ -282,7 +282,7 @@
(
Unification = construct(LHS, RHS, _, _, _, _, _),
(
- RHS = pred_const(ShroudedPPId, EvalMethod),
+ RHS = closure_cons(ShroudedPPId, EvalMethod),
EvalMethod = lambda_normal
->
PPId = unshroud_pred_proc_id(ShroudedPPId),
Index: compiler/code_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.372
diff -u -r1.372 code_info.m
--- compiler/code_info.m 6 Jan 2009 03:56:24 -0000 1.372
+++ compiler/code_info.m 30 May 2009 05:56:20 -0000
@@ -75,6 +75,7 @@
:- import_module ll_backend.code_util.
:- import_module ll_backend.opt_debug.
:- import_module ll_backend.var_locn.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.mercury_to_mercury.
@@ -807,15 +808,6 @@
:- func filter_region_vars(code_info, set(prog_var)) = set(prog_var).
- % Given a constructor id, and the type to which it belongs, determine
- % the tag representing that constructor.
- %
-:- func cons_id_to_tag_for_type(code_info, mer_type, cons_id) = cons_tag.
-
- % As cons_id_to_tag_for_type, but get the type from the variable.
- %
-:- func cons_id_to_tag_for_var(code_info, prog_var, cons_id) = cons_tag.
-
% Get the code model of the current procedure.
%
:- func get_proc_model(code_info) = code_model.
@@ -1014,13 +1006,6 @@
RegionVars = set.filter(is_region_var(VarTypes),
ForwardLiveVarsBeforeGoal).
-cons_id_to_tag_for_type(CI, Type, ConsId) = ConsTag :-
- get_module_info(CI, ModuleInfo),
- ConsTag = cons_id_to_tag(ModuleInfo, Type, ConsId).
-
-cons_id_to_tag_for_var(CI, Var, ConsId) =
- cons_id_to_tag_for_type(CI, variable_type(CI, Var), ConsId).
-
%---------------------------------------------------------------------------%
get_proc_model(CI) = CodeModel :-
Index: compiler/complexity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/complexity.m,v
retrieving revision 1.31
diff -u -r1.31 complexity.m
--- compiler/complexity.m 30 Dec 2007 08:23:33 -0000 1.31
+++ compiler/complexity.m 30 May 2009 06:00:54 -0000
@@ -69,6 +69,7 @@
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
@@ -323,7 +324,7 @@
CodeModel = model_det,
TransformedGoalExpr = conj(plain_conj,
SlotGoals ++ [OrigGoal, ExitGoal]),
- TransformedGoal = hlds_goal(TransformedGoalExpr, ImpureOrigGoalInfo)
+ TransGoal = hlds_goal(TransformedGoalExpr, ImpureOrigGoalInfo)
;
CodeModel = model_semi,
OrigAfterGoal = hlds_goal(conj(plain_conj, [OrigGoal, ExitGoal]),
@@ -331,7 +332,7 @@
DisjGoal = hlds_goal(
disj([OrigAfterGoal, FailGoal]),
ImpureOrigGoalInfo),
- TransformedGoal = hlds_goal(
+ TransGoal = hlds_goal(
conj(plain_conj, SlotGoals ++ [DisjGoal]),
ImpureOrigGoalInfo)
;
@@ -352,15 +353,16 @@
DisjGoal = hlds_goal(
disj([OrigAfterGoal, FailGoal]),
ImpureOrigGoalInfo),
- TransformedGoal = hlds_goal(
+ TransGoal = hlds_goal(
conj(plain_conj, SlotGoals ++ [DisjGoal]),
ImpureOrigGoalInfo)
),
TSPB = mercury_term_size_prof_builtin_module,
+ TypeCtor = type_ctor(qualified(TSPB, "complexity_is_active"), 0),
SwitchArms = [
- case(cons(qualified(TSPB, "is_inactive"), 0), [], TransformedGoal),
- case(cons(qualified(TSPB, "is_active"), 0), [], OrigGoal)
+ case(cons(qualified(TSPB, "is_inactive"), 0, TypeCtor), [], TransGoal),
+ case(cons(qualified(TSPB, "is_active"), 0, TypeCtor), [], OrigGoal)
],
SwitchExpr = switch(IsActiveVar, cannot_fail, SwitchArms),
Index: compiler/ctgc.selector.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ctgc.selector.m,v
retrieving revision 1.27
diff -u -r1.27 ctgc.selector.m
--- compiler/ctgc.selector.m 28 Aug 2008 04:40:47 -0000 1.27
+++ compiler/ctgc.selector.m 5 Feb 2009 07:26:27 -0000
@@ -105,23 +105,26 @@
top_selector = [].
-selector_init(Cons, Index) = [TermSel] :-
+selector_init(ConsId, Index) = [TermSel] :-
(
- Cons = cons(_, _),
- TermSel = termsel(Cons, Index)
+ ( ConsId = cons(_, _, _)
+ ; ConsId = tuple_cons(_)
+ ),
+ TermSel = termsel(ConsId, Index)
;
- ( Cons = int_const(_)
- ; Cons = string_const(_)
- ; Cons = float_const(_)
- ; Cons = implementation_defined_const(_)
- ; Cons = pred_const(_, _)
- ; Cons = type_ctor_info_const(_, _, _)
- ; Cons = base_typeclass_info_const(_, _, _, _)
- ; Cons = type_info_cell_constructor(_)
- ; Cons = typeclass_info_cell_constructor
- ; Cons = tabling_info_const(_)
- ; Cons = deep_profiling_proc_layout(_)
- ; Cons = table_io_decl(_)
+ ( ConsId = closure_cons(_, _)
+ ; ConsId = int_const(_)
+ ; ConsId = float_const(_)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
+ ; ConsId = impl_defined_const(_)
+ ; ConsId = type_ctor_info_const(_, _, _)
+ ; ConsId = base_typeclass_info_const(_, _, _, _)
+ ; ConsId = type_info_cell_constructor(_)
+ ; ConsId = typeclass_info_cell_constructor
+ ; ConsId = tabling_info_const(_)
+ ; ConsId = table_io_decl(_)
+ ; ConsId = deep_profiling_proc_layout(_)
),
unexpected(this_file, "selector_init: cannot handle cons_id")
).
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.131
diff -u -r1.131 dead_proc_elim.m
--- compiler/dead_proc_elim.m 11 Mar 2009 06:32:24 -0000 1.131
+++ compiler/dead_proc_elim.m 12 Mar 2009 01:25:45 -0000
@@ -564,7 +564,7 @@
Unification = construct(_, ConsId, _, _, _, _, _),
(
(
- ConsId = pred_const(ShroudedPredProcId, _),
+ ConsId = closure_cons(ShroudedPredProcId, _),
proc(PredId, ProcId) =
unshroud_pred_proc_id(ShroudedPredProcId),
Entity = entity_proc(PredId, ProcId),
@@ -594,11 +594,13 @@
svqueue.put(Entity, !Queue),
svmap.set(Entity, not_eliminable, !Needed)
;
- ( ConsId = cons(_, _)
+ ( ConsId = cons(_, _, _)
+ ; ConsId = tuple_cons(_)
; ConsId = int_const(_)
- ; ConsId = string_const(_)
; ConsId = float_const(_)
- ; ConsId = implementation_defined_const(_)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
+ ; ConsId = impl_defined_const(_)
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
@@ -1100,7 +1102,7 @@
pre_modecheck_examine_unify_rhs(rhs_var(_), !DeadInfo).
pre_modecheck_examine_unify_rhs(rhs_functor(Functor, _, _), !DeadInfo) :-
- ( Functor = cons(Name, _) ->
+ ( Functor = cons(Name, _, _) ->
dead_pred_info_add_pred_name(Name, !DeadInfo)
;
true
Index: compiler/deep_profiling.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/deep_profiling.m,v
retrieving revision 1.96
diff -u -r1.96 deep_profiling.m
--- compiler/deep_profiling.m 6 Feb 2009 10:11:13 -0000 1.96
+++ compiler/deep_profiling.m 30 May 2009 05:56:32 -0000
@@ -37,6 +37,7 @@
:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
:- import_module hlds.goal_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_out.
:- import_module hlds.hlds_pred.
@@ -49,6 +50,7 @@
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.program_representation.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
:- import_module transform_hlds.
@@ -1684,11 +1686,13 @@
VarInfo0 = !.DeepInfo ^ deep_varinfo,
ProfilingBuiltin = mercury_profiling_builtin_module,
CellTypeName = string.format("call_site_nums_%d", [i(Length)]),
- CellTypeId = type_ctor(qualified(ProfilingBuiltin, CellTypeName), Length),
- construct_type(CellTypeId, [], CellType),
+ CellTypeCtor = type_ctor(qualified(ProfilingBuiltin, CellTypeName),
+ Length),
+ construct_type(CellTypeCtor, [], CellType),
generate_var("CSNCell", CellType, CellVar, VarInfo0, VarInfo),
!DeepInfo ^ deep_varinfo := VarInfo,
- ConsId = cons(qualified(ProfilingBuiltin, CellTypeName), Length),
+ ConsId = cons(qualified(ProfilingBuiltin, CellTypeName), Length,
+ CellTypeCtor),
generate_cell_unify(Length, ConsId, CSNVars, CellVar, CellGoal).
:- pred generate_single_csn_unify(int::in,
Index: compiler/delay_partial_inst.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/delay_partial_inst.m,v
retrieving revision 1.12
diff -u -r1.12 delay_partial_inst.m
--- compiler/delay_partial_inst.m 10 Mar 2009 05:00:29 -0000 1.12
+++ compiler/delay_partial_inst.m 12 Mar 2009 01:25:45 -0000
@@ -298,7 +298,9 @@
% V = f(A1, A2, A3, ...)
% and at least one of the arguments is free?
%
- ConsId = cons(_, _),
+ ( ConsId = cons(_, _, _)
+ ; ConsId = tuple_cons(_)
+ ),
ModuleInfo = !.DelayInfo ^ dpi_module_info,
some [RhsAfter] (
list.member(_ -> _ - RhsAfter, UniModes),
Index: compiler/dependency_graph.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dependency_graph.m,v
retrieving revision 1.103
diff -u -r1.103 dependency_graph.m
--- compiler/dependency_graph.m 10 Mar 2009 05:00:29 -0000 1.103
+++ compiler/dependency_graph.m 12 Mar 2009 01:25:46 -0000
@@ -468,7 +468,7 @@
add_dependency_arcs_in_cons(Caller, ConsId, !DepGraph) :-
(
- ConsId = pred_const(ShroudedPredProcId, _),
+ ConsId = closure_cons(ShroudedPredProcId, _),
PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
(
% If the node isn't in the graph, then we didn't insert it
@@ -480,18 +480,20 @@
true
)
;
- ( ConsId = cons(_, _)
+ ( ConsId = cons(_, _, _)
+ ; ConsId = tuple_cons(_)
; ConsId = int_const(_)
- ; ConsId = string_const(_)
; ConsId = float_const(_)
- ; ConsId = implementation_defined_const(_)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
+ ; ConsId = impl_defined_const(_)
; ConsId = type_ctor_info_const(_, _, _)
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
; ConsId = tabling_info_const(_)
- ; ConsId = deep_profiling_proc_layout(_)
; ConsId = table_io_decl(_)
+ ; ConsId = deep_profiling_proc_layout(_)
)
).
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_analysis.m,v
retrieving revision 1.219
diff -u -r1.219 det_analysis.m
--- compiler/det_analysis.m 10 Mar 2009 05:00:28 -0000 1.219
+++ compiler/det_analysis.m 12 Mar 2009 01:25:46 -0000
@@ -1226,31 +1226,33 @@
Context = goal_info_get_context(GoalInfo),
(
Unify = construct(_, _, _, _, _, _, _),
- unexpected(this_file, "can_fail construct")
+ unexpected(this_file, "det_infer_unify: can_fail construct")
;
Unify = assign(_, _),
- unexpected(this_file, "can_fail assign")
+ unexpected(this_file, "det_infer_unify: can_fail assign")
;
Unify = complicated_unify(_, _, _),
(
RHS = rhs_var(RHSVar),
- FailingContext = failing_context(Context,
- test_goal(LHS, RHSVar)),
+ FailingGoal = test_goal(LHS, RHSVar),
+ FailingContext = failing_context(Context, FailingGoal),
GoalFailingContexts = [FailingContext]
;
( RHS = rhs_functor(_, _, _)
; RHS = rhs_lambda_goal(_, _, _, _, _, _, _, _, _)
),
- unexpected(this_file, "complicated_unify but no var")
+ unexpected(this_file,
+ "det_infer_unify: complicated_unify but no var")
)
;
Unify = deconstruct(Var, ConsId, _, _, _, _),
- FailingContext = failing_context(Context,
- deconstruct_goal(Var, ConsId)),
+ FailingGoal = deconstruct_goal(Var, ConsId),
+ FailingContext = failing_context(Context, FailingGoal),
GoalFailingContexts = [FailingContext]
;
Unify = simple_test(Var1, Var2),
- FailingContext = failing_context(Context, test_goal(Var1, Var2)),
+ FailingGoal = test_goal(Var1, Var2),
+ FailingContext = failing_context(Context, FailingGoal),
GoalFailingContexts = [FailingContext]
)
;
Index: compiler/det_report.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/det_report.m,v
retrieving revision 1.146
diff -u -r1.146 det_report.m
--- compiler/det_report.m 10 Mar 2009 05:00:29 -0000 1.146
+++ compiler/det_report.m 4 Jun 2009 07:04:36 -0000
@@ -152,6 +152,7 @@
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
@@ -574,9 +575,13 @@
(
(
instmap_lookup_var(InstMap0, Var, VarInst),
- inst_is_bound_to_functors(ModuleInfo, VarInst, Functors)
+ inst_is_bound_to_functors(ModuleInfo, VarInst, BoundInsts)
->
- functors_to_cons_ids(Functors, ConsIds)
+ det_info_get_vartypes(!.DetInfo, VarTypes),
+ map.lookup(VarTypes, Var, VarType),
+ type_to_ctor_det(VarType, VarTypeCtor),
+ list.map(bound_inst_to_cons_id(VarTypeCtor),
+ BoundInsts, ConsIds)
;
det_lookup_var_type(ModuleInfo, ProcInfo, Var, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
@@ -897,7 +902,7 @@
cons_id_list_to_pieces([], []).
cons_id_list_to_pieces([ConsId | ConsIds], Pieces) :-
- ConsIdStr = cons_id_to_string(ConsId),
+ ConsIdStr = cons_id_and_arity_to_string(ConsId),
(
ConsIds = [],
PiecesHead = [fixed(ConsIdStr ++ ".")]
@@ -915,9 +920,9 @@
:- type switch_context
---> switch_context(
- prog_var, % The variable being switched on.
- cons_id, % The first cons_id of this case.
- list(cons_id) % Any other cons_ids of this case.
+ prog_var, % The variable being switched on.
+ cons_id, % The first cons_id of this case.
+ list(cons_id) % Any other cons_ids of this case.
).
:- pred det_diagnose_switch_context(list(switch_context)::in, det_info::in,
@@ -929,8 +934,8 @@
det_get_proc_info(DetInfo, ProcInfo),
proc_info_get_varset(ProcInfo, VarSet),
SwitchContext = switch_context(Var, MainConsId, OtherConsIds),
- MainConsIdStr = cons_id_to_string(MainConsId),
- OtherConsIdStrs = list.map(cons_id_to_string, OtherConsIds),
+ MainConsIdStr = cons_id_and_arity_to_string(MainConsId),
+ OtherConsIdStrs = list.map(cons_id_and_arity_to_string, OtherConsIds),
ConsIdsStr = string.join_list(", ", [MainConsIdStr | OtherConsIdStrs]),
VarStr = mercury_var_to_string(VarSet, no, Var),
HeadPieces = [words("Inside the case"), words(ConsIdsStr),
@@ -1085,7 +1090,7 @@
;
FailingGoal = deconstruct_goal(Var, ConsId),
VarStr = mercury_var_to_string(VarSet, no, Var),
- ConsIdStr = cons_id_to_string(ConsId),
+ ConsIdStr = cons_id_and_arity_to_string(ConsId),
Pieces = [words("Unification of"), fixed(VarStr),
words("with"), fixed(ConsIdStr), words("can fail.")]
;
Index: compiler/distance_granularity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/distance_granularity.m,v
retrieving revision 1.8
diff -u -r1.8 distance_granularity.m
--- compiler/distance_granularity.m 23 Dec 2008 01:37:32 -0000 1.8
+++ compiler/distance_granularity.m 30 May 2009 06:01:19 -0000
@@ -152,11 +152,11 @@
:- import_module hlds.instmap.
:- import_module libs.compiler_util.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
-:- import_module term.
:- import_module transform_hlds.implicit_parallelism.
:- import_module bool.
@@ -169,6 +169,7 @@
:- import_module require.
:- import_module string.
:- import_module set.
+:- import_module term.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -695,9 +696,10 @@
MinusPredId, MinusProcId),
MinusCallArgs = [GranularityVar, Var, VarResult],
MinusCallBuiltin = inline_builtin,
- MinusCallSymName = qualified(unqualified("int"),"-"),
- Rhs = rhs_functor(cons(MinusCallSymName, 2), no,
- [GranularityVar, Var]),
+ MinusCallSymName = qualified(unqualified("int"), "-"),
+ ConsId =
+ cons(MinusCallSymName, 2, cons_id_dummy_type_ctor),
+ Rhs = rhs_functor(ConsId, no, [GranularityVar, Var]),
MinusCallUnifyContext = yes(call_unify_context(VarResult,
Rhs, unify_context(
umc_implicit("distance_granularity"), []))),
Index: compiler/erl_rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_rtti.m,v
retrieving revision 1.19
diff -u -r1.19 erl_rtti.m
--- compiler/erl_rtti.m 23 Nov 2007 07:35:00 -0000 1.19
+++ compiler/erl_rtti.m 25 Dec 2008 11:00:46 -0000
@@ -5,10 +5,10 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: erl_rtti.m.
% Main author: wangp, petdr
-%
+%
% This module converts from the back-end-independent RTTI data structures into
% ELDS function definitions.
%
@@ -28,15 +28,13 @@
%-----------------------------------------------------------------------------%
- %
% erlang_rtti_data(MI, RD)
%
- % converts from rtti_data to erlang_rtti_data.
+ % Converts from rtti_data to erlang_rtti_data.
%
:- func erlang_rtti_data(module_info, rtti_data) = erlang_rtti_data.
- %
- % Generate a representation of all the erlang RTTI
+ % Generate a representation of all the erlang RTTI.
%
:- pred rtti_data_list_to_elds(module_info::in,
list(erlang_rtti_data)::in, list(elds_rtti_defn)::out) is det.
@@ -57,6 +55,8 @@
:- import_module parse_tree.prog_util.
:- import_module bool.
+:- import_module deconstruct.
+:- import_module exception.
:- import_module int.
:- import_module maybe.
:- import_module string.
@@ -87,7 +87,7 @@
erlang_rtti_data_type_class_decl(TCDecl).
erlang_rtti_data(_, rtti_data_type_class_instance(TCInstance)) =
erlang_rtti_data_type_class_instance(TCInstance).
-
+
:- func maybe_get_special_predicate(univ) = maybe(rtti_proc_label).
maybe_get_special_predicate(Univ) =
@@ -97,9 +97,7 @@
no
).
- %
- % Given the type_ctor_details return the erlang version of those
- % details.
+ % Given the type_ctor_details return the erlang version of those details.
% This means conflating enum and no_tags into erlang_du,
% aborting on reserved types, and specially handling the list type.
%
@@ -126,47 +124,59 @@
:- func erlang_type_ctor_details_2(type_ctor_details) =
erlang_type_ctor_details.
-erlang_type_ctor_details_2(enum(_, Functors, _, _, IsDummy, FunctorNums))
- = Details :-
+erlang_type_ctor_details_2(CtorDetails) = Details :-
(
- IsDummy = yes,
- ( Functors = [F] ->
- Details = erlang_dummy(F ^ enum_name)
+ CtorDetails = tcd_enum(_, Functors, _, _, IsDummy, FunctorNums),
+ (
+ IsDummy = yes,
+ ( Functors = [F] ->
+ Details = erlang_dummy(F ^ enum_name)
+ ;
+ unexpected(this_file, "dummy type with more than one functor")
+ )
;
- unexpected(this_file, "dummy type with more than one functor")
+ IsDummy = no,
+ list.map_corresponding(convert_enum_functor, Functors, FunctorNums,
+ ErlFunctors),
+ Details = erlang_du(ErlFunctors)
)
;
- IsDummy = no,
- list.map_corresponding(convert_enum_functor, Functors, FunctorNums,
- ErlFunctors),
- Details = erlang_du(ErlFunctors)
- ).
-erlang_type_ctor_details_2(foreign_enum(_, _, _, _, _, _)) =
- sorry(this_file, "NYI foreign enumerations for Erlang.").
-erlang_type_ctor_details_2(du(_, Functors, _, _, FunctorNums)) = Details :-
- list.map_corresponding(convert_du_functor, Functors, FunctorNums,
- ErlangFunctors),
- Details = erlang_du(ErlangFunctors).
-erlang_type_ctor_details_2(reserved(_, _, _, _, _, _)) =
+ CtorDetails = tcd_foreign_enum(_, _, _, _, _, _),
+ sorry(this_file, "NYI foreign enumerations for Erlang.")
+ ;
+ CtorDetails = tcd_du(_, Functors, _, _, FunctorNums),
+ list.map_corresponding(convert_du_functor, Functors, FunctorNums,
+ ErlangFunctors),
+ Details = erlang_du(ErlangFunctors)
+ ;
+ CtorDetails = tcd_reserved(_, _, _, _, _, _),
% Reserved types are not supported on the Erlang backend.
- unexpected(this_file, "erlang_type_ctor_details: reserved").
-erlang_type_ctor_details_2(notag(_, NoTagFunctor)) = Details :-
- NoTagFunctor = notag_functor(Name, TypeInfo, ArgName),
- OrigArity = 1,
- Ordinal = 0,
- FunctorNum = 0,
- ArgTypeInfo = convert_to_rtti_maybe_pseudo_type_info_or_self(TypeInfo),
- ArgInfos = [du_arg_info(ArgName, ArgTypeInfo)],
- DUFunctor = erlang_du_functor(Name, OrigArity, Ordinal, FunctorNum,
- erlang_atom_raw(Name), ArgInfos, no),
- Details = erlang_du([DUFunctor]).
-erlang_type_ctor_details_2(eqv(Type)) = erlang_eqv(Type).
-erlang_type_ctor_details_2(builtin(Builtin)) = erlang_builtin(Builtin).
-erlang_type_ctor_details_2(impl_artifact(Impl)) = erlang_impl_artifact(EImpl) :-
- EImpl = erlang_impl_ctor(Impl).
-erlang_type_ctor_details_2(foreign(_)) = erlang_foreign.
-
- %
+ unexpected(this_file, "erlang_type_ctor_details: reserved")
+ ;
+ CtorDetails = tcd_notag(_, NoTagFunctor),
+ NoTagFunctor = notag_functor(Name, TypeInfo, ArgName),
+ OrigArity = 1,
+ Ordinal = 0,
+ FunctorNum = 0,
+ ArgTypeInfo = convert_to_rtti_maybe_pseudo_type_info_or_self(TypeInfo),
+ ArgInfos = [du_arg_info(ArgName, ArgTypeInfo)],
+ DUFunctor = erlang_du_functor(Name, OrigArity, Ordinal, FunctorNum,
+ erlang_atom_raw(Name), ArgInfos, no),
+ Details = erlang_du([DUFunctor])
+ ;
+ CtorDetails = tcd_eqv(Type),
+ Details = erlang_eqv(Type)
+ ;
+ CtorDetails = tcd_builtin(Builtin),
+ Details = erlang_builtin(Builtin)
+ ;
+ CtorDetails = tcd_impl_artifact(Impl),
+ Details = erlang_impl_artifact(erlang_impl_ctor(Impl))
+ ;
+ CtorDetails = tcd_foreign(_),
+ Details = erlang_foreign
+ ).
+
% Convert an enum_functor into the equivalent erlang_du_functor
%
:- pred convert_enum_functor(enum_functor::in, int::in, erlang_du_functor::out)
@@ -177,7 +187,6 @@
ErlangFunctor = erlang_du_functor(Name, 0, Ordinal, FunctorNum,
erlang_atom_raw(Name), [], no).
- %
% Convert a du_functor into the equivalent erlang_du_functor
%
:- pred convert_du_functor(du_functor::in, int::in, erlang_du_functor::out)
@@ -194,7 +203,6 @@
convert_to_rtti_maybe_pseudo_type_info_or_self(pseudo(P)) = pseudo(P).
convert_to_rtti_maybe_pseudo_type_info_or_self(plain(P)) = plain(P).
- %
% Restrict the implementation artifacts to only those
% allowed on the erlang backend.
%
@@ -230,9 +238,8 @@
rtti_data_list_to_elds(ModuleInfo, RttiDatas, RttiDefns) :-
list.map(rtti_data_to_elds(ModuleInfo), RttiDatas, RttiDefns0),
- % XXX See mlds_defn_is_potentially_duplicated for how this can
- % be made more efficient.
- %
+ % XXX See mlds_defn_is_potentially_duplicated for how this can
+ % be made more efficient.
RttiDefns = list.sort_and_remove_dups(list.condense(RttiDefns0)).
:- pred rtti_data_to_elds(module_info::in, erlang_rtti_data::in,
@@ -245,10 +252,9 @@
NumExtra = BaseTypeClassInfo ^ num_extra,
list.map_foldl(erl_gen_method_wrapper(ModuleInfo, NumExtra), Methods,
MethodWrappers, varset.init, VarSet),
- %
+
% NOTE: if you modify this structure you may need to modify
% erl_base_typeclass_info_method_offset.
- %
BaseTypeClassInfoData = elds_tuple([
elds_term(elds_int(N1)),
elds_term(elds_int(N2)),
@@ -310,7 +316,6 @@
% E2, E3, ..., W1, W2, ...),
% {Y1, Y2, ...} /* may have additional outputs */
% end
- %
svvarset.new_named_var("TypeClassInfo", TCIVar, !VarSet),
svvarset.new_vars(list.length(ArgTypes) - NumExtra, Ws, !VarSet),
@@ -401,8 +406,8 @@
;
TypeInfo = plain_type_info(TypeCtor, ArgTypeInfos),
- rtti_type_info_to_elds_2(ModuleInfo,
- ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
+ rtti_type_info_to_elds_2(ModuleInfo, ArgTypeInfos, ELDSArgTypeInfos,
+ ArgRttiDefns),
ELDSTypeInfo = elds_term(elds_tuple([
elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)) |
@@ -411,8 +416,8 @@
TypeInfo = var_arity_type_info(VarCtorId, ArgTypeInfos),
TypeCtor = var_arity_id_to_rtti_type_ctor(VarCtorId),
- rtti_type_info_to_elds_2(ModuleInfo,
- ArgTypeInfos, ELDSArgTypeInfos, ArgRttiDefns),
+ rtti_type_info_to_elds_2(ModuleInfo, ArgTypeInfos, ELDSArgTypeInfos,
+ ArgRttiDefns),
ELDSTypeInfo = elds_term(elds_tuple([
elds_rtti_ref(elds_rtti_type_ctor_id(TypeCtor)),
@@ -420,19 +425,18 @@
ELDSArgTypeInfos]))
),
- %
- % A type_info can contain a call to construct a type_ctor_info
- % which requires this type_info, leading to infinite recursion,
- % we break this recursion by creating a closure which will
- % evaluate to the type_info, if the type_info is needed.
- %
+ % A type_info can contain a call to construct a type_ctor_info
+ % which requires this type_info, leading to infinite recursion,
+ % we break this recursion by creating a closure which will
+ % evaluate to the type_info, if the type_info is needed.
+
ELDSFun = elds_fun(elds_clause([], ELDSTypeInfo)),
ELDSTuple = elds_term(elds_tuple([
elds_term(elds_atom_raw("plain")),
ELDSFun
- ])),
-
+ ])),
+
RttiId = elds_rtti_type_info_id(TypeInfo),
IsExported = no,
RttiDefn = elds_rtti_defn(RttiId, IsExported, varset.init,
@@ -440,7 +444,6 @@
RttiDefns = [RttiDefn | ArgRttiDefns].
-
:- pred rtti_type_info_to_elds_2(module_info::in,
list(rtti_type_info)::in,
list(elds_expr)::out, list(elds_rtti_defn)::out) is det.
@@ -453,7 +456,6 @@
ELDSArgTypeInfos = list.map(
func(TI) = elds_rtti_ref(elds_rtti_type_info_id(TI)), ArgTypeInfos).
-
%-----------------------------------------------------------------------------%
%
@@ -493,23 +495,22 @@
elds_term(elds_int(list.length(ArgTypeInfos))) |
ELDSArgTypeInfos]))
;
- TypeInfo = type_var(I),
+ TypeInfo = type_var(I),
ELDSTypeInfo = elds_term(elds_int(I)),
ArgRttiDefns = []
),
- %
- % A pseudo_type_info can contain a call to construct a type_ctor_info
- % which requires this pseudo_type_info, leading to infinite recursion.
- % We break this recursion by creating a closure which will
- % evaluate to the pseudo_type_info, if the type_info is needed.
- %
+ % A pseudo_type_info can contain a call to construct a type_ctor_info
+ % which requires this pseudo_type_info, leading to infinite recursion.
+ % We break this recursion by creating a closure which will
+ % evaluate to the pseudo_type_info, if the type_info is needed.
+ %
ELDSFun = elds_fun(elds_clause([], ELDSTypeInfo)),
ELDSTuple = elds_term(elds_tuple([
elds_term(elds_atom_raw("pseudo")),
ELDSFun
- ])),
+ ])),
RttiId = elds_rtti_pseudo_type_info_id(TypeInfo),
IsExported = no,
@@ -539,7 +540,6 @@
)
), ArgTypeInfos).
-
:- pred rtti_maybe_pseudo_type_info_to_elds(module_info::in,
rtti_maybe_pseudo_type_info::in, list(elds_rtti_defn)::out) is det.
@@ -550,7 +550,6 @@
%-----------------------------------------------------------------------------%
- %
% This predicate defines the representation of type_ctor_info
% for the erlang backend.
%
@@ -583,7 +582,7 @@
elds_term(elds_list_of_ints(TypeName)),
erlang_type_ctor_rep(Details),
ELDSDetails
- ]),
+ ]),
ClauseBody = elds_block(list.reverse(RevAssignments) ++
[elds_term(ELDSTypeCtorData)]),
@@ -620,19 +619,19 @@
elds_term(make_enum_alternative("etcr_stable_c_pointer")).
erlang_type_ctor_rep(erlang_builtin(builtin_ctor_c_pointer(is_not_stable))) =
elds_term(make_enum_alternative("etcr_c_pointer")).
-erlang_type_ctor_rep(erlang_builtin(builtin_ctor_pred_ctor)) =
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_pred_ctor)) =
elds_term(make_enum_alternative("etcr_pred")).
-erlang_type_ctor_rep(erlang_builtin(builtin_ctor_func_ctor)) =
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_func_ctor)) =
elds_term(make_enum_alternative("etcr_func")).
-erlang_type_ctor_rep(erlang_builtin(builtin_ctor_tuple)) =
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_tuple)) =
elds_term(make_enum_alternative("etcr_tuple")).
-erlang_type_ctor_rep(erlang_builtin(builtin_ctor_ref)) =
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_ref)) =
elds_term(make_enum_alternative("etcr_ref")).
-erlang_type_ctor_rep(erlang_builtin(builtin_ctor_type_desc)) =
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_type_desc)) =
elds_term(make_enum_alternative("etcr_type_desc")).
-erlang_type_ctor_rep(erlang_builtin(builtin_ctor_pseudo_type_desc)) =
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_pseudo_type_desc)) =
elds_term(make_enum_alternative("etcr_pseudo_type_desc")).
-erlang_type_ctor_rep(erlang_builtin(builtin_ctor_type_ctor_desc)) =
+erlang_type_ctor_rep(erlang_builtin(builtin_ctor_type_ctor_desc)) =
elds_term(make_enum_alternative("etcr_type_ctor_desc")).
erlang_type_ctor_rep(erlang_impl_artifact(erlang_impl_ctor_type_info)) =
elds_term(make_enum_alternative("etcr_type_info")).
@@ -646,9 +645,7 @@
erlang_type_ctor_rep(erlang_foreign) =
elds_term(make_enum_alternative("etcr_foreign")).
- %
- % These three types should never actually be used in
- % an Erlang program.
+ % These three types should never actually be used in an Erlang program.
%
erlang_type_ctor_rep(erlang_impl_artifact(erlang_impl_ctor_hp)) =
elds_term(make_enum_alternative("etcr_hp")).
@@ -666,10 +663,9 @@
erl_gen_special_pred_wrapper(ModuleInfo, RttiProcId, Expr, !VarSet)
;
MaybeRttiProcId = no,
- unexpected(this_file,
- "gen_init_special_pred: no special pred")
+ unexpected(this_file, "gen_init_special_pred: no special pred")
).
-
+
:- pred erl_gen_special_pred_wrapper(module_info::in, rtti_proc_label::in,
elds_expr::out, prog_varset::in, prog_varset::out) is det.
@@ -727,8 +723,6 @@
WrapperFun = elds_fun(elds_clause(terms_from_vars(WrapperInputVars),
DoCall)).
-
- %
% erlang_type_ctor_details(ModuleInfo, Details, Expr, Defns)
%
% will return the expr, Expr, which evaluates to an erlang term
@@ -739,9 +733,8 @@
% definitions, so the user is responsible for getting rid
% of duplicate definitions.
%
-:- pred erlang_type_ctor_details(module_info::in,
- erlang_type_ctor_details::in, elds_expr::out,
- list(elds_rtti_defn)::out) is det.
+:- pred erlang_type_ctor_details(module_info::in, erlang_type_ctor_details::in,
+ elds_expr::out, list(elds_rtti_defn)::out) is det.
erlang_type_ctor_details(ModuleInfo, Details, Term, Defns) :-
(
@@ -754,7 +747,7 @@
Details = erlang_eqv(MaybePseudoTypeInfo),
rtti_to_elds_expr(ModuleInfo, MaybePseudoTypeInfo, Term, [], Defns)
;
- % The types don't require any extra information
+ % The types don't require any extra information
( Details = erlang_list
; Details = erlang_array
; Details = erlang_builtin(_)
@@ -778,27 +771,23 @@
prog_varset::in, prog_varset::out) is det.
reduce_list_term_complexity(Expr0, Expr, !RevAssignments, !VarSet) :-
- (if
+ (
Expr0 = elds_term(elds_tuple([Functor, Head, Tail0])),
Functor = elds_term(elds_atom(SymName)),
unqualify_name(SymName) = "[|]"
- then
+ ->
reduce_list_term_complexity(Tail0, Tail, !RevAssignments, !VarSet),
svvarset.new_var(V, !VarSet),
Assign = elds_eq(expr_from_var(V), Tail),
Expr = elds_term(elds_tuple([Functor, Head, expr_from_var(V)])),
list.cons(Assign, !RevAssignments)
- else
+ ;
Expr = Expr0
).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-:- import_module deconstruct.
-:- import_module exception.
-
- %
% rtti_to_elds_expr(MI, T, Expr, !Defns)
%
% Given some T which is a representation of the RTTI data,
@@ -813,7 +802,6 @@
:- pred rtti_to_elds_expr(module_info::in, T::in, elds_expr::out,
list(elds_rtti_defn)::in, list(elds_rtti_defn)::out) is det.
-
rtti_to_elds_expr(MI, Term, ELDS, !Defns) :-
( dynamic_cast(Term, Int) ->
ELDS = elds_term(elds_int(Int))
@@ -824,9 +812,7 @@
; dynamic_cast(Term, Float) ->
ELDS = elds_term(elds_float(Float))
- %
- % The RTTI types which have to be handled specially.
- %
+ % The RTTI types which have to be handled specially.
; dynamic_cast(Term, Atom) ->
Atom = erlang_atom_raw(S),
ELDS = elds_term(elds_atom_raw(S))
@@ -863,7 +849,8 @@
:- pred convert_maybe_pseudo_type_info_or_self_to_elds(module_info::in,
rtti_maybe_pseudo_type_info_or_self::in,
- elds_expr::out, list(elds_rtti_defn)::in, list(elds_rtti_defn)::out) is det.
+ elds_expr::out, list(elds_rtti_defn)::in, list(elds_rtti_defn)::out)
+ is det.
convert_maybe_pseudo_type_info_or_self_to_elds(MI, TI, Expr, !Defns) :-
maybe_pseudo_type_info_or_self_to_elds(MI, TI, RttiId, Defns),
@@ -872,7 +859,8 @@
:- pred convert_maybe_pseudo_type_info_to_elds(module_info::in,
rtti_maybe_pseudo_type_info::in,
- elds_expr::out, list(elds_rtti_defn)::in, list(elds_rtti_defn)::out) is det.
+ elds_expr::out, list(elds_rtti_defn)::in, list(elds_rtti_defn)::out)
+ is det.
convert_maybe_pseudo_type_info_to_elds(MI, TI, Expr, !Defns) :-
maybe_pseudo_type_info_to_elds(MI, TI, RttiId, Defns),
@@ -889,7 +877,7 @@
maybe_pseudo_type_info_to_elds(MI, pseudo(PTI), RttiId, Defns).
maybe_pseudo_type_info_or_self_to_elds(_MI, self, _RttiId, _Defns) :-
unexpected(this_file,
- "maybe_pseudo_type_info_or_self_to_elds: self not handled yet.").
+ "maybe_pseudo_type_info_or_self_to_elds: self not handled yet").
:- pred maybe_pseudo_type_info_to_elds(module_info::in,
rtti_maybe_pseudo_type_info::in,
Index: compiler/erl_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_unify_gen.m,v
retrieving revision 1.14
diff -u -r1.14 erl_unify_gen.m
--- compiler/erl_unify_gen.m 4 Jun 2009 08:02:39 -0000 1.14
+++ compiler/erl_unify_gen.m 4 Jun 2009 08:31:25 -0000
@@ -5,13 +5,13 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: erl_unify_gen.m
% Main author: wangp.
-%
+%
% This module is part of the Erlang code generator.
% It handles Erlang code generation for unifications.
-%
+%
% TODO
% type t
% ---> f(int, string)
@@ -60,10 +60,12 @@
:- mode cons_id_to_term(in(termable_cons_id), in, in, out, in, out) is det.
:- inst termable_cons_id
- ---> cons(ground, ground)
+ ---> cons(ground, ground, ground)
+ ; tuple_cons(ground)
; int_const(ground)
- ; string_const(ground)
- ; float_const(ground).
+ ; float_const(ground)
+ ; char_const(ground)
+ ; string_const(ground).
% Convert a cons id to the ELDS equivalent expression.
%
@@ -191,10 +193,9 @@
!Info) :-
cons_id_to_expr(ConsId, Args, elds_false, RHS, !Info),
Construct = elds_eq(expr_from_var(Var), RHS),
- %
+
% If there are any free variables in Args, assign them to false first.
% i.e. we are constructing a partially instantiated data structure.
- %
erl_gen_info_get_module_info(!.Info, ModuleInfo),
AssignFreeVars = list.filter_map_corresponding3(
assign_free_var(ModuleInfo), Args, ArgTypes, UniModes),
@@ -255,52 +256,55 @@
cons_id_to_term(ConsId, Args, DummyVarReplacement, Term, !Info) :-
(
- ConsId = cons(Name, _Arity),
(
- Name = unqualified(String),
- string.char_to_string(Char, String)
- ->
- Term = elds_char(Char)
+ ConsId = cons(Name, _Arity, _TypeCtor)
;
- % XXX optimise the cases where we don't actually need a
- % distinguishing atom.
- Functor = elds_term(elds_atom(Name)),
- erl_gen_info_get_module_info(!.Info, ModuleInfo),
- erl_gen_info_get_var_types(!.Info, VarTypes),
-
- % Replace dummy variables in the term. In construction
- % unifications we would want to replace them with `false' (what
- % we use for all dummy values). In deconstructions we replace
- % them by anonymous variables (_).
- TermArgs = list.map(erl_var_or_dummy_replacement(ModuleInfo,
- VarTypes, DummyVarReplacement), Args),
- Term = elds_tuple([Functor | TermArgs])
- )
+ ConsId = tuple_cons(_Arity),
+ Name = unqualified("{}")
+ ),
+ % XXX We should optimise the cases where we don't actually need a
+ % distinguishing atom.
+ Functor = elds_term(elds_atom(Name)),
+ erl_gen_info_get_module_info(!.Info, ModuleInfo),
+ erl_gen_info_get_var_types(!.Info, VarTypes),
+
+ % Replace dummy variables in the term. In construction unifications
+ % we would want to replace them with `false' (what we use for all
+ % dummy values). In deconstructions we replace them by anonymous
+ % variables (_).
+ TermArgs = list.map(erl_var_or_dummy_replacement(ModuleInfo,
+ VarTypes, DummyVarReplacement), Args),
+ Term = elds_tuple([Functor | TermArgs])
;
ConsId = int_const(Int),
Term = elds_int(Int)
;
- ConsId = string_const(String),
- Term = elds_binary(String)
- ;
ConsId = float_const(Float),
Term = elds_float(Float)
+ ;
+ ConsId = char_const(Char),
+ Term = elds_char(Char)
+ ;
+ ConsId = string_const(String),
+ Term = elds_binary(String)
).
cons_id_to_expr(ConsId, Args, DummyVarReplacement, Expr, !Info) :-
(
- ( ConsId = cons(_, _)
+ ( ConsId = cons(_, _, _)
+ ; ConsId = tuple_cons(_)
; ConsId = int_const(_)
- ; ConsId = string_const(_)
; ConsId = float_const(_)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
),
cons_id_to_term(ConsId, Args, DummyVarReplacement, Term, !Info),
Expr = elds_term(Term)
;
- ConsId = implementation_defined_const(_),
- unexpected(this_file, "cons_id_to_expr: implementation_defined_const")
+ ConsId = impl_defined_const(_),
+ unexpected(this_file, "cons_id_to_expr: impl_defined_const")
;
- ConsId = pred_const(ShroudedPredProcId, lambda_normal),
+ ConsId = closure_cons(ShroudedPredProcId, lambda_normal),
pred_const_to_closure(ShroudedPredProcId, Args, Expr, !Info)
;
ConsId = type_ctor_info_const(ModuleName, TypeCtor, Arity),
Index: compiler/export.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.122
diff -u -r1.122 export.m
--- compiler/export.m 27 May 2009 05:48:37 -0000 1.122
+++ compiler/export.m 29 May 2009 04:53:39 -0000
@@ -610,7 +610,7 @@
BuiltinType = builtin_type_float,
ConvertedRval = "MR_float_to_word(" ++ Rval ++ ")"
;
- BuiltinType = builtin_type_character,
+ BuiltinType = builtin_type_char,
% We need to explicitly cast to UnsignedChar
% to avoid problems with C compilers for which `char'
% is signed.
@@ -641,7 +641,7 @@
ConvertedRval = "MR_word_to_float(" ++ Rval ++ ")"
;
( BuiltinType = builtin_type_int
- ; BuiltinType = builtin_type_character
+ ; BuiltinType = builtin_type_char
),
ConvertedRval = Rval
)
@@ -843,7 +843,8 @@
; DuTypeKind = du_type_kind_foreign_enum(_)
; DuTypeKind = du_type_kind_direct_dummy
),
- list.foldl(foreign_const_name_and_tag(NameMapping, TagValues),
+ list.foldl(
+ foreign_const_name_and_tag(TypeCtor, NameMapping, TagValues),
Ctors, [], ForeignNamesAndTags0),
% We reverse the list so the constants are printed out in order.
list.reverse(ForeignNamesAndTags0, ForeignNamesAndTags),
@@ -876,15 +877,17 @@
io.format("#define %s %s", [s(ConstName), s(RawStrTag)], !IO)
).
-:- pred foreign_const_name_and_tag(map(sym_name, string)::in,
+:- pred foreign_const_name_and_tag(type_ctor::in, map(sym_name, string)::in,
cons_tag_values::in, constructor::in,
assoc_list(string, exported_enum_tag_rep)::in,
assoc_list(string, exported_enum_tag_rep)::out) is det.
-foreign_const_name_and_tag(Mapping, TagValues, Ctor, !NamesAndTags) :-
+foreign_const_name_and_tag(TypeCtor, Mapping, TagValues, Ctor,
+ !NamesAndTags) :-
Ctor = ctor(_, _, QualifiedCtorName, Args, _),
list.length(Args, Arity),
- map.lookup(TagValues, cons(QualifiedCtorName, Arity), TagVal),
+ ConsId = cons(QualifiedCtorName, Arity, TypeCtor),
+ map.lookup(TagValues, ConsId, TagVal),
(
TagVal = int_tag(IntTag),
Tag = ee_tag_rep_int(IntTag)
@@ -894,7 +897,7 @@
;
( TagVal = string_tag(_)
; TagVal = float_tag(_)
- ; TagVal = pred_closure_tag(_, _, _)
+ ; TagVal = closure_tag(_, _, _)
; TagVal = type_ctor_info_tag(_, _, _)
; TagVal = base_typeclass_info_tag(_, _, _)
; TagVal = tabling_info_tag(_, _)
Index: compiler/field_access.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/field_access.m,v
retrieving revision 1.14
diff -u -r1.14 field_access.m
--- compiler/field_access.m 2 Dec 2008 04:30:23 -0000 1.14
+++ compiler/field_access.m 5 Feb 2009 08:01:33 -0000
@@ -163,7 +163,7 @@
% Recursively update the field.
SubTermInputArgNumber = 2 + list.length(FieldArgs),
- TermInputContext = Functor - SubTermInputArgNumber,
+ TermInputContext = unify_sub_context(Functor, SubTermInputArgNumber),
SubContext = [TermInputContext | SubContext0],
expand_set_field_function_call_2(Context, MainContext,
SubContext, FieldNames, FieldValueVar, SubTermInputVar,
@@ -248,7 +248,7 @@
% Recursively extract until we run out of field names.
TermInputArgNumber = 1 + list.length(FieldArgVars),
- TermInputContext = Functor - TermInputArgNumber,
+ TermInputContext = unify_sub_context(Functor, TermInputArgNumber),
SubContext = [TermInputContext | SubContext0],
expand_get_field_function_call_2(Context, MainContext,
SubContext, FieldNames, FieldValueVar, SubTermInputVar, Purity,
@@ -284,7 +284,7 @@
!QualInfo) :-
field_access_function_name(AccessType, FieldName, FuncName),
list.length(Args, Arity),
- Functor = cons(FuncName, Arity),
+ Functor = cons(FuncName, Arity, cons_id_dummy_type_ctor),
make_atomic_unification(RetArg, rhs_functor(Functor, no, Args),
Context, MainContext, SubContext, Purity, Goal, !QualInfo).
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.78
diff -u -r1.78 foreign.m
--- compiler/foreign.m 11 Feb 2008 21:25:53 -0000 1.78
+++ compiler/foreign.m 29 Jan 2009 23:05:47 -0000
@@ -692,7 +692,7 @@
BuiltinType = builtin_type_string,
Result = "MR_String"
;
- BuiltinType = builtin_type_character,
+ BuiltinType = builtin_type_char,
Result = "MR_Char"
)
;
@@ -734,7 +734,7 @@
BuiltinType = builtin_type_string,
Result = "java.lang.String"
;
- BuiltinType = builtin_type_character,
+ BuiltinType = builtin_type_char,
Result = "char"
)
;
Index: compiler/format_call.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/format_call.m,v
retrieving revision 1.16
diff -u -r1.16 format_call.m
--- compiler/format_call.m 10 Mar 2009 05:00:29 -0000 1.16
+++ compiler/format_call.m 3 Jun 2009 13:14:01 -0000
@@ -109,6 +109,7 @@
:- import_module libs.
:- import_module libs.compiler_util.
:- import_module libs.options.
+:- import_module parse_tree.builtin_lib_types.
:- import_module bool.
:- import_module counter.
@@ -526,16 +527,17 @@
map.set(StringMap0, CellVar, StringConst, StringMap),
ConjMap = conj_map(StringMap, ListMap0, ElementMap0, EqvMap0)
;
- ConsId = cons(SymName, _Arity),
- StringModule =
- mercury_std_lib_module_name(unqualified("list")),
- SymName = qualified(StringModule, Functor),
+ ConsId = cons(SymName, Arity, TypeCtor),
+ TypeCtor = list_type_ctor,
+ Functor = unqualify_name(SymName),
(
Functor = "[|]",
+ Arity = 2,
ArgVars = [ArgVar1, ArgVar2],
List = list_skeleton_cons(ArgVar1, ArgVar2)
;
Functor = "[]",
+ Arity = 0,
ArgVars = [],
List = list_skeleton_nil
)
@@ -545,11 +547,10 @@
map.set(ListMap0, CellVar, List, ListMap),
ConjMap = conj_map(StringMap0, ListMap, ElementMap0, EqvMap0)
;
- ConsId = cons(SymName, Arity),
+ ConsId = cons(SymName, Arity, TypeCtor),
+ TypeCtor = poly_type_type_ctor,
Arity = 1,
- StringModule =
- mercury_std_lib_module_name(unqualified("string")),
- SymName = qualified(StringModule, Functor),
+ Functor = unqualify_name(SymName),
(
Functor = "f",
PolyType = f(0.0)
Index: compiler/hhf.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hhf.m,v
retrieving revision 1.35
diff -u -r1.35 hhf.m
--- compiler/hhf.m 29 Jan 2008 04:59:38 -0000 1.35
+++ compiler/hhf.m 5 Feb 2009 14:07:07 -0000
@@ -50,6 +50,7 @@
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
+:- import_module mdbcomp.prim_data.
:- import_module list.
:- import_module map.
@@ -73,10 +74,10 @@
some [!IG] (
pred_info_get_inst_graph_info(PredInfo0, !:IG),
inst_graph.init(HeadVars, InstGraph),
- !:IG = !.IG ^ implementation_inst_graph := InstGraph,
- !:IG = !.IG ^ interface_inst_graph := InstGraph,
- !:IG = !.IG ^ interface_vars := HeadVars,
- !:IG = !.IG ^ interface_varset := VarSet,
+ !IG ^ implementation_inst_graph := InstGraph,
+ !IG ^ interface_inst_graph := InstGraph,
+ !IG ^ interface_vars := HeadVars,
+ !IG ^ interface_varset := VarSet,
pred_info_set_inst_graph_info(!.IG, PredInfo0, PredInfo2)
)
;
@@ -101,8 +102,8 @@
inst_graph.reachable(ImplementationInstGraph,
V0, V)
), InterfaceVars),
- !:IG = !.IG ^ interface_vars := InterfaceVars,
- !:IG = !.IG ^ interface_varset := VarSet,
+ !IG ^ interface_vars := InterfaceVars,
+ !IG ^ interface_varset := VarSet,
pred_info_set_inst_graph_info(!.IG, PredInfo1, PredInfo2)
)
@@ -300,8 +301,7 @@
Unif, Context).
process_unify(rhs_functor(ConsId0, IsExistConstruct, ArgsA), NonLocals,
GoalInfo0, X, Mode, Unif, Context, GoalExpr, !HI) :-
- map.lookup(!.HI ^ hhfi_vartypes, X, TypeOfX),
- qualify_cons_id(TypeOfX, ArgsA, ConsId0, _, ConsId),
+ qualify_cons_id(ArgsA, ConsId0, _, ConsId),
InstGraph0 = !.HI ^ hhfi_inst_graph,
map.lookup(InstGraph0, X, node(Functors0, MaybeParent)),
( map.search(Functors0, ConsId, ArgsB) ->
@@ -365,9 +365,9 @@
map.det_insert(VarTypes0, V, Type, VarTypes),
map.init(Empty),
map.det_insert(InstGraph0, V, node(Empty, top_level), InstGraph),
- !:HI = !.HI ^ hhfi_varset := VarSet,
- !:HI = !.HI ^ hhfi_vartypes := VarTypes,
- !:HI = !.HI ^ hhfi_inst_graph := InstGraph,
+ !HI ^ hhfi_varset := VarSet,
+ !HI ^ hhfi_vartypes := VarTypes,
+ !HI ^ hhfi_inst_graph := InstGraph,
GINonlocals0 = goal_info_get_nonlocals(GI0),
GINonlocals = set.insert(GINonlocals0, V),
goal_info_set_nonlocals(GINonlocals, GI0, GI),
@@ -395,18 +395,31 @@
type_constructors(ModuleInfo, Type, Constructors),
type_to_ctor_and_args(Type, TypeCtor, _)
->
- list.foldl(maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeCtor),
+ TypeCtor = type_ctor(TypeCtorSymName, _),
+ (
+ TypeCtorSymName = unqualified(_),
+ unexpected(this_file,
+ "complete_inst_graph_node: unqualified TypeCtorSymName")
+ ;
+ TypeCtorSymName = qualified(TypeCtorModuleName, _)
+ ),
+ list.foldl(
+ maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeCtor,
+ TypeCtorModuleName),
Constructors, !HI)
;
true
).
:- pred maybe_add_cons_id(prog_var::in, module_info::in, list(prog_var)::in,
- type_ctor::in, constructor::in, hhf_info::in, hhf_info::out) is det.
+ type_ctor::in, module_name::in, constructor::in,
+ hhf_info::in, hhf_info::out) is det.
-maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeCtor, Ctor, !HI) :-
+maybe_add_cons_id(Var, ModuleInfo, BaseVars, TypeCtor, TypeCtorModuleName,
+ Ctor, !HI) :-
Ctor = ctor(_, _, Name, Args, _),
- ConsId = make_cons_id(Name, Args, TypeCtor),
+ SymName = qualified(TypeCtorModuleName, unqualify_name(Name)),
+ ConsId = cons(SymName, list.length(Args), TypeCtor),
map.lookup(!.HI ^ hhfi_inst_graph, Var, node(Functors0, MaybeParent)),
( map.contains(Functors0, ConsId) ->
true
@@ -414,7 +427,7 @@
list.map_foldl(add_cons_id(Var, ModuleInfo, BaseVars), Args, NewVars,
!HI),
map.det_insert(Functors0, ConsId, NewVars, Functors),
- !:HI = !.HI ^ hhfi_inst_graph :=
+ !HI ^ hhfi_inst_graph :=
map.det_update(!.HI ^ hhfi_inst_graph, Var,
node(Functors, MaybeParent))
).
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.180
diff -u -r1.180 higher_order.m
--- compiler/higher_order.m 23 Dec 2008 01:37:33 -0000 1.180
+++ compiler/higher_order.m 6 Feb 2009 00:50:31 -0000
@@ -614,7 +614,7 @@
Goal = Goal0
;
GoalExpr0 = unify(_, _, _, Unification0, _),
- ( Unification0 = construct(_, pred_const(_, _), _, _, _, _, _) ->
+ ( Unification0 = construct(_, closure_cons(_, _), _, _, _, _, _) ->
maybe_specialize_pred_const(Goal0, Goal, !Info)
;
Goal = Goal0
@@ -884,7 +884,7 @@
% more than one possible value.
Specializable = constant(_, _),
map.det_update(PredVars0, LVar, multiple_values, PredVars),
- !:Info = !.Info ^ hoi_pred_vars := PredVars
+ !Info ^ hoi_pred_vars := PredVars
;
% If a variable is already non-specializable, it can't
% become specializable.
@@ -893,7 +893,7 @@
;
map.det_insert(PredVars0, LVar, constant(ConsId, Args),
PredVars),
- !:Info = !.Info ^ hoi_pred_vars := PredVars
+ !Info ^ hoi_pred_vars := PredVars
)
;
IsInteresting = no
@@ -907,10 +907,12 @@
is_interesting_cons_id(Params, ConsId) = IsInteresting :-
(
- ( ConsId = cons(_, _)
- ; ConsId = string_const(_)
+ ( ConsId = cons(_, _, _)
+ ; ConsId = tuple_cons(_)
; ConsId = float_const(_)
- ; ConsId = implementation_defined_const(_)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
+ ; ConsId = impl_defined_const(_)
; ConsId = tabling_info_const(_)
; ConsId = deep_profiling_proc_layout(_)
; ConsId = table_io_decl(_)
@@ -930,7 +932,7 @@
),
IsInteresting = Params ^ param_do_user_type_spec
;
- ConsId = pred_const(_, _),
+ ConsId = closure_cons(_, _),
IsInteresting = Params ^ param_do_higher_order_spec
).
@@ -941,8 +943,9 @@
list(prog_var)::in, hlds_goal::in, list(hlds_goal)::out,
higher_order_info::in, higher_order_info::out) is det.
-maybe_specialize_higher_order_call(PredVar, MaybeMethod, Args,
- hlds_goal(GoalExpr0, GoalInfo), Goals, !Info) :-
+maybe_specialize_higher_order_call(PredVar, MaybeMethod, Args, Goal0,
+ Goals, !Info) :-
+ Goal0 = hlds_goal(GoalExpr0, GoalInfo),
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
% We can specialize calls to call/N and class_method_call/N
% if the closure or typeclass_info has a known value.
@@ -950,7 +953,7 @@
map.search(!.Info ^ hoi_pred_vars, PredVar,
constant(ConsId, CurriedArgs)),
(
- ConsId = pred_const(ShroudedPredProcId, _),
+ ConsId = closure_cons(ShroudedPredProcId, _),
MaybeMethod = no
->
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
@@ -963,7 +966,8 @@
CurriedArgs = [BaseTypeClassInfo | OtherTypeClassArgs],
map.search(!.Info ^ hoi_pred_vars, BaseTypeClassInfo,
constant(BaseConsId, _)),
- BaseConsId = base_typeclass_info_const(_, ClassId, Instance, _),
+ BaseConsId =
+ base_typeclass_info_const(_, ClassId, Instance, _),
MaybeMethod = yes(Method),
module_info_get_instance_table(ModuleInfo, Instances),
map.lookup(Instances, ClassId, InstanceList),
@@ -1041,8 +1045,8 @@
AllArgs),
list.append(ArgTypeInfoGoals, ArgTypeClassInfoGoals, ExtraGoals)
),
- !:Info = !.Info ^ hoi_pred_info := CallerPredInfo,
- !:Info = !.Info ^ hoi_proc_info := CallerProcInfo,
+ !Info ^ hoi_pred_info := CallerPredInfo,
+ !Info ^ hoi_proc_info := CallerProcInfo,
construct_specialized_higher_order_call(PredId, ProcId,
AllArgs, GoalInfo, Goal, !Info),
list.append(ExtraGoals, [Goal], Goals)
@@ -1195,7 +1199,7 @@
MaybeContext = no,
GoalExpr1 = plain_call(PredId, ProcId, AllArgs, Builtin, MaybeContext,
SymName),
- !:Info = !.Info ^ hoi_changed := ho_changed,
+ !Info ^ hoi_changed := ho_changed,
maybe_specialize_call(hlds_goal(GoalExpr1, GoalInfo),
hlds_goal(GoalExpr, _), !Info).
@@ -1217,7 +1221,7 @@
MaybeContext, GoalInfo, HaveSpecialPreds, GoalExpr1, !Info)
->
GoalExpr = GoalExpr1,
- !:Info = !.Info ^ hoi_changed := ho_changed
+ !Info ^ hoi_changed := ho_changed
;
polymorphism.is_typeclass_info_manipulator(ModuleInfo0,
CalledPred, Manipulator)
@@ -1281,7 +1285,7 @@
;
SubInfo = construct_sub_info(no, no)
),
- ConsId0 = pred_const(ShroudedPredProcId, EvalMethod),
+ ConsId0 = closure_cons(ShroudedPredProcId, EvalMethod),
PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
proc(PredId, ProcId) = PredProcId,
map.contains(NewPreds, PredProcId),
@@ -1293,7 +1297,7 @@
proc_info_create_vars_from_types(ArgTypes, UncurriedArgs,
ProcInfo0, ProcInfo1),
list.append(Args0, UncurriedArgs, Args1),
- !:Info = !.Info ^ hoi_proc_info := ProcInfo1,
+ !Info ^ hoi_proc_info := ProcInfo1,
module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
CalleePredInfo, CalleeProcInfo),
@@ -1342,11 +1346,11 @@
proc_info_get_vartypes(ProcInfo2, VarTypes2),
map.delete_list(VarTypes2, UncurriedArgs, VarTypes),
proc_info_set_vartypes(VarTypes, ProcInfo2, ProcInfo),
- !:Info = !.Info ^ hoi_proc_info := ProcInfo,
+ !Info ^ hoi_proc_info := ProcInfo,
NewPredProcId = proc(NewPredId, NewProcId),
NewShroudedPredProcId = shroud_pred_proc_id(NewPredProcId),
- NewConsId = pred_const(NewShroudedPredProcId, EvalMethod),
+ NewConsId = closure_cons(NewShroudedPredProcId, EvalMethod),
Unify = construct(LVar, NewConsId, NewArgs, UniModes,
HowToConstruct, CellIsUnique, no_construct_sub_info),
GoalExpr2 = unify(LVar, rhs_functor(NewConsId, no, NewArgs),
@@ -1366,7 +1370,7 @@
;
Result = not_specialized,
% The dummy arguments can't be used anywhere.
- !:Info = !.Info ^ hoi_proc_info := ProcInfo0,
+ !Info ^ hoi_proc_info := ProcInfo0,
GoalExpr = GoalExpr0
)
;
@@ -1455,7 +1459,7 @@
CallGoal = plain_call(NewCalledPred, NewCalledProc, Args,
IsBuiltin, MaybeContext, NewName),
Result = specialized(ExtraTypeInfoGoals, CallGoal),
- !:Info = !.Info ^ hoi_changed := ho_changed
+ !Info ^ hoi_changed := ho_changed
;
% There is a known higher order variable in the call, so we
% put in a request for a specialized version of the pred.
@@ -1467,8 +1471,8 @@
Changed0 = !.Info ^ hoi_changed,
set.insert(Requests0, Request, Requests),
update_changed_status(Changed0, ho_request, Changed),
- !:Info = !.Info ^ hoi_global_info ^ hogi_requests := Requests,
- !:Info = !.Info ^ hoi_changed := Changed
+ !Info ^ hoi_global_info ^ hogi_requests := Requests,
+ !Info ^ hoi_changed := Changed
;
CanRequest = can_not_request
)
@@ -1507,7 +1511,7 @@
% typeclass_infos).
ConsId \= int_const(_),
- ( ConsId = pred_const(_, _) ->
+ ( ConsId = closure_cons(_, _) ->
% If we don't have clauses for the callee, we can't specialize
% any higher-order arguments. We may be able to do user guided
% type specialization.
@@ -1523,7 +1527,7 @@
map.apply_to_list(CurriedArgs, VarTypes, CurriedArgTypes),
list.map(rtti_varmaps_var_info(RttiVarMaps), CurriedArgs,
CurriedArgRttiInfo),
- ( ConsId = pred_const(ShroudedPredProcId, _) ->
+ ( ConsId = closure_cons(ShroudedPredProcId, _) ->
proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_get_arg_types(PredInfo, CurriedCalleeArgTypes)
@@ -1689,7 +1693,7 @@
;
HigherOrder = yes,
list.member(HOArg, HigherOrderArgs),
- HOArg ^ hoa_cons_id = pred_const(_, _)
+ HOArg ^ hoa_cons_id = closure_cons(_, _)
;
TypeSpec = yes
)
@@ -1771,9 +1775,9 @@
TypeInfoVars, TypeInfoGoals, PolyInfo0, PolyInfo),
poly_info_extract(PolyInfo, !.Info ^ hoi_pred_info, PredInfo,
!.Info ^ hoi_proc_info, ProcInfo, ModuleInfo),
- !:Info = !.Info ^ hoi_pred_info := PredInfo,
- !:Info = !.Info ^ hoi_proc_info := ProcInfo,
- !:Info = !.Info ^ hoi_global_info ^ hogi_module_info := ModuleInfo.
+ !Info ^ hoi_pred_info := PredInfo,
+ !Info ^ hoi_proc_info := ProcInfo,
+ !Info ^ hoi_global_info ^ hogi_module_info := ModuleInfo.
:- pred search_for_version(higher_order_info::in, ho_params::in,
module_info::in, ho_request::in, list(new_pred)::in,
@@ -1890,7 +1894,7 @@
\+ (
list.member(RequestArg, RequestArgs),
RequestConsId = RequestArg ^ hoa_cons_id,
- RequestConsId = pred_const(_, _)
+ RequestConsId = closure_cons(_, _)
).
higher_order_args_match([RequestArg | Args1], [VersionArg | Args2],
Args, FullOrPartial) :-
@@ -1920,7 +1924,7 @@
% All the higher-order arguments must be present in the version
% otherwise we should create a new one.
- ConsId1 \= pred_const(_, _),
+ ConsId1 \= closure_cons(_, _),
higher_order_args_match(Args1, [VersionArg | Args2], Args, _),
FullOrPartial = match_is_partial
).
@@ -1966,7 +1970,7 @@
PredVars0 = !.Info ^ hoi_pred_vars,
( map.search(PredVars0, RVar, constant(A, B)) ->
map.set(PredVars0, LVar, constant(A, B), PredVars),
- !:Info = !.Info ^ hoi_pred_vars := PredVars
+ !Info ^ hoi_pred_vars := PredVars
;
true
).
@@ -2000,19 +2004,23 @@
map.search(PredVars, TypeClassInfoVar,
constant(_TypeClassInfoConsId, TypeClassInfoArgs)),
- map.search(PredVars, IndexVar, constant(int_const(Index0), [])),
+ map.search(PredVars, IndexVar, IndexMaybeConst),
+ IndexMaybeConst = constant(int_const(Index0), []),
% Extract the number of class constraints on the instance
% from the base_typeclass_info.
TypeClassInfoArgs = [BaseTypeClassInfoVar | OtherVars],
map.search(PredVars, BaseTypeClassInfoVar,
- constant(base_typeclass_info_const(_, ClassId, InstanceNum, _), _))
+ BaseTypeClassInfoMaybeConst),
+ BaseTypeClassInfoMaybeConst = constant(BaseTypeClassInfoConsId, _),
+ BaseTypeClassInfoConsId =
+ base_typeclass_info_const(_, ClassId, InstanceNum, _)
->
module_info_get_instance_table(ModuleInfo, Instances),
map.lookup(Instances, ClassId, InstanceDefns),
list.index1_det(InstanceDefns, InstanceNum, InstanceDefn),
- InstanceDefn = hlds_instance_defn(_,_,_,Constraints,_,_,_,_,_),
+ InstanceDefn = hlds_instance_defn(_, _, _, Constraints, _, _, _, _, _),
(
Manipulator = type_info_from_typeclass_info,
list.length(Constraints, NumConstraints),
@@ -2031,7 +2039,7 @@
Uni = assign(TypeInfoVar, TypeInfoArg),
Goal = unify(TypeInfoVar, rhs_var(TypeInfoArg), out_mode - in_mode,
Uni, unify_context(umc_explicit, [])),
- !:Info = !.Info ^ hoi_changed := ho_changed
+ !Info ^ hoi_changed := ho_changed
;
Goal = Goal0
).
@@ -2136,9 +2144,9 @@
% would need to be extracted first.
type_is_atomic(ModuleInfo, WrappedType)
->
- specialize_unify_or_compare_pred_for_no_tag(WrappedType,
- Constructor, MaybeResult, Arg1, Arg2, MaybeContext,
- OrigGoalInfo, Goal, !Info)
+ specialize_unify_or_compare_pred_for_no_tag(SpecialPredType,
+ WrappedType, Constructor, MaybeResult, Arg1, Arg2,
+ MaybeContext, OrigGoalInfo, Goal, !Info)
;
call_type_specific_unify_or_compare(SpecialPredType, SpecialId,
TypeInfoArgs, SpecialPredArgs, MaybeContext, HaveSpecialPreds,
@@ -2183,7 +2191,9 @@
GoalExpr = conj(plain_conj, []) % true
;
MaybeResult = yes(ComparisonResult),
- Eq = cons(qualified(mercury_public_builtin_module, "="), 0),
+ Builtin = mercury_public_builtin_module,
+ TypeCtor = type_ctor(qualified(Builtin, "comparison_result"), 0),
+ Eq = cons(qualified(mercury_public_builtin_module, "="), 0, TypeCtor),
make_const_construction(ComparisonResult, Eq, Goal),
Goal = hlds_goal(GoalExpr, _)
).
@@ -2231,24 +2241,24 @@
Context, GoalInfo),
GoalExpr = conj(plain_conj,
[CastGoal1, CastGoal2, hlds_goal(Call, GoalInfo)]),
- !:Info = !.Info ^ hoi_proc_info := ProcInfo
+ !Info ^ hoi_proc_info := ProcInfo
)
).
-:- pred specialize_unify_or_compare_pred_for_no_tag(mer_type::in, sym_name::in,
- maybe(prog_var)::in, prog_var::in, prog_var::in,
+:- pred specialize_unify_or_compare_pred_for_no_tag(mer_type::in, mer_type::in,
+ sym_name::in, maybe(prog_var)::in, prog_var::in, prog_var::in,
maybe(call_unify_context)::in, hlds_goal_info::in, hlds_goal_expr::out,
higher_order_info::in, higher_order_info::out) is det.
-specialize_unify_or_compare_pred_for_no_tag(WrappedType, Constructor,
- MaybeResult, Arg1, Arg2, MaybeContext, OrigGoalInfo, GoalExpr,
- !Info) :-
+specialize_unify_or_compare_pred_for_no_tag(OuterType, WrappedType,
+ Constructor, MaybeResult, Arg1, Arg2, MaybeContext, OrigGoalInfo,
+ GoalExpr, !Info) :-
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
ProcInfo0 = !.Info ^ hoi_proc_info,
Context = goal_info_get_context(OrigGoalInfo),
- unwrap_no_tag_arg(WrappedType, Context, Constructor, Arg1,
+ unwrap_no_tag_arg(OuterType, WrappedType, Context, Constructor, Arg1,
UnwrappedArg1, ExtractGoal1, ProcInfo0, ProcInfo1),
- unwrap_no_tag_arg(WrappedType, Context, Constructor, Arg2,
+ unwrap_no_tag_arg(OuterType, WrappedType, Context, Constructor, Arg2,
UnwrappedArg2, ExtractGoal2, ProcInfo1, ProcInfo2),
set.list_to_set([UnwrappedArg1, UnwrappedArg2], NonLocals0),
(
@@ -2264,7 +2274,7 @@
Context, GoalInfo),
GoalExpr = conj(plain_conj,
[ExtractGoal1, ExtractGoal2, hlds_goal(SpecialGoal, GoalInfo)]),
- !:Info = !.Info ^ hoi_proc_info := ProcInfo2
+ !Info ^ hoi_proc_info := ProcInfo2
;
MaybeResult = yes(ComparisonResult),
set.insert(NonLocals0, ComparisonResult, NonLocals),
@@ -2285,7 +2295,7 @@
Context, GoalInfo),
GoalExpr = conj(plain_conj, [ExtractGoal1, ExtractGoal2,
hlds_goal(SpecialGoal, GoalInfo)]),
- !:Info = !.Info ^ hoi_proc_info := ProcInfo2
+ !Info ^ hoi_proc_info := ProcInfo2
;
NeedIntCast = yes,
generate_unsafe_type_cast(Context, CompareType,
@@ -2300,7 +2310,7 @@
GoalExpr = conj(plain_conj,
[ExtractGoal1, CastGoal1, ExtractGoal2, CastGoal2,
hlds_goal(SpecialGoal, GoalInfo)]),
- !:Info = !.Info ^ hoi_proc_info := ProcInfo4
+ !Info ^ hoi_proc_info := ProcInfo4
)
).
@@ -2350,7 +2360,7 @@
ModuleName = pred_info_module(PredInfo),
Name = pred_info_name(PredInfo),
SymName = qualified(ModuleName, Name),
- !:Info = !.Info ^ hoi_global_info ^ hogi_module_info := ModuleInfo
+ !Info ^ hoi_global_info ^ hogi_module_info := ModuleInfo
).
:- pred find_builtin_type_with_equivalent_compare(module_info::in,
@@ -2388,14 +2398,15 @@
proc_info_create_var_from_type(ToType, no, CastArg, !ProcInfo),
generate_cast(unsafe_type_cast, Arg, CastArg, Context, Goal).
-:- pred unwrap_no_tag_arg(mer_type::in, prog_context::in, sym_name::in,
- prog_var::in, prog_var::out, hlds_goal::out,
+:- pred unwrap_no_tag_arg(mer_type::in, mer_type::in, prog_context::in,
+ sym_name::in, prog_var::in, prog_var::out, hlds_goal::out,
proc_info::in, proc_info::out) is det.
-unwrap_no_tag_arg(WrappedType, Context, Constructor, Arg, UnwrappedArg, Goal,
- !ProcInfo) :-
+unwrap_no_tag_arg(OuterType, WrappedType, Context, Constructor, Arg,
+ UnwrappedArg, Goal, !ProcInfo) :-
proc_info_create_var_from_type(WrappedType, no, UnwrappedArg, !ProcInfo),
- ConsId = cons(Constructor, 1),
+ type_to_ctor_det(OuterType, OuterTypeCtor),
+ ConsId = cons(Constructor, 1, OuterTypeCtor),
UniModes = [(ground(shared, none) - free) ->
(ground(shared, none) - ground(shared, none))],
set.list_to_set([Arg, UnwrappedArg], NonLocals),
@@ -2430,7 +2441,7 @@
filter_requests(FilteredRequests, LoopRequests, !Info, !IO) :-
Requests0 = set.to_sorted_list(!.Info ^ hogi_requests),
- !:Info = !.Info ^ hogi_requests := set.init,
+ !Info ^ hogi_requests := set.init,
list.foldl3(filter_requests_2(!.Info), Requests0,
[], FilteredRequests, [], LoopRequests, !IO).
@@ -2624,7 +2635,7 @@
NewProcId = hlds_pred.initial_proc_id,
IdCounter0 = !.Info ^ hogi_next_id,
counter.allocate(Id, IdCounter0, IdCounter),
- !:Info = !.Info ^ hogi_next_id := IdCounter,
+ !Info ^ hogi_next_id := IdCounter,
string.int_to_string(Id, IdStr),
string.append_list([Name0, "__ho", IdStr], PredName),
SymName = qualified(PredModule, PredName),
@@ -2667,7 +2678,7 @@
predicate_table_insert(NewPredInfo1, NewPredId, PredTable0, PredTable),
module_info_set_predicate_table(PredTable, ModuleInfo0, ModuleInfo1),
- !:Info = !.Info ^ hogi_module_info := ModuleInfo1,
+ !Info ^ hogi_module_info := ModuleInfo1,
NewPred = new_pred(proc(NewPredId, NewProcId), CalledPredProc, Caller,
SymName, HOArgs, CallArgs, ExtraTypeInfoTVars, ArgTypes,
@@ -2678,7 +2689,7 @@
create_new_proc(NewPred, ProcInfo0, NewPredInfo1, NewPredInfo, !Info),
ModuleInfo2 = !.Info ^ hogi_module_info,
module_info_set_pred_info(NewPredId, NewPredInfo, ModuleInfo2, ModuleInfo),
- !:Info = !.Info ^ hogi_module_info := ModuleInfo.
+ !Info ^ hogi_module_info := ModuleInfo.
:- pred add_new_pred(pred_proc_id::in, new_pred::in,
higher_order_global_info::in, higher_order_global_info::out) is det.
@@ -2692,7 +2703,7 @@
set.singleton_set(SpecVersions, NewPred),
map.det_insert(NewPreds0, CalledPredProcId, SpecVersions, NewPreds)
),
- !:Info = !.Info ^ hogi_new_preds := NewPreds.
+ !Info ^ hogi_new_preds := NewPreds.
:- pred maybe_write_request(bool::in, module_info::in, string::in,
sym_name::in, arity::in, arity::in, maybe(string)::in,
@@ -2734,7 +2745,7 @@
;
IsConst = no
),
- ( ConsId = pred_const(ShroudedPredProcId, _) ->
+ ( ConsId = closure_cons(ShroudedPredProcId, _) ->
proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
Name = pred_info_name(PredInfo),
@@ -2788,7 +2799,7 @@
Requests0 = !.Info ^ hogi_requests,
list.foldl(ho_fixup_pred(need_not_recompute), PredProcIds, !Info),
% Any additional requests must have already been denied.
- !:Info = !.Info ^ hogi_requests := Requests0.
+ !Info ^ hogi_requests := Requests0.
:- pred ho_fixup_specialized_versions(list(new_pred)::in,
higher_order_global_info::in, higher_order_global_info::out) is det.
@@ -3080,7 +3091,7 @@
CurriedArgTypes, CurriedArgRttiInfo, CurriedHOArgs, IsConst),
list.index1_det(HeadVars0, Index, LVar),
- ( ConsId = pred_const(ShroudedPredProcId, _) ->
+ ( ConsId = closure_cons(ShroudedPredProcId, _) ->
% Add the curried arguments to the procedure's argument list.
proc(PredId, ProcId) =
unshroud_pred_proc_id(ShroudedPredProcId),
Index: compiler/hlds_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_code_util.m,v
retrieving revision 1.38
diff -u -r1.38 hlds_code_util.m
--- compiler/hlds_code_util.m 3 Apr 2008 05:26:43 -0000 1.38
+++ compiler/hlds_code_util.m 5 Feb 2009 07:04:04 -0000
@@ -31,7 +31,7 @@
% Find out how a function symbol (constructor) is represented
% in the given type.
%
-:- func cons_id_to_tag(module_info, mer_type, cons_id) = cons_tag.
+:- func cons_id_to_tag(module_info, cons_id) = cons_tag.
% Given a list of types, mangle the names so into a string which
% identifies them. The types must all have their top level functor
@@ -50,6 +50,7 @@
:- implementation.
:- import_module check_hlds.mode_util.
+:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_pred.
:- import_module libs.compiler_util.
:- import_module libs.globals.
@@ -76,29 +77,33 @@
%-----------------------------------------------------------------------------%
-cons_id_to_tag(ModuleInfo, Type, ConsId) = Tag:-
+cons_id_to_tag(ModuleInfo, ConsId) = Tag:-
(
- ConsId = int_const(I),
- Tag = int_tag(I)
+ ConsId = int_const(Int),
+ Tag = int_tag(Int)
;
- ConsId = float_const(F),
- Tag = float_tag(F)
+ ConsId = float_const(Float),
+ Tag = float_tag(Float)
;
- ConsId = string_const(S),
- Tag = string_tag(S)
+ ConsId = char_const(Char),
+ char.to_int(Char, CharCode),
+ Tag = int_tag(CharCode)
;
- ConsId = implementation_defined_const(_),
+ ConsId = string_const(String),
+ Tag = string_tag(String)
+ ;
+ ConsId = impl_defined_const(_),
unexpected(this_file, "cons_id_to_tag: implementation_defined_const")
;
- ConsId = pred_const(ShroudedPredProcId, EvalMethod),
+ ConsId = closure_cons(ShroudedPredProcId, EvalMethod),
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
- Tag = pred_closure_tag(PredId, ProcId, EvalMethod)
+ Tag = closure_tag(PredId, ProcId, EvalMethod)
;
ConsId = type_ctor_info_const(ModuleName, TypeName, Arity),
Tag = type_ctor_info_tag(ModuleName, TypeName, Arity)
;
- ConsId = base_typeclass_info_const(ModuleName, ClassName, _Instance,
- EncodedArgs),
+ ConsId = base_typeclass_info_const(ModuleName, ClassName,
+ _Instance, EncodedArgs),
Tag = base_typeclass_info_tag(ModuleName, ClassName, EncodedArgs)
;
( ConsId = type_info_cell_constructor(_)
@@ -118,42 +123,26 @@
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
Tag = table_io_decl_tag(PredId, ProcId)
;
- ConsId = cons(Name, Arity),
+ ConsId = tuple_cons(_Arity),
+ % Tuples do not need a tag. Note that unary tuples are not treated
+ % as no_tag types. There is no reason why they couldn't be, it is
+ % just not worth the effort.
+ Tag = single_functor_tag
+ ;
+ ConsId = cons(_Name, _Arity, TypeCtor),
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ map.lookup(TypeTable, TypeCtor, TypeDefn),
+ hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
- % Handle the `character' type specially.
- Type = builtin_type(builtin_type_character),
- Name = unqualified(ConsName),
- string.char_to_string(Char, ConsName)
- ->
- char.to_int(Char, CharCode),
- Tag = int_tag(CharCode)
- ;
- % Tuples do not need a tag. Note that unary tuples are not treated
- % as no_tag types. There's no reason why they couldn't be, it is
- % just not worth the effort.
- type_is_tuple(Type, _)
- ->
- Tag = single_functor_tag
+ TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _, _),
+ map.lookup(ConsTagTable, ConsId, Tag)
;
- type_to_ctor_det(Type, TypeCtor),
- % Given the type_ctor, lookup up the constructor tag table
- % for that type.
- module_info_get_type_table(ModuleInfo, TypeTable),
- map.lookup(TypeTable, TypeCtor, TypeDefn),
- hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- (
- TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _, _)
- ;
- ( TypeBody = hlds_eqv_type(_)
- ; TypeBody = hlds_foreign_type(_)
- ; TypeBody = hlds_solver_type(_, _)
- ; TypeBody = hlds_abstract_type(_)
- ),
- unexpected(this_file, "cons_id_to_tag: type is not d.u. type?")
+ ( TypeBody = hlds_eqv_type(_)
+ ; TypeBody = hlds_foreign_type(_)
+ ; TypeBody = hlds_solver_type(_, _)
+ ; TypeBody = hlds_abstract_type(_)
),
-
- % Finally look up the cons_id in the table.
- map.lookup(ConsTagTable, cons(Name, Arity), Tag)
+ unexpected(this_file, "cons_id_to_tag: type is not d.u. type")
)
).
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.124
diff -u -r1.124 hlds_data.m
--- compiler/hlds_data.m 28 Jan 2009 01:58:10 -0000 1.124
+++ compiler/hlds_data.m 4 Jun 2009 06:55:16 -0000
@@ -36,12 +36,12 @@
:- import_module check_hlds.type_util.
:- import_module libs.compiler_util.
:- import_module parse_tree.prog_type_subst.
+:- import_module parse_tree.prog_util.
:- import_module cord.
:- import_module int.
:- import_module svmap.
:- import_module svmulti_map.
-:- import_module term.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -249,6 +249,16 @@
% a cons_tag which specifies how that functor and its arguments are
% represented.
%
+ % XXX At the moment, every value is in the map several times.
+ % One reason for duplicating values is to be able to get at them
+ % with the sym_name in the cons_id key being fully qualified, unqualified,
+ % or anything in between. Another reason is the need to get at them
+ % with the cons_id containing the standard dummy type_ctor before
+ % post-typecheck, and with the actual correct type_ctor after
+ % post-typecheck.
+ %
+ % The key in the map should be just a string/arity pair.
+ %
:- type cons_tag_values == map(cons_id, cons_tag).
% A cons_id together with its tag.
@@ -287,7 +297,7 @@
% foreign enumerations, i.e. those enumeration types that are the
% subject of a foreign_enum pragma.
- ; pred_closure_tag(pred_id, proc_id, lambda_eval_method)
+ ; closure_tag(pred_id, proc_id, lambda_eval_method)
% Higher-order pred closures tags. These are represented as
% a pointer to an argument vector. For closures with
% lambda_eval_method `normal', the first two words of the argument
@@ -385,6 +395,18 @@
%
:- type tag_bits == int. % actually only 2 (or maybe 3) bits
+ % Return the primary tag, if any, for a cons_tag.
+ % A return value of `no' means the primary tag is unknown.
+ % A return value of `yes(N)' means the primary tag is N.
+ % (`yes(0)' also corresponds to the case where there no primary tag.)
+ %
+:- func get_primary_tag(cons_tag) = maybe(int).
+
+ % Return the secondary tag, if any, for a cons_tag.
+ % A return value of `no' means there is no secondary tag.
+ %
+:- func get_secondary_tag(cons_tag) = maybe(int).
+
% The type definitions for no_tag types have information mirrored in a
% separate table for faster lookups. mode_util.mode_to_arg_mode makes
% heavy use of type_util.type_is_no_tag_type.
@@ -400,18 +422,6 @@
:- func get_maybe_cheaper_tag_test(hlds_type_body) = maybe_cheaper_tag_test.
- % Return the primary tag, if any, for a cons_tag.
- % A return value of `no' means the primary tag is unknown.
- % A return value of `yes(N)' means the primary tag is N.
- % (`yes(0)' also corresponds to the case where there no primary tag.)
- %
-:- func get_primary_tag(cons_tag) = maybe(int).
-
- % Return the secondary tag, if any, for a cons_tag.
- % A return value of `no' means there is no secondary tag.
- %
-:- func get_secondary_tag(cons_tag) = maybe(int).
-
% The atomic variants of the Boehm gc allocator calls (e.g.
% GC_malloc_atomic instead of GC_malloc) may yield slightly faster code
% since atomic blocks are not scanned for included pointers. However,
@@ -427,9 +437,72 @@
:- implementation.
+:- import_module string.
+
project_tagged_cons_id_tag(TaggedConsId) = Tag :-
TaggedConsId = tagged_cons_id(_, Tag).
+get_primary_tag(Tag) = MaybePrimaryTag :-
+ (
+ % In some of the cases where we return `no' here,
+ % it would probably be OK to return `yes(0)'.
+ % But it's safe to be conservative...
+ ( Tag = int_tag(_)
+ ; Tag = float_tag(_)
+ ; Tag = string_tag(_)
+ ; Tag = foreign_tag(_, _)
+ ; Tag = closure_tag(_, _, _)
+ ; Tag = no_tag
+ ; Tag = reserved_address_tag(_)
+ ; Tag = type_ctor_info_tag(_, _, _)
+ ; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = tabling_info_tag(_, _)
+ ; Tag = table_io_decl_tag(_, _)
+ ; Tag = deep_profiling_proc_layout_tag(_, _)
+ ),
+ MaybePrimaryTag = no
+ ;
+ Tag = single_functor_tag,
+ MaybePrimaryTag = yes(0)
+ ;
+ ( Tag = unshared_tag(PrimaryTag)
+ ; Tag = shared_remote_tag(PrimaryTag, _SecondaryTag)
+ ; Tag = shared_local_tag(PrimaryTag, _SecondaryTag)
+ ),
+ MaybePrimaryTag = yes(PrimaryTag)
+ ;
+ Tag = shared_with_reserved_addresses_tag(_RAs, InnerTag),
+ MaybePrimaryTag = get_primary_tag(InnerTag)
+ ).
+
+get_secondary_tag(Tag) = MaybeSecondaryTag :-
+ (
+ ( Tag = int_tag(_)
+ ; Tag = float_tag(_)
+ ; Tag = string_tag(_)
+ ; Tag = foreign_tag(_, _)
+ ; Tag = closure_tag(_, _, _)
+ ; Tag = type_ctor_info_tag(_, _, _)
+ ; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = tabling_info_tag(_, _)
+ ; Tag = deep_profiling_proc_layout_tag(_, _)
+ ; Tag = table_io_decl_tag(_, _)
+ ; Tag = no_tag
+ ; Tag = reserved_address_tag(_)
+ ; Tag = unshared_tag(_PrimaryTag)
+ ; Tag = single_functor_tag
+ ),
+ MaybeSecondaryTag = no
+ ;
+ ( Tag = shared_remote_tag(_PrimaryTag, SecondaryTag)
+ ; Tag = shared_local_tag(_PrimaryTag, SecondaryTag)
+ ),
+ MaybeSecondaryTag = yes(SecondaryTag)
+ ;
+ Tag = shared_with_reserved_addresses_tag(_RAs, InnerTag),
+ MaybeSecondaryTag = get_secondary_tag(InnerTag)
+ ).
+
get_maybe_cheaper_tag_test(TypeBody) = CheaperTagTest :-
(
TypeBody = hlds_du_type(_, _, CheaperTagTest, _, _, _, _, _)
@@ -442,49 +515,6 @@
CheaperTagTest = no_cheaper_tag_test
).
-% In some of the cases where we return `no' here,
-% it would probably be OK to return `yes(0)'.
-% But it's safe to be conservative...
-get_primary_tag(string_tag(_)) = no.
-get_primary_tag(float_tag(_)) = no.
-get_primary_tag(int_tag(_)) = no.
-get_primary_tag(foreign_tag(_, _)) = no.
-get_primary_tag(pred_closure_tag(_, _, _)) = no.
-get_primary_tag(type_ctor_info_tag(_, _, _)) = no.
-get_primary_tag(base_typeclass_info_tag(_, _, _)) = no.
-get_primary_tag(tabling_info_tag(_, _)) = no.
-get_primary_tag(deep_profiling_proc_layout_tag(_, _)) = no.
-get_primary_tag(table_io_decl_tag(_, _)) = no.
-get_primary_tag(single_functor_tag) = yes(0).
-get_primary_tag(unshared_tag(PrimaryTag)) = yes(PrimaryTag).
-get_primary_tag(shared_remote_tag(PrimaryTag, _SecondaryTag))
- = yes(PrimaryTag).
-get_primary_tag(shared_local_tag(PrimaryTag, _)) = yes(PrimaryTag).
-get_primary_tag(no_tag) = no.
-get_primary_tag(reserved_address_tag(_)) = no.
-get_primary_tag(shared_with_reserved_addresses_tag(_RAs, TagValue))
- = get_primary_tag(TagValue).
-
-get_secondary_tag(string_tag(_)) = no.
-get_secondary_tag(float_tag(_)) = no.
-get_secondary_tag(int_tag(_)) = no.
-get_secondary_tag(foreign_tag(_, _)) = no.
-get_secondary_tag(pred_closure_tag(_, _, _)) = no.
-get_secondary_tag(type_ctor_info_tag(_, _, _)) = no.
-get_secondary_tag(base_typeclass_info_tag(_, _, _)) = no.
-get_secondary_tag(tabling_info_tag(_, _)) = no.
-get_secondary_tag(deep_profiling_proc_layout_tag(_, _)) = no.
-get_secondary_tag(table_io_decl_tag(_, _)) = no.
-get_secondary_tag(single_functor_tag) = no.
-get_secondary_tag(unshared_tag(_)) = no.
-get_secondary_tag(shared_remote_tag(_PrimaryTag, SecondaryTag))
- = yes(SecondaryTag).
-get_secondary_tag(shared_local_tag(_, _)) = no.
-get_secondary_tag(no_tag) = no.
-get_secondary_tag(reserved_address_tag(_)) = no.
-get_secondary_tag(shared_with_reserved_addresses_tag(_RAs, TagValue))
- = get_secondary_tag(TagValue).
-
:- type hlds_type_defn
---> hlds_type_defn(
% Note that the first three of these fields are duplicated
@@ -541,13 +571,14 @@
get_type_defn_need_qualifier(Defn, Defn ^ type_defn_need_qualifier).
get_type_defn_context(Defn, Defn ^ type_defn_context).
-set_type_defn_body(Body, Defn, Defn ^ type_defn_body := Body).
-set_type_defn_tvarset(TVarSet, Defn,
- Defn ^ type_defn_tvarset := TVarSet).
-set_type_defn_status(Status, Defn,
- Defn ^ type_defn_import_status := Status).
-set_type_defn_in_exported_eqv(InExportedEqv, Defn,
- Defn ^ type_defn_in_exported_eqv := InExportedEqv).
+set_type_defn_body(Body, !Defn) :-
+ !Defn ^ type_defn_body := Body.
+set_type_defn_tvarset(TVarSet, !Defn) :-
+ !Defn ^ type_defn_tvarset := TVarSet.
+set_type_defn_status(Status, !Defn) :-
+ !Defn ^ type_defn_import_status := Status.
+set_type_defn_in_exported_eqv(InExportedEqv, !Defn) :-
+ !Defn ^ type_defn_in_exported_eqv := InExportedEqv.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/hlds_desc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_desc.m,v
retrieving revision 1.3
diff -u -r1.3 hlds_desc.m
--- compiler/hlds_desc.m 19 Feb 2009 03:49:17 -0000 1.3
+++ compiler/hlds_desc.m 20 Feb 2009 07:47:58 -0000
@@ -69,11 +69,13 @@
(
Unification = construct(Var, ConsId, Args, _, _, _, _),
Desc = describe_var(VarSet, Var) ++ " <= " ++
- cons_id_to_string(ConsId) ++ describe_args(VarSet, Args)
+ cons_id_and_arity_to_string(ConsId) ++
+ describe_args(VarSet, Args)
;
Unification = deconstruct(Var, ConsId, Args, _, _, _),
Desc = describe_var(VarSet, Var) ++ " => " ++
- cons_id_to_string(ConsId) ++ describe_args(VarSet, Args)
+ cons_id_and_arity_to_string(ConsId) ++
+ describe_args(VarSet, Args)
;
Unification = assign(ToVar, FromVar),
Desc = describe_var(VarSet, ToVar) ++
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.206
diff -u -r1.206 hlds_goal.m
--- compiler/hlds_goal.m 10 Mar 2009 05:00:28 -0000 1.206
+++ compiler/hlds_goal.m 30 May 2009 05:54:09 -0000
@@ -17,9 +17,9 @@
:- module hlds.hlds_goal.
:- interface.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_llds.
:- import_module hlds.hlds_pred.
-:- import_module hlds.hlds_data.
:- import_module hlds.instmap.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.program_representation.
@@ -693,22 +693,18 @@
---> construct_sub_info(
take_address_fields :: maybe(list(int)),
+ % The value `yes' tells the code generator to reserve an extra
+ % slot, at offset -1, to hold an integer giving the size of
+ % the term. The argument specifies the value to be put into
+ % this slot, either as an integer constant or as the value
+ % of a given variable.
+ %
+ % The value `no' means there is no extra slot, and is the
+ % default.
+ %
+ % The content of this slot is not meaningful before the
+ % size_prof pass has been run.
term_size_slot :: maybe(term_size_value)
- % The value `yes' tells the code
- % generator to reserve an extra slot,
- % at offset -1, to hold an integer
- % giving the size of the term.
- % The argument specifies the value
- % to be put into this slot, either
- % as an integer constant or as the
- % value of a given variable.
- %
- % The value `no' means there is no
- % extra slot, and is the default.
- %
- % The content of this slot is not
- % meaningful before the size_prof pass
- % has been run.
)
; no_construct_sub_info.
@@ -903,10 +899,10 @@
% unification.
%
:- type unify_sub_context
- == pair(
- cons_id, % The functor.
- int % The argument number (first arg == 1).
- ).
+ ---> unify_sub_context(
+ cons_id, % The functor.
+ int % The argument number (first arg == 1).
+ ).
:- type unify_sub_contexts == list(unify_sub_context).
@@ -949,7 +945,7 @@
%
:- type static_cons
---> static_cons(
- cons_id, % The cons_id of the functor.
+ cons_id, % The cons_id of the functor.
list(prog_var), % The list of arg variables.
list(static_cons) % How to construct the args.
).
@@ -959,7 +955,7 @@
:- type cell_to_reuse
---> cell_to_reuse(
prog_var,
- list(cons_id), % The cell to be reused may be tagged
+ list(cons_id), % The cell to be reused may be tagged
% with one of these cons_ids.
list(needs_update) % Whether the corresponding
% argument already has the correct value
@@ -1151,18 +1147,26 @@
:- type short_reuse_description
---> cell_died
; cell_reused(
- dead_var, % The dead variable selected for reusing.
- is_conditional, % States whether the reuse is conditional.
- list(cons_id), % What are the possible cons_ids that the
- % variable to be reused can have.
+ % The dead variable selected for reusing.
+ dead_var,
+
+ % States whether the reuse is conditional.
+ is_conditional,
+
+ % What are the possible cons_ids that the variable
+ % to be reused can have.
+ list(cons_id),
+
+ % Which of the fields of the cell to be reused already contain
+ % the correct value.
list(needs_update)
- % Which of the fields of the cell to be
- % reused already contain the correct value.
)
; reuse_call(
is_conditional,
- list(int) % Which arguments must not be clobbered;
- % determines the reuse version to call.
+
+ % Which arguments must not be clobbered; determines the reuse
+ % version to call.
+ list(int)
).
% Used to represent the fact whether a reuse opportunity is either
@@ -1742,6 +1746,7 @@
:- implementation.
:- import_module libs.compiler_util.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
@@ -3179,8 +3184,7 @@
make_const_construction(Var, float_const(Float), Goal).
make_char_const_construction(Var, Char, Goal) :-
- string.char_to_string(Char, String),
- make_const_construction(Var, cons(unqualified(String), 0), Goal).
+ make_const_construction(Var, char_const(Char), Goal).
make_const_construction(Var, ConsId, hlds_goal(GoalExpr, GoalInfo)) :-
RHS = rhs_functor(ConsId, no, []),
@@ -3229,12 +3233,12 @@
construct_tuple(Tuple, Args, Goal) :-
list.length(Args, Arity),
- ConsId = cons(unqualified("{}"), Arity),
+ ConsId = tuple_cons(Arity),
construct_functor(Tuple, ConsId, Args, Goal).
deconstruct_tuple(Tuple, Args, Goal) :-
list.length(Args, Arity),
- ConsId = cons(unqualified("{}"), Arity),
+ ConsId = tuple_cons(Arity),
deconstruct_functor(Tuple, ConsId, Args, Goal).
%-----------------------------------------------------------------------------%
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.464
diff -u -r1.464 hlds_out.m
--- compiler/hlds_out.m 29 Apr 2009 03:38:12 -0000 1.464
+++ compiler/hlds_out.m 3 Jun 2009 16:31:54 -0000
@@ -5,10 +5,10 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: hlds_out.m.
% Main authors: conway, fjh.
-%
+%
% There is quite a bit of overlap between the following modules:
%
% hlds_out.m
@@ -18,7 +18,7 @@
% mercury_to_mercury.m prints the parse tree data structure defined
% in prog_data.m. hlds_out.m does a similar task, but for the data
% structure defined in hlds.m. term_io.m prints terms.
-%
+%
% There are two different ways of printing variables.
% One way uses the names Var', Var'', etc. which are generated
% by the compiler. The other way converts all names back into
@@ -26,7 +26,7 @@
% mercury_to_mercury.m, which uses the second method, rather
% than term_io.m, which uses the first method. We should
% think about using an option to specify which method is used.
-%
+%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -56,8 +56,8 @@
:- pred write_class_id(class_id::in, io::di, io::uo) is det.
-:- pred write_cons_id(cons_id::in, io::di, io::uo) is det.
-:- func cons_id_to_string(cons_id) = string.
+:- pred write_cons_id_and_arity(cons_id::in, io::di, io::uo) is det.
+:- func cons_id_and_arity_to_string(cons_id) = string.
% write_pred_id/4 writes out a message such as
% predicate `foo.bar/3'
@@ -183,8 +183,8 @@
% give the context. The boolean says whether variables should have
% their numbers appended to them.
%
-:- pred write_functor_cons_id(cons_id::in, list(prog_var)::in, prog_varset::in,
- module_info::in, bool::in, io::di, io::uo) is det.
+:- pred write_functor_cons_id(cons_id::in, list(prog_var)::in,
+ prog_varset::in, module_info::in, bool::in, io::di, io::uo) is det.
:- func functor_cons_id_to_string(cons_id, list(prog_var), prog_varset,
module_info, bool) = string.
@@ -318,58 +318,87 @@
write_class_id(class_id(Name, Arity), !IO) :-
prog_out.write_sym_name_and_arity(Name / Arity, !IO).
-write_cons_id(ConsId, !IO) :-
- io.write_string(cons_id_to_string(ConsId), !IO).
+write_cons_id_and_arity(ConsId, !IO) :-
+ io.write_string(cons_id_and_arity_to_string(ConsId), !IO).
-cons_id_to_string(cons(SymName, Arity)) = String :-
- SymNameString0 = sym_name_to_string(SymName),
- ( string.contains_char(SymNameString0, '*') ->
- % We need to protect against the * appearing next to a /
- Stuff = (pred(Char::in, Str0::in, Str::out) is det :-
- ( Char = ('*') ->
- string.append(Str0, "star", Str)
- ;
- string.char_to_string(Char, CharStr),
- string.append(Str0, CharStr, Str)
- )
+cons_id_and_arity_to_string(ConsId) = String :-
+ (
+ ConsId = cons(SymName, Arity, _TypeCtor),
+ SymNameString0 = sym_name_to_string(SymName),
+ ( string.contains_char(SymNameString0, '*') ->
+ % We need to protect against the * appearing next to a /
+ Stuff = (pred(Char::in, Str0::in, Str::out) is det :-
+ ( Char = ('*') ->
+ string.append(Str0, "star", Str)
+ ;
+ string.char_to_string(Char, CharStr),
+ string.append(Str0, CharStr, Str)
+ )
+ ),
+ string.foldl(Stuff, SymNameString0, "", SymNameString1)
+ ;
+ SymNameString1 = SymNameString0
),
- string.foldl(Stuff, SymNameString0, "", SymNameString1)
+ SymNameString = term_io.escaped_string(SymNameString1),
+ string.int_to_string(Arity, ArityString),
+ string.append_list([SymNameString, "/", ArityString], String)
;
- SymNameString1 = SymNameString0
- ),
- SymNameString = term_io.escaped_string(SymNameString1),
- string.int_to_string(Arity, ArityString),
- string.append_list([SymNameString, "/", ArityString], String).
-cons_id_to_string(int_const(Int)) = String :-
- string.int_to_string(Int, String).
-cons_id_to_string(string_const(String)) =
- term_io.quoted_string(String).
-cons_id_to_string(float_const(Float)) =
- float_to_string(Float).
-cons_id_to_string(implementation_defined_const(Name)) =
- "$" ++ Name.
-cons_id_to_string(pred_const(shrouded_pred_proc_id(PredId, ProcId), _)) =
- "<pred " ++ int_to_string(PredId) ++
- " proc " ++ int_to_string(ProcId) ++ ">".
-cons_id_to_string(type_ctor_info_const(Module, Ctor, Arity)) =
- "<type_ctor_info " ++ sym_name_to_string(Module) ++ "." ++
- Ctor ++ "/" ++ int_to_string(Arity) ++ ">".
-cons_id_to_string(base_typeclass_info_const(_, _, _, _)) =
- "<base_typeclass_info>".
-cons_id_to_string(type_info_cell_constructor(_)) =
- "<type_info_cell_constructor>".
-cons_id_to_string(typeclass_info_cell_constructor) =
- "<typeclass_info_cell_constructor>".
-cons_id_to_string(tabling_info_const(shrouded_pred_proc_id(PredId, ProcId))) =
- "<tabling_info " ++ int_to_string(PredId) ++
- ", " ++ int_to_string(ProcId) ++ ">".
-cons_id_to_string(deep_profiling_proc_layout(
- shrouded_pred_proc_id(PredId, ProcId))) =
- "<deep_profiling_proc_layout " ++ int_to_string(PredId) ++
- ", " ++ int_to_string(ProcId) ++ ">".
-cons_id_to_string(table_io_decl(shrouded_pred_proc_id(PredId, ProcId))) =
- "<table_io_decl " ++ int_to_string(PredId) ++
- ", " ++ int_to_string(ProcId) ++ ">".
+ ConsId = tuple_cons(Arity),
+ String = "{}/" ++ string.int_to_string(Arity)
+ ;
+ ConsId = int_const(Int),
+ string.int_to_string(Int, String)
+ ;
+ ConsId = float_const(Float),
+ String = float_to_string(Float)
+ ;
+ ConsId = char_const(CharConst),
+ String = term_io.quoted_char(CharConst)
+ ;
+ ConsId = string_const(StringConst),
+ String = term_io.quoted_string(StringConst)
+ ;
+ ConsId = impl_defined_const(Name),
+ String = "$" ++ Name
+ ;
+ ConsId = closure_cons(PredProcId, _),
+ PredProcId = shrouded_pred_proc_id(PredId, ProcId),
+ String =
+ "<pred " ++ int_to_string(PredId) ++
+ " proc " ++ int_to_string(ProcId) ++ ">"
+ ;
+ ConsId = type_ctor_info_const(Module, Ctor, Arity),
+ String =
+ "<type_ctor_info " ++ sym_name_to_string(Module) ++ "." ++
+ Ctor ++ "/" ++ int_to_string(Arity) ++ ">"
+ ;
+ ConsId = base_typeclass_info_const(_, _, _, _),
+ String = "<base_typeclass_info>"
+ ;
+ ConsId = type_info_cell_constructor(_),
+ String = "<type_info_cell_constructor>"
+ ;
+ ConsId = typeclass_info_cell_constructor,
+ String = "<typeclass_info_cell_constructor>"
+ ;
+ ConsId = tabling_info_const(PredProcId),
+ PredProcId = shrouded_pred_proc_id(PredId, ProcId),
+ String =
+ "<tabling_info " ++ int_to_string(PredId) ++
+ ", " ++ int_to_string(ProcId) ++ ">"
+ ;
+ ConsId = table_io_decl(PredProcId),
+ PredProcId = shrouded_pred_proc_id(PredId, ProcId),
+ String =
+ "<table_io_decl " ++ int_to_string(PredId) ++ ", " ++
+ int_to_string(ProcId) ++ ">"
+ ;
+ ConsId = deep_profiling_proc_layout(PredProcId),
+ PredProcId = shrouded_pred_proc_id(PredId, ProcId),
+ String =
+ "<deep_profiling_proc_layout " ++ int_to_string(PredId) ++ ", " ++
+ int_to_string(ProcId) ++ ">"
+ ).
write_pred_id(ModuleInfo, PredId, !IO) :-
% The code of this predicate duplicates the functionality of
@@ -616,8 +645,9 @@
contexts_describe_list_element([SubContext | SubContexts],
NumElementsBefore, ElementNum, AfterContexts) :-
- SubContext = ConsId - ArgNum,
- ConsId = cons(Functor, 2),
+ SubContext = unify_sub_context(ConsId, ArgNum),
+ ConsId = cons(Functor, 2, _TypeCtor),
+ % We ignore _TypeCtor since it may not have been set yet.
(
Functor = unqualified("[|]")
;
@@ -634,16 +664,16 @@
NumElementsBefore + 1, ElementNum, AfterContexts)
).
-:- pred in_argument_to_pieces(is_first::in, pair(cons_id, int)::in,
+:- pred in_argument_to_pieces(is_first::in, unify_sub_context::in,
list(format_component)::in, list(format_component)::out) is det.
in_argument_to_pieces(First, SubContext, !Pieces) :-
start_in_message_to_pieces(First, !Pieces),
- SubContext = ConsId - ArgNum,
+ SubContext = unify_sub_context(ConsId, ArgNum),
ArgNumStr = int_to_string(ArgNum),
+ ConsIdStr = cons_id_and_arity_to_string(ConsId),
!:Pieces = !.Pieces ++ [words("argument"), fixed(ArgNumStr),
- words("of functor"),
- prefix("`"), fixed(cons_id_to_string(ConsId)), suffix("':"), nl].
+ words("of functor"), quote(ConsIdStr), suffix(":"), nl].
:- pred in_element_to_pieces(is_first::in, int::in,
list(format_component)::in, list(format_component)::out) is det.
@@ -1473,7 +1503,7 @@
;
PortCountsGiveCoverageAfter =
no_port_counts_give_coverage_after,
- io.write_string("% no port counts give coverage after\n",
+ io.write_string("% no port counts give coverage after\n",
!IO)
)
;
@@ -1543,8 +1573,8 @@
( string.contains_char(Verbose, 'R') ->
(
yes(LFU) = goal_info_get_maybe_lfu(GoalInfo),
- yes(LBU) = goal_info_get_maybe_lbu(GoalInfo),
- yes(ReuseDescription) = goal_info_get_maybe_reuse(GoalInfo),
+ yes(LBU) = goal_info_get_maybe_lbu(GoalInfo),
+ yes(ReuseDescription) = goal_info_get_maybe_reuse(GoalInfo),
set.to_sorted_list(LFU, ListLFU),
set.to_sorted_list(LBU, ListLBU)
->
@@ -1567,22 +1597,22 @@
io.write_string("no possible reuse", !IO)
;
ReuseDescription = missed_reuse(Messages),
- io.write_string("missed (", !IO),
+ io.write_string("missed (", !IO),
io.write_list(Messages, ", ", io.write_string, !IO),
io.write_string(")", !IO)
;
ReuseDescription = potential_reuse(ShortReuseDescr),
- io.write_string("potential reuse (", !IO),
- write_short_reuse_description(ShortReuseDescr, VarSet,
- AppendVarNums, !IO),
+ io.write_string("potential reuse (", !IO),
+ write_short_reuse_description(ShortReuseDescr, VarSet,
+ AppendVarNums, !IO),
io.write_string(")", !IO)
;
ReuseDescription = reuse(ShortReuseDescr),
- io.write_string("reuse (", !IO),
+ io.write_string("reuse (", !IO),
write_short_reuse_description(ShortReuseDescr, VarSet,
- AppendVarNums, !IO),
+ AppendVarNums, !IO),
io.write_string(")", !IO)
- ),
+ ),
io.write_string("\n", !IO)
;
true
@@ -2168,7 +2198,7 @@
write_goal_2_shorthand(ShortHandGoal, ModuleInfo, VarSet, AppendVarNums,
Indent, Follow, TypeQual, !IO).
-:- pred write_atomic_interface_vars(string::in, atomic_interface_vars::in,
+:- pred write_atomic_interface_vars(string::in, atomic_interface_vars::in,
prog_varset::in, bool::in, io::di, io::uo) is det.
write_atomic_interface_vars(CompName, CompState, VarSet, AppendVarNums, !IO) :-
@@ -2190,7 +2220,7 @@
io.write_string("or_else\n", !IO),
write_goal_a(Goal, ModuleInfo, VarSet, AppendVarNums, Indent+1, Follow,
TypeQual, !IO),
- write_or_else_list(Goals, ModuleInfo, VarSet, AppendVarNums, Indent+1,
+ write_or_else_list(Goals, ModuleInfo, VarSet, AppendVarNums, Indent+1,
Follow, TypeQual, !IO).
:- pred write_goal_2_shorthand(shorthand_goal_expr::in, module_info::in,
@@ -2219,8 +2249,8 @@
io.write_string("])", !IO)
),
io.write_string("] (\n",!IO),
-
- write_goal_a(MainGoal, ModuleInfo, VarSet, AppendVarNums,
+
+ write_goal_a(MainGoal, ModuleInfo, VarSet, AppendVarNums,
Indent + 1, "\n", TypeQual, !IO),
write_goal_list(OrElseGoals, ModuleInfo, VarSet, AppendVarNums,
Indent, "or_else\n", TypeQual, !IO),
@@ -2548,6 +2578,15 @@
globals.io_lookup_string_option(dump_hlds_options, Verbose, !IO),
( string.contains_char(Verbose, 'u') ->
+ ( ConsId = cons(_, _, TypeCtor) ->
+ TypeCtor = type_ctor(TypeCtorSymName, TypeCtorArity),
+ write_indent(Indent, !IO),
+ TypeCtorSymNameStr = sym_name_to_string(TypeCtorSymName),
+ io.format("%% cons_id type_ctor: %s/%d",
+ [s(TypeCtorSymNameStr), i(TypeCtorArity)], !IO)
+ ;
+ true
+ ),
(
Uniqueness = cell_is_unique,
write_indent(Indent, !IO),
@@ -2664,7 +2703,7 @@
write_indent(Indent, !IO),
io.write_string("% ", !IO),
write_indent(Depth, !IO),
- mercury_output_cons_id(ConsId, does_not_need_brackets, !IO),
+ write_cons_id_and_arity(ConsId, !IO),
io.write_string("\n", !IO),
(
ArgVars = []
@@ -2685,7 +2724,7 @@
write_functor_and_submodes(ConsId, ArgVars, ArgModes, _ModuleInfo, ProgVarSet,
InstVarSet, AppendVarNums, Indent, !IO) :-
- write_cons_id(ConsId, !IO),
+ write_cons_id_and_arity(ConsId, !IO),
(
ArgVars = [],
io.write_string("\n", !IO)
@@ -2730,10 +2769,10 @@
VarSet, _, AppendVarNums, _Indent, MaybeType, TypeQual, !IO) :-
(
IsExistConstruct = yes,
- ConsId0 = cons(SymName0, Arity)
+ ConsId0 = cons(SymName0, Arity, TypeCtor)
->
remove_new_prefix(SymName, SymName0),
- ConsId = cons(SymName, Arity)
+ ConsId = cons(SymName, Arity, TypeCtor)
;
ConsId = ConsId0
),
@@ -2842,10 +2881,10 @@
ModuleInfo, VarSet, AppendVarNums) = Str :-
(
IsExistConstruct = yes,
- ConsId0 = cons(SymName0, Arity)
+ ConsId0 = cons(SymName0, Arity, TypeCtor)
->
remove_new_prefix(SymName, SymName0),
- ConsId = cons(SymName, Arity)
+ ConsId = cons(SymName, Arity, TypeCtor)
;
ConsId = ConsId0
),
@@ -2941,7 +2980,7 @@
functor_cons_id_to_string(ConsId, ArgVars, VarSet, ModuleInfo, AppendVarNums)
= Str :-
(
- ConsId = cons(SymName, _),
+ ConsId = cons(SymName, _, _),
(
SymName = qualified(Module, Name),
Str = qualified_functor_to_string(Module, term.atom(Name),
@@ -2952,6 +2991,10 @@
ArgVars, VarSet, AppendVarNums, next_to_graphic_token)
)
;
+ ConsId = tuple_cons(_),
+ Str = functor_to_string_maybe_needs_quotes(term.atom("{}"),
+ ArgVars, VarSet, AppendVarNums, next_to_graphic_token)
+ ;
ConsId = int_const(Int),
Str = functor_to_string(term.integer(Int), ArgVars, VarSet,
AppendVarNums)
@@ -2960,28 +3003,40 @@
Str = functor_to_string(term.float(Float), ArgVars, VarSet,
AppendVarNums)
;
+ ConsId = char_const(Char),
+ % XXX The strings ('z') and ('\n') should always denote
+ % the last letter of the alphabet and the newline character
+ % respectively. We need to decide whether forms such as (z)
+ % and 'z' should acceptable too. I (zs) think that 'z' should
+ % be acceptable to the scanner and parser (which currently it isn't),
+ % but (z) should not be.
+ Str = "(" ++ term_io.quoted_char(Char) ++ ")"
+ ;
ConsId = string_const(String),
Str = functor_to_string(term.string(String), ArgVars, VarSet,
AppendVarNums)
;
- ConsId = implementation_defined_const(Name),
+ ConsId = impl_defined_const(Name),
Str = "$" ++ Name
;
- ConsId = pred_const(ShroudedPredProcId, _),
+ ConsId = closure_cons(ShroudedPredProcId, _),
proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
PredModule = pred_info_module(PredInfo),
PredName = pred_info_name(PredInfo),
- Str = functor_cons_id_to_string(cons(qualified(PredModule, PredName),
- list.length(ArgVars)), ArgVars, VarSet, ModuleInfo, AppendVarNums)
+ PredSymName = qualified(PredModule, PredName),
+ PredConsId = cons(PredSymName, list.length(ArgVars),
+ cons_id_dummy_type_ctor),
+ Str = functor_cons_id_to_string(PredConsId, ArgVars, VarSet,
+ ModuleInfo, AppendVarNums)
;
ConsId = type_ctor_info_const(Module, Name, Arity),
Str = "type_ctor_info("""
++ prog_out.sym_name_to_escaped_string(Module)
++ """, """ ++ Name ++ """, " ++ int_to_string(Arity) ++ ")"
;
- ConsId = base_typeclass_info_const(Module, class_id(Name, Arity), _,
- Instance),
+ ConsId = base_typeclass_info_const(Module, ClassId, _, Instance),
+ ClassId = class_id(Name, Arity),
Str = "base_typeclass_info("""
++ prog_out.sym_name_to_escaped_string(Module) ++ """, "
++ "class_id(" ++ prog_out.sym_name_to_escaped_string(Name)
@@ -3004,17 +3059,17 @@
++ pred_id_to_string(ModuleInfo, PredId)
++ ", " ++ int_to_string(ProcIdInt) ++ ")"
;
- ConsId = deep_profiling_proc_layout(ShroudedPredProcId),
+ ConsId = table_io_decl(ShroudedPredProcId),
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
proc_id_to_int(ProcId, ProcIdInt),
- Str = "deep_profiling_proc_layout("
+ Str = "table_io_decl("
++ pred_id_to_string(ModuleInfo, PredId)
++ " (mode " ++ int_to_string(ProcIdInt) ++ "))"
;
- ConsId = table_io_decl(ShroudedPredProcId),
+ ConsId = deep_profiling_proc_layout(ShroudedPredProcId),
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
proc_id_to_int(ProcId, ProcIdInt),
- Str = "table_io_decl("
+ Str = "deep_profiling_proc_layout("
++ pred_id_to_string(ModuleInfo, PredId)
++ " (mode " ++ int_to_string(ProcIdInt) ++ "))"
).
@@ -3094,7 +3149,7 @@
io.write_string("% ", !IO),
mercury_output_var(VarSet, AppendVarNums, Var, !IO),
io.write_string(" has functor ", !IO),
- write_cons_id(MainConsId, !IO),
+ write_cons_id_and_arity(MainConsId, !IO),
list.foldl(write_alternative_cons_id, OtherConsIds, !IO),
io.write_string("\n", !IO),
% XXX if the output of this is to be used, e.g. in
@@ -3109,7 +3164,7 @@
write_alternative_cons_id(ConsId, !IO) :-
io.write_string(" or ", !IO),
- write_cons_id(ConsId, !IO).
+ write_cons_id_and_arity(ConsId, !IO).
:- pred write_cases(list(case)::in, prog_var::in, module_info::in,
prog_varset::in, bool::in, int::in, maybe_vartypes::in, io::di, io::uo)
@@ -3470,7 +3525,7 @@
),
write_type_name(TypeCtor, !IO),
write_type_params(TVarSet, TypeParams, !IO),
- write_type_body(Indent + 1, TVarSet, TypeBody, !IO),
+ write_type_body(TypeCtor, TypeBody, Indent + 1, TVarSet, !IO),
write_types_2(Indent, Types, !IO).
:- pred write_type_name(type_ctor::in, io::di, io::uo) is det.
@@ -3507,10 +3562,10 @@
mercury_output_var(TVarSet, no, P, !IO),
write_type_params_2(TVarSet, Ps, !IO).
-:- pred write_type_body(int::in, tvarset::in, hlds_type_body::in,
- io::di, io::uo) is det.
+:- pred write_type_body(type_ctor::in, hlds_type_body::in,
+ int::in, tvarset::in, io::di, io::uo) is det.
-write_type_body(Indent, TVarSet, TypeBody, !IO) :-
+write_type_body(TypeCtor, TypeBody, Indent, TVarSet, !IO) :-
(
TypeBody = hlds_du_type(Ctors, ConsTagMap, CheaperTagTest, DuTypeKind,
MaybeUserEqComp, ReservedTag, ReservedAddr, Foreign),
@@ -3521,11 +3576,11 @@
CheaperTagTest = cheaper_tag_test(ExpConsId, ExpConsTag,
CheapConsId, CheapConsTag),
io.write_string("/* cheaper tag test: ", !IO),
- write_cons_id(ExpConsId, !IO),
+ write_cons_id_and_arity(ExpConsId, !IO),
io.write_string(" tag ", !IO),
io.print(ExpConsTag, !IO),
io.write_string(" -> ", !IO),
- write_cons_id(CheapConsId, !IO),
+ write_cons_id_and_arity(CheapConsId, !IO),
io.write_string(" tag ", !IO),
io.print(CheapConsTag, !IO),
io.write_string(" */\n", !IO)
@@ -3545,7 +3600,8 @@
write_indent(Indent, !IO),
io.write_string("/* KIND dummy */\n", !IO)
;
- DuTypeKind = du_type_kind_notag(FunctorName, ArgType, MaybeArgName),
+ DuTypeKind = du_type_kind_notag(FunctorName, ArgType,
+ MaybeArgName),
write_indent(Indent, !IO),
io.write_string("/* KIND notag: ", !IO),
write_sym_name(FunctorName, !IO),
@@ -3578,7 +3634,7 @@
;
ReservedAddr = does_not_use_reserved_address
),
- write_constructors(Indent, TVarSet, Ctors, ConsTagMap, !IO),
+ write_constructors(TypeCtor, Indent, TVarSet, Ctors, ConsTagMap, !IO),
mercury_output_where_attributes(TVarSet, no, MaybeUserEqComp, !IO),
(
Foreign = yes(_),
@@ -3607,46 +3663,48 @@
io.write_string(".\n", !IO)
).
-:- pred write_constructors(int::in, tvarset::in,
+:- pred write_constructors(type_ctor::in, int::in, tvarset::in,
list(constructor)::in, cons_tag_values::in, io::di, io::uo) is det.
-write_constructors(_Indent, _TVarSet, [], _, !IO) :-
+write_constructors(_TypeCtor, _Indent, _TVarSet, [], _, !IO) :-
unexpected(this_file, "write_constructors: empty constructor list?").
-write_constructors(Indent, TVarSet, [C], TagValues, !IO) :-
+write_constructors(TypeCtor, Indent, TVarSet, [Ctor], TagValues, !IO) :-
write_indent(Indent, !IO),
io.write_char('\t', !IO),
- write_ctor(C, TVarSet, TagValues, !IO).
-write_constructors(Indent, TVarSet, [C | Cs], TagValues, !IO) :-
- Cs = [_ | _],
+ write_ctor(TypeCtor, Ctor, TVarSet, TagValues, !IO).
+write_constructors(TypeCtor, Indent, TVarSet, [Ctor | Ctors], TagValues,
+ !IO) :-
+ Ctors = [_ | _],
write_indent(Indent, !IO),
io.write_char('\t', !IO),
- write_ctor(C, TVarSet, TagValues, !IO),
+ write_ctor(TypeCtor, Ctor, TVarSet, TagValues, !IO),
io.write_string("\n", !IO),
- write_constructors_2(Indent, TVarSet, Cs, TagValues, !IO).
+ write_constructors_2(TypeCtor, Indent, TVarSet, Ctors, TagValues, !IO).
-:- pred write_constructors_2(int::in, tvarset::in,
+:- pred write_constructors_2(type_ctor::in, int::in, tvarset::in,
list(constructor)::in, cons_tag_values::in, io::di, io::uo) is det.
-write_constructors_2(_Indent, _TVarSet, [], _, !IO).
-write_constructors_2(Indent, TVarSet, [C | Cs], TagValues, !IO) :-
+write_constructors_2(_TypeCtor, _Indent, _TVarSet, [], _, !IO).
+write_constructors_2(TypeCtor, Indent, TVarSet, [Ctor | Ctors], TagValues,
+ !IO) :-
write_indent(Indent, !IO),
io.write_string(";\t", !IO),
- write_ctor(C, TVarSet, TagValues, !IO),
+ write_ctor(TypeCtor, Ctor, TVarSet, TagValues, !IO),
(
- Cs = []
+ Ctors = []
;
- Cs = [_ | _],
+ Ctors = [_ | _],
io.write_string("\n", !IO),
- write_constructors_2(Indent, TVarSet, Cs, TagValues, !IO)
+ write_constructors_2(TypeCtor, Indent, TVarSet, Ctors, TagValues, !IO)
).
-:- pred write_ctor(constructor::in, tvarset::in, cons_tag_values::in,
- io::di, io::uo) is det.
+:- pred write_ctor(type_ctor::in, constructor::in, tvarset::in,
+ cons_tag_values::in, io::di, io::uo) is det.
-write_ctor(C, TVarSet, TagValues, !IO) :-
- mercury_output_ctor(C, TVarSet, !IO),
- C = ctor(_, _, Name, Args, _),
- ConsId = make_cons_id_from_qualified_sym_name(Name, Args),
+write_ctor(TypeCtor, Ctor, TVarSet, TagValues, !IO) :-
+ mercury_output_ctor(Ctor, TVarSet, !IO),
+ Ctor = ctor(_, _, Name, Args, _),
+ ConsId = cons(Name, list.length(Args), TypeCtor),
( map.search(TagValues, ConsId, TagValue) ->
io.write_string("\t% tag: ", !IO),
io.print(TagValue, !IO)
@@ -3899,7 +3957,7 @@
io.write_string("% no output steps", !IO)
),
write_table_arg_infos(TVarSet, ArgInfos, !IO),
-
+
Attributes = table_attributes(Strictness, SizeLimit, Stats, AllowReset),
(
Strictness = all_strict,
@@ -4006,8 +4064,8 @@
proc_info_get_context(Proc, ModeContext),
proc_info_get_maybe_arg_size_info(Proc, MaybeArgSize),
proc_info_get_maybe_termination_info(Proc, MaybeTermination),
- proc_info_get_structure_sharing(Proc, MaybeStructureSharing),
- proc_info_get_structure_reuse(Proc, MaybeStructureReuse),
+ proc_info_get_structure_sharing(Proc, MaybeStructureSharing),
+ proc_info_get_structure_reuse(Proc, MaybeStructureReuse),
proc_info_get_rtti_varmaps(Proc, RttiVarMaps),
proc_info_get_eval_method(Proc, EvalMethod),
proc_info_get_is_address_taken(Proc, IsAddressTaken),
@@ -4765,12 +4823,10 @@
bound_insts_to_term([], _) = _ :-
unexpected(this_file, "bound_insts_to_term([])").
-bound_insts_to_term([bound_functor(ConsId, Args) | BoundInsts], Context)
- = Term :-
- (
- cons_id_and_args_to_term(ConsId,
- list.map(map_inst_to_term(Context), Args), FirstTerm)
- ->
+bound_insts_to_term([BoundInst | BoundInsts], Context) = Term :-
+ BoundInst = bound_functor(ConsId, Args),
+ ArgTerms = list.map(map_inst_to_term(Context), Args),
+ ( cons_id_and_args_to_term(ConsId, ArgTerms, FirstTerm) ->
(
BoundInsts = [],
Term = FirstTerm
@@ -4880,23 +4936,23 @@
mercury_format_inst(Inst,
expanded_inst_info(VarSet, ModuleInfo, Expansions), "", String).
-:- pred write_short_reuse_description(short_reuse_description::in,
- prog_varset::in, bool::in,
+:- pred write_short_reuse_description(short_reuse_description::in,
+ prog_varset::in, bool::in,
io::di, io::uo) is det.
-write_short_reuse_description(ShortDescription, VarSet, AppendVarnums, !IO):-
+write_short_reuse_description(ShortDescription, VarSet, AppendVarnums, !IO):-
(
- ShortDescription = cell_died,
+ ShortDescription = cell_died,
io.write_string("cell died", !IO)
;
ShortDescription = cell_reused(Var, IsConditional, _, _),
io.write_string("cell reuse - ", !IO),
mercury_output_var(VarSet, AppendVarnums, Var, !IO),
- io.write_string(" - ", !IO),
+ io.write_string(" - ", !IO),
write_is_conditional(IsConditional, !IO)
;
ShortDescription = reuse_call(IsConditional, NoClobbers),
- io.write_string("reuse call - ", !IO),
+ io.write_string("reuse call - ", !IO),
write_is_conditional(IsConditional, !IO),
io.write_string(", no clobbers = ", !IO),
io.write(NoClobbers, !IO)
@@ -4904,7 +4960,7 @@
:- pred write_is_conditional(is_conditional::in, io::di, io::uo) is det.
-write_is_conditional(IsConditional, !IO) :-
+write_is_conditional(IsConditional, !IO) :-
(
IsConditional = conditional_reuse,
io.write_string("with condition", !IO)
@@ -4917,7 +4973,7 @@
project_cons_name_and_tag(TaggedConsId, ConsName, ConsTag) :-
TaggedConsId = tagged_cons_id(ConsId, ConsTag),
- ConsName = hlds_out.cons_id_to_string(ConsId).
+ ConsName = cons_id_and_arity_to_string(ConsId).
case_comment(VarName, MainConsName, OtherConsNames) = Comment :-
(
Index: compiler/implementation_defined_literals.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/implementation_defined_literals.m,v
retrieving revision 1.3
diff -u -r1.3 implementation_defined_literals.m
--- compiler/implementation_defined_literals.m 23 Dec 2008 01:37:34 -0000 1.3
+++ compiler/implementation_defined_literals.m 5 Feb 2009 08:43:22 -0000
@@ -23,8 +23,8 @@
:- import_module io.
-:- pred subst_implementation_defined_literals(module_info::in,
- module_info::out, io::di, io::uo) is det.
+:- pred subst_impl_defined_literals(module_info::in, module_info::out,
+ io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -57,7 +57,7 @@
%-----------------------------------------------------------------------------%
-subst_implementation_defined_literals(!ModuleInfo, !IO) :-
+subst_impl_defined_literals(!ModuleInfo, !IO) :-
module_info_preds(!.ModuleInfo, Preds0),
map.map_values(subst_literals_in_pred(!.ModuleInfo), Preds0, Preds),
module_info_set_preds(Preds, !ModuleInfo).
@@ -93,18 +93,19 @@
(
RHS0 = rhs_functor(ConsId, _, _),
(
- ConsId = implementation_defined_const(Name),
+ ConsId = impl_defined_const(Name),
Context = goal_info_get_context(GoalInfo0),
- make_implementation_defined_literal(Var, Name, Context, Info,
- Goal1),
+ make_impl_defined_literal(Var, Name, Context, Info, Goal1),
Goal1 = hlds_goal(GoalExpr, _),
Goal = hlds_goal(GoalExpr, GoalInfo0)
;
- ( ConsId = cons(_, _)
+ ( ConsId = cons(_, _, _)
+ ; ConsId = tuple_cons(_)
+ ; ConsId = closure_cons(_, _)
; ConsId = int_const(_)
- ; ConsId = string_const(_)
; ConsId = float_const(_)
- ; ConsId = pred_const(_, _)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
; ConsId = type_ctor_info_const(_, _, _)
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
@@ -180,10 +181,10 @@
subst_literals_in_goal(Info, Goal0, Goal),
Case = case(MainConsId, OtherConsIds, Goal).
-:- pred make_implementation_defined_literal(prog_var::in, string::in,
+:- pred make_impl_defined_literal(prog_var::in, string::in,
term.context::in, subst_literals_info::in, hlds_goal::out) is det.
-make_implementation_defined_literal(Var, Name, Context, Info, Goal) :-
+make_impl_defined_literal(Var, Name, Context, Info, Goal) :-
Context = term.context(File, Line),
Info = subst_literals_info(ModuleInfo, PredInfo, PredId),
( Name = "file" ->
@@ -204,7 +205,7 @@
;
% These should have been caught during type checking.
unexpected(this_file,
- "make_implementation_defined_literal: unknown literal")
+ "make_impl_defined_literal: unknown literal")
).
%-----------------------------------------------------------------------------%
Index: compiler/inst_check.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_check.m,v
retrieving revision 1.11
diff -u -r1.11 inst_check.m
--- compiler/inst_check.m 8 Aug 2008 05:02:21 -0000 1.11
+++ compiler/inst_check.m 5 Feb 2009 04:17:43 -0000
@@ -127,10 +127,12 @@
:- type functors_to_types == multi_map(sym_name_and_arity, hlds_type_defn).
:- type bound_inst_functor
- ---> name_and_arity(sym_name, arity)
- ; string_constant
- ; int_constant
- ; float_constant.
+ ---> bif_name_and_arity(sym_name, arity)
+ ; bif_tuple(arity)
+ ; bif_int_constant
+ ; bif_float_constant
+ ; bif_char_constant
+ ; bif_string_constant.
:- type type_defn_or_builtin
---> type_def(hlds_type_defn)
@@ -229,32 +231,30 @@
find_types_for_functor(FunctorsToTypes, Functor, Types) :-
(
- Functor = name_and_arity(Name, Arity),
- ( multi_map.search(FunctorsToTypes, strip_qualifiers(Name) / Arity,
- TypeDefs) ->
+ Functor = bif_name_and_arity(Name, Arity),
+ (
+ multi_map.search(FunctorsToTypes, strip_qualifiers(Name) / Arity,
+ TypeDefs)
+ ->
TypesExceptChar = list.map(func(TypeDef) = type_def(TypeDef),
TypeDefs)
;
TypesExceptChar = []
),
(
- %
- % Zero arity functors with length 1 could match the
- % character builtin type.
- %
+ % Zero arity functors with length 1 could match the builtin
+ % character type.
Name = unqualified(NameStr),
string.length(NameStr) = 1
->
- TypesExceptTuple = [type_builtin(builtin_type_character)
+ TypesExceptTuple = [type_builtin(builtin_type_char)
| TypesExceptChar]
;
TypesExceptTuple = TypesExceptChar
),
(
- %
% The inst could match a tuple type, which won't be explicitly
% declared.
- %
type_ctor_is_tuple(type_ctor(Name, Arity))
->
Types = [type_tuple(Arity) | TypesExceptTuple]
@@ -262,13 +262,19 @@
Types = TypesExceptTuple
)
;
- Functor = int_constant,
+ Functor = bif_tuple(Arity),
+ Types = [type_tuple(Arity)]
+ ;
+ Functor = bif_int_constant,
Types = [type_builtin(builtin_type_int)]
;
- Functor = float_constant,
+ Functor = bif_float_constant,
Types = [type_builtin(builtin_type_float)]
;
- Functor = string_constant,
+ Functor = bif_char_constant,
+ Types = [type_builtin(builtin_type_char)]
+ ;
+ Functor = bif_string_constant,
Types = [type_builtin(builtin_type_string)]
).
@@ -288,20 +294,26 @@
get_functor_if_must_check_for_type(ConsId, MaybeFunctor) :-
(
- ConsId = cons(Name, Arity),
- MaybeFunctor = yes(name_and_arity(Name, Arity))
+ ConsId = cons(Name, Arity, _),
+ MaybeFunctor = yes(bif_name_and_arity(Name, Arity))
;
- ConsId = int_const(_),
- MaybeFunctor = yes(int_constant)
+ ConsId = tuple_cons(Arity),
+ MaybeFunctor = yes(bif_tuple(Arity))
;
- ConsId = string_const(_),
- MaybeFunctor = yes(string_constant)
+ ConsId = int_const(_),
+ MaybeFunctor = yes(bif_int_constant)
;
ConsId = float_const(_),
- MaybeFunctor = yes(float_constant)
+ MaybeFunctor = yes(bif_float_constant)
+ ;
+ ConsId = char_const(_),
+ MaybeFunctor = yes(bif_char_constant)
+ ;
+ ConsId = string_const(_),
+ MaybeFunctor = yes(bif_string_constant)
;
- ( ConsId = implementation_defined_const(_)
- ; ConsId = pred_const(_, _)
+ ( ConsId = closure_cons(_, _)
+ ; ConsId = impl_defined_const(_)
; ConsId = type_ctor_info_const(_, _, _)
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
Index: compiler/inst_graph.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_graph.m,v
retrieving revision 1.17
diff -u -r1.17 inst_graph.m
--- compiler/inst_graph.m 23 Nov 2007 07:35:07 -0000 1.17
+++ compiler/inst_graph.m 7 Feb 2009 10:04:05 -0000
@@ -424,7 +424,7 @@
dump_functor(VarSet, ConsId, Args, !IO) :-
io.write_string("%%\t", !IO),
- hlds_out.write_cons_id(ConsId, !IO),
+ write_cons_id_and_arity(ConsId, !IO),
(
Args = [_ | _],
io.write_char('(', !IO),
Index: compiler/inst_match.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_match.m,v
retrieving revision 1.86
diff -u -r1.86 inst_match.m
--- compiler/inst_match.m 28 Jan 2009 06:57:46 -0000 1.86
+++ compiler/inst_match.m 6 Feb 2009 15:58:46 -0000
@@ -81,7 +81,7 @@
% (inst_var_sub). For each inst_var which occurs in InstA there will be
% a substitution to the corresponding inst in InstB.
%
-:- pred inst_matches_initial(mer_inst::in, mer_inst::in, mer_type::in,
+:- pred inst_matches_initial_sub(mer_inst::in, mer_inst::in, mer_type::in,
module_info::in, module_info::out, inst_var_sub::in, inst_var_sub::out)
is semidet.
@@ -94,7 +94,7 @@
% A version of the above that also computes the inst_var_sub.
%
-:- pred inst_matches_initial_no_implied_modes(mer_inst::in, mer_inst::in,
+:- pred inst_matches_initial_no_implied_modes_sub(mer_inst::in, mer_inst::in,
mer_type::in, module_info::in, module_info::out,
inst_var_sub::in, inst_var_sub::out) is semidet.
@@ -115,7 +115,7 @@
% bound(...), ...). This version is to be preferred when the type is
% available.
%
-:- pred inst_matches_final(mer_inst::in, mer_inst::in, mer_type::in,
+:- pred inst_matches_final_typed(mer_inst::in, mer_inst::in, mer_type::in,
module_info::in) is semidet.
% The difference between inst_matches_initial and inst_matches_final is
@@ -558,21 +558,22 @@
inst_matches_initial(InstA, InstB, Type, ModuleInfo) :-
inst_matches_initial_1(InstA, InstB, Type, ModuleInfo, _, no, _).
-inst_matches_initial(InstA, InstB, Type, !ModuleInfo, !Sub) :-
+inst_matches_initial_sub(InstA, InstB, Type, !ModuleInfo, !Sub) :-
inst_matches_initial_1(InstA, InstB, Type, !ModuleInfo,
yes(!.Sub), MaybeSub),
(
MaybeSub = yes(!:Sub)
;
MaybeSub = no,
- unexpected(this_file, "inst_matches_initial: missing inst_var_sub")
+ unexpected(this_file, "inst_matches_initial_sub: missing inst_var_sub")
).
inst_matches_initial_no_implied_modes(InstA, InstB, Type, ModuleInfo) :-
Info0 = init_inst_match_info(ModuleInfo, no, forward, match, yes),
inst_matches_final_2(InstA, InstB, yes(Type), Info0, _).
-inst_matches_initial_no_implied_modes(InstA, InstB, Type, !ModuleInfo, !Sub) :-
+inst_matches_initial_no_implied_modes_sub(InstA, InstB, Type,
+ !ModuleInfo, !Sub) :-
Info0 = init_inst_match_info(!.ModuleInfo, yes(!.Sub), forward,
match, yes),
inst_matches_final_2(InstA, InstB, yes(Type), Info0, Info),
@@ -758,30 +759,6 @@
Inst \= not_reached
).
- % Check that two cons_ids are the same, except that one may be less
- % module qualified than the other.
- %
-:- pred equivalent_cons_ids(cons_id::in, cons_id::in) is semidet.
-
-equivalent_cons_ids(ConsIdA, ConsIdB) :-
- (
- ConsIdA = cons(NameA, ArityA),
- ConsIdB = cons(NameB, ArityB)
- ->
- ArityA = ArityB,
- equivalent_sym_names(NameA, NameB)
- ;
- ConsIdA = ConsIdB
- ).
-
-:- pred equivalent_sym_names(sym_name::in, sym_name::in) is semidet.
-
-equivalent_sym_names(unqualified(S), unqualified(S)).
-equivalent_sym_names(qualified(_, S), unqualified(S)).
-equivalent_sym_names(unqualified(S), qualified(_, S)).
-equivalent_sym_names(qualified(QualA, S), qualified(QualB, S)) :-
- equivalent_sym_names(QualA, QualB).
-
% Check that the first cons_id is lexically greater than the
% second, after all module qualifiers have been removed.
%
@@ -790,8 +767,8 @@
greater_than_disregard_module_qual(ConsIdA, ConsIdB) :-
(
- ConsIdA = cons(QNameA, ArityA),
- ConsIdB = cons(QNameB, ArityB)
+ ConsIdA = cons(QNameA, ArityA, _),
+ ConsIdB = cons(QNameB, ArityB, _)
->
( QNameA = unqualified(NameA)
; QNameA = qualified(_, NameA)
@@ -994,7 +971,7 @@
Info0 = init_inst_match_info(ModuleInfo, no, none, match, yes),
inst_matches_final_2(InstA, InstB, no, Info0, _).
-inst_matches_final(InstA, InstB, Type, ModuleInfo) :-
+inst_matches_final_typed(InstA, InstB, Type, ModuleInfo) :-
Info0 = init_inst_match_info(ModuleInfo, no, none, match, yes),
inst_matches_final_2(InstA, InstB, yes(Type), Info0, _).
@@ -2040,8 +2017,9 @@
maybe_any_to_bound(yes(Type), ModuleInfo, Uniq, none, Inst) :-
\+ type_util.is_solver_type(ModuleInfo, Type),
( type_constructors(ModuleInfo, Type, Constructors) ->
- constructors_to_bound_any_insts(ModuleInfo, Uniq, Constructors,
- BoundInsts0),
+ type_to_ctor_det(Type, TypeCtor),
+ constructors_to_bound_any_insts(ModuleInfo, Uniq, TypeCtor,
+ Constructors, BoundInsts0),
list.sort_and_remove_dups(BoundInsts0, BoundInsts),
Inst = bound(Uniq, BoundInsts)
; type_may_contain_solver_type(ModuleInfo, Type) ->
Index: compiler/inst_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_util.m,v
retrieving revision 1.58
diff -u -r1.58 inst_util.m
--- compiler/inst_util.m 28 Jan 2009 06:57:46 -0000 1.58
+++ compiler/inst_util.m 5 Feb 2009 08:27:28 -0000
@@ -68,10 +68,10 @@
% Compute the inst that results from abstractly unifying
% a variable with a functor.
%
-:- pred abstractly_unify_inst_functor(is_live::in, mer_inst::in, cons_id::in,
- list(mer_inst)::in, list(is_live)::in, unify_is_real::in, mer_type::in,
- mer_inst::out, determinism::out, module_info::in, module_info::out)
- is semidet.
+:- pred abstractly_unify_inst_functor(is_live::in, mer_inst::in,
+ cons_id::in, list(mer_inst)::in, list(is_live)::in, unify_is_real::in,
+ mer_type::in, mer_inst::out, determinism::out,
+ module_info::in, module_info::out) is semidet.
%-----------------------------------------------------------------------------%
@@ -157,6 +157,7 @@
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_mode.
+:- import_module parse_tree.prog_type.
:- import_module int.
:- import_module list.
@@ -576,10 +577,10 @@
ArgLives, Real, Type, Inst, Det, !ModuleInfo)
).
-:- pred abstractly_unify_inst_functor_2(is_live::in, mer_inst::in, cons_id::in,
- list(mer_inst)::in, list(is_live)::in, unify_is_real::in, mer_type::in,
- mer_inst::out, determinism::out, module_info::in, module_info::out)
- is semidet.
+:- pred abstractly_unify_inst_functor_2(is_live::in, mer_inst::in,
+ cons_id::in, list(mer_inst)::in, list(is_live)::in, unify_is_real::in,
+ mer_type::in, mer_inst::out, determinism::out,
+ module_info::in, module_info::out) is semidet.
abstractly_unify_inst_functor_2(is_live, not_reached, _, _, _, _, _,
not_reached, detism_erroneous, !ModuleInfo).
@@ -686,7 +687,7 @@
(
Xs = [bound_functor(ConsIdX, _)],
Ys = [bound_functor(ConsIdY, _)],
- cons_ids_match(ConsIdX, ConsIdY)
+ equivalent_cons_ids(ConsIdX, ConsIdY)
->
Det = Det0
;
@@ -710,7 +711,7 @@
!ModuleInfo) :-
X = bound_functor(ConsIdX, ArgsX),
Y = bound_functor(ConsIdY, ArgsY),
- ( cons_ids_match(ConsIdX, ConsIdY) ->
+ ( equivalent_cons_ids(ConsIdX, ConsIdY) ->
abstractly_unify_inst_list(ArgsX, ArgsY, Live, Real,
Args, Det1, !ModuleInfo),
abstractly_unify_bound_inst_list_2(Live, Xs, Ys, Real,
@@ -745,7 +746,7 @@
abstractly_unify_bound_inst_list_lives([X | Xs], ConsIdY, ArgsY, LivesY, Real,
L, Det, !ModuleInfo) :-
X = bound_functor(ConsIdX, ArgsX),
- ( cons_ids_match(ConsIdX, ConsIdY) ->
+ ( equivalent_cons_ids(ConsIdX, ConsIdY) ->
abstractly_unify_inst_list_lives(ArgsX, ArgsY, LivesY, Real,
Args, Det, !ModuleInfo),
L = [bound_functor(ConsIdX, Args)]
@@ -1693,8 +1694,9 @@
(
MaybeType = yes(Type),
type_constructors(!.ModuleInfo, Type, Constructors),
- constructors_to_bound_insts(!.ModuleInfo, UniqB, Constructors,
- ListB0),
+ type_to_ctor_det(Type, TypeCtor),
+ constructors_to_bound_insts(!.ModuleInfo, UniqB, TypeCtor,
+ Constructors, ListB0),
list.sort_and_remove_dups(ListB0, ListB),
inst_merge_4(bound(UniqA, ListA), bound(UniqB, ListB),
MaybeType, Result, !ModuleInfo)
@@ -1738,7 +1740,7 @@
Ys = [Y | Ys1],
X = bound_functor(ConsIdX, ArgsX),
Y = bound_functor(ConsIdY, ArgsY),
- ( cons_ids_match(ConsIdX, ConsIdY) ->
+ ( equivalent_cons_ids(ConsIdX, ConsIdY) ->
maybe_get_cons_id_arg_types(!.ModuleInfo, MaybeType,
ConsIdX, list.length(ArgsX), MaybeTypes),
inst_list_merge(ArgsX, ArgsY, MaybeTypes, Args, !ModuleInfo),
@@ -1832,36 +1834,6 @@
%-----------------------------------------------------------------------------%
- % A non-module-qualified cons_id name matches a module-qualified
- % cons_id name.
- %
-:- pred cons_ids_match(cons_id::in, cons_id::in) is semidet.
-
-cons_ids_match(ConsIdA, ConsIdB) :-
- (
- ConsIdA = cons(SymNameA, ArityA),
- ConsIdB = cons(SymNameB, ArityB)
- ->
- ArityA = ArityB,
- (
- SymNameA = unqualified(Name),
- SymNameB = unqualified(Name)
- ;
- SymNameA = unqualified(Name),
- SymNameB = qualified(_, Name)
- ;
- SymNameA = qualified(_, Name),
- SymNameB = unqualified(Name)
- ;
- SymNameA = qualified(Qualifier, Name),
- SymNameB = qualified(Qualifier, Name)
- )
- ;
- ConsIdA = ConsIdB
- ).
-
-%-----------------------------------------------------------------------------%
-
inst_may_restrict_cons_ids(ModuleInfo, Inst) = MayRestrict :-
(
Inst = any(_, _),
Index: compiler/instmap.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/instmap.m,v
retrieving revision 1.64
diff -u -r1.64 instmap.m
--- compiler/instmap.m 28 Jan 2009 06:57:46 -0000 1.64
+++ compiler/instmap.m 4 Jun 2009 07:18:40 -0000
@@ -486,7 +486,7 @@
instmap_lookup_var(InstMapB, VarB, FinalInst),
map.lookup(VarTypes, VarB, Type),
- ( inst_matches_final(InitialInst, FinalInst, Type, ModuleInfo) ->
+ ( inst_matches_final_typed(InitialInst, FinalInst, Type, ModuleInfo) ->
ChangedVars = ChangedVars0
;
set.insert(ChangedVars0, VarB, ChangedVars)
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.244
diff -u -r1.244 intermod.m
--- compiler/intermod.m 29 Apr 2009 03:38:12 -0000 1.244
+++ compiler/intermod.m 4 Jun 2009 06:27:07 -0000
@@ -133,6 +133,7 @@
:- import_module solutions.
:- import_module string.
:- import_module term.
+:- import_module term_io.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -770,7 +771,7 @@
RHS0 = rhs_functor(Functor, _Exist, _Vars),
RHS = RHS0,
% Is this a higher-order predicate or higher-order function term?
- ( Functor = pred_const(ShroudedPredProcId, _) ->
+ ( Functor = closure_cons(ShroudedPredProcId, _) ->
% Yes, the unification creates a higher-order term.
% Make sure that the predicate/function is exported.
@@ -978,8 +979,9 @@
),
module_info_get_cons_table(ModuleInfo, Ctors),
(
- map.search(Ctors, cons(InstanceMethodName0, MethodArity),
- MatchingConstructors)
+ ConsId = cons(InstanceMethodName0, MethodArity,
+ cons_id_dummy_type_ctor),
+ map.search(Ctors, ConsId, MatchingConstructors)
->
TypeCtors1 = list.map(
(func(ConsDefn) = TypeCtor :-
@@ -1443,7 +1445,7 @@
is det.
gather_foreign_enum_value_pair(ConsId, ConsTag, !Values) :-
- ( ConsId = cons(SymName0, 0) ->
+ ( ConsId = cons(SymName0, 0, _) ->
SymName = SymName0
;
unexpected(this_file, "expected enumeration constant")
@@ -1845,10 +1847,14 @@
ConsId = float_const(Float),
RHSTerm = term.functor(term.float(Float), [], Context)
;
+ ConsId = char_const(Char),
+ RHSTerm = term.functor(term.atom(term_io.escaped_char(Char)),
+ [], Context)
+ ;
ConsId = string_const(String),
RHSTerm = term.functor(term.string(String), [], Context)
;
- ConsId = cons(SymName, _),
+ ConsId = cons(SymName, _, _),
term.var_list_to_term_list(Args, ArgTerms),
construct_qualified_term(SymName, ArgTerms, RHSTerm)
)
Index: compiler/interval.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/interval.m,v
retrieving revision 1.40
diff -u -r1.40 interval.m
--- compiler/interval.m 19 Feb 2009 03:49:17 -0000 1.40
+++ compiler/interval.m 20 Feb 2009 07:47:59 -0000
@@ -135,8 +135,9 @@
; doesnt_need_flush.
:- typeclass build_interval_info_acc(T) where [
- pred use_cell(prog_var::in, list(prog_var)::in, cons_id::in, hlds_goal::in,
- interval_info::in, interval_info::out, T::in, T::out) is det
+ pred use_cell(prog_var::in, list(prog_var)::in, cons_id::in,
+ hlds_goal::in, interval_info::in, interval_info::out, T::in, T::out)
+ is det
].
:- pred build_interval_info_in_goal(hlds_goal::in, interval_info::in,
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.139
diff -u -r1.139 lambda.m
--- compiler/lambda.m 10 Mar 2009 05:00:29 -0000 1.139
+++ compiler/lambda.m 12 Mar 2009 01:25:47 -0000
@@ -377,8 +377,8 @@
% We need all the typeinfos, including the ones that are not used,
% for the layout structure describing the closure.
- NewTypeInfos = ExtraTypeInfos `set.difference` NonLocals1,
- NonLocals = NonLocals1 `set.union` NewTypeInfos,
+ set.difference(ExtraTypeInfos, NonLocals1, NewTypeInfos),
+ set.union(NonLocals1, NewTypeInfos, NonLocals),
% If we added variables to the nonlocals of the lambda goal, then
% we need to recompute the nonlocals for the procedure that contains it.
@@ -560,7 +560,7 @@
ModuleInfo1, ModuleInfo)
),
ShroudedPredProcId = shroud_pred_proc_id(proc(PredId, ProcId)),
- ConsId = pred_const(ShroudedPredProcId, EvalMethod),
+ ConsId = closure_cons(ShroudedPredProcId, EvalMethod),
Functor = rhs_functor(ConsId, no, ArgVars),
Unification = construct(Var, ConsId, ArgVars, UniModes,
Index: compiler/lco.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/lco.m,v
retrieving revision 1.56
diff -u -r1.56 lco.m
--- compiler/lco.m 23 Dec 2008 01:37:35 -0000 1.56
+++ compiler/lco.m 5 Feb 2009 08:37:38 -0000
@@ -485,8 +485,7 @@
SubInfo = construct_sub_info(no, _)
),
all_true(acceptable_construct_mode(ModuleInfo), ArgUniModes),
- map.lookup(VarTypes, ConstructedVar, ConstructedType),
- ConsTag = cons_id_to_tag(ModuleInfo, ConstructedType, ConsId),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
% The code generator can't handle the other tags. For example, it
% doesn't make sense to take the address of the field of a function
% symbol of a `notag' type.
Index: compiler/make_tags.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_tags.m,v
retrieving revision 1.59
diff -u -r1.59 make_tags.m
--- compiler/make_tags.m 11 Feb 2008 21:25:58 -0000 1.59
+++ compiler/make_tags.m 6 Feb 2009 16:13:49 -0000
@@ -5,10 +5,10 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: make_tags.m.
% Main author: fjh.
-%
+%
% This module is where we determine the representation for
% discriminated union types. Each d.u. type is represented as
% a word. In the case of functors with arguments, we allocate
@@ -53,7 +53,7 @@
% unbound variables). This is used by HAL, for Herbrand constraints
% (i.e. Prolog-style logic variables).
% This also disables enumerations and no_tag types.
-%
+%
%-----------------------------------------------------------------------------%
:- module hlds.make_tags.
@@ -99,8 +99,7 @@
%-----------------------------------------------------------------------------%
assign_constructor_tags(Ctors, UserEqCmp, TypeCtor, ReservedTagPragma, Globals,
- CtorTags, ReservedAddr, DuTypeKind) :-
-
+ !:CtorTags, ReservedAddr, DuTypeKind) :-
% Work out how many tag bits and reserved addresses we've got to play with.
globals.lookup_int_option(Globals, num_tag_bits, NumTagBits),
globals.lookup_int_option(Globals, num_reserved_addresses,
@@ -120,7 +119,7 @@
),
% Now assign them.
- map.init(CtorTags0),
+ map.init(!:CtorTags),
(
% Try representing the type as an enumeration: all the constructors
% must be constant, and we must be allowed to make unboxed enums.
@@ -133,7 +132,7 @@
;
DuTypeKind = du_type_kind_mercury_enum
),
- assign_enum_constants(Ctors, InitTag, CtorTags0, CtorTags),
+ assign_enum_constants(TypeCtor, Ctors, InitTag, !CtorTags),
ReservedAddr = does_not_use_reserved_address
;
(
@@ -142,9 +141,8 @@
Ctors, UserEqCmp, SingleFunctorName, SingleArgType,
MaybeSingleArgName)
->
- SingleConsId = make_cons_id_from_qualified_sym_name(
- SingleFunctorName, [SingleArgType]),
- map.set(CtorTags0, SingleConsId, no_tag, CtorTags),
+ SingleConsId = cons(SingleFunctorName, 1, TypeCtor),
+ svmap.det_insert(SingleConsId, no_tag, !CtorTags),
% XXX What if SingleArgType uses reserved addresses?
ReservedAddr = does_not_use_reserved_address,
DuTypeKind = du_type_kind_notag(SingleFunctorName, SingleArgType,
@@ -162,93 +160,97 @@
),
% Assign reserved addresses to the constants, if possible.
separate_out_constants(Ctors, Constants, Functors),
- assign_reserved_numeric_addresses(Constants,
- LeftOverConstants0, CtorTags0, CtorTags1,
- 0, NumReservedAddresses,
+ assign_reserved_numeric_addresses(TypeCtor, Constants,
+ LeftOverConstants0, !CtorTags, 0, NumReservedAddresses,
does_not_use_reserved_address, ReservedAddr1),
(
HighLevelCode = yes,
- assign_reserved_symbolic_addresses(
- LeftOverConstants0, LeftOverConstants, TypeCtor,
- CtorTags1, CtorTags2, 0, NumReservedObjects,
+ assign_reserved_symbolic_addresses(TypeCtor,
+ LeftOverConstants0, LeftOverConstants,
+ !CtorTags, 0, NumReservedObjects,
ReservedAddr1, ReservedAddr)
;
HighLevelCode = no,
% Reserved symbolic addresses are not supported for the
% LLDS back-end.
LeftOverConstants = LeftOverConstants0,
- CtorTags2 = CtorTags1,
ReservedAddr = ReservedAddr1
),
% Assign shared_with_reserved_address(...) representations
% for the remaining constructors.
RemainingCtors = LeftOverConstants ++ Functors,
- ReservedAddresses = list.filter_map(
- (func(reserved_address_tag(RA)) = RA is semidet),
- map.values(CtorTags2)),
- assign_unshared_tags(RemainingCtors, 0, 0, ReservedAddresses,
- CtorTags2, CtorTags)
+ GetRA = (func(reserved_address_tag(RA)) = RA is semidet),
+ ReservedAddresses = list.filter_map(GetRA,
+ map.values(!.CtorTags)),
+ assign_unshared_tags(TypeCtor, RemainingCtors, 0, 0,
+ ReservedAddresses, !CtorTags)
;
MaxTag = max_num_tags(NumTagBits) - 1,
separate_out_constants(Ctors, Constants, Functors),
- assign_constant_tags(Constants, CtorTags0, CtorTags1,
+ assign_constant_tags(TypeCtor, Constants, !CtorTags,
InitTag, NextTag),
- assign_unshared_tags(Functors, NextTag, MaxTag, [],
- CtorTags1, CtorTags),
+ assign_unshared_tags(TypeCtor, Functors, NextTag, MaxTag,
+ [], !CtorTags),
ReservedAddr = does_not_use_reserved_address
)
)
).
-:- pred assign_enum_constants(list(constructor)::in, int::in,
+:- pred assign_enum_constants(type_ctor::in, list(constructor)::in, int::in,
cons_tag_values::in, cons_tag_values::out) is det.
-assign_enum_constants([], _, !CtorTags).
-assign_enum_constants([Ctor | Rest], Val, !CtorTags) :-
+assign_enum_constants(_, [], _, !CtorTags).
+assign_enum_constants(TypeCtor, [Ctor | Ctors], Val, !CtorTags) :-
Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt),
- ConsId = make_cons_id_from_qualified_sym_name(Name, Args),
+ ConsId = cons(Name, list.length(Args), TypeCtor),
Tag = int_tag(Val),
+ % We call set instead of det_insert because we don't want types
+ % that erroneously contain more than one copy of a cons_id to crash
+ % the compiler.
svmap.set(ConsId, Tag, !CtorTags),
- assign_enum_constants(Rest, Val + 1, !CtorTags).
+ assign_enum_constants(TypeCtor, Ctors, Val + 1, !CtorTags).
% Assign the representations null_pointer, small_pointer(1),
% small_pointer(2), ..., small_pointer(N) to the constructors,
% until N >= NumReservedAddresses.
%
-:- pred assign_reserved_numeric_addresses(
+:- pred assign_reserved_numeric_addresses(type_ctor::in,
list(constructor)::in, list(constructor)::out,
cons_tag_values::in, cons_tag_values::out, int::in, int::in,
uses_reserved_address::in, uses_reserved_address::out) is det.
-assign_reserved_numeric_addresses([], [], !CtorTags, _, _, !ReservedAddr).
-assign_reserved_numeric_addresses([Ctor | Rest], LeftOverConstants,
+assign_reserved_numeric_addresses(_, [], [], !CtorTags, _, _, !ReservedAddr).
+assign_reserved_numeric_addresses(TypeCtor, [Ctor | Ctors], LeftOverConstants,
!CtorTags, Address, NumReservedAddresses, !ReservedAddr) :-
( Address >= NumReservedAddresses ->
- LeftOverConstants = [Ctor | Rest]
+ LeftOverConstants = [Ctor | Ctors]
;
Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt),
- ConsId = make_cons_id_from_qualified_sym_name(Name, Args),
+ ConsId = cons(Name, list.length(Args), TypeCtor),
( Address = 0 ->
Tag = reserved_address_tag(null_pointer)
;
Tag = reserved_address_tag(small_pointer(Address))
),
+ % We call set instead of det_insert because we don't want types
+ % that erroneously contain more than one copy of a cons_id to crash
+ % the compiler.
svmap.set(ConsId, Tag, !CtorTags),
!:ReservedAddr = uses_reserved_address,
- assign_reserved_numeric_addresses(Rest, LeftOverConstants,
+ assign_reserved_numeric_addresses(TypeCtor, Ctors, LeftOverConstants,
!CtorTags, Address + 1, NumReservedAddresses, !ReservedAddr)
).
% Assign reserved_object(CtorName, CtorArity) representations
% to the specified constructors.
%
-:- pred assign_reserved_symbolic_addresses(
- list(constructor)::in, list(constructor)::out, type_ctor::in,
+:- pred assign_reserved_symbolic_addresses(type_ctor::in,
+ list(constructor)::in, list(constructor)::out,
cons_tag_values::in, cons_tag_values::out, int::in, int::in,
uses_reserved_address::in, uses_reserved_address::out) is det.
-assign_reserved_symbolic_addresses([], [], _, !CtorTags, _, _, !ReservedAddr).
-assign_reserved_symbolic_addresses([Ctor | Ctors], LeftOverConstants, TypeCtor,
+assign_reserved_symbolic_addresses(_, [], [], !CtorTags, _, _, !ReservedAddr).
+assign_reserved_symbolic_addresses(TypeCtor, [Ctor | Ctors], LeftOverConstants,
!CtorTags, Num, Max, !ReservedAddr) :-
( Num >= Max ->
LeftOverConstants = [Ctor | Ctors]
@@ -256,15 +258,18 @@
Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt),
Arity = list.length(Args),
Tag = reserved_address_tag(reserved_object(TypeCtor, Name, Arity)),
- ConsId = make_cons_id_from_qualified_sym_name(Name, Args),
+ ConsId = cons(Name, list.length(Args), TypeCtor),
+ % We call set instead of det_insert because we don't want types
+ % that erroneously contain more than one copy of a cons_id to crash
+ % the compiler.
svmap.set(ConsId, Tag, !CtorTags),
!:ReservedAddr = uses_reserved_address,
- assign_reserved_symbolic_addresses(Ctors, LeftOverConstants,
- TypeCtor, !CtorTags, Num + 1, Max, !ReservedAddr)
+ assign_reserved_symbolic_addresses(TypeCtor, Ctors, LeftOverConstants,
+ !CtorTags, Num + 1, Max, !ReservedAddr)
).
-:- pred assign_constant_tags(list(constructor)::in, cons_tag_values::in,
- cons_tag_values::out, int::in, int::out) is det.
+:- pred assign_constant_tags(type_ctor::in, list(constructor)::in,
+ cons_tag_values::in, cons_tag_values::out, int::in, int::out) is det.
% If there's no constants, don't do anything. Otherwise, allocate the
% first tag for the constants, and give them all shared local tags
@@ -275,78 +280,90 @@
% shared_local_tag rather than a unshared_tag. That's because
% deconstruction of the shared_local_tag is more efficient.
%
-assign_constant_tags(Constants, !CtorTags, InitTag, NextTag) :-
+assign_constant_tags(TypeCtor, Constants, !CtorTags, InitTag, NextTag) :-
(
Constants = [],
NextTag = InitTag
;
Constants = [_ | _],
NextTag = InitTag + 1,
- assign_shared_local_tags(Constants, InitTag, 0, !CtorTags)
+ assign_shared_local_tags(TypeCtor, Constants, InitTag, 0, !CtorTags)
).
-:- pred assign_unshared_tags(list(constructor)::in, int::in, int::in,
- list(reserved_address)::in, cons_tag_values::in, cons_tag_values::out)
- is det.
+:- pred assign_unshared_tags(type_ctor::in, list(constructor)::in,
+ int::in, int::in, list(reserved_address)::in,
+ cons_tag_values::in, cons_tag_values::out) is det.
-assign_unshared_tags([], _, _, _, !CtorTags).
-assign_unshared_tags([Ctor | Rest], Val, MaxTag, ReservedAddresses,
+assign_unshared_tags(_, [], _, _, _, !CtorTags).
+assign_unshared_tags(TypeCtor, [Ctor | Ctors], Val, MaxTag, ReservedAddresses,
!CtorTags) :-
Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt),
- ConsId = make_cons_id_from_qualified_sym_name(Name, Args),
- % If there's only one functor,
- % give it the "single_functor" (untagged)
+ ConsId = cons(Name, list.length(Args), TypeCtor),
+ % If there's only one functor, give it the "single_functor" (untagged)
% representation, rather than giving it unshared_tag(0).
(
Val = 0,
- Rest = []
+ Ctors = []
->
Tag = maybe_add_reserved_addresses(ReservedAddresses,
single_functor_tag),
+ % We call set instead of det_insert because we don't want types
+ % that erroneously contain more than one copy of a cons_id to crash
+ % the compiler.
svmap.set(ConsId, Tag, !CtorTags)
;
% If we're about to run out of unshared tags, start assigning
% shared remote tags instead.
Val = MaxTag,
- Rest = [_ | _]
+ Ctors = [_ | _]
->
- assign_shared_remote_tags([Ctor | Rest], MaxTag, 0, ReservedAddresses,
- !CtorTags)
+ assign_shared_remote_tags(TypeCtor, [Ctor | Ctors], MaxTag, 0,
+ ReservedAddresses, !CtorTags)
;
Tag = maybe_add_reserved_addresses(ReservedAddresses,
unshared_tag(Val)),
+ % We call set instead of det_insert because we don't want types
+ % that erroneously contain more than one copy of a cons_id to crash
+ % the compiler.
svmap.set(ConsId, Tag, !CtorTags),
- assign_unshared_tags(Rest, Val + 1, MaxTag, ReservedAddresses,
- !CtorTags)
+ assign_unshared_tags(TypeCtor, Ctors, Val + 1, MaxTag,
+ ReservedAddresses, !CtorTags)
).
-:- pred assign_shared_remote_tags(list(constructor)::in, int::in, int::in,
- list(reserved_address)::in, cons_tag_values::in, cons_tag_values::out)
- is det.
+:- pred assign_shared_remote_tags(type_ctor::in, list(constructor)::in,
+ int::in, int::in, list(reserved_address)::in,
+ cons_tag_values::in, cons_tag_values::out) is det.
-assign_shared_remote_tags([], _, _, _, !CtorTags).
-assign_shared_remote_tags([Ctor | Rest], PrimaryVal, SecondaryVal,
+assign_shared_remote_tags(_, [], _, _, _, !CtorTags).
+assign_shared_remote_tags(TypeCtor, [Ctor | Ctors], PrimaryVal, SecondaryVal,
ReservedAddresses, !CtorTags) :-
Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt),
- ConsId = make_cons_id_from_qualified_sym_name(Name, Args),
+ ConsId = cons(Name, list.length(Args), TypeCtor),
Tag = maybe_add_reserved_addresses(ReservedAddresses,
shared_remote_tag(PrimaryVal, SecondaryVal)),
+ % We call set instead of det_insert because we don't want types
+ % that erroneously contain more than one copy of a cons_id to crash
+ % the compiler.
svmap.set(ConsId, Tag, !CtorTags),
SecondaryVal1 = SecondaryVal + 1,
- assign_shared_remote_tags(Rest, PrimaryVal, SecondaryVal1,
+ assign_shared_remote_tags(TypeCtor, Ctors, PrimaryVal, SecondaryVal1,
ReservedAddresses, !CtorTags).
-:- pred assign_shared_local_tags(list(constructor)::in, int::in, int::in,
- cons_tag_values::in, cons_tag_values::out) is det.
+:- pred assign_shared_local_tags(type_ctor::in, list(constructor)::in,
+ int::in, int::in, cons_tag_values::in, cons_tag_values::out) is det.
-assign_shared_local_tags([], _, _, !CtorTags).
-assign_shared_local_tags([Ctor | Rest], PrimaryVal, SecondaryVal, !CtorTags) :-
+assign_shared_local_tags(_, [], _, _, !CtorTags).
+assign_shared_local_tags(TypeCtor, [Ctor | Ctors], PrimaryVal, SecondaryVal,
+ !CtorTags) :-
Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt),
- ConsId = make_cons_id_from_qualified_sym_name(Name, Args),
+ ConsId = cons(Name, list.length(Args), TypeCtor),
Tag = shared_local_tag(PrimaryVal, SecondaryVal),
+ % We call set instead of det_insert because we don't want types
+ % that erroneously contain more than one copy of a cons_id to crash
+ % the compiler.
svmap.set(ConsId, Tag, !CtorTags),
- SecondaryVal1 = SecondaryVal + 1,
- assign_shared_local_tags(Rest, PrimaryVal, SecondaryVal1, !CtorTags).
+ assign_shared_local_tags(TypeCtor, Ctors, PrimaryVal, SecondaryVal + 1,
+ !CtorTags).
:- func maybe_add_reserved_addresses(list(reserved_address), cons_tag) =
cons_tag.
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.491
diff -u -r1.491 mercury_compile.m
--- compiler/mercury_compile.m 5 May 2009 05:53:15 -0000 1.491
+++ compiler/mercury_compile.m 29 May 2009 04:53:42 -0000
@@ -3828,7 +3828,7 @@
maybe_write_string(Verbose,
"% Substituting implementation-defined literals...\n", !IO),
maybe_flush_output(Verbose, !IO),
- subst_implementation_defined_literals(!HLDS, !IO),
+ subst_impl_defined_literals(!HLDS, !IO),
maybe_write_string(Verbose, "% done.\n", !IO),
maybe_report_stats(Stats, !IO).
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.335
diff -u -r1.335 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 16 Apr 2009 02:09:08 -0000 1.335
+++ compiler/mercury_to_mercury.m 29 May 2009 04:53:42 -0000
@@ -494,7 +494,7 @@
mercury_output_item_2(UnqualifiedItemNames, Item, !IO) :-
(
Item = item_module_defn(ItemModuleDefn),
- mercury_output_item_module_defn(UnqualifiedItemNames, ItemModuleDefn,
+ mercury_output_item_module_defn(UnqualifiedItemNames, ItemModuleDefn,
!IO)
;
Item = item_clause(ItemClause),
@@ -528,7 +528,7 @@
mercury_output_item_instance(UnqualifiedItemNames, ItemInstance, !IO)
;
Item = item_initialise(ItemInitialise),
- mercury_output_item_initialise(UnqualifiedItemNames, ItemInitialise,
+ mercury_output_item_initialise(UnqualifiedItemNames, ItemInitialise,
!IO)
;
Item = item_finalise(ItemFinalise),
@@ -692,10 +692,10 @@
ExportName),
mercury_format_pragma_foreign_export(Lang, Pred, PredOrFunc, ModeList,
ExportName, !IO)
- ;
+ ;
Pragma = pragma_foreign_export_enum(Lang, TypeName, TypeArity,
Attributes, Overrides),
- mercury_format_pragma_foreign_export_enum(Lang, TypeName, TypeArity,
+ mercury_format_pragma_foreign_export_enum(Lang, TypeName, TypeArity,
Attributes, Overrides, !IO)
;
Pragma = pragma_foreign_enum(Lang, TypeName, TypeArity, Values),
@@ -971,7 +971,7 @@
:- pred mercury_output_item_initialise(bool::in, item_initialise_info::in,
io::di, io::uo) is det.
-mercury_output_item_initialise(_, ItemInitialise, !IO) :-
+mercury_output_item_initialise(_, ItemInitialise, !IO) :-
ItemInitialise = item_initialise_info(_, PredSymName, Arity, _Context,
_SeqNum),
io.write_string(":- initialise ", !IO),
@@ -1717,8 +1717,8 @@
U::di, U::uo) is det <= (output(U), inst_info(InstInfo)).
mercury_format_bound_insts([], _, !U).
-mercury_format_bound_insts([bound_functor(ConsId, Args) | BoundInsts],
- InstInfo, !U) :-
+mercury_format_bound_insts([BoundInst | BoundInsts], InstInfo, !U) :-
+ BoundInst = bound_functor(ConsId, Args),
(
Args = [],
mercury_format_cons_id(ConsId, needs_brackets, !U)
@@ -1743,68 +1743,88 @@
mercury_cons_id_to_string(ConsId, NeedsBrackets) = String :-
mercury_format_cons_id(ConsId, NeedsBrackets, "", String).
-:- pred mercury_format_cons_id(cons_id::in, needs_brackets::in,
- U::di, U::uo) is det <= output(U).
+:- pred mercury_format_cons_id(cons_id::in, needs_brackets::in, U::di, U::uo)
+ is det <= output(U).
-mercury_format_cons_id(cons(Name, _), NeedsBrackets, !U) :-
+mercury_format_cons_id(ConsId, NeedsBrackets, !U) :-
(
- NeedsBrackets = needs_brackets,
- mercury_format_bracketed_sym_name(Name, !U)
+ ConsId = cons(Name, _, _),
+ (
+ NeedsBrackets = needs_brackets,
+ mercury_format_bracketed_sym_name(Name, !U)
+ ;
+ NeedsBrackets = does_not_need_brackets,
+ mercury_format_sym_name(Name, !U)
+ )
;
- NeedsBrackets = does_not_need_brackets,
- mercury_format_sym_name(Name, !U)
- ).
-mercury_format_cons_id(int_const(X), _, !U) :-
- add_int(X, !U).
-mercury_format_cons_id(float_const(X), _, !U) :-
- add_float(X, !U).
-mercury_format_cons_id(string_const(X), _, !U) :-
- add_quoted_string(X, !U).
-mercury_format_cons_id(implementation_defined_const(Name), _, !U) :-
- add_string("$", !U),
- add_string(Name, !U).
-mercury_format_cons_id(pred_const(ShroudedPredProcId, EvalMethod), _, !U) :-
- % XXX Sufficient, but probably should print this out in
- % name/arity form.
- ShroudedPredProcId = shrouded_pred_proc_id(PredInt, ProcInt),
- add_string("<pred_const(", !U),
- add_int(PredInt, !U),
- add_string(", ", !U),
- add_int(ProcInt, !U),
- add_string(", ", !U),
- add_lambda_eval_method(EvalMethod, !U),
- add_string(")>", !U).
-mercury_format_cons_id(type_ctor_info_const(Module, Type, Arity), _, !U) :-
- ModuleString = sym_name_to_string(Module),
- string.int_to_string(Arity, ArityString),
- add_strings(["<type_ctor_info for ",
- ModuleString, ".", Type, "/", ArityString, ">"], !U).
-mercury_format_cons_id(base_typeclass_info_const(Module, Class, InstanceNum,
- InstanceString), _, !U) :-
- ModuleString = sym_name_to_string(Module),
- add_string("<base_typeclass_info for ", !U),
- add_class_id(Class, !U),
- ( ModuleString \= "some bogus module name" ->
- add_strings([" from module ", ModuleString], !U)
+ ConsId = tuple_cons(_),
+ add_string("{}", !U)
;
- true
- ),
- add_format(", instance number %d (%s)>",
- [i(InstanceNum), s(InstanceString)], !U).
-mercury_format_cons_id(type_info_cell_constructor(_), _, !U) :-
- add_string("<type_info_cell_constructor>", !U).
-mercury_format_cons_id(typeclass_info_cell_constructor, _, !U) :-
- add_string("<typeclass_info_cell_constructor>", !U).
-mercury_format_cons_id(tabling_info_const(_), _, !U) :-
- add_string("<tabling info>", !U).
-mercury_format_cons_id(deep_profiling_proc_layout(_), _, !U) :-
- add_string("<deep_profiling_proc_layout>", !U).
-mercury_format_cons_id(table_io_decl(_), _, !U) :-
- add_string("<table_io_decl>", !U).
+ ConsId = int_const(Int),
+ add_int(Int, !U)
+ ;
+ ConsId = float_const(Float),
+ add_float(Float, !U)
+ ;
+ ConsId = char_const(Char),
+ add_string(term_io.quoted_char(Char), !U)
+ ;
+ ConsId = string_const(Str),
+ add_quoted_string(Str, !U)
+ ;
+ ConsId = impl_defined_const(Name),
+ add_string("$", !U),
+ add_string(Name, !U)
+ ;
+ ConsId = closure_cons(ShroudedPredProcId, _EvalMethod),
+ % XXX Should probably print this out in name/arity form.
+ ShroudedPredProcId = shrouded_pred_proc_id(PredInt, ProcInt),
+ add_string("<closure_cons(", !U),
+ add_int(PredInt, !U),
+ add_string(", ", !U),
+ add_int(ProcInt, !U),
+ % add_string(", ", !U),
+ % add_lambda_eval_method(EvalMethod, !U),
+ add_string(")>", !U)
+ ;
+ ConsId = type_ctor_info_const(Module, Type, Arity),
+ ModuleString = sym_name_to_string(Module),
+ string.int_to_string(Arity, ArityString),
+ add_strings(["<type_ctor_info for ",
+ ModuleString, ".", Type, "/", ArityString, ">"], !U)
+ ;
+ ConsId = base_typeclass_info_const(Module, Class, InstanceNum,
+ InstanceString),
+ ModuleString = sym_name_to_string(Module),
+ add_string("<base_typeclass_info for ", !U),
+ add_class_id(Class, !U),
+ ( ModuleString \= "some bogus module name" ->
+ add_strings([" from module ", ModuleString], !U)
+ ;
+ true
+ ),
+ add_format(", instance number %d (%s)>",
+ [i(InstanceNum), s(InstanceString)], !U)
+ ;
+ ConsId = type_info_cell_constructor(_),
+ add_string("<type_info_cell_constructor>", !U)
+ ;
+ ConsId = typeclass_info_cell_constructor,
+ add_string("<typeclass_info_cell_constructor>", !U)
+ ;
+ ConsId = tabling_info_const(_),
+ add_string("<tabling info>", !U)
+ ;
+ ConsId = table_io_decl(_),
+ add_string("<table_io_decl>", !U)
+ ;
+ ConsId = deep_profiling_proc_layout(_),
+ add_string("<deep_profiling_proc_layout>", !U)
+ ).
:- pred mercury_format_constrained_inst_vars(set(inst_var)::in, mer_inst::in,
- InstInfo::in, U::di, U::uo) is det
- <= (output(U), inst_info(InstInfo)).
+ InstInfo::in, U::di, U::uo) is det
+ <= (output(U), inst_info(InstInfo)).
mercury_format_constrained_inst_vars(Vars0, Inst, InstInfo, !U) :-
( set.remove_least(Vars0, Var, Vars1) ->
@@ -2937,7 +2957,7 @@
mercury_output_newline(Indent, !IO),
io.write_string(")", !IO).
-mercury_output_goal_2(atomic_expr(Outer, Inner, _, MainExpr,
+mercury_output_goal_2(atomic_expr(Outer, Inner, _, MainExpr,
OrElseExprs), VarSet, Indent, !IO) :-
io.write_string("atomic [outer(", !IO),
(
@@ -3858,7 +3878,7 @@
%-----------------------------------------------------------------------------%
:- pred mercury_format_pragma_import(sym_name::in, pred_or_func::in,
- list(mer_mode)::in, pragma_foreign_proc_attributes::in, prog_varset::in,
+ list(mer_mode)::in, pragma_foreign_proc_attributes::in, prog_varset::in,
string::in, U::di, U::uo) is det <= output(U).
mercury_format_pragma_import(Name, PredOrFunc, ModeList, Attributes,
@@ -3894,7 +3914,7 @@
mercury_format_pragma_foreign_export_enum(Lang, TypeName, TypeArity,
Attributes, Overrides, !U) :-
- add_string(":- pragma foreign_export_enum(", !U),
+ add_string(":- pragma foreign_export_enum(", !U),
mercury_format_foreign_language_string(Lang, !U),
add_string(", ", !U),
mercury_format_bracketed_sym_name(TypeName, next_to_graphic_token, !U),
@@ -3944,14 +3964,14 @@
add_quoted_string(String, !U).
%-----------------------------------------------------------------------------%
-
+
:- pred mercury_format_pragma_foreign_enum(foreign_language::in,
sym_name::in, arity::in, assoc_list(sym_name, string)::in,
U::di, U::uo) is det <= output(U).
mercury_format_pragma_foreign_enum(Lang, TypeName, TypeArity,
Values, !U) :-
- add_string(":- pragma foreign_enum(", !U),
+ add_string(":- pragma foreign_enum(", !U),
mercury_format_foreign_language_string(Lang, !U),
add_string(", ", !U),
mercury_format_bracketed_sym_name(TypeName, next_to_graphic_token, !U),
@@ -4723,14 +4743,12 @@
is det <= output(U).
mercury_format_quoted_atom(Name, NextToGraphicToken, !U) :-
- %
- % If the symname is composed of only graphic token chars,
- % then term_io.quote_atom will not quote it; but if
- % it is next another graphic token, it needs to be quoted,
- % otherwise the two would be considered part of one
- % symbol name (e.g. In "int:<", the ":<" parses as one token,
- % so when writing out the "<" after the ":" we need to quote it.
- %
+ % If the symname is composed of only graphic token chars, then
+ % term_io.quote_atom will not quote it; but if it is next another
+ % graphic token, it needs to be quoted, otherwise the two would be
+ % considered part of one symbol name (e.g. In "int:<", the ":<" parses
+ % as one token, so when writing out the "<" after the ":" we need
+ % to quote it.
(
NextToGraphicToken = next_to_graphic_token,
string.to_char_list(Name, Chars),
Index: compiler/middle_rec.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/middle_rec.m,v
retrieving revision 1.137
diff -u -r1.137 middle_rec.m
--- compiler/middle_rec.m 6 Jan 2009 03:56:26 -0000 1.137
+++ compiler/middle_rec.m 3 Feb 2009 03:07:44 -0000
@@ -32,6 +32,7 @@
:- import_module backend_libs.builtin_ops.
:- import_module hlds.code_model.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_llds.
:- import_module libs.compiler_util.
:- import_module ll_backend.code_gen.
@@ -235,8 +236,8 @@
%---------------------------------------------------------------------------%
-:- pred middle_rec_generate_switch(prog_var::in, cons_id::in, hlds_goal::in,
- hlds_goal::in, hlds_goal_info::in, llds_code::out,
+:- pred middle_rec_generate_switch(prog_var::in, cons_id::in,
+ hlds_goal::in, hlds_goal::in, hlds_goal_info::in, llds_code::out,
code_info::in, code_info::out) is semidet.
middle_rec_generate_switch(Var, BaseConsId, Base, Recursive, SwitchGoalInfo,
Index: compiler/ml_closure_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_closure_gen.m,v
retrieving revision 1.59
diff -u -r1.59 ml_closure_gen.m
--- compiler/ml_closure_gen.m 25 May 2009 02:34:35 -0000 1.59
+++ compiler/ml_closure_gen.m 30 May 2009 05:57:30 -0000
@@ -96,15 +96,14 @@
% XXX The following modules depend on the LLDS,
% so ideally they should not be used here.
:- import_module ll_backend.
-:- import_module ll_backend.continuation_info. % needed for
- % `generate_closure_layout'
-:- import_module ll_backend.llds. % needed for `layout_locn'
-:- import_module ll_backend.stack_layout. % needed for
- % `represent_locn_as_int'
+:- import_module ll_backend.continuation_info. % for `generate_closure_layout'
+:- import_module ll_backend.llds. % for `layout_locn'
+:- import_module ll_backend.stack_layout. % for `represent_locn_as_int'
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.ml_call_gen.
:- import_module ml_backend.ml_unify_gen.
:- import_module ml_backend.rtti_to_mlds.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_type.
:- import_module assoc_list.
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.214
diff -u -r1.214 ml_code_gen.m
--- compiler/ml_code_gen.m 16 Jan 2009 02:31:23 -0000 1.214
+++ compiler/ml_code_gen.m 30 May 2009 05:57:43 -0000
@@ -784,6 +784,7 @@
:- import_module ml_backend.ml_type_gen.
:- import_module ml_backend.ml_unify_gen.
:- import_module ml_backend.ml_util.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_type.
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.136
diff -u -r1.136 ml_code_util.m
--- compiler/ml_code_util.m 16 Jan 2009 02:31:23 -0000 1.136
+++ compiler/ml_code_util.m 30 May 2009 08:33:09 -0000
@@ -755,6 +755,7 @@
:- import_module mdbcomp.program_representation.
:- import_module ml_backend.ml_call_gen.
:- import_module ml_backend.ml_code_gen.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.38
diff -u -r1.38 ml_switch_gen.m
--- compiler/ml_switch_gen.m 16 Jan 2009 02:31:24 -0000 1.38
+++ compiler/ml_switch_gen.m 5 Feb 2009 08:39:19 -0000
@@ -343,8 +343,7 @@
Case = case(MainConsId, OtherConsIds, Goal),
expect(unify(OtherConsIds, []), this_file,
"ml_switch_lookup_tags: multi-cons-id switch arms NYI"),
- ml_variable_type(Info, Var, Type),
- ml_cons_id_to_tag(Info, MainConsId, Type, MainConsTag),
+ ml_cons_id_to_tag(Info, MainConsId, MainConsTag),
Cost = estimate_switch_tag_test_cost(MainConsTag),
TaggedMainConsId = tagged_cons_id(MainConsId, MainConsTag),
TaggedCase = tagged_case(TaggedMainConsId, [], Goal),
@@ -467,7 +466,7 @@
mlds_native_int_type))
;
( Tag = float_tag(_)
- ; Tag = pred_closure_tag(_, _, _)
+ ; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
; Tag = tabling_info_tag(_, _)
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.81
diff -u -r1.81 ml_type_gen.m
--- compiler/ml_type_gen.m 5 Jun 2009 04:17:09 -0000 1.81
+++ compiler/ml_type_gen.m 9 Jun 2009 03:36:20 -0000
@@ -76,12 +76,12 @@
%
:- func ml_gen_special_member_decl_flags = mlds_decl_flags.
- % ml_uses_secondary_tag(ConsTagValues, Ctor, SecondaryTag):
+ % ml_uses_secondary_tag(TypeCtor, ConsTagValues, Ctor, SecondaryTag):
% Check if this constructor uses a secondary tag,
% and if so, return the secondary tag value.
%
-:- pred ml_uses_secondary_tag(cons_tag_values::in, constructor::in, int::out)
- is semidet.
+:- pred ml_uses_secondary_tag(type_ctor::in, cons_tag_values::in,
+ constructor::in, int::out) is semidet.
% A constructor is represented using the base class rather than a derived
% class if there is only a single functor, or if there is a single
@@ -234,7 +234,8 @@
% Generate the class members.
ValueMember = ml_gen_enum_value_member(Context),
- EnumConstMembers = list.map(ml_gen_enum_constant(Context, TagValues),
+ EnumConstMembers = list.map(
+ ml_gen_enum_constant(Context, TypeCtor, TagValues),
Ctors),
Members = MaybeEqualityMembers ++
[ValueMember | EnumConstMembers],
@@ -262,14 +263,14 @@
ml_gen_member_decl_flags,
mlds_data(mlds_native_int_type, no_initializer, gc_no_stmt)).
-:- func ml_gen_enum_constant(prog_context, cons_tag_values, constructor)
- = mlds_defn.
+:- func ml_gen_enum_constant(prog_context, type_ctor, cons_tag_values,
+ constructor) = mlds_defn.
-ml_gen_enum_constant(Context, ConsTagValues, Ctor) = MLDS_Defn :-
+ml_gen_enum_constant(Context, TypeCtor, ConsTagValues, Ctor) = MLDS_Defn :-
% Figure out the value of this enumeration constant.
Ctor = ctor(_ExistQTVars, _Constraints, Name, Args, _Ctxt),
list.length(Args, Arity),
- map.lookup(ConsTagValues, cons(Name, Arity), TagVal),
+ map.lookup(ConsTagValues, cons(Name, Arity, TypeCtor), TagVal),
(
TagVal = int_tag(Int),
ConstValue = const(mlconst_int(Int))
@@ -280,7 +281,7 @@
;
( TagVal = string_tag(_)
; TagVal = float_tag(_)
- ; TagVal = pred_closure_tag(_, _, _)
+ ; TagVal = closure_tag(_, _, _)
; TagVal = type_ctor_info_tag(_, _, _)
; TagVal = base_typeclass_info_tag(_, _, _)
; TagVal = tabling_info_tag(_, _)
@@ -422,7 +423,7 @@
\+ (some [Ctor] (
list.member(Ctor, Ctors),
- ml_needs_secondary_tag(TagValues, Ctor)
+ ml_needs_secondary_tag(TypeCtor, TagValues, Ctor)
))
->
TagMembers = [],
@@ -434,18 +435,18 @@
% XXX we don't yet bother with these;
% mlds_to_c.m doesn't support static (one_copy) members.
% TagConstMembers = list.condense(list.map(
- % ml_gen_tag_constant(Context, TagValues), Ctors)),
+ % ml_gen_tag_constant(Context, TypeCtor, TagValues), Ctors)),
TagMembers0 = [TagDataMember | TagConstMembers],
% If all the constructors for this type need a secondary tag, then
% we put the secondary tag members directly in the base class,
% otherwise we put it in a separate nested derived class.
- %
+
(
all [Ctor] (
list.member(Ctor, Ctors)
=>
- ml_needs_secondary_tag(TagValues, Ctor)
+ ml_needs_secondary_tag(TypeCtor, TagValues, Ctor)
)
->
TagMembers = TagMembers0,
@@ -503,12 +504,12 @@
ml_gen_member_decl_flags,
mlds_data(mlds_native_int_type, no_initializer, gc_no_stmt)).
-:- func ml_gen_tag_constant(prog_context, cons_tag_values, constructor)
- = list(mlds_defn).
+:- func ml_gen_tag_constant(prog_context, type_ctor, cons_tag_values,
+ constructor) = list(mlds_defn).
-ml_gen_tag_constant(Context, ConsTagValues, Ctor) = MLDS_Defns :-
+ml_gen_tag_constant(Context, TypeCtor, ConsTagValues, Ctor) = MLDS_Defns :-
% Check if this constructor uses a secondary tag.
- ( ml_uses_secondary_tag(ConsTagValues, Ctor, SecondaryTag) ->
+ ( ml_uses_secondary_tag(TypeCtor, ConsTagValues, Ctor, SecondaryTag) ->
% Generate an MLDS definition for this secondary tag constant.
% We do this mainly for readability and interoperability. Note that
% we don't do the same thing for primary tags, so this is most useful
@@ -531,8 +532,8 @@
% and if so, return the secondary tag value.
% BEWARE that this is not the same as ml_needs_secondary_tag, below.
%
-ml_uses_secondary_tag(ConsTagValues, Ctor, SecondaryTag) :-
- TagVal = get_tagval(ConsTagValues, Ctor),
+ml_uses_secondary_tag(TypeCtor, ConsTagValues, Ctor, SecondaryTag) :-
+ TagVal = get_tagval(TypeCtor, ConsTagValues, Ctor),
get_secondary_tag(TagVal) = yes(SecondaryTag).
% Check if this constructor needs a secondary tag. This is true if its
@@ -543,25 +544,15 @@
% to ensure that its address is distinct from any other reserved objects
% for the same type.
%
-:- pred ml_needs_secondary_tag(cons_tag_values::in, constructor::in)
- is semidet.
+:- pred ml_needs_secondary_tag(type_ctor::in, cons_tag_values::in,
+ constructor::in) is semidet.
-ml_needs_secondary_tag(TagValues, Ctor) :-
- TagVal = get_tagval(TagValues, Ctor),
+ml_needs_secondary_tag(TypeCtor, TagValues, Ctor) :-
+ TagVal = get_tagval(TypeCtor, TagValues, Ctor),
( get_secondary_tag(TagVal) = yes(_)
; tagval_is_reserved_addr(TagVal, reserved_object(_, _, _))
).
- % Check if this constructor is a constant whose value is represented
- % as a reserved address.
- %
-:- pred ml_uses_reserved_addr(cons_tag_values::in, constructor::in,
- reserved_address::out) is semidet.
-
-ml_uses_reserved_addr(ConsTagValues, Ctor, RA) :-
- TagVal = get_tagval(ConsTagValues, Ctor),
- tagval_is_reserved_addr(TagVal, RA).
-
:- pred tagval_is_reserved_addr(cons_tag::in, reserved_address::out)
is semidet.
@@ -569,12 +560,12 @@
tagval_is_reserved_addr(shared_with_reserved_addresses_tag(_, TagVal), RA) :-
tagval_is_reserved_addr(TagVal, RA).
-:- func get_tagval(cons_tag_values, constructor) = cons_tag.
+:- func get_tagval(type_ctor, cons_tag_values, constructor) = cons_tag.
-get_tagval(ConsTagValues, Ctor) = TagVal :-
+get_tagval(TypeCtor, ConsTagValues, Ctor) = TagVal :-
Ctor = ctor(_ExistQTVars, _Constraints, Name, Args, _Ctxt),
list.length(Args, Arity),
- map.lookup(ConsTagValues, cons(Name, Arity), TagVal).
+ map.lookup(ConsTagValues, cons(Name, Arity, TypeCtor), TagVal).
% Generate a definition for the class used for the secondary tag type.
% This is needed for discriminated unions for which some but not all
@@ -646,7 +637,7 @@
UnqualCtorName = ml_gen_du_ctor_name(Target, TypeCtor,
CtorName, CtorArity),
- TagVal = get_tagval(ConsTagValues, Ctor),
+ TagVal = get_tagval(TypeCtor, ConsTagValues, Ctor),
( tagval_is_reserved_addr(TagVal, ReservedAddr) ->
( ReservedAddr = reserved_object(_, _, _) ->
% Generate a reserved object for this constructor.
@@ -1135,21 +1126,23 @@
TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest,
_IsEnumOrDummy, _MaybeUserEq, _ReservedTag, _ReservedAddr,
_IsForeignType),
- list.foldl(generate_foreign_enum_constant(Mapping, TagValues),
+ list.foldl(
+ generate_foreign_enum_constant(TypeCtor, Mapping, TagValues),
Ctors, [], ExportConstants),
MLDS_ExportedEnum = mlds_exported_enum(Lang, Context, TypeCtor,
ExportConstants)
).
-:- pred generate_foreign_enum_constant(map(sym_name, string)::in,
- cons_tag_values::in, constructor::in,
+:- pred generate_foreign_enum_constant(type_ctor::in,
+ map(sym_name, string)::in, cons_tag_values::in, constructor::in,
list(mlds_exported_enum_constant)::in,
list(mlds_exported_enum_constant)::out) is det.
-generate_foreign_enum_constant(Mapping, TagValues, Ctor, !ExportConstants) :-
+generate_foreign_enum_constant(TypeCtor, Mapping, TagValues, Ctor,
+ !ExportConstants) :-
Ctor = ctor(_, _, QualName, Args, _),
list.length(Args, Arity),
- map.lookup(TagValues, cons(QualName, Arity), TagVal),
+ map.lookup(TagValues, cons(QualName, Arity, TypeCtor), TagVal),
(
TagVal = int_tag(Int),
ConstValue = const(mlconst_int(Int))
@@ -1159,7 +1152,7 @@
;
( TagVal = string_tag(_)
; TagVal = float_tag(_)
- ; TagVal = pred_closure_tag(_, _, _)
+ ; TagVal = closure_tag(_, _, _)
; TagVal = type_ctor_info_tag(_, _, _)
; TagVal = base_typeclass_info_tag(_, _, _)
; TagVal = tabling_info_tag(_, _)
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.129
diff -u -r1.129 ml_unify_gen.m
--- compiler/ml_unify_gen.m 21 May 2009 05:57:02 -0000 1.129
+++ compiler/ml_unify_gen.m 3 Jun 2009 13:33:39 -0000
@@ -37,10 +37,9 @@
list(mlds_defn)::out, list(statement)::out,
ml_gen_info::in, ml_gen_info::out) is det.
- % Convert a cons_id for a given type to a cons_tag.
+ % Convert a cons_id to a cons_tag.
%
-:- pred ml_cons_id_to_tag(ml_gen_info::in, cons_id::in, mer_type::in,
- cons_tag::out) is det.
+:- pred ml_cons_id_to_tag(ml_gen_info::in, cons_id::in, cons_tag::out) is det.
% ml_gen_tag_test(Var, ConsId, Defns, Statements, Expression):
%
@@ -250,7 +249,7 @@
Context, Decls, Statements, !Info) :-
% Figure out how this cons_id is represented.
ml_variable_type(!.Info, Var, Type),
- ml_cons_id_to_tag(!.Info, ConsId, Type, Tag),
+ ml_cons_id_to_tag(!.Info, ConsId, Tag),
ml_gen_construct_2(Tag, Type, Var, ConsId, Args, ArgModes, TakeAddr,
HowToConstruct, Context, Decls, Statements, !Info).
@@ -288,7 +287,7 @@
)
;
% Lambda expressions.
- Tag = pred_closure_tag(PredId, ProcId, _EvalMethod),
+ Tag = closure_tag(PredId, ProcId, _EvalMethod),
ml_gen_closure(PredId, ProcId, Var, Args, ArgModes, HowToConstruct,
Context, Decls, Statements, !Info)
;
@@ -297,8 +296,7 @@
; Tag = unshared_tag(_TagVal)
; Tag = shared_remote_tag(_PrimaryTag, _SecondaryTag)
),
- type_to_ctor_and_args_det(Type, TypeCtor, _),
- ml_gen_compound(Tag, TypeCtor, ConsId, Var, Args, ArgModes, TakeAddr,
+ ml_gen_compound(Tag, ConsId, Var, Args, ArgModes, TakeAddr,
HowToConstruct, Context, Decls, Statements, !Info)
;
% Constants.
@@ -335,15 +333,15 @@
% Note that any changes here may require similar changes to
% ml_gen_construct.
%
-:- pred ml_gen_static_const_arg(prog_var::in, static_cons::in, prog_context::in,
- list(mlds_defn)::out, mlds_rval::out,
+:- pred ml_gen_static_const_arg(prog_var::in, static_cons::in,
+ prog_context::in, list(mlds_defn)::out, mlds_rval::out,
ml_gen_info::in, ml_gen_info::out) is det.
ml_gen_static_const_arg(Var, StaticCons, Context, Defns, Rval, !Info) :-
% Figure out how this argument is represented.
StaticCons = static_cons(ConsId, _ArgVars, _StaticArgs),
ml_variable_type(!.Info, Var, VarType),
- ml_cons_id_to_tag(!.Info, ConsId, VarType, Tag),
+ ml_cons_id_to_tag(!.Info, ConsId, Tag),
ml_gen_static_const_arg_2(Tag, VarType, Var, StaticCons, Context, Defns,
Rval, !Info).
@@ -384,7 +382,7 @@
)
;
% Compound terms, including lambda expressions.
- ( Tag = pred_closure_tag(_, _, _), TagVal = 0
+ ( Tag = closure_tag(_, _, _), TagVal = 0
; Tag = single_functor_tag, TagVal = 0
; Tag = unshared_tag(TagVal)
; Tag = shared_remote_tag(TagVal, _SecondaryTag)
@@ -508,8 +506,8 @@
unexpected(this_file, "ml_gen_constant: unshared_tag").
ml_gen_constant(shared_remote_tag(_, _), _, _, !Info) :-
unexpected(this_file, "ml_gen_constant: shared_remote_tag").
-ml_gen_constant(pred_closure_tag(_, _, _), _, _, !Info) :-
- unexpected(this_file, "ml_gen_constant: pred_closure_tag").
+ml_gen_constant(closure_tag(_, _, _), _, _, !Info) :-
+ unexpected(this_file, "ml_gen_constant: closure_tag").
%-----------------------------------------------------------------------------%
@@ -572,18 +570,18 @@
% Convert a cons_id for a given type to a cons_tag.
%
-ml_cons_id_to_tag(Info, ConsId, Type, Tag) :-
+ml_cons_id_to_tag(Info, ConsId, Tag) :-
ml_gen_info_get_module_info(Info, ModuleInfo),
- Tag = cons_id_to_tag(ModuleInfo, Type, ConsId).
+ Tag = cons_id_to_tag(ModuleInfo, ConsId).
% Generate code to construct a new object.
%
-:- pred ml_gen_compound(cons_tag::in, type_ctor::in, cons_id::in, prog_var::in,
+:- pred ml_gen_compound(cons_tag::in, cons_id::in, prog_var::in,
prog_vars::in, list(uni_mode)::in, list(int)::in, how_to_construct::in,
prog_context::in, list(mlds_defn)::out, list(statement)::out,
ml_gen_info::in, ml_gen_info::out) is det.
-ml_gen_compound(Tag, TypeCtor, ConsId, Var, ArgVars, ArgModes, TakeAddr,
+ml_gen_compound(Tag, ConsId, Var, ArgVars, ArgModes, TakeAddr,
HowToConstruct, Context, Decls, Statements, !Info) :-
% Get the primary and secondary tags.
( get_primary_tag(Tag) = yes(PrimaryTag0) ->
@@ -601,7 +599,7 @@
MaybeCtorName = no
;
globals.get_target(Globals, CompilationTarget),
- ml_cons_name(CompilationTarget, TypeCtor, ConsId, CtorName),
+ ml_cons_name(CompilationTarget, ConsId, CtorName),
MaybeCtorName = yes(CtorName)
),
@@ -784,17 +782,15 @@
MaybeConsId = no,
unexpected(this_file, "ml_gen_new_object: unknown cons id")
),
- ml_variable_type(!.Info, ReuseVar, ReuseType),
list.map(
(pred(ReuseConsId::in, ReusePrimTag::out) is det :-
- ml_cons_id_to_tag(!.Info, ReuseConsId,
- ReuseType, ReuseConsIdTag),
+ ml_cons_id_to_tag(!.Info, ReuseConsId, ReuseConsIdTag),
ml_tag_offset_and_argnum(ReuseConsIdTag, ReusePrimTag,
_ReuseOffSet, _ReuseArgNum)
), ReuseConsIds, ReusePrimaryTags0),
list.remove_dups(ReusePrimaryTags0, ReusePrimaryTags),
- ml_cons_id_to_tag(!.Info, ConsId, Type, ConsIdTag),
+ ml_cons_id_to_tag(!.Info, ConsId, ConsIdTag),
ml_field_names_and_types(!.Info, Type, ConsId, ArgTypes, Fields),
ml_tag_offset_and_argnum(ConsIdTag, PrimaryTag, OffSet, ArgNum),
@@ -889,8 +885,8 @@
% Return the MLDS type suitable for constructing a constant static
% ground term with the specified cons_id.
%
-:- func get_type_for_cons_id(mlds_type, bool, maybe(cons_id), bool, globals)
- = mlds_type.
+:- func get_type_for_cons_id(mlds_type, bool, maybe(cons_id), bool,
+ globals) = mlds_type.
get_type_for_cons_id(MLDS_Type, UsesBaseClass, MaybeConsId, HighLevelData,
Globals) = ConstType :-
@@ -914,7 +910,7 @@
% union type.
UsesBaseClass = no,
MaybeConsId = yes(ConsId),
- ConsId = cons(CtorSymName, CtorArity),
+ ConsId = cons(CtorSymName, CtorArity, _TypeCtor),
(
MLDS_Type = mlds_class_type(QualTypeName, TypeArity, _)
;
@@ -1006,8 +1002,9 @@
BoxedFieldType = FieldType
).
-:- pred get_maybe_cons_id_arg_types(maybe(cons_id)::in, list(mer_type)::in,
- mer_type::in, module_info::in, list(mer_type)::out) is det.
+:- pred get_maybe_cons_id_arg_types(maybe(cons_id)::in,
+ list(mer_type)::in, mer_type::in, module_info::in, list(mer_type)::out)
+ is det.
get_maybe_cons_id_arg_types(MaybeConsId, ArgTypes, Type, ModuleInfo,
ConsArgTypes) :-
@@ -1021,12 +1018,12 @@
ConsArgTypes = ml_make_boxed_types(list.length(ArgTypes))
).
-:- func constructor_arg_types(cons_id, list(mer_type), mer_type, module_info)
- = list(mer_type).
+:- func constructor_arg_types(cons_id, list(mer_type), mer_type,
+ module_info) = list(mer_type).
-constructor_arg_types(CtorId, ArgTypes, Type, ModuleInfo) = ConsArgTypes :-
+constructor_arg_types(ConsId, ArgTypes, Type, ModuleInfo) = ConsArgTypes :-
(
- CtorId = cons(_, _),
+ ConsId = cons(_, _, _),
\+ is_introduced_type_info_type(Type)
->
% Use the type to determine the type_ctor
@@ -1040,7 +1037,7 @@
% Given the type_ctor, lookup up the constructor.
(
- type_util.get_cons_defn(ModuleInfo, TypeCtor, CtorId, ConsDefn)
+ type_util.get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn)
->
ConsArgDefns = ConsDefn ^ cons_args,
ConsArgTypes0 = list.map(func(C) = C ^ arg_type, ConsArgDefns),
@@ -1068,9 +1065,9 @@
unexpected(this_file, "cons_id_to_arg_types: get_cons_defn failed")
)
;
- % For cases when CtorId \= cons(_, _) and it is not a tuple, as can
- % happen e.g. for closures and type_infos, we assume that the arguments
- % all have the right type already.
+ % For cases when ConsId \= hlds_cons(_, _) and it is not a tuple,
+ % as can happen e.g. for closures and type_infos, we assume that
+ % the arguments all have the right type already.
% XXX is this the right thing to do?
ArgTypes = ConsArgTypes
).
@@ -1241,12 +1238,12 @@
ml_gen_var_lval(Info, ConstName, Type, ConstLval),
ConstAddrRval = mem_addr(ConstLval).
-:- pred ml_cons_name(compilation_target::in, type_ctor::in,
- cons_id::in, ctor_name::out) is det.
+:- pred ml_cons_name(compilation_target::in, cons_id::in, ctor_name::out)
+ is det.
-ml_cons_name(CompilationTarget, TypeCtor, HLDS_ConsId, QualifiedConsId) :-
+ml_cons_name(CompilationTarget, HLDS_ConsId, QualifiedConsId) :-
(
- HLDS_ConsId = cons(ConsSymName, ConsArity),
+ HLDS_ConsId = cons(ConsSymName, ConsArity, TypeCtor),
ConsSymName = qualified(SymModuleName, _)
->
ConsName = ml_gen_du_ctor_name(CompilationTarget, TypeCtor,
@@ -1254,7 +1251,7 @@
ConsId = ctor_id(ConsName, ConsArity),
ModuleName = mercury_module_name_to_mlds(SymModuleName)
;
- ConsName = hlds_out.cons_id_to_string(HLDS_ConsId),
+ ConsName = cons_id_and_arity_to_string(HLDS_ConsId),
ConsId = ctor_id(ConsName, 0),
ModuleName = mercury_module_name_to_mlds(unqualified(""))
),
@@ -1413,7 +1410,7 @@
!Info) :-
Decls = [],
ml_variable_type(!.Info, Var, Type),
- ml_cons_id_to_tag(!.Info, ConsId, Type, Tag),
+ ml_cons_id_to_tag(!.Info, ConsId, Tag),
ml_gen_det_deconstruct_2(Tag, Type, Var, ConsId, Args, Modes, Context,
Statements, !Info).
@@ -1430,7 +1427,7 @@
; Tag = int_tag(_Int)
; Tag = foreign_tag(_, _)
; Tag = float_tag(_Float)
- ; Tag = pred_closure_tag(_, _, _)
+ ; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
; Tag = tabling_info_tag(_, _)
@@ -1507,7 +1504,7 @@
; Tag = int_tag(_Int)
; Tag = foreign_tag(_, _)
; Tag = float_tag(_Float)
- ; Tag = pred_closure_tag(_, _, _)
+ ; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
; Tag = tabling_info_tag(_, _)
@@ -1527,8 +1524,8 @@
% polymorphic types, the types of the actual arguments can be an instance
% of the field types.
%
-:- pred ml_field_names_and_types(ml_gen_info::in, mer_type::in, cons_id::in,
- list(mer_type)::in, list(constructor_arg)::out) is det.
+:- pred ml_field_names_and_types(ml_gen_info::in, mer_type::in,
+ cons_id::in, list(mer_type)::in, list(constructor_arg)::out) is det.
ml_field_names_and_types(Info, Type, ConsId, ArgTypes, Fields) :-
% Lookup the field types for the arguments of this cons_id.
@@ -1575,10 +1572,10 @@
unexpected(this_file, "ml_gen_unify_args: length mismatch")
).
-:- pred ml_gen_unify_args_2(cons_id::in, prog_vars::in, list(uni_mode)::in,
- list(mer_type)::in, list(constructor_arg)::in, mer_type::in,
- mlds_lval::in, int::in, int::in, cons_tag::in, prog_context::in,
- list(statement)::in, list(statement)::out,
+:- pred ml_gen_unify_args_2(cons_id::in, prog_vars::in,
+ list(uni_mode)::in, list(mer_type)::in, list(constructor_arg)::in,
+ mer_type::in, mlds_lval::in, int::in, int::in, cons_tag::in,
+ prog_context::in, list(statement)::in, list(statement)::out,
ml_gen_info::in, ml_gen_info::out) is semidet.
ml_gen_unify_args_2(_, [], [], [], _, _, _, _, _, _, _, !Statements, !Info).
@@ -1645,9 +1642,9 @@
unexpected(this_file, "ml_gen_unify_args_for_reuse: length mismatch")
).
-:- pred ml_gen_unify_arg(cons_id::in, prog_var::in, uni_mode::in, mer_type::in,
- constructor_arg::in, mer_type::in, mlds_lval::in, int::in, int::in,
- cons_tag::in, prog_context::in,
+:- pred ml_gen_unify_arg(cons_id::in, prog_var::in, uni_mode::in,
+ mer_type::in, constructor_arg::in, mer_type::in, mlds_lval::in,
+ int::in, int::in, cons_tag::in, prog_context::in,
list(statement)::in, list(statement)::out,
ml_gen_info::in, ml_gen_info::out) is det.
@@ -1664,7 +1661,7 @@
HighLevelData = no,
FieldId = offset(const(mlconst_int(Offset)))
;
- % With the high-level data representation, we always used named fields,
+ % With the high-level data representation, we always use named fields,
% except for tuple types.
HighLevelData = yes,
globals.get_target(Globals, Target),
@@ -1676,15 +1673,14 @@
FieldId = offset(const(mlconst_int(Offset)))
;
FieldName = ml_gen_field_name(MaybeFieldName, ArgNum),
- ( ConsId = cons(ConsName, ConsArity) ->
+ ( ConsId = cons(ConsName, ConsArity, TypeCtor) ->
globals.get_target(Globals, CompilationTarget),
- type_to_ctor_and_args_det(VarType, TypeCtor, _),
UnqualConsName = ml_gen_du_ctor_name(CompilationTarget,
TypeCtor, ConsName, ConsArity),
FieldId = ml_gen_field_id(VarType, Tag, UnqualConsName,
ConsArity, FieldName, Globals)
;
- unexpected(this_file, "ml_gen_unify_args: invalid cons_id")
+ unexpected(this_file, "ml_gen_unify_arg: invalid cons_id")
)
)
),
@@ -1822,7 +1818,7 @@
TagTestExpression, !Info) :-
ml_gen_var(!.Info, Var, VarLval),
ml_variable_type(!.Info, Var, Type),
- ml_cons_id_to_tag(!.Info, ConsId, Type, Tag),
+ ml_cons_id_to_tag(!.Info, ConsId, Tag),
ml_gen_info_get_module_info(!.Info, ModuleInfo),
TagTestExpression = ml_gen_tag_test_rval(Tag, Type, ModuleInfo,
lval(VarLval)),
@@ -1853,7 +1849,7 @@
mlds_native_int_type)),
TagTestRval = binop(eq, Rval, Const)
;
- ( Tag = pred_closure_tag(_, _, _)
+ ( Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
; Tag = tabling_info_tag(_, _)
@@ -1972,15 +1968,15 @@
(
TypeDefnBody =
hlds_du_type(Ctors, TagValues, _, _, _, _ReservedTag, _, _),
- % XXX we probably shouldn't ignore ReservedTag here
+ % XXX We probably shouldn't ignore ReservedTag here.
(
some [Ctor] (
list.member(Ctor, Ctors),
- ml_uses_secondary_tag(TagValues, Ctor, _)
+ ml_uses_secondary_tag(TypeCtor, TagValues, Ctor, _)
),
some [Ctor] (
list.member(Ctor, Ctors),
- \+ ml_uses_secondary_tag(TagValues, Ctor, _)
+ \+ ml_uses_secondary_tag(TypeCtor, TagValues, Ctor, _)
)
->
ClassQualifier = mlds_append_class_qualifier(MLDS_Module,
Index: compiler/ml_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_util.m,v
retrieving revision 1.62
diff -u -r1.62 ml_util.m
--- compiler/ml_util.m 16 Jan 2009 02:31:24 -0000 1.62
+++ compiler/ml_util.m 3 Feb 2009 03:09:18 -0000
@@ -17,8 +17,8 @@
:- interface.
:- import_module libs.globals. % for foreign_language
-:- import_module hlds.hlds_module.
:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_module.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.234
diff -u -r1.234 mlds_to_c.m
--- compiler/mlds_to_c.m 27 May 2009 05:48:37 -0000 1.234
+++ compiler/mlds_to_c.m 29 May 2009 04:53:43 -0000
@@ -3685,7 +3685,7 @@
mlds_output_rval(Exprn, !IO),
io.write_string(")", !IO)
;
- ( Type = mercury_type(builtin_type(builtin_type_character), _, _)
+ ( Type = mercury_type(builtin_type(builtin_type_char), _, _)
; Type = mlds_native_char_type
; Type = mlds_native_bool_type
; Type = mlds_native_int_type
@@ -3730,7 +3730,7 @@
mlds_output_rval(Exprn, !IO),
io.write_string(")", !IO)
;
- ( Type = mercury_type(builtin_type(builtin_type_character), _, _)
+ ( Type = mercury_type(builtin_type(builtin_type_char), _, _)
; Type = mlds_native_char_type
; Type = mlds_native_bool_type
; Type = mlds_native_int_type
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.118
diff -u -r1.118 mlds_to_java.m
--- compiler/mlds_to_java.m 5 Jun 2009 04:17:09 -0000 1.118
+++ compiler/mlds_to_java.m 9 Jun 2009 03:36:20 -0000
@@ -98,6 +98,7 @@
:- import_module ml_backend.ml_code_util. % for ml_gen_local_var_decl_flags.
:- import_module ml_backend.ml_type_gen. % for ml_gen_type_name
:- import_module ml_backend.ml_util.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.file_names. % for mercury_std_library_name.
:- import_module parse_tree.java_names.
:- import_module parse_tree.prog_data.
@@ -136,8 +137,7 @@
% Utility predicates for various purposes.
%
- % Succeeds iff this definition is a data definition which
- % defines RTTI.
+ % Succeeds iff this definition is a data definition which defines RTTI.
%
:- pred defn_is_rtti_data(mlds_defn::in) is semidet.
@@ -3444,7 +3444,7 @@
java_builtin_type(Type, "char", "java.lang.Character", "charValue") :-
Type = mlds_native_char_type.
java_builtin_type(Type, "char", "java.lang.Character", "charValue") :-
- Type = mercury_type(builtin_type(builtin_type_character), _, _).
+ Type = mercury_type(builtin_type(builtin_type_char), _, _).
java_builtin_type(Type, "boolean", "java.lang.Boolean", "booleanValue") :-
Type = mlds_native_bool_type.
Index: compiler/mode_constraints.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_constraints.m,v
retrieving revision 1.50
diff -u -r1.50 mode_constraints.m
--- compiler/mode_constraints.m 4 Jun 2009 04:39:20 -0000 1.50
+++ compiler/mode_constraints.m 4 Jun 2009 05:30:37 -0000
@@ -1911,27 +1911,6 @@
cons_id_in_bound_insts(ConsId, BIs, Insts)
).
-:- pred equivalent_cons_ids(cons_id::in, cons_id::in) is semidet.
-
-equivalent_cons_ids(ConsIdA, ConsIdB) :-
- (
- ConsIdA = cons(NameA, ArityA),
- ConsIdB = cons(NameB, ArityB)
- ->
- ArityA = ArityB,
- equivalent_sym_names(NameA, NameB)
- ;
- ConsIdA = ConsIdB
- ).
-
-:- pred equivalent_sym_names(sym_name::in, sym_name::in) is semidet.
-
-equivalent_sym_names(unqualified(S), unqualified(S)).
-equivalent_sym_names(qualified(_, S), unqualified(S)).
-equivalent_sym_names(unqualified(S), qualified(_, S)).
-equivalent_sym_names(qualified(QualA, S), qualified(QualB, S)) :-
- equivalent_sym_names(QualA, QualB).
-
%------------------------------------------------------------------------%
% For local variables, V_ must be equivalent to Vgp.
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_errors.m,v
retrieving revision 1.127
diff -u -r1.127 mode_errors.m
--- compiler/mode_errors.m 16 Jul 2008 03:30:28 -0000 1.127
+++ compiler/mode_errors.m 7 Feb 2009 10:04:59 -0000
@@ -16,16 +16,16 @@
:- module check_hlds.mode_errors.
:- interface.
+:- import_module check_hlds.mode_info.
:- import_module hlds.
-:- import_module hlds.hlds_pred.
-:- import_module hlds.hlds_module.
:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
-:- import_module check_hlds.mode_info.
:- import_module bool.
:- import_module io.
@@ -115,8 +115,8 @@
; mode_error_unify_var_var(prog_var, prog_var, mer_inst, mer_inst)
% Attempt to unify two free variables.
- ; mode_error_unify_var_functor(prog_var, cons_id, list(prog_var),
- mer_inst, list(mer_inst))
+ ; mode_error_unify_var_functor(prog_var, cons_id,
+ list(prog_var), mer_inst, list(mer_inst))
% Attempt to unify a free var with a functor containing
% free arguments.
@@ -1030,19 +1030,17 @@
words("term"),
words(add_quotes(hlds_out.functor_cons_id_to_string(ConsId, Args,
VarSet, ModuleInfo, no)))],
+ ConsIdStr = mercury_cons_id_to_string(ConsId, does_not_need_brackets),
(
Args = [_ | _],
Pieces2 = [words("has instantiatedness"),
- prefix("`"),
- words(mercury_cons_id_to_string(ConsId, does_not_need_brackets)),
- suffix("("), nl_indent_delta(1)] ++
+ prefix("`"), words(ConsIdStr), suffix("("), nl_indent_delta(1)] ++
inst_list_to_sep_lines(ModeInfo, ArgInsts) ++
[fixed(")'.")]
;
Args = [],
Pieces2 = [words("has instantiatedness"),
- words(add_quotes(mercury_cons_id_to_string(ConsId,
- does_not_need_brackets))), suffix("."), nl]
+ words(ConsIdStr), suffix("."), nl]
),
Spec = error_spec(severity_error, phase_mode_check(report_in_any_mode),
[simple_msg(Context, [always(Preamble ++ Pieces1 ++ Pieces2)])]).
Index: compiler/mode_ordering.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_ordering.m,v
retrieving revision 1.29
diff -u -r1.29 mode_ordering.m
--- compiler/mode_ordering.m 23 Dec 2008 01:37:37 -0000 1.29
+++ compiler/mode_ordering.m 6 Feb 2009 03:13:32 -0000
@@ -18,7 +18,6 @@
:- import_module hlds.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
-:- import_module hlds.inst_graph.
:- import_module io.
:- import_module list.
@@ -39,10 +38,6 @@
:- pred mode_ordering(pred_constraint_map::in, list(list(pred_id))::in,
module_info::in, module_info::out, io::di, io::uo) is det.
-:- pred mode_ordering.proc(inst_graph::in, mode_constraint::in,
- mode_constraint_info::in, module_info::in, pred_constraint_map::in,
- proc_info::in, proc_info::out) is det.
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -51,6 +46,7 @@
:- import_module check_hlds.clause_to_proc.
:- import_module check_hlds.mode_constraint_robdd.
:- import_module hlds.hlds_goal.
+:- import_module hlds.inst_graph.
:- import_module mode_robdd.
% :- import_module mode_robdd.check.
% :- import_module mode_robdd.tfeir.
@@ -71,20 +67,20 @@
:- import_module stack.
mode_ordering(PredConstraintMap, SCCs, !ModuleInfo, !IO) :-
- list.foldl(mode_ordering.scc(PredConstraintMap), SCCs, !ModuleInfo),
+ list.foldl(mode_ordering_scc(PredConstraintMap), SCCs, !ModuleInfo),
report_ordering_mode_errors(!.ModuleInfo, !IO).
-:- pred mode_ordering.scc(pred_constraint_map::in, list(pred_id)::in,
+:- pred mode_ordering_scc(pred_constraint_map::in, list(pred_id)::in,
module_info::in, module_info::out) is det.
-mode_ordering.scc(PredConstraintMap, SCC, !ModuleInfo) :-
+mode_ordering_scc(PredConstraintMap, SCC, !ModuleInfo) :-
copy_module_clauses_to_procs(SCC, !ModuleInfo),
- list.foldl(mode_ordering.pred(PredConstraintMap, SCC), SCC, !ModuleInfo).
+ list.foldl(mode_ordering_pred(PredConstraintMap, SCC), SCC, !ModuleInfo).
-:- pred mode_ordering.pred(pred_constraint_map::in, list(pred_id)::in,
+:- pred mode_ordering_pred(pred_constraint_map::in, list(pred_id)::in,
pred_id::in, module_info::in, module_info::out) is det.
-mode_ordering.pred(PredConstraintMap, _SCC, PredId, !ModuleInfo) :-
+mode_ordering_pred(PredConstraintMap, _SCC, PredId, !ModuleInfo) :-
% XXX Mode inference NYI.
RequestedProcsMap0 = map.init,
@@ -94,7 +90,7 @@
( pred_info_infer_modes(PredInfo0) ->
( map.search(RequestedProcsMap0, PredId, RequestedProcs) ->
list.foldl(
- mode_ordering.infer_proc(ModeConstraint0,
+ mode_ordering_infer_proc(ModeConstraint0,
ModeConstraintInfo, !.ModuleInfo, PredConstraintMap),
RequestedProcs, PredInfo0, PredInfo)
;
@@ -105,42 +101,46 @@
;
ProcIds = pred_info_non_imported_procids(PredInfo0),
list.foldl(
- mode_ordering.check_proc(ModeConstraint0,
+ mode_ordering_check_proc(ModeConstraint0,
ModeConstraintInfo, !.ModuleInfo, PredConstraintMap),
ProcIds, PredInfo0, PredInfo)
),
module_info_set_pred_info(PredId, PredInfo, !ModuleInfo).
-:- pred mode_ordering.infer_proc(mode_constraint::in,
+:- pred mode_ordering_infer_proc(mode_constraint::in,
mode_constraint_info::in, module_info::in, pred_constraint_map::in,
mode_constraint::in, pred_info::in, pred_info::out) is det.
-mode_ordering.infer_proc(Constraint0, ModeConstraintInfo, ModuleInfo,
+mode_ordering_infer_proc(Constraint0, ModeConstraintInfo, ModuleInfo,
PredConstraintMap, ModeDeclConstraint, !PredInfo) :-
pred_info_create_proc_info_for_mode_decl_constraint(
ModeDeclConstraint, ProcId, !PredInfo),
- mode_ordering.check_proc(Constraint0, ModeConstraintInfo, ModuleInfo,
+ mode_ordering_check_proc(Constraint0, ModeConstraintInfo, ModuleInfo,
PredConstraintMap, ProcId, !PredInfo).
-:- pred mode_ordering.check_proc(mode_constraint::in,
+:- pred mode_ordering_check_proc(mode_constraint::in,
mode_constraint_info::in, module_info::in, pred_constraint_map::in,
proc_id::in, pred_info::in, pred_info::out) is det.
-mode_ordering.check_proc(Constraint0, ModeConstraintInfo, ModuleInfo,
+mode_ordering_check_proc(Constraint0, ModeConstraintInfo, ModuleInfo,
PredConstraintMap, ProcId, !PredInfo) :-
pred_info_proc_info(!.PredInfo, ProcId, ProcInfo0),
proc_info_head_modes_constraint(ProcInfo0, ModeDeclConstraint),
Constraint = Constraint0 * ModeDeclConstraint,
pred_info_get_inst_graph_info(!.PredInfo, InstGraphInfo),
InstGraph = InstGraphInfo ^ implementation_inst_graph,
- mode_ordering.proc(InstGraph, Constraint, ModeConstraintInfo,
+ mode_ordering_proc(InstGraph, Constraint, ModeConstraintInfo,
ModuleInfo, PredConstraintMap, ProcInfo0, ProcInfo),
pred_info_set_proc_info(ProcId, ProcInfo, !PredInfo).
+:- pred mode_ordering_proc(inst_graph::in, mode_constraint::in,
+ mode_constraint_info::in, module_info::in, pred_constraint_map::in,
+ proc_info::in, proc_info::out) is det.
+
% Perform mode ordering for a procedure. The ModeConstraint must be
% constrained to contain just the mode information for this procedure.
%
-mode_ordering.proc(InstGraph, ModeConstraint, ModeConstraintInfo, ModuleInfo,
+mode_ordering_proc(InstGraph, ModeConstraint, ModeConstraintInfo, ModuleInfo,
PredConstraintMap, !ProcInfo) :-
MOI = mode_ordering_info(InstGraph,
atomic_prodvars_map(ModeConstraint, ModeConstraintInfo),
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.210
diff -u -r1.210 mode_util.m
--- compiler/mode_util.m 10 Mar 2009 05:00:29 -0000 1.210
+++ compiler/mode_util.m 3 Jun 2009 13:37:08 -0000
@@ -141,11 +141,10 @@
% Convert a list of constructors to a list of bound_insts where the
% arguments are `ground'.
%
- % NOTE: the list(bound_inst) is not sorted and may contain
- % duplicates.
+ % NOTE: the list(bound_inst) is not sorted and may contain duplicates.
%
:- pred constructors_to_bound_insts(module_info::in, uniqueness::in,
- list(constructor)::in, list(bound_inst)::out) is det.
+ type_ctor::in, list(constructor)::in, list(bound_inst)::out) is det.
% Convert a list of constructors to a list of bound_insts where the
% arguments are `any'.
@@ -154,7 +153,7 @@
% duplicates.
%
:- pred constructors_to_bound_any_insts(module_info::in, uniqueness::in,
- list(constructor)::in, list(bound_inst)::out) is det.
+ type_ctor::in, list(constructor)::in, list(bound_inst)::out) is det.
% Given the mode of a predicate, work out which arguments are live
% (might be used again by the caller of that predicate) and which
@@ -288,12 +287,10 @@
list(type_ctor)::in, arg_mode::out) is det.
mode_to_arg_mode_2(ModuleInfo, Mode, Type, ContainingTypes, ArgMode) :-
- %
% We need to handle no_tag types (types which have exactly one constructor,
% and whose one constructor has exactly one argument) specially here,
% since for them an inst of bound(f(free)) is not really bound as far as
% code generation is concerned, since the f/1 will get optimized away.
- %
(
% Is this a no_tag type?
type_is_no_tag_type(ModuleInfo, Type, FunctorName, ArgType),
@@ -304,11 +301,11 @@
% The arg_mode will be determined by the mode and type of the
% functor's argument, so we figure out the mode and type of the
% argument, and then recurse.
- %
+
mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst),
- ConsId = cons(FunctorName, 1),
- get_single_arg_inst(InitialInst, ModuleInfo, ConsId, InitialArgInst),
- get_single_arg_inst(FinalInst, ModuleInfo, ConsId, FinalArgInst),
+ ConsId = cons(FunctorName, 1, TypeCtor),
+ get_single_arg_inst(ModuleInfo, InitialInst, ConsId, InitialArgInst),
+ get_single_arg_inst(ModuleInfo, FinalInst, ConsId, FinalArgInst),
ModeOfArg = (InitialArgInst -> FinalArgInst),
mode_to_arg_mode_2(ModuleInfo, ModeOfArg, ArgType,
[TypeCtor | ContainingTypes], ArgMode)
@@ -331,37 +328,53 @@
%-----------------------------------------------------------------------------%
- % get_single_arg_inst(Inst, ConsId, Arity, ArgInsts):
+ % get_single_arg_inst(ModuleInfo, Inst, ConsId, ArgInsts):
% Given an inst `Inst', figure out what the inst of the argument would be,
% assuming that the functor is the one given by the specified ConsId,
% whose arity is 1.
%
-:- pred get_single_arg_inst(mer_inst::in, module_info::in, cons_id::in,
+:- pred get_single_arg_inst(module_info::in, mer_inst::in, cons_id::in,
mer_inst::out) is det.
-get_single_arg_inst(defined_inst(InstName), ModuleInfo, ConsId, ArgInst) :-
- inst_lookup(ModuleInfo, InstName, Inst),
- get_single_arg_inst(Inst, ModuleInfo, ConsId, ArgInst).
-get_single_arg_inst(not_reached, _, _, not_reached).
-get_single_arg_inst(ground(Uniq, _PredInst), _, _, ground(Uniq, none)).
-get_single_arg_inst(bound(_Uniq, List), _, ConsId, ArgInst) :-
- ( get_single_arg_inst_2(List, ConsId, ArgInst0) ->
- ArgInst = ArgInst0
+get_single_arg_inst(ModuleInfo, Inst, ConsId, ArgInst) :-
+ (
+ Inst = defined_inst(InstName),
+ inst_lookup(ModuleInfo, InstName, NamedInst),
+ get_single_arg_inst(ModuleInfo, NamedInst, ConsId, ArgInst)
;
- % The code is unreachable.
+ Inst = not_reached,
ArgInst = not_reached
+ ;
+ Inst = ground(Uniq, _PredInst),
+ ArgInst = ground(Uniq, none)
+ ;
+ Inst = bound(_Uniq, List),
+ ( get_single_arg_inst_2(List, ConsId, ArgInst0) ->
+ ArgInst = ArgInst0
+ ;
+ % The code is unreachable.
+ ArgInst = not_reached
+ )
+ ;
+ Inst = free,
+ ArgInst = free
+ ;
+ Inst = free(_Type),
+ ArgInst = free % XXX loses type info
+ ;
+ Inst = any(Uniq, _),
+ ArgInst = any(Uniq, none)
+ ;
+ Inst = abstract_inst(_, _),
+ unexpected(this_file,
+ "get_single_arg_inst: abstract insts not supported")
+ ;
+ Inst = inst_var(_),
+ unexpected(this_file, "get_single_arg_inst: inst_var")
+ ;
+ Inst = constrained_inst_vars(_, InsideInst),
+ get_single_arg_inst(ModuleInfo, InsideInst, ConsId, ArgInst)
).
-get_single_arg_inst(free, _, _, free).
-get_single_arg_inst(free(_Type), _, _, free). % XXX loses type info
-get_single_arg_inst(any(Uniq, _), _, _, any(Uniq, none)).
-get_single_arg_inst(abstract_inst(_, _), _, _, _) :-
- unexpected(this_file,
- "get_single_arg_inst: abstract insts not supported").
-get_single_arg_inst(inst_var(_), _, _, _) :-
- unexpected(this_file, "get_single_arg_inst: inst_var").
-get_single_arg_inst(constrained_inst_vars(_, Inst), ModuleInfo, ConsId,
- ArgInst) :-
- get_single_arg_inst(Inst, ModuleInfo, ConsId, ArgInst).
:- pred get_single_arg_inst_2(list(bound_inst)::in, cons_id::in, mer_inst::out)
is semidet.
@@ -579,8 +592,9 @@
default_higher_order_func_inst(ModuleInfo, ArgTypes, PredInstInfo),
Inst = any(Uniq, higher_order(PredInstInfo))
;
- constructors_to_bound_any_insts(ModuleInfo, Uniq, Constructors,
- BoundInsts0),
+ type_to_ctor_det(Type, TypeCtor),
+ constructors_to_bound_any_insts(ModuleInfo, Uniq, TypeCtor,
+ Constructors, BoundInsts0),
list.sort_and_remove_dups(BoundInsts0, BoundInsts),
Inst = bound(Uniq, BoundInsts)
)
@@ -626,7 +640,8 @@
HigherOrderInstInfo),
Inst = ground(Uniq, higher_order(HigherOrderInstInfo))
;
- constructors_to_bound_insts(ModuleInfo, Uniq,
+ type_to_ctor_det(Type, TypeCtor),
+ constructors_to_bound_insts(ModuleInfo, Uniq, TypeCtor,
Constructors, BoundInsts0),
list.sort_and_remove_dups(BoundInsts0, BoundInsts),
Inst = bound(Uniq, BoundInsts)
@@ -803,25 +818,28 @@
PredArgModes0, PredArgModes),
PredInstInfo = pred_inst_info(pf_function, PredArgModes, detism_det).
-constructors_to_bound_insts(ModuleInfo, Uniq, Constructors, BoundInsts) :-
- constructors_to_bound_insts_2(ModuleInfo, Uniq,
- Constructors, ground(Uniq, none), BoundInsts).
-
-constructors_to_bound_any_insts(ModuleInfo, Uniq, Constructors, BoundInsts) :-
- constructors_to_bound_insts_2(ModuleInfo, Uniq,
- Constructors, any(Uniq, none), BoundInsts).
+constructors_to_bound_insts(ModuleInfo, Uniq, TypeCtor, Constructors,
+ BoundInsts) :-
+ constructors_to_bound_insts_2(ModuleInfo, Uniq, TypeCtor, Constructors,
+ ground(Uniq, none), BoundInsts).
+
+constructors_to_bound_any_insts(ModuleInfo, Uniq, TypeCtor, Constructors,
+ BoundInsts) :-
+ constructors_to_bound_insts_2(ModuleInfo, Uniq, TypeCtor, Constructors,
+ any(Uniq, none), BoundInsts).
:- pred constructors_to_bound_insts_2(module_info::in, uniqueness::in,
- list(constructor)::in, mer_inst::in, list(bound_inst)::out) is det.
+ type_ctor::in, list(constructor)::in, mer_inst::in, list(bound_inst)::out)
+ is det.
-constructors_to_bound_insts_2(_, _, [], _, []).
-constructors_to_bound_insts_2(ModuleInfo, Uniq, [Ctor | Ctors], ArgInst,
- [BoundInst | BoundInsts]) :-
+constructors_to_bound_insts_2(_, _, _, [], _, []).
+constructors_to_bound_insts_2(ModuleInfo, Uniq, TypeCtor, [Ctor | Ctors],
+ ArgInst, [BoundInst | BoundInsts]) :-
Ctor = ctor(_ExistQVars, _Constraints, Name, Args, _Ctxt),
ctor_arg_list_to_inst_list(Args, ArgInst, Insts),
list.length(Insts, Arity),
- BoundInst = bound_functor(cons(Name, Arity), Insts),
- constructors_to_bound_insts_2(ModuleInfo, Uniq, Ctors,
+ BoundInst = bound_functor(cons(Name, Arity, TypeCtor), Insts),
+ constructors_to_bound_insts_2(ModuleInfo, Uniq, TypeCtor, Ctors,
ArgInst, BoundInsts).
:- pred ctor_arg_list_to_inst_list(list(constructor_arg)::in, mer_inst::in,
@@ -850,8 +868,8 @@
Constructors = TypeBody ^ du_type_ctors
->
map.from_corresponding_lists(TypeParams, TypeArgs, ArgSubst),
- propagate_ctor_info_3(ModuleInfo, ArgSubst, TypeModule, Constructors,
- BoundInsts0, BoundInsts1),
+ propagate_ctor_info_3(ModuleInfo, ArgSubst, TypeCtor, TypeModule,
+ Constructors, BoundInsts0, BoundInsts1),
list.sort(BoundInsts1, BoundInsts)
;
% Builtin types don't need processing.
@@ -864,7 +882,7 @@
propagate_ctor_info_tuple(ModuleInfo, TupleArgTypes, BoundInst0, BoundInst) :-
BoundInst0 = bound_functor(Functor, ArgInsts0),
(
- Functor = cons(unqualified("{}"), _),
+ Functor = tuple_cons(_),
list.length(ArgInsts0, ArgInstsLen),
list.length(TupleArgTypes, TupleArgTypesLen),
ArgInstsLen = TupleArgTypesLen
@@ -873,30 +891,30 @@
propagate_types_into_inst_list(ModuleInfo, Subst, TupleArgTypes,
ArgInsts0, ArgInsts)
;
- % The bound_inst's arity does not match the
- % tuple's arity, so leave it alone. This can
- % only happen in a user defined bound_inst.
- % A mode error should be reported if anything
- % tries to match with the inst.
+ % The bound_inst's arity does not match the tuple's arity, so leave it
+ % alone. This can only happen in a user defined bound_inst.
+ % A mode error should be reported if anything tries to match with
+ % the inst.
ArgInsts = ArgInsts0
),
BoundInst = bound_functor(Functor, ArgInsts).
:- pred propagate_ctor_info_3(module_info::in, tsubst::in,
- module_name::in, list(constructor)::in,
+ type_ctor::in, module_name::in, list(constructor)::in,
list(bound_inst)::in, list(bound_inst)::out) is det.
-propagate_ctor_info_3(_, _, _, _, [], []).
-propagate_ctor_info_3(ModuleInfo, Subst, TypeModule, Constructors,
+propagate_ctor_info_3(_, _, _, _, _, [], []).
+propagate_ctor_info_3(ModuleInfo, Subst, TypeCtor, TypeModule, Constructors,
[BoundInst0 | BoundInsts0], [BoundInst | BoundInsts]) :-
BoundInst0 = bound_functor(ConsId0, ArgInsts0),
- ( ConsId0 = cons(unqualified(Name), Ar) ->
- ConsId = cons(qualified(TypeModule, Name), Ar)
+ ( ConsId0 = cons(unqualified(Name), ConsArity, _ConsTypeCtor) ->
+ % _ConsTypeCtor should be either TypeCtor or cons_id_dummy_type_ctor.
+ ConsId = cons(qualified(TypeModule, Name), ConsArity, TypeCtor)
;
ConsId = ConsId0
),
(
- ConsId = cons(ConsName, Arity),
+ ConsId = cons(ConsName, Arity, _),
GetCons = (pred(Ctor::in) is semidet :-
Ctor = ctor(_, _, ConsName, CtorArgs, _),
list.length(CtorArgs, Arity)
@@ -918,7 +936,7 @@
% tries to match with the inst.
BoundInst = bound_functor(ConsId, ArgInsts0)
),
- propagate_ctor_info_3(ModuleInfo, Subst, TypeModule,
+ propagate_ctor_info_3(ModuleInfo, Subst, TypeCtor, TypeModule,
Constructors, BoundInsts0, BoundInsts).
:- pred apply_type_subst(mer_type::in, tsubst::in, mer_type::out) is det.
@@ -936,10 +954,14 @@
:- pred inst_lookup_subst_args(hlds_inst_body::in, list(inst_var)::in,
sym_name::in, list(mer_inst)::in, mer_inst::out) is det.
-inst_lookup_subst_args(eqv_inst(Inst0), Params, _Name, Args, Inst) :-
- inst_substitute_arg_list(Params, Args, Inst0, Inst).
-inst_lookup_subst_args(abstract_inst, _Params, Name, Args,
- abstract_inst(Name, Args)).
+inst_lookup_subst_args(InstBody, Params, Name, Args, Inst) :-
+ (
+ InstBody = eqv_inst(Inst0),
+ inst_substitute_arg_list(Params, Args, Inst0, Inst)
+ ;
+ InstBody = abstract_inst,
+ Inst = abstract_inst(Name, Args)
+ ).
%-----------------------------------------------------------------------------%
@@ -1376,7 +1398,7 @@
( instmap_is_reachable(InstMap) ->
instmap_lookup_var(InstMap, Arg, ArgInst),
map.lookup(VarTypes, Arg, Type),
- ( inst_matches_initial(ArgInst, Inst, Type, !ModuleInfo, !Sub) ->
+ ( inst_matches_initial_sub(ArgInst, Inst, Type, !ModuleInfo, !Sub) ->
true
;
% error("compute_inst_var_sub: " ++
@@ -1518,42 +1540,50 @@
%
:- func cons_id_to_shared_inst(module_info, cons_id, int) = maybe(mer_inst).
-cons_id_to_shared_inst(_, cons(_, _), _) = no.
-cons_id_to_shared_inst(_, ConsId @ int_const(_), _) =
- yes(bound(shared, [bound_functor(ConsId, [])])).
-cons_id_to_shared_inst(_, ConsId @ float_const(_), _) =
- yes(bound(shared, [bound_functor(ConsId, [])])).
-cons_id_to_shared_inst(_, ConsId @ string_const(_), _) =
- yes(bound(shared, [bound_functor(ConsId, [])])).
-cons_id_to_shared_inst(_, implementation_defined_const(_), _) = _ :-
- unexpected(this_file,
- "cons_id_to_shared_inst: implementation_defined_const").
-cons_id_to_shared_inst(ModuleInfo, pred_const(PredProcId, _), NumArgs) =
- yes(ground(shared, higher_order(pred_inst_info(PorF, Modes, Det)))) :-
- module_info_pred_proc_info(ModuleInfo, unshroud_pred_proc_id(PredProcId),
- PredInfo, ProcInfo),
- PorF = pred_info_is_pred_or_func(PredInfo),
- proc_info_interface_determinism(ProcInfo, Det),
- proc_info_get_argmodes(ProcInfo, ProcArgModes),
- ( list.drop(NumArgs, ProcArgModes, Modes0) ->
- Modes = Modes0
+cons_id_to_shared_inst(ModuleInfo, ConsId, NumArgs) = MaybeInst :-
+ (
+ ( ConsId = cons(_, _, _)
+ ; ConsId = tuple_cons(_)
+ ),
+ MaybeInst = no
+ ;
+ % Note that before the change that introduced the char_const functor,
+ % we used to handle character constants as user-defined cons_ids.
+ ( ConsId = int_const(_)
+ ; ConsId = float_const(_)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
+ ),
+ MaybeInst = yes(bound(shared, [bound_functor(ConsId, [])]))
+ ;
+ ConsId = impl_defined_const(_),
+ unexpected(this_file,
+ "cons_id_to_shared_inst: impl_defined_const")
;
- unexpected(this_file, "list.drop failed in cons_id_to_shared_inst")
+ ConsId = closure_cons(PredProcId, _),
+ module_info_pred_proc_info(ModuleInfo,
+ unshroud_pred_proc_id(PredProcId), PredInfo, ProcInfo),
+ PorF = pred_info_is_pred_or_func(PredInfo),
+ proc_info_interface_determinism(ProcInfo, Det),
+ proc_info_get_argmodes(ProcInfo, ProcArgModes),
+ ( list.drop(NumArgs, ProcArgModes, ModesPrime) ->
+ Modes = ModesPrime
+ ;
+ unexpected(this_file, "cons_id_to_shared_inst: list.drop failed")
+ ),
+ Inst = ground(shared, higher_order(pred_inst_info(PorF, Modes, Det))),
+ MaybeInst = yes(Inst)
+ ;
+ ( ConsId = type_ctor_info_const(_, _, _)
+ ; ConsId = base_typeclass_info_const(_, _, _, _)
+ ; ConsId = type_info_cell_constructor(_)
+ ; ConsId = typeclass_info_cell_constructor
+ ; ConsId = tabling_info_const(_)
+ ; ConsId = table_io_decl(_)
+ ; ConsId = deep_profiling_proc_layout(_)
+ ),
+ MaybeInst = yes(ground(shared, none))
).
-cons_id_to_shared_inst(_, type_ctor_info_const(_, _, _), _) =
- yes(ground(shared, none)).
-cons_id_to_shared_inst(_, base_typeclass_info_const(_, _, _, _), _) =
- yes(ground(shared, none)).
-cons_id_to_shared_inst(_, type_info_cell_constructor(_), _) =
- yes(ground(shared, none)).
-cons_id_to_shared_inst(_, typeclass_info_cell_constructor, _) =
- yes(ground(shared, none)).
-cons_id_to_shared_inst(_, tabling_info_const(_), _) =
- yes(ground(shared, none)).
-cons_id_to_shared_inst(_, deep_profiling_proc_layout(_), _) =
- yes(ground(shared, none)).
-cons_id_to_shared_inst(_, table_io_decl(_), _) =
- yes(ground(shared, none)).
%-----------------------------------------------------------------------------%
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.127
diff -u -r1.127 modecheck_unify.m
--- compiler/modecheck_unify.m 23 Dec 2008 01:37:37 -0000 1.127
+++ compiler/modecheck_unify.m 3 Jun 2009 13:39:17 -0000
@@ -269,7 +269,7 @@
% Check if variable has a higher-order type.
type_is_higher_order_details(TypeOfX, Purity, _, EvalMethod,
PredArgTypes),
- ConsId0 = pred_const(ShroudedPredProcId, _)
+ ConsId0 = closure_cons(ShroudedPredProcId, _)
->
% Convert the pred term to a lambda expression.
mode_info_get_varset(!.ModeInfo, VarSet0),
@@ -586,7 +586,7 @@
% Fully module qualify all cons_ids (except for builtins such as
% ints and characters).
- qualify_cons_id(TypeOfX, ArgVars0, ConsId0, ConsId, InstConsId),
+ qualify_cons_id(ArgVars0, ConsId0, ConsId, InstConsId),
mode_info_get_instmap(!.ModeInfo, InstMap0),
instmap_lookup_var(InstMap0, X0, InstOfX0),
@@ -687,7 +687,7 @@
list.member(InstArg, InstArgs),
inst_is_free(ModuleInfo0, InstArg),
list.member(ArgVar, ArgVars0),
- ArgType = VarTypes ^ elem(ArgVar),
+ map.search(VarTypes, ArgVar, ArgType),
type_is_solver_type(ModuleInfo0, ArgType)
),
abstractly_unify_inst_functor(LiveX, InstOfX, InstConsId,
@@ -1226,7 +1226,7 @@
;
% Ensure that we will generate code for the unification procedure
% that will be used to implement this complicated unification.
- type_to_ctor_and_args(Type, TypeCtor, _)
+ type_to_ctor(Type, TypeCtor)
->
mode_info_get_context(!.ModeInfo, Context),
mode_info_get_instvarset(!.ModeInfo, InstVarSet),
@@ -1253,29 +1253,27 @@
% If we are re-doing mode analysis, preserve the existing cons_id.
list.length(ArgVars, Arity),
(
- Unification0 = construct(_, ConsIdPrime, _, _, _, _, SubInfo0),
+ Unification0 = construct(_, ConsId, _, _, _, _, SubInfo),
(
- SubInfo0 = construct_sub_info(MaybeTakeAddr, _MaybeSize),
+ SubInfo = construct_sub_info(MaybeTakeAddr, _MaybeSize),
expect(unify(MaybeTakeAddr, no), this_file,
"categorize_unify_var_lambda: take_addr")
;
- SubInfo0 = no_construct_sub_info
- ),
- SubInfo = SubInfo0,
- ConsId = ConsIdPrime
+ SubInfo = no_construct_sub_info
+ )
;
- Unification0 = deconstruct(_, ConsIdPrime, _, _, _, _),
- SubInfo = no_construct_sub_info,
- ConsId = ConsIdPrime
+ Unification0 = deconstruct(_, ConsId, _, _, _, _),
+ SubInfo = no_construct_sub_info
;
( Unification0 = assign(_, _)
; Unification0 = simple_test(_, _)
; Unification0 = complicated_unify(_, _, _)
),
+ SubInfo = no_construct_sub_info,
% The real cons_id will be computed by lambda.m;
% we just put in a dummy one for now.
- SubInfo = no_construct_sub_info,
- ConsId = cons(unqualified("__LambdaGoal__"), Arity)
+ TypeCtor = type_ctor(unqualified("int"), 0),
+ ConsId = cons(unqualified("__LambdaGoal__"), Arity, TypeCtor)
),
mode_info_get_module_info(!.ModeInfo, ModuleInfo),
modes_to_uni_modes(ModuleInfo, ArgModes0, ArgModes0, ArgModes),
@@ -1290,7 +1288,7 @@
% is considered to be bound. In this case the lambda_goal may
% not be converted back to a predicate constant, but that doesn't
% matter since the code will be pruned away later by simplify.m.
- ConsId = pred_const(ShroudedPredProcId, EvalMethod),
+ ConsId = closure_cons(ShroudedPredProcId, EvalMethod),
instmap_is_reachable(InstMap)
->
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
@@ -1301,8 +1299,23 @@
module_info_pred_info(ModuleInfo, PredId, PredInfo),
PredModule = pred_info_module(PredInfo),
PredName = pred_info_name(PredInfo),
- RHS = rhs_functor(cons(qualified(PredModule, PredName), Arity),
- no, ArgVars)
+ mode_info_get_var_types(!.ModeInfo, VarTypes),
+ map.lookup(VarTypes, X, Type),
+ ( Type = higher_order_type(_, MaybeReturnType, _, _) ->
+ (
+ MaybeReturnType = no,
+ RHSTypeCtor = type_ctor(unqualified("pred"), 0)
+ ;
+ MaybeReturnType = yes(_),
+ RHSTypeCtor = type_ctor(unqualified("func"), 0)
+ )
+ ;
+ unexpected(this_file,
+ "categorize_unify_var_lambda: bad HO type")
+ ),
+ RHSConsId = cons(qualified(PredModule, PredName), Arity,
+ RHSTypeCtor),
+ RHS = rhs_functor(RHSConsId, no, ArgVars)
;
unexpected(this_file,
"categorize_unify_var_lambda - reintroduced lambda goal")
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.376
diff -u -r1.376 modes.m
--- compiler/modes.m 10 Mar 2009 05:00:30 -0000 1.376
+++ compiler/modes.m 30 May 2009 05:35:03 -0000
@@ -383,6 +383,7 @@
:- import_module libs.options.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_event.
@@ -736,8 +737,7 @@
% Mode-check the code for predicate in a given mode.
%
-modecheck_proc(ProcId, PredId, !ModuleInfo, Errors, Changed, !IO)
- :-
+modecheck_proc(ProcId, PredId, !ModuleInfo, Errors, Changed, !IO) :-
modecheck_proc_general(ProcId, PredId, check_modes, may_change_called_proc,
!ModuleInfo, Errors, Changed, !IO).
@@ -754,9 +754,12 @@
!ModuleInfo, !Changed, Errors, !IO) :-
module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId,
_PredInfo0, ProcInfo0),
- ( proc_info_get_can_process(ProcInfo0, no) ->
+ proc_info_get_can_process(ProcInfo0, CanProcess),
+ (
+ CanProcess = no,
Errors = []
;
+ CanProcess = yes,
do_modecheck_proc(ProcId, PredId, WhatToCheck, MayChangeCalledProc,
!ModuleInfo, ProcInfo0, ProcInfo, !Changed, Errors, !IO),
module_info_preds(!.ModuleInfo, Preds1),
@@ -943,11 +946,11 @@
InferModes = no,
AllErrorSpecs = list.map(mode_error_info_to_spec(!.ModeInfo),
ModeErrors),
- %
+
% We only return the first error, because there could be a
% large number of mode errors and usually only one is needed to
% diagnose the problem.
- %
+
(
AllErrorSpecs = [ErrorSpec | _],
ErrorSpecs = [ErrorSpec]
@@ -1184,7 +1187,7 @@
mode_info_get_var_types(!.ModeInfo, VarTypes),
map.lookup(VarTypes, Var, Type),
(
- inst_matches_final(VarInst, Inst, Type, ModuleInfo)
+ inst_matches_final_typed(VarInst, Inst, Type, ModuleInfo)
->
true
;
@@ -2556,7 +2559,7 @@
mode_info_set_instmap(InstMap0, !ModeInfo),
mode_info_add_live_vars(NonLocalVars, !ModeInfo),
delay_info_delay_goal(DelayInfo0, FirstErrorInfo, Goal0, DelayInfo1),
- % Delaying an impure goal is an impurity error.
+ % Delaying an impure goal is an impurity error.
(
Impure = yes,
FirstErrorInfo = mode_error_info(Vars, _, _, _),
@@ -3549,7 +3552,7 @@
map.lookup(VarTypes, VarId, Type),
mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
(
- inst_matches_initial_no_implied_modes(VarInst, Inst, Type,
+ inst_matches_initial_no_implied_modes_sub(VarInst, Inst, Type,
ModuleInfo0, ModuleInfo, !Subst)
->
mode_info_set_module_info(ModuleInfo, !ModeInfo)
@@ -3570,7 +3573,7 @@
map.lookup(VarTypes, VarId, Type),
mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
(
- inst_matches_initial(VarInst, Inst, Type, ModuleInfo0, ModuleInfo,
+ inst_matches_initial_sub(VarInst, Inst, Type, ModuleInfo0, ModuleInfo,
!Subst)
->
mode_info_set_module_info(ModuleInfo, !ModeInfo)
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.172
diff -u -r1.172 module_qual.m
--- compiler/module_qual.m 22 May 2009 02:51:21 -0000 1.172
+++ compiler/module_qual.m 29 May 2009 04:53:44 -0000
@@ -1160,23 +1160,25 @@
qualify_bound_inst_list([bound_functor(ConsId, Insts0) | BoundInsts0],
[bound_functor(ConsId, Insts) | BoundInsts], !Info, !Specs) :-
(
- ConsId = cons(Name, Arity),
+ ConsId = cons(Name, Arity, _),
Id = item_name(Name, Arity),
update_recompilation_info(
recompilation.record_used_item(functor_item, Id, Id), !Info)
;
- ( ConsId = int_const(_)
- ; ConsId = string_const(_)
+ ( ConsId = tuple_cons(_)
+ ; ConsId = closure_cons(_, _)
+ ; ConsId = int_const(_)
; ConsId = float_const(_)
- ; ConsId = implementation_defined_const(_)
- ; ConsId = pred_const(_, _)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
+ ; ConsId = impl_defined_const(_)
; ConsId = type_ctor_info_const(_, _, _)
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
; ConsId = tabling_info_const(_)
- ; ConsId = deep_profiling_proc_layout(_)
; ConsId = table_io_decl(_)
+ ; ConsId = deep_profiling_proc_layout(_)
)
),
qualify_inst_list(Insts0, Insts, !Info, !Specs),
@@ -1243,7 +1245,7 @@
BuiltinType = builtin_type_string,
mq_info_set_module_used(unqualified("string"), !Info)
;
- BuiltinType = builtin_type_character
+ BuiltinType = builtin_type_char
).
qualify_type(higher_order_type(Args0, MaybeRet0, Purity, EvalMethod),
higher_order_type(Args, MaybeRet, Purity, EvalMethod),
Index: compiler/parse_tree.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/parse_tree.m,v
retrieving revision 1.21
diff -u -r1.21 parse_tree.m
--- compiler/parse_tree.m 11 May 2009 04:56:45 -0000 1.21
+++ compiler/parse_tree.m 30 May 2009 05:36:08 -0000
@@ -46,6 +46,7 @@
:- include_module prog_out.
% Utility routines.
+:- include_module builtin_lib_types.
:- include_module error_util.
:- include_module prog_event.
:- include_module prog_foreign.
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.339
diff -u -r1.339 polymorphism.m
--- compiler/polymorphism.m 10 Mar 2009 05:00:30 -0000 1.339
+++ compiler/polymorphism.m 30 May 2009 05:36:33 -0000
@@ -407,6 +407,7 @@
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.program_representation.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
@@ -1348,8 +1349,7 @@
poly_info_get_var_types(!.Info, VarTypes0),
map.lookup(VarTypes0, X0, TypeOfX),
list.length(ArgVars0, Arity),
- (
- %
+
% We replace any unifications with higher order pred constants
% by lambda expressions. For example, we replace
%
@@ -1364,19 +1364,19 @@
% (e.g. `Y' in above example). This would require a bit of moderately
% tricky special case code if we didn't expand them here. Second, this pass
% (polymorphism.m) is a lot easier if we don't have to handle higher order
- % pred consts. If it turns out that the predicate was nonpolymorphic,
- % lambda.m will turn the lambda expression back into a higher order pred
+ % constants. If it turns out that the predicate was nonpolymorphic,
+ % lambda.m will turn the lambda expression back into a higher order
% constant again.
%
% Note that this transformation is also done by modecheck_unify.m, in case
% we are rerunning mode analysis after lambda.m has already been run;
% any changes to the code here will also need to be duplicated there.
- %
+ (
% Check if variable has a higher order type.
type_is_higher_order_details(TypeOfX, Purity, _PredOrFunc, EvalMethod,
CalleeArgTypes),
- ConsId0 = pred_const(ShroudedPredProcId, _),
+ ConsId0 = closure_cons(ShroudedPredProcId, _),
proc(PredId, ProcId0) = unshroud_pred_proc_id(ShroudedPredProcId)
->
% An `invalid_proc_id' means the predicate is multi-moded. We can't
@@ -1417,9 +1417,9 @@
% If so, assume it is a construction, and strip off the prefix.
% Otherwise, assume it is a deconstruction.
- ConsId0 = cons(Functor0, Arity),
+ ConsId0 = cons(Functor0, Arity, ConsTypeCtor),
( remove_new_prefix(Functor0, OrigFunctor) ->
- ConsId = cons(OrigFunctor, Arity),
+ ConsId = cons(OrigFunctor, Arity, ConsTypeCtor),
IsConstruction = yes
;
ConsId = ConsId0,
@@ -1479,9 +1479,11 @@
PredName = pred_info_name(PredInfo),
QualifiedPName = qualified(PredModule, PredName),
- CallUnifyContext = call_unify_context(X0,
- rhs_functor(cons(QualifiedPName, list.length(ArgVars0)), no, ArgVars0),
- UnifyContext),
+ % The ConsId's type_ctor shouldn't matter in a call_unify_context.
+ ConsId = cons(QualifiedPName, list.length(ArgVars0),
+ cons_id_dummy_type_ctor),
+ RHS = rhs_functor(ConsId, no, ArgVars0),
+ CallUnifyContext = call_unify_context(X0, RHS, UnifyContext),
LambdaGoalExpr = plain_call(PredId, ProcId, Args, not_builtin,
yes(CallUnifyContext), QualifiedPName),
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.132
diff -u -r1.132 post_typecheck.m
--- compiler/post_typecheck.m 10 Mar 2009 05:00:30 -0000 1.132
+++ compiler/post_typecheck.m 30 May 2009 05:36:48 -0000
@@ -130,6 +130,7 @@
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.program_representation.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
@@ -144,6 +145,7 @@
:- import_module string.
:- import_module svmap.
:- import_module svvarset.
+:- import_module term_io.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -678,7 +680,7 @@
DefinedInImpl = status_defined_in_impl_section(TypeStatus),
(
DefinedInImpl = yes,
- ConsIdStr = cons_id_to_string(ConsId),
+ ConsIdStr = cons_id_and_arity_to_string(ConsId),
IdPieces = [words("constructor"), quote(ConsIdStr)],
report_assertion_interface_error(ModuleInfo, Context, IdPieces,
!Specs)
@@ -932,7 +934,7 @@
% function call? Or the impure/semipure equivalents impure_apply/N
% and semipure_apply/N?
% (XXX FIXME We should use nicer syntax for impure apply/N.)
- ConsId0 = cons(unqualified(ApplyName), _),
+ ConsId0 = cons(unqualified(ApplyName), _, _),
( ApplyName = "apply", Purity = purity_pure
; ApplyName = "", Purity = purity_pure
; ApplyName = "impure_apply", Purity = purity_impure
@@ -944,7 +946,7 @@
% Convert the higher-order function call (apply/N) into a higher-order
% predicate call (i.e., replace `X = apply(F, A, B, C)'
% with `call(F, A, B, C, X)')
- list.append(FuncArgVars, [X0], ArgVars),
+ ArgVars = FuncArgVars ++ [X0],
Modes = [],
Det = detism_erroneous,
adjust_func_arity(pf_function, Arity, FullArity),
@@ -958,7 +960,7 @@
% Find the set of candidate predicates which have the
% specified name and arity (and module, if module-qualified)
- ConsId0 = cons(PredName, _),
+ ConsId0 = cons(PredName, _, _),
% We don't do this for compiler-generated predicates; they are assumed
% to have been generated with all functions already expanded. If we did
@@ -986,7 +988,7 @@
pred_info_get_exist_quant_tvars(!.PredInfo, ExistQTVars),
pred_info_get_head_type_params(!.PredInfo, HeadTypeParams),
map.apply_to_list(ArgVars0, !.VarTypes, ArgTypes0),
- list.append(ArgTypes0, [TypeOfX], ArgTypes),
+ ArgTypes = ArgTypes0 ++ [TypeOfX],
pred_info_get_constraint_map(!.PredInfo, ConstraintMap),
GoalPath = goal_info_get_goal_path(GoalInfo0),
ConstraintSearch =
@@ -996,20 +998,19 @@
ArgTypes, HeadTypeParams, yes(ConstraintSearch), Context,
PredId, QualifiedFuncName)
->
- % Convert function calls into predicate calls:
+ % Convert function calls in unifications into plain calls:
% replace `X = f(A, B, C)' with `f(A, B, C, X)'.
- %
+
ProcId = invalid_proc_id,
- list.append(ArgVars0, [X0], ArgVars),
+ ArgVars = ArgVars0 ++ [X0],
FuncCallUnifyContext = call_unify_context(X0,
rhs_functor(ConsId0, no, ArgVars0), UnifyContext),
FuncCall = plain_call(PredId, ProcId, ArgVars, not_builtin,
yes(FuncCallUnifyContext), QualifiedFuncName),
Goal = hlds_goal(FuncCall, GoalInfo0)
;
- % Is the function symbol a higher-order predicate
- % or function constant?
- ConsId0 = cons(Name, _),
+ % Is the function symbol a higher-order predicate or function constant?
+ ConsId0 = cons(Name, _, _),
type_is_higher_order_details(TypeOfX, _Purity, PredOrFunc,
EvalMethod, HOArgTypes),
@@ -1045,7 +1046,7 @@
get_proc_id(ModuleInfo, PredId, ProcId)
),
ShroudedPredProcId = shroud_pred_proc_id(proc(PredId, ProcId)),
- ConsId = pred_const(ShroudedPredProcId, EvalMethod),
+ ConsId = closure_cons(ShroudedPredProcId, EvalMethod),
GoalExpr = unify(X0, rhs_functor(ConsId, no, ArgVars0), Mode0,
Unification0, UnifyContext),
Goal = hlds_goal(GoalExpr, GoalInfo0)
@@ -1055,7 +1056,7 @@
% higher-order terms above. It's done that way because it's easier
% to check that the types match for functions calls and higher-order
% terms.
- ConsId0 = cons(Name, Arity),
+ ConsId0 = cons(Name, Arity, _),
is_field_access_function_name(ModuleInfo, Name, Arity,
AccessType, FieldName),
@@ -1076,13 +1077,37 @@
AccessType, FieldName, UnifyContext, X0, ArgVars0, GoalInfo0, Goal)
;
% Module qualify ordinary construction/deconstruction unifications.
- (
- ConsId0 = cons(Name0, Arity),
- type_to_ctor_and_args(TypeOfX, TypeCtorOfX, _),
- TypeCtorOfX = type_ctor(qualified(TypeModule, _), _)
- ->
- Name = unqualify_name(Name0),
- ConsId = cons(qualified(TypeModule, Name), Arity)
+ type_to_ctor_det(TypeOfX, TypeCtorOfX),
+ ( ConsId0 = cons(SymName0, Arity, _OldTypeCtor) ->
+ ( TypeOfX = tuple_type(_, _) ->
+ ConsId = tuple_cons(Arity)
+ ; TypeOfX = builtin_type(builtin_type_char) ->
+ (
+ SymName0 = unqualified(Name0),
+ ( encode_escaped_char(Char, Name0) ->
+ ConsId = char_const(Char)
+ ;
+ unexpected(this_file,
+ "resolve_unify_functor: encode_escaped_char")
+ )
+ ;
+ SymName0 = qualified(_, _),
+ unexpected(this_file,
+ "resolve_unify_functor: qualified char const")
+ )
+ ;
+ Name = unqualify_name(SymName0),
+ TypeCtorOfX = type_ctor(TypeCtorSymName, _),
+ (
+ TypeCtorSymName = qualified(TypeCtorModule, _),
+ SymName = qualified(TypeCtorModule, Name),
+ ConsId = cons(SymName, Arity, TypeCtorOfX)
+ ;
+ TypeCtorSymName = unqualified(_),
+ unexpected(this_file,
+ "resolve_unify_functor: unqualified type_ctor")
+ )
+ )
;
ConsId = ConsId0
),
@@ -1197,7 +1222,7 @@
make_new_vars(TypesBeforeField, VarsBeforeField, !VarTypes, !VarSet),
make_new_vars(TypesAfterField, VarsAfterField, !VarTypes, !VarSet),
- list.append(VarsBeforeField, [FieldVar | VarsAfterField], ArgVars),
+ ArgVars = VarsBeforeField ++ [FieldVar | VarsAfterField],
RestrictNonLocals = goal_info_get_nonlocals(OldGoalInfo),
create_pure_atomic_unification_with_nonlocals(TermInputVar,
@@ -1211,11 +1236,10 @@
prog_var::in, prog_var::in, prog_var::in,
hlds_goal_info::in, hlds_goal_expr::out) is det.
-translate_set_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet,
- FieldName, UnifyContext, FieldVar, TermInputVar, TermOutputVar,
- OldGoalInfo, Goal) :-
+translate_set_function(ModuleInfo, !PredInfo, !VarTypes, !VarSet, FieldName,
+ UnifyContext, FieldVar, TermInputVar, TermOutputVar, OldGoalInfo,
+ Goal) :-
map.lookup(!.VarTypes, TermInputVar, TermType),
-
get_constructor_containing_field(ModuleInfo, TermType, FieldName,
ConsId0, FieldNumber),
@@ -1231,12 +1255,10 @@
make_new_vars(TypesAfterField, VarsAfterField, !VarTypes, !VarSet),
% Build a goal to deconstruct the input.
- list.append(VarsBeforeField, [SingletonFieldVar | VarsAfterField],
- DeconstructArgs),
+ DeconstructArgs = VarsBeforeField ++ [SingletonFieldVar | VarsAfterField],
OldNonLocals = goal_info_get_nonlocals(OldGoalInfo),
- list.append(VarsBeforeField, VarsAfterField, NonLocalArgs),
- set.insert_list(OldNonLocals, NonLocalArgs,
- DeconstructRestrictNonLocals),
+ NonLocalArgs = VarsBeforeField ++ VarsAfterField,
+ set.insert_list(OldNonLocals, NonLocalArgs, DeconstructRestrictNonLocals),
create_pure_atomic_unification_with_nonlocals(TermInputVar,
rhs_functor(ConsId0, no, DeconstructArgs), OldGoalInfo,
@@ -1244,7 +1266,7 @@
UnifyContext, DeconstructGoal),
% Build a goal to construct the output.
- list.append(VarsBeforeField, [FieldVar | VarsAfterField], ConstructArgs),
+ ConstructArgs = VarsBeforeField ++ [FieldVar | VarsAfterField],
set.insert_list(OldNonLocals, NonLocalArgs, ConstructRestrictNonLocals),
% If the cons_id is existentially quantified, add a `new' prefix
@@ -1254,9 +1276,9 @@
ConsId = ConsId0
;
ExistQVars = [_ | _],
- ( ConsId0 = cons(ConsName0, ConsArity) ->
+ ( ConsId0 = cons(ConsName0, ConsArity, TypeCtor) ->
remove_new_prefix(ConsName, ConsName0),
- ConsId = cons(ConsName, ConsArity)
+ ConsId = cons(ConsName, ConsArity, TypeCtor)
;
unexpected(this_file, "translate_set_function: invalid cons_id")
)
@@ -1390,19 +1412,14 @@
get_constructor_containing_field(ModuleInfo, TermType, FieldName,
ConsId, FieldNumber) :-
- ( type_to_ctor_and_args(TermType, TermTypeCtor0, _) ->
- TermTypeCtor = TermTypeCtor0
- ;
- unexpected(this_file,
- "get_constructor_containing_field: type_to_ctor_and_args failed")
- ),
+ type_to_ctor_det(TermType, TermTypeCtor),
module_info_get_type_table(ModuleInfo, Types),
map.lookup(Types, TermTypeCtor, TermTypeDefn),
hlds_data.get_type_defn_body(TermTypeDefn, TermTypeBody),
(
TermTypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _),
- get_constructor_containing_field_2(Ctors, FieldName, ConsId,
- FieldNumber)
+ get_constructor_containing_field_2(TermTypeCtor, Ctors, FieldName,
+ ConsId, FieldNumber)
;
( TermTypeBody = hlds_eqv_type(_)
; TermTypeBody = hlds_foreign_type(_)
@@ -1412,13 +1429,13 @@
unexpected(this_file, "get_constructor_containing_field: not du type")
).
-:- pred get_constructor_containing_field_2(list(constructor)::in,
- ctor_field_name::in, cons_id::out, int::out) is det.
+:- pred get_constructor_containing_field_2(type_ctor::in,
+ list(constructor)::in, ctor_field_name::in, cons_id::out, int::out) is det.
-get_constructor_containing_field_2([], _, _, _) :-
+get_constructor_containing_field_2(_, [], _, _, _) :-
unexpected(this_file,
"get_constructor_containing_field: can't find field").
-get_constructor_containing_field_2([Ctor | Ctors], FieldName,
+get_constructor_containing_field_2(TypeCtor, [Ctor | Ctors], FieldName,
ConsId, FieldNumber) :-
Ctor = ctor(_, _, SymName, CtorArgs, _Ctxt),
(
@@ -1426,10 +1443,10 @@
1, FieldNumber0)
->
list.length(CtorArgs, Arity),
- ConsId = cons(SymName, Arity),
+ ConsId = cons(SymName, Arity, TypeCtor),
FieldNumber = FieldNumber0
;
- get_constructor_containing_field_2(Ctors, FieldName,
+ get_constructor_containing_field_2(TypeCtor, Ctors, FieldName,
ConsId, FieldNumber)
).
Index: compiler/prog_ctgc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_ctgc.m,v
retrieving revision 1.22
diff -u -r1.22 prog_ctgc.m
--- compiler/prog_ctgc.m 2 Dec 2008 04:30:24 -0000 1.22
+++ compiler/prog_ctgc.m 5 Feb 2009 08:32:07 -0000
@@ -195,6 +195,9 @@
(
Term = term.functor(term.atom(Cons), Args, _)
->
+ % XXX We should include non-dummy type_ctors in cons ConsIds.
+ % XXX Why do we parse int, float, and string ConsIds when they
+ % never have any arguments and thus cannot select anything?
(
Cons = "sel",
Args = [ConsTerm, ArityTerm, PosTerm]
@@ -204,22 +207,22 @@
ArityTerm = term.functor(term.integer(Arity), _, _),
PosTerm = term.functor(term.integer(Pos), _, _)
->
- ConsId = cons(ConsIdName, Arity),
+ ConsId = cons(ConsIdName, Arity, cons_id_dummy_type_ctor),
UnitSelector = termsel(ConsId, Pos)
;
- ConsTerm = term.functor(term.integer(X), _, _)
+ ConsTerm = term.functor(term.integer(Int), _, _)
->
- ConsId = int_const(X),
+ ConsId = int_const(Int),
UnitSelector = termsel(ConsId, 0)
;
- ConsTerm = term.functor(term.float(X), _, _)
+ ConsTerm = term.functor(term.float(Float), _, _)
->
- ConsId = float_const(X),
+ ConsId = float_const(Float),
UnitSelector = termsel(ConsId, 0)
;
- ConsTerm = term.functor(term.string(S), _, _)
+ ConsTerm = term.functor(term.string(Str), _, _)
->
- ConsId = string_const(S),
+ ConsId = string_const(Str),
UnitSelector = termsel(ConsId, 0)
;
unexpected(this_file, "parse_unit_selector: " ++
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.216
diff -u -r1.216 prog_data.m
--- compiler/prog_data.m 19 Feb 2009 03:49:17 -0000 1.216
+++ compiler/prog_data.m 3 Jun 2009 13:41:39 -0000
@@ -29,6 +29,7 @@
:- import_module parse_tree.prog_item.
:- import_module assoc_list.
+:- import_module char.
:- import_module bool.
:- import_module list.
:- import_module map.
@@ -39,7 +40,19 @@
:- import_module unit.
:- import_module varset.
+:- implementation.
+
+:- import_module library.
+:- import_module libs.compiler_util.
+
+:- import_module string.
+
%-----------------------------------------------------------------------------%
+%
+% Miscellaneous stuff.
+%
+
+:- interface.
% Indicates the type of information the compiler should get from the
% promise declaration's clause.
@@ -62,6 +75,13 @@
---> type_only(mer_type)
; type_and_mode(mer_type, mer_mode).
+%-----------------------------------------------------------------------------%
+%
+% Stuff about purity.
+%
+
+:- interface.
+
% Purity indicates whether a goal can have side effects or can depend on
% global state. See purity.m and the "Purity" section of the Mercury
% language reference manual.
@@ -82,6 +102,46 @@
%
:- func best_purity(purity, purity) = purity.
+:- implementation.
+
+less_pure(P1, P2) :-
+ \+ ( worst_purity(P1, P2) = P2).
+
+ % worst_purity/3 could be written more compactly, but this definition
+ % guarantees us a determinism error if we add to type `purity'. We also
+ % define less_pure/2 in terms of worst_purity/3 rather than the other way
+ % around for the same reason.
+ %
+worst_purity(purity_pure, purity_pure) = purity_pure.
+worst_purity(purity_pure, purity_semipure) = purity_semipure.
+worst_purity(purity_pure, purity_impure) = purity_impure.
+worst_purity(purity_semipure, purity_pure) = purity_semipure.
+worst_purity(purity_semipure, purity_semipure) = purity_semipure.
+worst_purity(purity_semipure, purity_impure) = purity_impure.
+worst_purity(purity_impure, purity_pure) = purity_impure.
+worst_purity(purity_impure, purity_semipure) = purity_impure.
+worst_purity(purity_impure, purity_impure) = purity_impure.
+
+ % best_purity/3 is written as a switch for the same reason as
+ % worst_purity/3.
+ %
+best_purity(purity_pure, purity_pure) = purity_pure.
+best_purity(purity_pure, purity_semipure) = purity_pure.
+best_purity(purity_pure, purity_impure) = purity_pure.
+best_purity(purity_semipure, purity_pure) = purity_pure.
+best_purity(purity_semipure, purity_semipure) = purity_semipure.
+best_purity(purity_semipure, purity_impure) = purity_semipure.
+best_purity(purity_impure, purity_pure) = purity_pure.
+best_purity(purity_impure, purity_semipure) = purity_semipure.
+best_purity(purity_impure, purity_impure) = purity_impure.
+
+%-----------------------------------------------------------------------------%
+%
+% Stuff about determinism.
+%
+
+:- interface.
+
% The `determinism' type specifies how many solutions a given procedure
% may have.
%
@@ -126,6 +186,18 @@
:- pred det_negation_det(determinism::in, maybe(determinism)::out) is det.
+ % The following predicates do abstract interpretation to count
+ % the number of solutions and the possible number of failures.
+ %
+ % If the num_solns is at_most_many_cc, this means that the goal might have
+ % many logical solutions if there were no pruning, but that the goal occurs
+ % in a single-solution context, so only the first solution will be
+ % returned.
+ %
+ % The reason why we don't throw an exception in det_switch_maxsoln and
+ % det_disjunction_maxsoln is given in the documentation of the test case
+ % invalid/magicbox.m.
+
:- pred det_conjunction_maxsoln(soln_count::in, soln_count::in,
soln_count::out) is det.
@@ -143,11 +215,149 @@
:- pred det_switch_canfail(can_fail::in, can_fail::in, can_fail::out) is det.
+:- implementation.
+
+determinism_components(detism_det, cannot_fail, at_most_one).
+determinism_components(detism_semi, can_fail, at_most_one).
+determinism_components(detism_multi, cannot_fail, at_most_many).
+determinism_components(detism_non, can_fail, at_most_many).
+determinism_components(detism_cc_multi, cannot_fail, at_most_many_cc).
+determinism_components(detism_cc_non, can_fail, at_most_many_cc).
+determinism_components(detism_erroneous, cannot_fail, at_most_zero).
+determinism_components(detism_failure, can_fail, at_most_zero).
+
+det_conjunction_detism(DetismA, DetismB, Detism) :-
+ % When figuring out the determinism of a conjunction, if the second goal
+ % is unreachable, then then the determinism of the conjunction is just
+ % the determinism of the first goal.
+
+ determinism_components(DetismA, CanFailA, MaxSolnA),
+ (
+ MaxSolnA = at_most_zero,
+ Detism = DetismA
+ ;
+ ( MaxSolnA = at_most_one
+ ; MaxSolnA = at_most_many
+ ; MaxSolnA = at_most_many_cc
+ ),
+ determinism_components(DetismB, CanFailB, MaxSolnB),
+ det_conjunction_canfail(CanFailA, CanFailB, CanFail),
+ det_conjunction_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
+ determinism_components(Detism, CanFail, MaxSoln)
+ ).
+
+det_par_conjunction_detism(DetismA, DetismB, Detism) :-
+ % Figuring out the determinism of a parallel conjunction is much easier
+ % than for a sequential conjunction, since you simply ignore the case
+ % where the second goal is unreachable. Just do a normal solution count.
+
+ determinism_components(DetismA, CanFailA, MaxSolnA),
+ determinism_components(DetismB, CanFailB, MaxSolnB),
+ det_conjunction_canfail(CanFailA, CanFailB, CanFail),
+ det_conjunction_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
+ determinism_components(Detism, CanFail, MaxSoln).
+
+det_switch_detism(DetismA, DetismB, Detism) :-
+ determinism_components(DetismA, CanFailA, MaxSolnA),
+ determinism_components(DetismB, CanFailB, MaxSolnB),
+ det_switch_canfail(CanFailA, CanFailB, CanFail),
+ det_switch_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
+ determinism_components(Detism, CanFail, MaxSoln).
+
+det_conjunction_maxsoln(at_most_zero, at_most_zero, at_most_zero).
+det_conjunction_maxsoln(at_most_zero, at_most_one, at_most_zero).
+det_conjunction_maxsoln(at_most_zero, at_most_many_cc, at_most_zero).
+det_conjunction_maxsoln(at_most_zero, at_most_many, at_most_zero).
+
+det_conjunction_maxsoln(at_most_one, at_most_zero, at_most_zero).
+det_conjunction_maxsoln(at_most_one, at_most_one, at_most_one).
+det_conjunction_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
+det_conjunction_maxsoln(at_most_one, at_most_many, at_most_many).
+
+det_conjunction_maxsoln(at_most_many_cc, at_most_zero, at_most_zero).
+det_conjunction_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
+det_conjunction_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
+det_conjunction_maxsoln(at_most_many_cc, at_most_many, _) :-
+ % If the first conjunct could be cc pruned, the second conj ought to have
+ % been cc pruned too.
+ unexpected(this_file, "det_conjunction_maxsoln: many_cc , many").
+
+det_conjunction_maxsoln(at_most_many, at_most_zero, at_most_zero).
+det_conjunction_maxsoln(at_most_many, at_most_one, at_most_many).
+det_conjunction_maxsoln(at_most_many, at_most_many_cc, at_most_many).
+det_conjunction_maxsoln(at_most_many, at_most_many, at_most_many).
+
+det_conjunction_canfail(can_fail, can_fail, can_fail).
+det_conjunction_canfail(can_fail, cannot_fail, can_fail).
+det_conjunction_canfail(cannot_fail, can_fail, can_fail).
+det_conjunction_canfail(cannot_fail, cannot_fail, cannot_fail).
+
+det_disjunction_maxsoln(at_most_zero, at_most_zero, at_most_zero).
+det_disjunction_maxsoln(at_most_zero, at_most_one, at_most_one).
+det_disjunction_maxsoln(at_most_zero, at_most_many_cc, at_most_many_cc).
+det_disjunction_maxsoln(at_most_zero, at_most_many, at_most_many).
+
+det_disjunction_maxsoln(at_most_one, at_most_zero, at_most_one).
+det_disjunction_maxsoln(at_most_one, at_most_one, at_most_many).
+det_disjunction_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
+det_disjunction_maxsoln(at_most_one, at_most_many, at_most_many).
+
+det_disjunction_maxsoln(at_most_many_cc, at_most_zero, at_most_many_cc).
+det_disjunction_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
+det_disjunction_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
+det_disjunction_maxsoln(at_most_many_cc, at_most_many, at_most_many_cc).
+
+det_disjunction_maxsoln(at_most_many, at_most_zero, at_most_many).
+det_disjunction_maxsoln(at_most_many, at_most_one, at_most_many).
+det_disjunction_maxsoln(at_most_many, at_most_many_cc, at_most_many_cc).
+det_disjunction_maxsoln(at_most_many, at_most_many, at_most_many).
+
+det_disjunction_canfail(can_fail, can_fail, can_fail).
+det_disjunction_canfail(can_fail, cannot_fail, cannot_fail).
+det_disjunction_canfail(cannot_fail, can_fail, cannot_fail).
+det_disjunction_canfail(cannot_fail, cannot_fail, cannot_fail).
+
+det_switch_maxsoln(at_most_zero, at_most_zero, at_most_zero).
+det_switch_maxsoln(at_most_zero, at_most_one, at_most_one).
+det_switch_maxsoln(at_most_zero, at_most_many_cc, at_most_many_cc).
+det_switch_maxsoln(at_most_zero, at_most_many, at_most_many).
+
+det_switch_maxsoln(at_most_one, at_most_zero, at_most_one).
+det_switch_maxsoln(at_most_one, at_most_one, at_most_one).
+det_switch_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
+det_switch_maxsoln(at_most_one, at_most_many, at_most_many).
+
+det_switch_maxsoln(at_most_many_cc, at_most_zero, at_most_many_cc).
+det_switch_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
+det_switch_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
+det_switch_maxsoln(at_most_many_cc, at_most_many, at_most_many_cc).
+
+det_switch_maxsoln(at_most_many, at_most_zero, at_most_many).
+det_switch_maxsoln(at_most_many, at_most_one, at_most_many).
+det_switch_maxsoln(at_most_many, at_most_many_cc, at_most_many_cc).
+det_switch_maxsoln(at_most_many, at_most_many, at_most_many).
+
+det_switch_canfail(can_fail, can_fail, can_fail).
+det_switch_canfail(can_fail, cannot_fail, can_fail).
+det_switch_canfail(cannot_fail, can_fail, can_fail).
+det_switch_canfail(cannot_fail, cannot_fail, cannot_fail).
+
+det_negation_det(detism_det, yes(detism_failure)).
+det_negation_det(detism_semi, yes(detism_semi)).
+det_negation_det(detism_multi, no).
+det_negation_det(detism_non, no).
+det_negation_det(detism_cc_multi, no).
+det_negation_det(detism_cc_non, no).
+det_negation_det(detism_erroneous, yes(detism_erroneous)).
+det_negation_det(detism_failure, yes(detism_det)).
+
%-----------------------------------------------------------------------------%
%
-% Stuff for the foreign language interface pragmas
+% Stuff for the foreign language interface pragmas.
%
+:- interface.
+
% Is the foreign code declarations local to this module or
% exported?
%
@@ -197,7 +407,7 @@
%-----------------------------------------------------------------------------%
%
-% Stuff for tabling pragmas
+% Stuff for tabling pragmas.
%
:- type eval_minimal_method
@@ -283,12 +493,44 @@
:- func eval_method_to_table_type(eval_method) = string.
+:- implementation.
+
+default_memo_table_attributes =
+ table_attributes(all_strict, no, table_dont_gather_statistics,
+ table_dont_allow_reset).
+
+eval_method_to_table_type(EvalMethod) = TableTypeStr :-
+ (
+ EvalMethod = eval_normal,
+ unexpected(this_file, "eval_method_to_table_type: eval_normal")
+ ;
+ EvalMethod = eval_table_io(_, _),
+ unexpected(this_file, "eval_method_to_table_type: eval_table_io")
+ ;
+ EvalMethod = eval_loop_check,
+ TableTypeStr = "MR_TABLE_TYPE_LOOPCHECK"
+ ;
+ EvalMethod = eval_memo,
+ TableTypeStr = "MR_TABLE_TYPE_MEMO"
+ ;
+ EvalMethod = eval_minimal(stack_copy),
+ TableTypeStr = "MR_TABLE_TYPE_MINIMAL_MODEL_STACK_COPY"
+ ;
+ EvalMethod = eval_minimal(own_stacks_consumer),
+ unexpected(this_file, "eval_method_to_table_type: own_stacks_consumer")
+ ;
+ EvalMethod = eval_minimal(own_stacks_generator),
+ TableTypeStr = "MR_TABLE_TYPE_MINIMAL_MODEL_OWN_STACKS"
+ ).
+
%-----------------------------------------------------------------------------%
%
% Stuff for the `termination_info' pragma.
% See term_util.m.
%
+:- interface.
+
:- type generic_arg_size_info(ErrorInfo)
---> finite(int, list(bool))
% The termination constant is a finite integer. The list of bool
@@ -310,9 +552,11 @@
%-----------------------------------------------------------------------------%
%
-% Stuff for the `termination2_info' pragma
+% Stuff for the `termination2_info' pragma.
%
+:- interface.
+
% This is the form in which termination information from other
% modules (imported via `.opt' or `.trans_opt' files) comes.
% We convert this to an intermediate form and let the termination
@@ -339,6 +583,8 @@
% Stuff for the `structure_sharing_info' pragma.
%
+:- interface.
+
% Whenever structure sharing analysis is unable to determine a good
% approximation of the set of structure sharing pairs that might exist
% during the execution of a program, it must use "top" as the only safe
@@ -396,10 +642,10 @@
%
:- type selector == list(unit_selector).
- % Unit-selectors are either term selectors or type selectors. A term
- % selector selects a subterm f/n of a term, where f is a functor
- % (identified by the cons_id), and n an integer. A type selector
- % designates any subterm that has that specific type.
+ % Unit-selectors are either term selectors or type selectors.
+ % - A term selector selects a subterm f/n of a term, where f is a functor
+ % (identified by the cons_id), and n an integer.
+ % - A type selector designates any subterm that has that specific type.
%
:- type unit_selector
---> termsel(cons_id, int) % term selector
@@ -429,6 +675,8 @@
% Stuff for the `structure_reuse_info' pragma.
%
+:- interface.
+
:- type dead_var == prog_var.
:- type dead_vars == list(dead_var).
:- type dead_datastruct == datastruct.
@@ -468,9 +716,11 @@
%-----------------------------------------------------------------------------%
%
-% Stuff for the `unused_args' pragma
+% Stuff for the `unused_args' pragma.
%
+:- interface.
+
% This `mode_num' type is only used for mode numbers written out in
% automatically-generated `pragma unused_args' pragmas in `.opt' files.
% The mode_num gets converted to an HLDS proc_id by make_hlds.m.
@@ -481,9 +731,11 @@
%-----------------------------------------------------------------------------%
%
-% Stuff for the `exceptions' pragma
+% Stuff for the `exceptions' pragma.
%
+:- interface.
+
:- type exception_status
---> will_not_throw
% This procedure will not throw an exception.
@@ -511,9 +763,11 @@
%-----------------------------------------------------------------------------%
%
-% Stuff for the trailing analysis
+% Stuff for the trailing analysis.
%
+:- interface.
+
:- type trailing_status
---> trail_may_modify
; trail_will_not_modify
@@ -521,9 +775,11 @@
%-----------------------------------------------------------------------------%
%
-% Stuff for minimal model tabling analysis
+% Stuff for minimal model tabling analysis.
%
+:- interface.
+
:- type mm_tabling_status
---> mm_tabled_may_call
; mm_tabled_will_not_call
@@ -531,9 +787,11 @@
%-----------------------------------------------------------------------------%
%
-% Stuff for the `type_spec' pragma
+% Stuff for the `type_spec' pragma.
%
+:- interface.
+
% The type substitution for a `pragma type_spec' declaration.
% Elsewhere in the compiler we generally use the `tsubst' type
% which is a map rather than an assoc_list.
@@ -542,9 +800,11 @@
%-----------------------------------------------------------------------------%
%
-% Stuff for `foreign_code' pragma
+% Stuff for `foreign_code' pragma.
%
+:- interface.
+
% This type holds information about the implementation details
% of procedures defined via `pragma foreign_code'.
%
@@ -573,32 +833,31 @@
% This is a foreign language definition of a model_non
% procedure.
+ % The info saved for the time when backtracking reenters
+ % this procedure is stored in a data structure. This arg
+ % contains the field declarations.
string,
maybe(prog_context),
- % The info saved for the time when backtracking reenters
- % this procedure is stored in a data structure. This arg
- % contains the field declarations.
+ % Gives the code to be executed when the procedure is
+ % called for the first time. This code may access the
+ % input variables.
string,
maybe(prog_context),
- % Gives the code to be executed when the procedure is
- % called for the first time. This code may access the
- % input variables.
+ % Gives the code to be executed when control backtracks
+ % into the procedure. This code may not access the input
+ % variables.
string,
maybe(prog_context),
- % Gives the code to be executed when control backtracks
- % into the procedure. This code may not access the input
- % variables.
+ % How should the shared code be treated during code generation.
foreign_proc_shared_code_treatment,
- % How should the shared code be treated during code
- % generation.
+ % Shared code that is executed after both the previous
+ % code fragments. May not access the input variables.
string,
maybe(prog_context)
- % Shared code that is executed after both the previous
- % code fragments. May not access the input variables.
)
; fc_impl_import(
@@ -617,8 +876,8 @@
; shared_code_share
; shared_code_automatic.
+ % In reverse order.
:- type foreign_import_module_info_list == list(foreign_import_module_info).
- % in reverse order
:- type foreign_import_module_info
---> foreign_import_module_info(
@@ -629,9 +888,11 @@
%-----------------------------------------------------------------------------%
%
-% Stuff for the `foreign_export_enum' pragma
+% Stuff for the `foreign_export_enum' pragma.
%
+:- interface.
+
:- type uppercase_export_enum
---> uppercase_export_enum
; do_not_uppercase_export_enum.
@@ -644,11 +905,18 @@
:- func default_export_enum_attributes = export_enum_attributes.
+:- implementation.
+
+default_export_enum_attributes =
+ export_enum_attributes(no, do_not_uppercase_export_enum).
+
%-----------------------------------------------------------------------------%
%
-% Stuff for the `require_feature_set' pragma
+% Stuff for the `require_feature_set' pragma.
%
+:- interface.
+
:- type required_feature
---> reqf_concurrency
; reqf_single_prec_float
@@ -661,9 +929,11 @@
%-----------------------------------------------------------------------------%
%
-% Type classes
+% Type classes.
%
+:- interface.
+
% A class constraint represents a constraint that a given list of types
% is a member of the specified type class. It is an invariant of this data
% structure that the types in a class constraint do not contain any
@@ -742,7 +1012,7 @@
%-----------------------------------------------------------------------------%
%
-% Some more stuff for the foreign language interface
+% Some more stuff for the foreign language interface.
%
:- interface.
@@ -966,13 +1236,113 @@
:- type pragma_foreign_proc_extra_attributes ==
list(pragma_foreign_proc_extra_attribute).
+:- implementation.
+
+ % If you add an attribute you may need to modify
+ % `foreign_proc_attributes_to_strings'.
+ %
+:- type pragma_foreign_proc_attributes
+ ---> attributes(
+ attr_foreign_language :: foreign_language,
+ attr_may_call_mercury :: proc_may_call_mercury,
+ attr_thread_safe :: proc_thread_safe,
+ attr_tabled_for_io :: proc_tabled_for_io,
+ attr_purity :: purity,
+ attr_terminates :: proc_terminates,
+ attr_user_annotated_sharing :: user_annotated_sharing,
+ attr_may_throw_exception :: proc_may_throw_exception,
+
+ % There is some special case behaviour for pragma c_code
+ % and pragma import purity if legacy_purity_behaviour is `yes'.
+ attr_legacy_purity_behaviour :: bool,
+ attr_ordinary_despite_detism :: bool,
+ attr_may_modify_trail :: proc_may_modify_trail,
+ attr_may_call_mm_tabled :: may_call_mm_tabled,
+ attr_box_policy :: box_policy,
+ attr_affects_liveness :: proc_affects_liveness,
+ attr_allocates_memory :: proc_allocates_memory,
+ attr_registers_roots :: proc_registers_roots,
+ attr_may_duplicate :: maybe(proc_may_duplicate),
+ attr_extra_attributes ::
+ list(pragma_foreign_proc_extra_attribute)
+ ).
+
+default_attributes(Language) =
+ attributes(Language, proc_may_call_mercury, proc_not_thread_safe,
+ proc_not_tabled_for_io, purity_impure, depends_on_mercury_calls,
+ no_user_annotated_sharing, default_exception_behaviour,
+ no, no, proc_may_modify_trail, default_calls_mm_tabled,
+ native_if_possible, proc_default_affects_liveness,
+ proc_default_allocates_memory, proc_default_registers_roots,
+ no, []).
+
+get_may_call_mercury(Attrs) = Attrs ^ attr_may_call_mercury.
+get_thread_safe(Attrs) = Attrs ^ attr_thread_safe.
+get_foreign_language(Attrs) = Attrs ^ attr_foreign_language.
+get_tabled_for_io(Attrs) = Attrs ^ attr_tabled_for_io.
+get_purity(Attrs) = Attrs ^ attr_purity.
+get_terminates(Attrs) = Attrs ^ attr_terminates.
+get_user_annotated_sharing(Attrs) = Attrs ^ attr_user_annotated_sharing.
+get_may_throw_exception(Attrs) = Attrs ^ attr_may_throw_exception.
+get_legacy_purity_behaviour(Attrs) = Attrs ^ attr_legacy_purity_behaviour.
+get_ordinary_despite_detism(Attrs) = Attrs ^ attr_ordinary_despite_detism.
+get_may_modify_trail(Attrs) = Attrs ^ attr_may_modify_trail.
+get_may_call_mm_tabled(Attrs) = Attrs ^ attr_may_call_mm_tabled.
+get_box_policy(Attrs) = Attrs ^ attr_box_policy.
+get_affects_liveness(Attrs) = Attrs ^ attr_affects_liveness.
+get_allocates_memory(Attrs) = Attrs ^ attr_allocates_memory.
+get_registers_roots(Attrs) = Attrs ^ attr_registers_roots.
+get_may_duplicate(Attrs) = Attrs ^ attr_may_duplicate.
+get_extra_attributes(Attrs) = Attrs ^ attr_extra_attributes.
+
+set_may_call_mercury(MayCallMercury, !Attrs) :-
+ !Attrs ^ attr_may_call_mercury := MayCallMercury.
+set_thread_safe(ThreadSafe, !Attrs) :-
+ !Attrs ^ attr_thread_safe := ThreadSafe.
+set_foreign_language(ForeignLanguage, !Attrs) :-
+ !Attrs ^ attr_foreign_language := ForeignLanguage.
+set_tabled_for_io(TabledForIo, !Attrs) :-
+ !Attrs ^ attr_tabled_for_io := TabledForIo.
+set_purity(Purity, !Attrs) :-
+ !Attrs ^ attr_purity := Purity.
+set_terminates(Terminates, !Attrs) :-
+ !Attrs ^ attr_terminates := Terminates.
+set_user_annotated_sharing(UserSharing, !Attrs) :-
+ !Attrs ^ attr_user_annotated_sharing := UserSharing.
+set_may_throw_exception(MayThrowException, !Attrs) :-
+ !Attrs ^ attr_may_throw_exception := MayThrowException.
+set_legacy_purity_behaviour(Legacy, !Attrs) :-
+ !Attrs ^ attr_legacy_purity_behaviour := Legacy.
+set_ordinary_despite_detism(OrdinaryDespiteDetism, !Attrs) :-
+ !Attrs ^ attr_ordinary_despite_detism := OrdinaryDespiteDetism.
+set_may_modify_trail(MayModifyTrail, !Attrs) :-
+ !Attrs ^ attr_may_modify_trail := MayModifyTrail.
+set_may_call_mm_tabled(MayCallMM_Tabled, !Attrs) :-
+ !Attrs ^ attr_may_call_mm_tabled := MayCallMM_Tabled.
+set_box_policy(BoxPolicyStr, !Attrs) :-
+ !Attrs ^ attr_box_policy := BoxPolicyStr.
+set_affects_liveness(AffectsLiveness, !Attrs) :-
+ !Attrs ^ attr_affects_liveness := AffectsLiveness.
+set_allocates_memory(AllocatesMemory, !Attrs) :-
+ !Attrs ^ attr_allocates_memory := AllocatesMemory.
+set_registers_roots(RegistersRoots, !Attrs) :-
+ !Attrs ^ attr_registers_roots := RegistersRoots.
+set_may_duplicate(MayDuplicate, !Attrs) :-
+ !Attrs ^ attr_may_duplicate := MayDuplicate.
+
+add_extra_attribute(NewAttribute, !Attrs) :-
+ !Attrs ^ attr_extra_attributes :=
+ [NewAttribute | !.Attrs ^ attr_extra_attributes].
+
%-----------------------------------------------------------------------------%
%
-% Goals
+% Goals.
%
% NOTE: the representation of goals in the parse tree is defined in
-% prog_item.m.
+% prog_item.m.
+
+:- interface.
:- type trace_expr(Base)
---> trace_base(Base)
@@ -1024,6 +1394,17 @@
%
:- type prog_context == term.context.
+%-----------------------------------------------------------------------------%
+%
+% Renaming
+%
+% The predicates here are similar to the "apply_variable_renaming" family of
+% predicates in library/term.m, but they allow the caller to specify that all
+% variables in the data structure being updated must appear in the renaming.
+%
+
+:- interface.
+
:- type must_rename
---> must_rename
; need_not_rename.
@@ -1043,11 +1424,57 @@
:- pred rename_var(must_rename::in, map(var(V), var(V))::in,
var(V)::in, var(V)::out) is det.
+:- implementation.
+
+rename_vars_in_term(Must, Renaming, Term0, Term) :-
+ (
+ Term0 = variable(Var0, Context),
+ rename_var(Must, Renaming, Var0, Var),
+ Term = variable(Var, Context)
+ ;
+ Term0 = functor(ConsId, Args0, Context),
+ rename_vars_in_term_list(Must, Renaming, Args0, Args),
+ Term = functor(ConsId, Args, Context)
+ ).
+
+rename_vars_in_term_list(_Must, _Renaming, [], []).
+rename_vars_in_term_list(Must, Renaming, [Term0 | Terms0], [Term | Terms]) :-
+ rename_vars_in_term(Must, Renaming, Term0, Term),
+ rename_vars_in_term_list(Must, Renaming, Terms0, Terms).
+
+rename_vars_in_var_set(Must, Renaming, Vars0, Vars) :-
+ set.to_sorted_list(Vars0, VarsList0),
+ rename_var_list(Must, Renaming, VarsList0, VarsList),
+ set.list_to_set(VarsList, Vars).
+
+rename_var_list(_Must, _Renaming, [], []).
+rename_var_list(Must, Renaming, [Var0 | Vars0], [Var | Vars]) :-
+ rename_var(Must, Renaming, Var0, Var),
+ rename_var_list(Must, Renaming, Vars0, Vars).
+
+rename_var(Must, Renaming, Var0, Var) :-
+ ( map.search(Renaming, Var0, VarPrime) ->
+ Var = VarPrime
+ ;
+ (
+ Must = need_not_rename,
+ Var = Var0
+ ;
+ Must = must_rename,
+ term.var_to_int(Var0, Var0Int),
+ string.format("rename_var: no substitute for var %i", [i(Var0Int)],
+ Msg),
+ unexpected(this_file, Msg)
+ )
+ ).
+
%-----------------------------------------------------------------------------%
%
-% Cons ids
+% Cons ids.
%
+:- interface.
+
% The representation of cons_ids below is a compromise. The cons_id
% type must be defined here, in a submodule of parse_tree.m, because
% it is a component of insts. However, after the program has been read
@@ -1064,7 +1491,7 @@
% for cons_ids, one defined here for use in the parse tree and one
% defined in hlds_data.m for use in the HLDS. We could distinguish
% the two by having the HLDS cons_id have a definition such as
- % hlds_cons_id ---> parse_cons_id(parse_cons_id) ; ...
+ % cons_id ---> parse_cons_id(parse_cons_id) ; ...
% or, alternatively, by making cons_id parametric in the type of
% constants, and substitute different constant types (since all the
% cons_ids that refer to HLDS concepts are constants).
@@ -1086,22 +1513,34 @@
% equivalents by the unshroud functions in hlds_pred.m, and for
% printing for diagnostics.
%
-:- type shrouded_pred_id ---> shrouded_pred_id(int).
-:- type shrouded_proc_id ---> shrouded_proc_id(int).
+:- type shrouded_pred_id ---> shrouded_pred_id(int).
+:- type shrouded_proc_id ---> shrouded_proc_id(int).
:- type shrouded_pred_proc_id ---> shrouded_pred_proc_id(int, int).
:- type cons_id
- ---> cons(sym_name, arity) % name, arity
- % Tuples have cons_id `cons(unqualified("{}"), Arity)'.
+ ---> cons(sym_name, arity, type_ctor)
+ % Before post-typecheck, the type_ctor field is not meaningful.
+ %
+ % Before post-typecheck, tuples and characters have this cons_id.
+ % For tuples, this will be of the form
+ % `cons(unqualified("{}"), Arity, _)',
+ % while for charaters, this will be of the form
+ % `cons(unqualified(Str), 0, _)'
+ % where Str = term_io.quoted_char(Char).
+
+ ; tuple_cons(arity)
+
+ ; closure_cons(shrouded_pred_proc_id, lambda_eval_method)
+ % Note that a closure_cons represents a closure, not just
+ % a code address.
+ % XXX We should have a pred_or_func field as well.
; int_const(int)
- ; string_const(string)
; float_const(float)
- ; implementation_defined_const(string)
+ ; char_const(char)
+ ; string_const(string)
- ; pred_const(shrouded_pred_proc_id, lambda_eval_method)
- % Note that a pred_const represents a closure,
- % not just a code address.
+ ; impl_defined_const(string)
; type_ctor_info_const(
module_name,
@@ -1126,15 +1565,15 @@
% about the table that implements memoization, loop checking
% or the minimal model semantics for the given procedure.
- ; deep_profiling_proc_layout(shrouded_pred_proc_id)
+ ; table_io_decl(shrouded_pred_proc_id)
+ % The address of a structure that describes the layout of the
+ % answer block used by I/O tabling for declarative debugging.
+
+ ; deep_profiling_proc_layout(shrouded_pred_proc_id).
% The Proc_Layout structure of a procedure. Its proc_static field
% is used by deep profiling, as documented in the deep profiling
% paper.
- ; table_io_decl(shrouded_pred_proc_id).
- % The address of a structure that describes the layout of the
- % answer block used by I/O tabling for declarative debugging.
-
% Describe how a lambda expression is to be evaluated.
%
% `normal' is the top-down Mercury execution algorithm.
@@ -1142,11 +1581,58 @@
:- type lambda_eval_method
---> lambda_normal.
+:- func cons_id_dummy_type_ctor = type_ctor.
+
+ % Are the two cons_ids equivalent, modulo any module qualifications?
+ %
+:- pred equivalent_cons_ids(cons_id::in, cons_id::in) is semidet.
+
+:- implementation.
+
+cons_id_dummy_type_ctor = type_ctor(unqualified(""), -1).
+
+equivalent_cons_ids(ConsIdA, ConsIdB) :-
+ (
+ ConsIdA = cons(SymNameA, ArityA, _),
+ ConsIdB = cons(SymNameB, ArityB, _)
+ ->
+ ArityA = ArityB,
+ (
+ SymNameA = unqualified(Name),
+ SymNameB = unqualified(Name)
+ ;
+ SymNameA = unqualified(Name),
+ SymNameB = qualified(_, Name)
+ ;
+ SymNameA = qualified(_, Name),
+ SymNameB = unqualified(Name)
+ ;
+ SymNameA = qualified(Qualifier, Name),
+ SymNameB = qualified(Qualifier, Name)
+ )
+ ;
+ ConsIdA = cons(SymNameA, ArityA, _),
+ ConsIdB = tuple_cons(ArityB)
+ ->
+ ArityA = ArityB,
+ SymNameA = unqualified("{}")
+ ;
+ ConsIdA = tuple_cons(ArityA),
+ ConsIdB = cons(SymNameB, ArityB, _)
+ ->
+ ArityA = ArityB,
+ SymNameB = unqualified("{}")
+ ;
+ ConsIdA = ConsIdB
+ ).
+
%-----------------------------------------------------------------------------%
%
-% Types
+% Types.
%
+:- interface.
+
% This is how types are represented.
% One day we might allow types to take
@@ -1195,9 +1681,14 @@
:- type constructor
---> ctor(
cons_exist :: existq_tvars,
+ % existential constraints
cons_constraints :: list(prog_constraint),
- % existential constraints
+
+ % The cons_id should be cons(SymName, Arity, TypeCtor)
+ % for user-defined types, and tuple_cons(Arity) for the
+ % system-defined tuple types.
cons_name :: sym_name,
+
cons_args :: list(constructor_arg),
cons_context :: prog_context
).
@@ -1322,7 +1813,7 @@
---> builtin_type_int
; builtin_type_float
; builtin_type_string
- ; builtin_type_character.
+ ; builtin_type_char.
:- type type_term == term(tvar_type).
@@ -1375,14 +1866,33 @@
:- pred tvarset_merge_renaming_without_names(tvarset::in, tvarset::in,
tvarset::out, tvar_renaming::out) is det.
+:- implementation.
+
+tvarset_merge_renaming(TVarSetA, TVarSetB, TVarSet, Renaming) :-
+ varset.merge_subst(TVarSetA, TVarSetB, TVarSet, Subst),
+ map.map_values(convert_subst_term_to_tvar, Subst, Renaming).
+
+tvarset_merge_renaming_without_names(TVarSetA, TVarSetB, TVarSet, Renaming) :-
+ varset.merge_subst_without_names(TVarSetA, TVarSetB, TVarSet, Subst),
+ map.map_values(convert_subst_term_to_tvar, Subst, Renaming).
+
+:- pred convert_subst_term_to_tvar(tvar::in, term(tvar_type)::in, tvar::out)
+ is det.
+
+convert_subst_term_to_tvar(_, variable(TVar, _), TVar).
+convert_subst_term_to_tvar(_, functor(_, _, _), _) :-
+ unexpected(this_file, "non-variable found in renaming").
+
%-----------------------------------------------------------------------------%
%
-% Kinds
+% Kinds.
%
- % Note that we don't support any kind other than `star' at the
- % moment. The other kinds are intended for the implementation
- % of constructor classes.
+:- interface.
+
+ % Note that we don't support any kind other than `star' at the moment.
+ % The other kinds are intended for the implementation of constructor
+ % classes.
%
:- type kind
---> kind_star
@@ -1414,11 +1924,30 @@
%
:- func get_type_kind(mer_type) = kind.
+:- implementation.
+
+get_tvar_kind(Map, TVar, Kind) :-
+ ( map.search(Map, TVar, Kind0) ->
+ Kind = Kind0
+ ;
+ Kind = kind_star
+ ).
+
+get_type_kind(type_variable(_, Kind)) = Kind.
+get_type_kind(defined_type(_, _, Kind)) = Kind.
+get_type_kind(builtin_type(_)) = kind_star.
+get_type_kind(higher_order_type(_, _, _, _)) = kind_star.
+get_type_kind(tuple_type(_, Kind)) = Kind.
+get_type_kind(apply_n_type(_, _, Kind)) = Kind.
+get_type_kind(kinded_type(_, Kind)) = Kind.
+
%-----------------------------------------------------------------------------%
%
-% Insts and modes
+% Insts and modes.
%
+:- interface.
+
% This is how instantiatednesses and modes are represented.
%
:- type mer_inst
@@ -1602,9 +2131,11 @@
%-----------------------------------------------------------------------------%
%
-% Module system
+% Module system.
%
+:- interface.
+
:- type backend
---> high_level_backend
; low_level_backend.
@@ -1654,9 +2185,6 @@
---> has_main
; no_main.
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
:- type item_visibility
---> visibility_public
; visibility_private.
@@ -1683,11 +2211,37 @@
:- pred add_all_modules(item_visibility::in, sym_name::in,
used_modules::in, used_modules::out) is det.
+:- implementation.
+
+used_modules_init = used_modules(set.init, set.init).
+
+add_sym_name_module(_Visibility, unqualified(_), !UsedModules).
+add_sym_name_module(Visibility, qualified(ModuleName, _), !UsedModules) :-
+ add_all_modules(Visibility, ModuleName, !UsedModules).
+
+add_all_modules(Visibility, ModuleName @ unqualified(_), !UsedModules) :-
+ add_module(Visibility, ModuleName, !UsedModules).
+add_all_modules(Visibility, ModuleName @ qualified(Parent, _), !UsedModules) :-
+ add_module(Visibility, ModuleName, !UsedModules),
+ add_all_modules(Visibility, Parent, !UsedModules).
+
+:- pred add_module(item_visibility::in, module_name::in,
+ used_modules::in, used_modules::out) is det.
+
+add_module(visibility_public, Module, !UsedModules) :-
+ !UsedModules ^ int_used_modules :=
+ set.insert(!.UsedModules ^ int_used_modules, Module).
+add_module(visibility_private, Module, !UsedModules) :-
+ !UsedModules ^ impl_used_modules :=
+ set.insert(!.UsedModules ^ impl_used_modules, Module).
+
%-----------------------------------------------------------------------------%
%
-% Event specifications
+% Event specifications.
%
+:- interface.
+
:- type event_attribute
---> event_attribute(
attr_num :: int,
@@ -1731,457 +2285,9 @@
).
%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module libs.compiler_util.
-
-:- import_module string.
-
-%-----------------------------------------------------------------------------%
-
-eval_method_to_table_type(EvalMethod) = TableTypeStr :-
- (
- EvalMethod = eval_normal,
- unexpected(this_file, "eval_method_to_table_type: eval_normal")
- ;
- EvalMethod = eval_table_io(_, _),
- unexpected(this_file, "eval_method_to_table_type: eval_table_io")
- ;
- EvalMethod = eval_loop_check,
- TableTypeStr = "MR_TABLE_TYPE_LOOPCHECK"
- ;
- EvalMethod = eval_memo,
- TableTypeStr = "MR_TABLE_TYPE_MEMO"
- ;
- EvalMethod = eval_minimal(stack_copy),
- TableTypeStr = "MR_TABLE_TYPE_MINIMAL_MODEL_STACK_COPY"
- ;
- EvalMethod = eval_minimal(own_stacks_consumer),
- unexpected(this_file, "eval_method_to_table_type: own_stacks_consumer")
- ;
- EvalMethod = eval_minimal(own_stacks_generator),
- TableTypeStr = "MR_TABLE_TYPE_MINIMAL_MODEL_OWN_STACKS"
- ).
-
-default_memo_table_attributes =
- table_attributes(all_strict, no, table_dont_gather_statistics,
- table_dont_allow_reset).
-
-%-----------------------------------------------------------------------------%
-%
-% Some more stuff for the foreign language interface
-%
-
- % If you add an attribute you may need to modify
- % `foreign_proc_attributes_to_strings'.
- %
-:- type pragma_foreign_proc_attributes
- ---> attributes(
- attr_foreign_language :: foreign_language,
- attr_may_call_mercury :: proc_may_call_mercury,
- attr_thread_safe :: proc_thread_safe,
- attr_tabled_for_io :: proc_tabled_for_io,
- attr_purity :: purity,
- attr_terminates :: proc_terminates,
- attr_user_annotated_sharing :: user_annotated_sharing,
- attr_may_throw_exception :: proc_may_throw_exception,
-
- % There is some special case behaviour for pragma c_code
- % and pragma import purity if legacy_purity_behaviour is `yes'.
- attr_legacy_purity_behaviour :: bool,
- attr_ordinary_despite_detism :: bool,
- attr_may_modify_trail :: proc_may_modify_trail,
- attr_may_call_mm_tabled :: may_call_mm_tabled,
- attr_box_policy :: box_policy,
- attr_affects_liveness :: proc_affects_liveness,
- attr_allocates_memory :: proc_allocates_memory,
- attr_registers_roots :: proc_registers_roots,
- attr_may_duplicate :: maybe(proc_may_duplicate),
- attr_extra_attributes ::
- list(pragma_foreign_proc_extra_attribute)
- ).
-
-default_attributes(Language) =
- attributes(Language, proc_may_call_mercury, proc_not_thread_safe,
- proc_not_tabled_for_io, purity_impure, depends_on_mercury_calls,
- no_user_annotated_sharing, default_exception_behaviour,
- no, no, proc_may_modify_trail, default_calls_mm_tabled,
- native_if_possible, proc_default_affects_liveness,
- proc_default_allocates_memory, proc_default_registers_roots,
- no, []).
-
-get_may_call_mercury(Attrs) = Attrs ^ attr_may_call_mercury.
-get_thread_safe(Attrs) = Attrs ^ attr_thread_safe.
-get_foreign_language(Attrs) = Attrs ^ attr_foreign_language.
-get_tabled_for_io(Attrs) = Attrs ^ attr_tabled_for_io.
-get_purity(Attrs) = Attrs ^ attr_purity.
-get_terminates(Attrs) = Attrs ^ attr_terminates.
-get_user_annotated_sharing(Attrs) = Attrs ^ attr_user_annotated_sharing.
-get_may_throw_exception(Attrs) = Attrs ^ attr_may_throw_exception.
-get_legacy_purity_behaviour(Attrs) = Attrs ^ attr_legacy_purity_behaviour.
-get_ordinary_despite_detism(Attrs) = Attrs ^ attr_ordinary_despite_detism.
-get_may_modify_trail(Attrs) = Attrs ^ attr_may_modify_trail.
-get_may_call_mm_tabled(Attrs) = Attrs ^ attr_may_call_mm_tabled.
-get_box_policy(Attrs) = Attrs ^ attr_box_policy.
-get_affects_liveness(Attrs) = Attrs ^ attr_affects_liveness.
-get_allocates_memory(Attrs) = Attrs ^ attr_allocates_memory.
-get_registers_roots(Attrs) = Attrs ^ attr_registers_roots.
-get_may_duplicate(Attrs) = Attrs ^ attr_may_duplicate.
-get_extra_attributes(Attrs) = Attrs ^ attr_extra_attributes.
-
-set_may_call_mercury(MayCallMercury, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_may_call_mercury := MayCallMercury.
-set_thread_safe(ThreadSafe, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_thread_safe := ThreadSafe.
-set_foreign_language(ForeignLanguage, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_foreign_language := ForeignLanguage.
-set_tabled_for_io(TabledForIo, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_tabled_for_io := TabledForIo.
-set_purity(Purity, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_purity := Purity.
-set_terminates(Terminates, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_terminates := Terminates.
-set_user_annotated_sharing(UserSharing, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_user_annotated_sharing := UserSharing.
-set_may_throw_exception(MayThrowException, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_may_throw_exception := MayThrowException.
-set_legacy_purity_behaviour(Legacy, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_legacy_purity_behaviour := Legacy.
-set_ordinary_despite_detism(OrdinaryDespiteDetism, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_ordinary_despite_detism := OrdinaryDespiteDetism.
-set_may_modify_trail(MayModifyTrail, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_may_modify_trail := MayModifyTrail.
-set_may_call_mm_tabled(MayCallMM_Tabled, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_may_call_mm_tabled := MayCallMM_Tabled.
-set_box_policy(BoxPolicyStr, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_box_policy := BoxPolicyStr.
-set_affects_liveness(AffectsLiveness, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_affects_liveness := AffectsLiveness.
-set_allocates_memory(AllocatesMemory, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_allocates_memory := AllocatesMemory.
-set_registers_roots(RegistersRoots, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_registers_roots := RegistersRoots.
-set_may_duplicate(MayDuplicate, Attrs0, Attrs) :-
- Attrs = Attrs0 ^ attr_may_duplicate := MayDuplicate.
-
-add_extra_attribute(NewAttribute, Attributes0,
- Attributes0 ^ attr_extra_attributes :=
- [NewAttribute | Attributes0 ^ attr_extra_attributes]).
-
-%-----------------------------------------------------------------------------%
-%
-% Renaming
-%
-% The predicates here are similar to the "apply_variable_renaming" family of
-% predicates in library/term.m, but they allow the caller to specify that all
-% variables in the data structure being updated must appear in the renaming.
-
-rename_vars_in_term(Must, Renaming, Term0, Term) :-
- (
- Term0 = variable(Var0, Context),
- rename_var(Must, Renaming, Var0, Var),
- Term = variable(Var, Context)
- ;
- Term0 = functor(ConsId, Args0, Context),
- rename_vars_in_term_list(Must, Renaming, Args0, Args),
- Term = functor(ConsId, Args, Context)
- ).
-
-rename_vars_in_term_list(_Must, _Renaming, [], []).
-rename_vars_in_term_list(Must, Renaming, [Term0 | Terms0], [Term | Terms]) :-
- rename_vars_in_term(Must, Renaming, Term0, Term),
- rename_vars_in_term_list(Must, Renaming, Terms0, Terms).
-
-rename_vars_in_var_set(Must, Renaming, Vars0, Vars) :-
- set.to_sorted_list(Vars0, VarsList0),
- rename_var_list(Must, Renaming, VarsList0, VarsList),
- set.list_to_set(VarsList, Vars).
-
-rename_var_list(_Must, _Renaming, [], []).
-rename_var_list(Must, Renaming, [Var0 | Vars0], [Var | Vars]) :-
- rename_var(Must, Renaming, Var0, Var),
- rename_var_list(Must, Renaming, Vars0, Vars).
-
-rename_var(Must, Renaming, Var0, Var) :-
- ( map.search(Renaming, Var0, VarPrime) ->
- Var = VarPrime
- ;
- (
- Must = need_not_rename,
- Var = Var0
- ;
- Must = must_rename,
- term.var_to_int(Var0, Var0Int),
- string.format("rename_var: no substitute for var %i", [i(Var0Int)],
- Msg),
- unexpected(this_file, Msg)
- )
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% Purity
-%
-
-less_pure(P1, P2) :-
- \+ ( worst_purity(P1, P2) = P2).
-
- % worst_purity/3 could be written more compactly, but this definition
- % guarantees us a determinism error if we add to type `purity'. We also
- % define less_pure/2 in terms of worst_purity/3 rather than the other way
- % around for the same reason.
- %
-worst_purity(purity_pure, purity_pure) = purity_pure.
-worst_purity(purity_pure, purity_semipure) = purity_semipure.
-worst_purity(purity_pure, purity_impure) = purity_impure.
-worst_purity(purity_semipure, purity_pure) = purity_semipure.
-worst_purity(purity_semipure, purity_semipure) = purity_semipure.
-worst_purity(purity_semipure, purity_impure) = purity_impure.
-worst_purity(purity_impure, purity_pure) = purity_impure.
-worst_purity(purity_impure, purity_semipure) = purity_impure.
-worst_purity(purity_impure, purity_impure) = purity_impure.
-
- % best_purity/3 is written as a switch for the same reason as
- % worst_purity/3.
- %
-best_purity(purity_pure, purity_pure) = purity_pure.
-best_purity(purity_pure, purity_semipure) = purity_pure.
-best_purity(purity_pure, purity_impure) = purity_pure.
-best_purity(purity_semipure, purity_pure) = purity_pure.
-best_purity(purity_semipure, purity_semipure) = purity_semipure.
-best_purity(purity_semipure, purity_impure) = purity_semipure.
-best_purity(purity_impure, purity_pure) = purity_pure.
-best_purity(purity_impure, purity_semipure) = purity_semipure.
-best_purity(purity_impure, purity_impure) = purity_impure.
-
-%-----------------------------------------------------------------------------%
-%
-% Determinism
-%
-
-determinism_components(detism_det, cannot_fail, at_most_one).
-determinism_components(detism_semi, can_fail, at_most_one).
-determinism_components(detism_multi, cannot_fail, at_most_many).
-determinism_components(detism_non, can_fail, at_most_many).
-determinism_components(detism_cc_multi, cannot_fail, at_most_many_cc).
-determinism_components(detism_cc_non, can_fail, at_most_many_cc).
-determinism_components(detism_erroneous, cannot_fail, at_most_zero).
-determinism_components(detism_failure, can_fail, at_most_zero).
-
-det_conjunction_detism(DetismA, DetismB, Detism) :-
- % When figuring out the determinism of a conjunction, if the second goal
- % is unreachable, then then the determinism of the conjunction is just
- % the determinism of the first goal.
-
- determinism_components(DetismA, CanFailA, MaxSolnA),
- (
- MaxSolnA = at_most_zero,
- Detism = DetismA
- ;
- ( MaxSolnA = at_most_one
- ; MaxSolnA = at_most_many
- ; MaxSolnA = at_most_many_cc
- ),
- determinism_components(DetismB, CanFailB, MaxSolnB),
- det_conjunction_canfail(CanFailA, CanFailB, CanFail),
- det_conjunction_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
- determinism_components(Detism, CanFail, MaxSoln)
- ).
-
-det_par_conjunction_detism(DetismA, DetismB, Detism) :-
- % Figuring out the determinism of a parallel conjunction is much easier
- % than for a sequential conjunction, since you simply ignore the case
- % where the second goal is unreachable. Just do a normal solution count.
-
- determinism_components(DetismA, CanFailA, MaxSolnA),
- determinism_components(DetismB, CanFailB, MaxSolnB),
- det_conjunction_canfail(CanFailA, CanFailB, CanFail),
- det_conjunction_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
- determinism_components(Detism, CanFail, MaxSoln).
-
-det_switch_detism(DetismA, DetismB, Detism) :-
- determinism_components(DetismA, CanFailA, MaxSolnA),
- determinism_components(DetismB, CanFailB, MaxSolnB),
- det_switch_canfail(CanFailA, CanFailB, CanFail),
- det_switch_maxsoln(MaxSolnA, MaxSolnB, MaxSoln),
- determinism_components(Detism, CanFail, MaxSoln).
-
-%-----------------------------------------------------------------------------%
-%
-% The predicates in this section do abstract interpretation to count
-% the number of solutions and the possible number of failures.
-%
-% If the num_solns is at_most_many_cc, this means that the goal might have
-% many logical solutions if there were no pruning, but that the goal occurs
-% in a single-solution context, so only the first solution will be
-% returned.
-%
-% The reason why we don't throw an exception in det_switch_maxsoln and
-% det_disjunction_maxsoln is given in the documentation of the test case
-% invalid/magicbox.m.
-
-det_conjunction_maxsoln(at_most_zero, at_most_zero, at_most_zero).
-det_conjunction_maxsoln(at_most_zero, at_most_one, at_most_zero).
-det_conjunction_maxsoln(at_most_zero, at_most_many_cc, at_most_zero).
-det_conjunction_maxsoln(at_most_zero, at_most_many, at_most_zero).
-
-det_conjunction_maxsoln(at_most_one, at_most_zero, at_most_zero).
-det_conjunction_maxsoln(at_most_one, at_most_one, at_most_one).
-det_conjunction_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
-det_conjunction_maxsoln(at_most_one, at_most_many, at_most_many).
-
-det_conjunction_maxsoln(at_most_many_cc, at_most_zero, at_most_zero).
-det_conjunction_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
-det_conjunction_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
-det_conjunction_maxsoln(at_most_many_cc, at_most_many, _) :-
- % If the first conjunct could be cc pruned, the second conj ought to have
- % been cc pruned too.
- unexpected(this_file, "det_conjunction_maxsoln: many_cc , many").
-
-det_conjunction_maxsoln(at_most_many, at_most_zero, at_most_zero).
-det_conjunction_maxsoln(at_most_many, at_most_one, at_most_many).
-det_conjunction_maxsoln(at_most_many, at_most_many_cc, at_most_many).
-det_conjunction_maxsoln(at_most_many, at_most_many, at_most_many).
-
-det_conjunction_canfail(can_fail, can_fail, can_fail).
-det_conjunction_canfail(can_fail, cannot_fail, can_fail).
-det_conjunction_canfail(cannot_fail, can_fail, can_fail).
-det_conjunction_canfail(cannot_fail, cannot_fail, cannot_fail).
-
-det_disjunction_maxsoln(at_most_zero, at_most_zero, at_most_zero).
-det_disjunction_maxsoln(at_most_zero, at_most_one, at_most_one).
-det_disjunction_maxsoln(at_most_zero, at_most_many_cc, at_most_many_cc).
-det_disjunction_maxsoln(at_most_zero, at_most_many, at_most_many).
-
-det_disjunction_maxsoln(at_most_one, at_most_zero, at_most_one).
-det_disjunction_maxsoln(at_most_one, at_most_one, at_most_many).
-det_disjunction_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
-det_disjunction_maxsoln(at_most_one, at_most_many, at_most_many).
-
-det_disjunction_maxsoln(at_most_many_cc, at_most_zero, at_most_many_cc).
-det_disjunction_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
-det_disjunction_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
-det_disjunction_maxsoln(at_most_many_cc, at_most_many, at_most_many_cc).
-
-det_disjunction_maxsoln(at_most_many, at_most_zero, at_most_many).
-det_disjunction_maxsoln(at_most_many, at_most_one, at_most_many).
-det_disjunction_maxsoln(at_most_many, at_most_many_cc, at_most_many_cc).
-det_disjunction_maxsoln(at_most_many, at_most_many, at_most_many).
-
-det_disjunction_canfail(can_fail, can_fail, can_fail).
-det_disjunction_canfail(can_fail, cannot_fail, cannot_fail).
-det_disjunction_canfail(cannot_fail, can_fail, cannot_fail).
-det_disjunction_canfail(cannot_fail, cannot_fail, cannot_fail).
-
-det_switch_maxsoln(at_most_zero, at_most_zero, at_most_zero).
-det_switch_maxsoln(at_most_zero, at_most_one, at_most_one).
-det_switch_maxsoln(at_most_zero, at_most_many_cc, at_most_many_cc).
-det_switch_maxsoln(at_most_zero, at_most_many, at_most_many).
-
-det_switch_maxsoln(at_most_one, at_most_zero, at_most_one).
-det_switch_maxsoln(at_most_one, at_most_one, at_most_one).
-det_switch_maxsoln(at_most_one, at_most_many_cc, at_most_many_cc).
-det_switch_maxsoln(at_most_one, at_most_many, at_most_many).
-
-det_switch_maxsoln(at_most_many_cc, at_most_zero, at_most_many_cc).
-det_switch_maxsoln(at_most_many_cc, at_most_one, at_most_many_cc).
-det_switch_maxsoln(at_most_many_cc, at_most_many_cc, at_most_many_cc).
-det_switch_maxsoln(at_most_many_cc, at_most_many, at_most_many_cc).
-
-det_switch_maxsoln(at_most_many, at_most_zero, at_most_many).
-det_switch_maxsoln(at_most_many, at_most_one, at_most_many).
-det_switch_maxsoln(at_most_many, at_most_many_cc, at_most_many_cc).
-det_switch_maxsoln(at_most_many, at_most_many, at_most_many).
-
-det_switch_canfail(can_fail, can_fail, can_fail).
-det_switch_canfail(can_fail, cannot_fail, can_fail).
-det_switch_canfail(cannot_fail, can_fail, can_fail).
-det_switch_canfail(cannot_fail, cannot_fail, cannot_fail).
-
-det_negation_det(detism_det, yes(detism_failure)).
-det_negation_det(detism_semi, yes(detism_semi)).
-det_negation_det(detism_multi, no).
-det_negation_det(detism_non, no).
-det_negation_det(detism_cc_multi, no).
-det_negation_det(detism_cc_non, no).
-det_negation_det(detism_erroneous, yes(detism_erroneous)).
-det_negation_det(detism_failure, yes(detism_det)).
-
-%-----------------------------------------------------------------------------%
-
-tvarset_merge_renaming(TVarSetA, TVarSetB, TVarSet, Renaming) :-
- varset.merge_subst(TVarSetA, TVarSetB, TVarSet, Subst),
- map.map_values(convert_subst_term_to_tvar, Subst, Renaming).
-
-tvarset_merge_renaming_without_names(TVarSetA, TVarSetB, TVarSet, Renaming) :-
- varset.merge_subst_without_names(TVarSetA, TVarSetB, TVarSet, Subst),
- map.map_values(convert_subst_term_to_tvar, Subst, Renaming).
-
-:- pred convert_subst_term_to_tvar(tvar::in, term(tvar_type)::in, tvar::out)
- is det.
-
-convert_subst_term_to_tvar(_, variable(TVar, _), TVar).
-convert_subst_term_to_tvar(_, functor(_, _, _), _) :-
- unexpected(this_file, "non-variable found in renaming").
-
-%-----------------------------------------------------------------------------%
-
-get_tvar_kind(Map, TVar, Kind) :-
- ( map.search(Map, TVar, Kind0) ->
- Kind = Kind0
- ;
- Kind = kind_star
- ).
-
-get_type_kind(type_variable(_, Kind)) = Kind.
-get_type_kind(defined_type(_, _, Kind)) = Kind.
-get_type_kind(builtin_type(_)) = kind_star.
-get_type_kind(higher_order_type(_, _, _, _)) = kind_star.
-get_type_kind(tuple_type(_, Kind)) = Kind.
-get_type_kind(apply_n_type(_, _, Kind)) = Kind.
-get_type_kind(kinded_type(_, Kind)) = Kind.
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-used_modules_init = used_modules(set.init, set.init).
-
-%-----------------------------------------------------------------------------%
-
-add_sym_name_module(_Status, unqualified(_), !UsedModules).
-add_sym_name_module(Visibility, qualified(ModuleName, _), !UsedModules) :-
- add_all_modules(Visibility, ModuleName, !UsedModules).
-
-add_all_modules(Visibility, ModuleName @ unqualified(_), !UsedModules) :-
- add_module(Visibility, ModuleName, !UsedModules).
-add_all_modules(Visibility, ModuleName @ qualified(Parent, _), !UsedModules) :-
- add_module(Visibility, ModuleName, !UsedModules),
- add_all_modules(Visibility, Parent, !UsedModules).
-
-:- pred add_module(item_visibility::in, module_name::in,
- used_modules::in, used_modules::out) is det.
-
-add_module(visibility_public, Module, !UsedModules) :-
- !:UsedModules = !.UsedModules ^ int_used_modules :=
- set.insert(!.UsedModules ^ int_used_modules, Module).
-add_module(visibility_private, Module, !UsedModules) :-
- !:UsedModules = !.UsedModules ^ impl_used_modules :=
- set.insert(!.UsedModules ^ impl_used_modules, Module).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-%
-% Stuff for the `foreign_export_enum' pragma
-%
-
-default_export_enum_attributes =
- export_enum_attributes(no, do_not_uppercase_export_enum).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
:- func this_file = string.
this_file = "prog_data.m".
Index: compiler/prog_event.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_event.m,v
retrieving revision 1.15
diff -u -r1.15 prog_event.m
--- compiler/prog_event.m 16 Jul 2008 03:30:30 -0000 1.15
+++ compiler/prog_event.m 30 May 2009 06:00:26 -0000
@@ -61,6 +61,7 @@
:- import_module libs.compiler_util.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_util.m,v
retrieving revision 1.65
diff -u -r1.65 prog_io_util.m
--- compiler/prog_io_util.m 3 Dec 2008 05:01:41 -0000 1.65
+++ compiler/prog_io_util.m 5 Feb 2009 08:24:51 -0000
@@ -814,14 +814,13 @@
:- pred convert_bound_inst(allow_constrained_inst_var::in, term::in,
bound_inst::out) is semidet.
-convert_bound_inst(AllowConstrainedInstVar, InstTerm,
- bound_functor(ConsId, Args)) :-
+convert_bound_inst(AllowConstrainedInstVar, InstTerm, BoundInst) :-
InstTerm = term.functor(Functor, Args0, _),
(
Functor = term.atom(_),
sym_name_and_args(InstTerm, SymName, Args1),
list.length(Args1, Arity),
- ConsId = cons(SymName, Arity)
+ ConsId = cons(SymName, Arity, cons_id_dummy_type_ctor)
;
Functor = term.implementation_defined(_),
% Implementation-defined literals should not appear in inst
@@ -836,7 +835,8 @@
list.length(Args1, Arity),
ConsId = make_functor_cons_id(Functor, Arity)
),
- convert_inst_list(AllowConstrainedInstVar, Args1, Args).
+ convert_inst_list(AllowConstrainedInstVar, Args1, Args),
+ BoundInst = bound_functor(ConsId, Args).
disjunction_to_list(Term, List) :-
binop_term_to_list(";", Term, List).
Index: compiler/prog_mode.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_mode.m,v
retrieving revision 1.21
diff -u -r1.21 prog_mode.m
--- compiler/prog_mode.m 22 Jan 2008 15:06:15 -0000 1.21
+++ compiler/prog_mode.m 6 Feb 2009 03:47:26 -0000
@@ -5,13 +5,13 @@
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
-%
+%
% File: prog_mode.m.
% Main author: fjh.
-%
+%
% Utility predicates dealing with modes and insts that do not require access
% to the HLDS. (The predicates that do are in mode_util.m.)
-%
+%
%-----------------------------------------------------------------------------%
:- module parse_tree.prog_mode.
@@ -105,9 +105,13 @@
:- pred get_arg_insts(mer_inst::in, cons_id::in, arity::in,
list(mer_inst)::out) is semidet.
- % Given a list of bound_insts, get the corresponding list of cons_ids
+ % Given a (list of) bound_insts, get the corresponding cons_ids.
+ % The type_ctor, if given,
%
-:- pred functors_to_cons_ids(list(bound_inst)::in, list(cons_id)::out) is det.
+:- pred bound_inst_to_cons_id(type_ctor::in, bound_inst::in,
+ cons_id::out) is det.
+:- pred bound_insts_to_cons_ids(type_ctor::in, list(bound_inst)::in,
+ list(cons_id)::out) is det.
:- pred mode_id_to_int(mode_id::in, int::out) is det.
@@ -502,10 +506,19 @@
%-----------------------------------------------------------------------------%
-functors_to_cons_ids([], []).
-functors_to_cons_ids([Functor | Functors], [ConsId | ConsIds]) :-
- Functor = bound_functor(ConsId, _ArgInsts),
- functors_to_cons_ids(Functors, ConsIds).
+bound_inst_to_cons_id(TypeCtor, BoundInst, ConsId) :-
+ BoundInst = bound_functor(ConsId0, _ArgInsts),
+ ( ConsId0 = cons(SymName, Arity, _TypeCtor) ->
+ ConsId = cons(SymName, Arity, TypeCtor)
+ ;
+ ConsId = ConsId0
+ ).
+
+bound_insts_to_cons_ids(_, [], []).
+bound_insts_to_cons_ids(TypeCtor, [BoundInst | BoundInsts],
+ [ConsId | ConsIds]) :-
+ bound_inst_to_cons_id(TypeCtor, BoundInst, ConsId),
+ bound_insts_to_cons_ids(TypeCtor, BoundInsts, ConsIds).
%-----------------------------------------------------------------------------%
@@ -531,13 +544,16 @@
is semidet.
get_arg_insts_2([BoundInst | BoundInsts], ConsId, ArgInsts) :-
- ( BoundInst = bound_functor(ConsId, ArgInsts0) ->
+ (
+ BoundInst = bound_functor(FunctorConsId, ArgInsts0),
+ equivalent_cons_ids(ConsId, FunctorConsId)
+ ->
ArgInsts = ArgInsts0
;
get_arg_insts_2(BoundInsts, ConsId, ArgInsts)
).
- % In case we later decided to change the representation of mode_ids.
+ % In case we later decide to change the representation of mode_ids.
mode_id_to_int(mode_id(_, X), X).
%-----------------------------------------------------------------------------%
@@ -552,16 +568,15 @@
strip_builtin_qualifiers_from_mode((Initial0 -> Final0), (Initial -> Final)) :-
strip_builtin_qualifiers_from_inst(Initial0, Initial),
strip_builtin_qualifiers_from_inst(Final0, Final).
-
strip_builtin_qualifiers_from_mode(user_defined_mode(SymName0, Insts0),
user_defined_mode(SymName, Insts)) :-
strip_builtin_qualifiers_from_inst_list(Insts0, Insts),
strip_builtin_qualifier_from_sym_name(SymName0, SymName).
strip_builtin_qualifier_from_cons_id(ConsId0, ConsId) :-
- ( ConsId0 = cons(Name0, Arity) ->
+ ( ConsId0 = cons(Name0, Arity, TypeCtor) ->
strip_builtin_qualifier_from_sym_name(Name0, Name),
- ConsId = cons(Name, Arity)
+ ConsId = cons(Name, Arity, TypeCtor)
;
ConsId = ConsId0
).
Index: compiler/prog_mutable.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_mutable.m,v
retrieving revision 1.27
diff -u -r1.27 prog_mutable.m
--- compiler/prog_mutable.m 27 Apr 2009 05:09:22 -0000 1.27
+++ compiler/prog_mutable.m 30 May 2009 06:00:39 -0000
@@ -499,6 +499,7 @@
:- implementation.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.file_names.
:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_mode.
Index: compiler/prog_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_out.m,v
retrieving revision 1.86
diff -u -r1.86 prog_out.m
--- compiler/prog_out.m 29 Aug 2008 00:51:15 -0000 1.86
+++ compiler/prog_out.m 5 Feb 2009 08:28:32 -0000
@@ -296,7 +296,7 @@
builtin_type_to_string(builtin_type_int, "int").
builtin_type_to_string(builtin_type_float, "float").
builtin_type_to_string(builtin_type_string, "string").
-builtin_type_to_string(builtin_type_character, "character").
+builtin_type_to_string(builtin_type_char, "character").
write_promise_type(PromiseType, !IO) :-
io.write_string(promise_to_string(PromiseType), !IO).
Index: compiler/prog_rep.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.66
diff -u -r1.66 prog_rep.m
--- compiler/prog_rep.m 23 Dec 2008 01:37:39 -0000 1.66
+++ compiler/prog_rep.m 5 Feb 2009 06:54:51 -0000
@@ -68,6 +68,7 @@
:- import_module check_hlds.inst_match.
:- import_module check_hlds.mode_util.
:- import_module hlds.code_model.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred.
:- import_module libs.compiler_util.
:- import_module mdbcomp.
@@ -464,12 +465,15 @@
:- func cons_id_rep(cons_id) = string.
-cons_id_rep(cons(SymName, _)) = prog_rep.sym_base_name_to_string(SymName).
+cons_id_rep(cons(SymName, _, _)) =
+ prog_rep.sym_base_name_to_string(SymName).
+cons_id_rep(tuple_cons(_)) = "{}".
cons_id_rep(int_const(Int)) = string.int_to_string(Int).
cons_id_rep(float_const(Float)) = string.float_to_string(Float).
-cons_id_rep(string_const(String)) = string.append_list(["""", String, """"]).
-cons_id_rep(implementation_defined_const(Name)) = "$" ++ Name.
-cons_id_rep(pred_const(_, _)) = "$pred_const".
+cons_id_rep(char_const(Char)) = string.char_to_string(Char).
+cons_id_rep(string_const(String)) = """" ++ String ++ """".
+cons_id_rep(impl_defined_const(Name)) = "$" ++ Name.
+cons_id_rep(closure_cons(_, _)) = "$closure_cons".
cons_id_rep(type_ctor_info_const(_, _, _)) = "$type_ctor_info_const".
cons_id_rep(base_typeclass_info_const(_, _, _, _)) =
"$base_typeclass_info_const".
@@ -477,8 +481,8 @@
cons_id_rep(typeclass_info_cell_constructor) =
"$typeclass_info_cell_constructor".
cons_id_rep(tabling_info_const(_)) = "$tabling_info_const".
-cons_id_rep(deep_profiling_proc_layout(_)) = "$deep_profiling_procedure_data".
cons_id_rep(table_io_decl(_)) = "$table_io_decl".
+cons_id_rep(deep_profiling_proc_layout(_)) = "$deep_profiling_proc_layout".
:- func sym_base_name_to_string(sym_name) = string.
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.48
diff -u -r1.48 prog_type.m
--- compiler/prog_type.m 22 May 2009 02:51:21 -0000 1.48
+++ compiler/prog_type.m 4 Jun 2009 06:14:04 -0000
@@ -116,7 +116,12 @@
:- pred type_to_ctor_and_args_det(mer_type::in, type_ctor::out,
list(mer_type)::out) is det.
- % Given a non-variable type, return its type_ctor and argument types.
+ % Given a non-variable type, return its type_ctor.
+ % Fail if the type is a variable.
+ %
+:- pred type_to_ctor(mer_type::in, type_ctor::out) is semidet.
+
+ % Given a non-variable type, return its type_ctor.
% Abort if the type is a variable.
%
:- pred type_to_ctor_det(mer_type::in, type_ctor::out) is det.
@@ -293,32 +298,6 @@
; cat_user_notag
; cat_user_general.
- % Construct builtin types.
- %
-:- func int_type = mer_type.
-:- func string_type = mer_type.
-:- func float_type = mer_type.
-:- func char_type = mer_type.
-:- func void_type = mer_type.
-:- func c_pointer_type = mer_type.
-:- func heap_pointer_type = mer_type.
-:- func sample_type_info_type = mer_type.
-:- func sample_typeclass_info_type = mer_type.
-:- func comparison_result_type = mer_type.
-:- func io_state_type = mer_type.
-:- func io_io_type = mer_type.
-:- func stm_atomic_type = mer_type.
-:- func region_type = mer_type.
-
- % Succeed iff the given variable is of region_type.
- %
-:- pred is_region_var(vartypes::in, prog_var::in) is semidet.
-
- % Construct the types of type_infos and type_ctor_infos.
- %
-:- func type_info_type = mer_type.
-:- func type_ctor_info_type = mer_type.
-
% Given a constant and an arity, return a type_ctor.
% Fails if the constant is not an atom.
%
@@ -339,7 +318,7 @@
% and is just used for obtaining the arity for typeclass_info and type_info
% cons_ids.
%
-:- pred qualify_cons_id(mer_type::in, list(prog_var)::in, cons_id::in,
+:- pred qualify_cons_id(list(prog_var)::in, cons_id::in,
cons_id::out, cons_id::out) is det.
% This type is used to return information about a constructor definition,
@@ -559,6 +538,9 @@
"type_to_ctor_and_args_det: type_to_ctor_and_args failed")
).
+type_to_ctor(Type, TypeCtor) :-
+ type_to_ctor_and_args(Type, TypeCtor, _Args).
+
type_to_ctor_det(Type, TypeCtor) :-
type_to_ctor_and_args_det(Type, TypeCtor, _Args).
@@ -870,66 +852,6 @@
%-----------------------------------------------------------------------------%
-int_type = builtin_type(builtin_type_int).
-
-string_type = builtin_type(builtin_type_string).
-
-float_type = builtin_type(builtin_type_float).
-
-char_type = builtin_type(builtin_type_character).
-
-void_type = defined_type(unqualified("void"), [], kind_star).
-
-c_pointer_type = defined_type(Name, [], kind_star) :-
- BuiltinModule = mercury_public_builtin_module,
- Name = qualified(BuiltinModule, "c_pointer").
-
-heap_pointer_type = defined_type(Name, [], kind_star) :-
- BuiltinModule = mercury_private_builtin_module,
- Name = qualified(BuiltinModule, "heap_pointer").
-
-sample_type_info_type = defined_type(Name, [], kind_star) :-
- BuiltinModule = mercury_private_builtin_module,
- Name = qualified(BuiltinModule, "sample_type_info").
-
-sample_typeclass_info_type = defined_type(Name, [], kind_star) :-
- BuiltinModule = mercury_private_builtin_module,
- Name = qualified(BuiltinModule, "sample_typeclass_info").
-
-comparison_result_type = defined_type(Name, [], kind_star) :-
- BuiltinModule = mercury_public_builtin_module,
- Name = qualified(BuiltinModule, "comparison_result").
-
-type_info_type = defined_type(Name, [], kind_star) :-
- BuiltinModule = mercury_private_builtin_module,
- Name = qualified(BuiltinModule, "type_info").
-
-type_ctor_info_type = defined_type(Name, [], kind_star) :-
- BuiltinModule = mercury_private_builtin_module,
- Name = qualified(BuiltinModule, "type_ctor_info").
-
-io_state_type = defined_type(Name, [], kind_star) :-
- Module = mercury_std_lib_module_name(unqualified("io")),
- Name = qualified(Module, "state").
-
-io_io_type = defined_type(Name, [], kind_star) :-
- Module = mercury_std_lib_module_name(unqualified("io")),
- Name = qualified(Module, "io").
-
-stm_atomic_type = defined_type(Name, [], kind_star) :-
- Module = mercury_std_lib_module_name(unqualified("stm_builtin")),
- Name = qualified(Module, "stm").
-
-region_type = defined_type(Name, [], kind_star) :-
- Module = mercury_region_builtin_module,
- Name = qualified(Module, "region").
-
-is_region_var(VarTypes, Var) :-
- map.lookup(VarTypes, Var, Type),
- Type = region_type.
-
-%-----------------------------------------------------------------------------%
-
% Given a constant and an arity, return a type_ctor.
% This really ought to take a name and an arity -
% use of integers/floats/strings as type names should
@@ -953,24 +875,22 @@
Symbol = "typeclass_info"
),
PrivateBuiltin = mercury_private_builtin_module,
- InstConsId = cons(qualified(PrivateBuiltin, Symbol), Arity).
+ TypeCtor = cons_id_dummy_type_ctor,
+ InstConsId = cons(qualified(PrivateBuiltin, Symbol), Arity, TypeCtor).
%-----------------------------------------------------------------------------%
-qualify_cons_id(Type, Args, ConsId0, ConsId, InstConsId) :-
+qualify_cons_id(Args, ConsId0, ConsId, InstConsId) :-
(
- ConsId0 = cons(Name0, OrigArity),
- (
- type_to_ctor_and_args(Type, TypeCtor, _),
- TypeCtor = type_ctor(qualified(TypeModule, _), _)
- ->
+ ConsId0 = cons(Name0, OrigArity, TypeCtor),
+ ( TypeCtor = type_ctor(qualified(TypeModule, _), _) ->
UnqualName = unqualify_name(Name0),
Name = qualified(TypeModule, UnqualName),
- ConsId = cons(Name, OrigArity),
- InstConsId = ConsId
+ ConsId = cons(Name, OrigArity, TypeCtor),
+ InstConsId = cons(Name, OrigArity, cons_id_dummy_type_ctor)
;
ConsId = ConsId0,
- InstConsId = ConsId
+ InstConsId = cons(Name0, OrigArity, cons_id_dummy_type_ctor)
)
;
ConsId0 = type_info_cell_constructor(CellCtor),
@@ -979,14 +899,16 @@
list.length(Args))
;
ConsId0 = typeclass_info_cell_constructor,
- ConsId = typeclass_info_cell_constructor,
+ ConsId = ConsId0,
InstConsId = cell_inst_cons_id(typeclass_info_cell, list.length(Args))
;
- ( ConsId0 = int_const(_)
+ ( ConsId0 = tuple_cons(_)
+ ; ConsId0 = closure_cons(_, _)
+ ; ConsId0 = int_const(_)
; ConsId0 = float_const(_)
+ ; ConsId0 = char_const(_)
; ConsId0 = string_const(_)
- ; ConsId0 = implementation_defined_const(_)
- ; ConsId0 = pred_const(_, _)
+ ; ConsId0 = impl_defined_const(_)
; ConsId0 = type_ctor_info_const(_, _, _)
; ConsId0 = base_typeclass_info_const(_, _, _, _)
; ConsId0 = table_io_decl(_)
@@ -1159,46 +1081,51 @@
:- pred type_unify_nonvar(mer_type::in, mer_type::in, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
-type_unify_nonvar(defined_type(SymName, ArgsX, _),
- defined_type(SymName, ArgsY, _), HeadTypeParams, !Bindings) :-
- % Instead of insisting that the names are equal and the arg lists
- % unify, we should consider attempting to expand equivalence types
- % first. That would require the type table to be passed in to the
- % unification algorithm, though.
- type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
-type_unify_nonvar(builtin_type(BuiltinType), builtin_type(BuiltinType), _,
- !Bindings).
-type_unify_nonvar(higher_order_type(ArgsX, no, Purity, EvalMethod),
- higher_order_type(ArgsY, no, Purity, EvalMethod),
- HeadTypeParams, !Bindings) :-
- type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
-type_unify_nonvar(higher_order_type(ArgsX, yes(RetX), Purity, EvalMethod),
- higher_order_type(ArgsY, yes(RetY), Purity, EvalMethod),
- HeadTypeParams, !Bindings) :-
- type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings),
- type_unify(RetX, RetY, HeadTypeParams, !Bindings).
-type_unify_nonvar(tuple_type(ArgsX, _), tuple_type(ArgsY, _), HeadTypeParams,
- !Bindings) :-
- type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
+type_unify_nonvar(TypeX, TypeY, HeadTypeParams, !Bindings) :-
+ (
+ TypeX = defined_type(SymName, ArgsX, _),
+ TypeY = defined_type(SymName, ArgsY, _),
+ % Instead of insisting that the names are equal and the arg lists
+ % unify, we should consider attempting to expand equivalence types
+ % first. That would require the type table to be passed in to the
+ % unification algorithm, though.
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings)
+ ;
+ TypeX = builtin_type(BuiltinType),
+ TypeY = builtin_type(BuiltinType)
+ ;
+ TypeX = higher_order_type(ArgsX, no, Purity, EvalMethod),
+ TypeY = higher_order_type(ArgsY, no, Purity, EvalMethod),
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings)
+ ;
+ TypeX = higher_order_type(ArgsX, yes(RetX), Purity, EvalMethod),
+ TypeY = higher_order_type(ArgsY, yes(RetY), Purity, EvalMethod),
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings),
+ type_unify(RetX, RetY, HeadTypeParams, !Bindings)
+ ;
+ TypeX = tuple_type(ArgsX, _),
+ TypeY = tuple_type(ArgsY, _),
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings)
+ ).
% Handle apply_n types and kinded types.
%
:- pred type_unify_special(mer_type::in, mer_type::in, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
-type_unify_special(X, Y, HeadTypeParams, !Bindings) :-
- ( X = apply_n_type(VarX, ArgsX, _) ->
- type_unify_apply(Y, VarX, ArgsX, HeadTypeParams, !Bindings)
- ; Y = apply_n_type(VarY, ArgsY, _) ->
- type_unify_apply(X, VarY, ArgsY, HeadTypeParams, !Bindings)
- ; X = kinded_type(RawX, _) ->
- ( Y = kinded_type(RawY, _) ->
+type_unify_special(TypeX, TypeY, HeadTypeParams, !Bindings) :-
+ ( TypeX = apply_n_type(VarX, ArgsX, _) ->
+ type_unify_apply(TypeY, VarX, ArgsX, HeadTypeParams, !Bindings)
+ ; TypeY = apply_n_type(VarY, ArgsY, _) ->
+ type_unify_apply(TypeX, VarY, ArgsY, HeadTypeParams, !Bindings)
+ ; TypeX = kinded_type(RawX, _) ->
+ ( TypeY = kinded_type(RawY, _) ->
type_unify(RawX, RawY, HeadTypeParams, !Bindings)
;
- type_unify(RawX, Y, HeadTypeParams, !Bindings)
+ type_unify(RawX, TypeY, HeadTypeParams, !Bindings)
)
- ; Y = kinded_type(RawY, _) ->
- type_unify(X, RawY, HeadTypeParams, !Bindings)
+ ; TypeY = kinded_type(RawY, _) ->
+ type_unify(TypeX, RawY, HeadTypeParams, !Bindings)
;
fail
).
@@ -1217,50 +1144,55 @@
:- pred type_unify_apply(mer_type::in, tvar::in, list(mer_type)::in,
list(tvar)::in, tsubst::in, tsubst::out) is semidet.
-type_unify_apply(defined_type(NameY, ArgsY0, KindY0), VarX, ArgsX,
- HeadTypeParams, !Bindings) :-
- type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
- !Bindings),
- type_unify_var(VarX, defined_type(NameY, ArgsY, KindY), HeadTypeParams,
- !Bindings).
-type_unify_apply(Type @ builtin_type(_), VarX, [], HeadTypeParams,
- !Bindings) :-
- type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
-type_unify_apply(Type @ higher_order_type(_, _, _, _), VarX, [],
- HeadTypeParams, !Bindings) :-
- type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
-type_unify_apply(tuple_type(ArgsY0, KindY0), VarX, ArgsX, HeadTypeParams,
- !Bindings) :-
- type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
- !Bindings),
- type_unify_var(VarX, tuple_type(ArgsY, KindY), HeadTypeParams, !Bindings).
-type_unify_apply(apply_n_type(VarY, ArgsY0, Kind0), VarX, ArgsX0,
- HeadTypeParams, !Bindings) :-
- list.length(ArgsX0, NArgsX0),
- list.length(ArgsY0, NArgsY0),
- compare(Result, NArgsX0, NArgsY0),
+type_unify_apply(TypeY, VarX, ArgsX0, HeadTypeParams, !Bindings) :-
(
- Result = (<),
- type_unify_args(ArgsX0, ArgsY0, ArgsY, Kind0, Kind,
- HeadTypeParams, !Bindings),
- type_unify_var(VarX, apply_n_type(VarY, ArgsY, Kind),
- HeadTypeParams, !Bindings)
- ;
- Result = (=),
- % We know here that the list of remaining args will be empty.
- type_unify_args(ArgsX0, ArgsY0, _, Kind0, Kind, HeadTypeParams,
+ TypeY = defined_type(NameY, ArgsY0, KindY0),
+ type_unify_args(ArgsX0, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
!Bindings),
- type_unify_var_var(VarX, VarY, Kind, HeadTypeParams, !Bindings)
+ type_unify_var(VarX, defined_type(NameY, ArgsY, KindY), HeadTypeParams,
+ !Bindings)
+ ;
+ TypeY = builtin_type(_),
+ ArgsX0 = [],
+ type_unify_var(VarX, TypeY, HeadTypeParams, !Bindings)
+ ;
+ TypeY = higher_order_type(_, _, _, _),
+ ArgsX0 = [],
+ type_unify_var(VarX, TypeY, HeadTypeParams, !Bindings)
+ ;
+ TypeY = tuple_type(ArgsY0, KindY0),
+ type_unify_args(ArgsX0, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
+ !Bindings),
+ type_unify_var(VarX, tuple_type(ArgsY, KindY), HeadTypeParams,
+ !Bindings)
;
- Result = (>),
- type_unify_args(ArgsY0, ArgsX0, ArgsX, Kind0, Kind,
- HeadTypeParams, !Bindings),
- type_unify_var(VarY, apply_n_type(VarX, ArgsX, Kind),
- HeadTypeParams, !Bindings)
+ TypeY = apply_n_type(VarY, ArgsY0, Kind0),
+ list.length(ArgsX0, NArgsX0),
+ list.length(ArgsY0, NArgsY0),
+ compare(Result, NArgsX0, NArgsY0),
+ (
+ Result = (<),
+ type_unify_args(ArgsX0, ArgsY0, ArgsY, Kind0, Kind,
+ HeadTypeParams, !Bindings),
+ type_unify_var(VarX, apply_n_type(VarY, ArgsY, Kind),
+ HeadTypeParams, !Bindings)
+ ;
+ Result = (=),
+ % We know here that the list of remaining args will be empty.
+ type_unify_args(ArgsX0, ArgsY0, _, Kind0, Kind, HeadTypeParams,
+ !Bindings),
+ type_unify_var_var(VarX, VarY, Kind, HeadTypeParams, !Bindings)
+ ;
+ Result = (>),
+ type_unify_args(ArgsY0, ArgsX0, ArgsX, Kind0, Kind,
+ HeadTypeParams, !Bindings),
+ type_unify_var(VarY, apply_n_type(VarX, ArgsX, Kind),
+ HeadTypeParams, !Bindings)
+ )
+ ;
+ TypeY = kinded_type(RawY, _),
+ type_unify_apply(RawY, VarX, ArgsX0, HeadTypeParams, !Bindings)
).
-type_unify_apply(kinded_type(RawY, _), VarX, ArgsX, HeadTypeParams,
- !Bindings) :-
- type_unify_apply(RawY, VarX, ArgsX, HeadTypeParams, !Bindings).
:- pred type_unify_args(list(mer_type)::in, list(mer_type)::in,
list(mer_type)::out, kind::in, kind::out, list(tvar)::in,
@@ -1297,35 +1229,43 @@
%
:- pred type_occurs(mer_type::in, tvar::in, tsubst::in) is semidet.
-type_occurs(type_variable(X, _), Y, Bindings) :-
- ( X = Y ->
- true
- ;
- map.search(Bindings, X, BindingOfX),
- type_occurs(BindingOfX, Y, Bindings)
- ).
-type_occurs(defined_type(_, Args, _), Y, Bindings) :-
- type_occurs_list(Args, Y, Bindings).
-type_occurs(higher_order_type(Args, MaybeRet, _, _), Y, Bindings) :-
+type_occurs(TypeX, Y, Bindings) :-
(
+ TypeX = type_variable(X, _),
+ ( X = Y ->
+ true
+ ;
+ map.search(Bindings, X, BindingOfX),
+ type_occurs(BindingOfX, Y, Bindings)
+ )
+ ;
+ TypeX = defined_type(_, Args, _),
type_occurs_list(Args, Y, Bindings)
;
- MaybeRet = yes(Ret),
- type_occurs(Ret, Y, Bindings)
- ).
-type_occurs(tuple_type(Args, _), Y, Bindings) :-
- type_occurs_list(Args, Y, Bindings).
-type_occurs(apply_n_type(X, Args, _), Y, Bindings) :-
- (
- X = Y
+ TypeX = higher_order_type(Args, MaybeRet, _, _),
+ (
+ type_occurs_list(Args, Y, Bindings)
+ ;
+ MaybeRet = yes(Ret),
+ type_occurs(Ret, Y, Bindings)
+ )
;
+ TypeX = tuple_type(Args, _),
type_occurs_list(Args, Y, Bindings)
;
- map.search(Bindings, X, BindingOfX),
- type_occurs(BindingOfX, Y, Bindings)
+ TypeX = apply_n_type(X, Args, _),
+ (
+ X = Y
+ ;
+ type_occurs_list(Args, Y, Bindings)
+ ;
+ map.search(Bindings, X, BindingOfX),
+ type_occurs(BindingOfX, Y, Bindings)
+ )
+ ;
+ TypeX = kinded_type(X, _),
+ type_occurs(X, Y, Bindings)
).
-type_occurs(kinded_type(X, _), Y, Bindings) :-
- type_occurs(X, Y, Bindings).
:- pred type_occurs_list(list(mer_type)::in, tvar::in, tsubst::in) is semidet.
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.108
diff -u -r1.108 prog_util.m
--- compiler/prog_util.m 10 Mar 2009 05:00:28 -0000 1.108
+++ compiler/prog_util.m 4 Jun 2009 06:27:24 -0000
@@ -107,8 +107,9 @@
% Various predicates for accessing the cons_id type.
- % Given a cons_id and a list of argument terms, convert it into a
- % term. Fails if the cons_id is a pred_const, or type_ctor_info_const.
+ % Given a cons_id and a list of argument terms, convert it into a term.
+ % Works only on the cons_ids that can be expressed in source programs,
+ % so it fails e.g. on pred_consts and type_ctor_info_consts.
%
:- pred cons_id_and_args_to_term(cons_id::in, list(term(T))::in, term(T)::out)
is semidet.
@@ -128,23 +129,6 @@
%
:- func make_functor_cons_id(const, arity) = cons_id.
- % Another way of making a cons_id from a functor.
- % Given the name, argument types, and type_ctor of a functor,
- % create a cons_id for that functor.
- %
-:- func make_cons_id(sym_name, list(constructor_arg), type_ctor) = cons_id.
-
- % Another way of making a cons_id from a functor.
- % Given the name, argument types, and type_ctor of a functor,
- % create a cons_id for that functor.
- %
- % Differs from make_cons_id in that (a) it requires the sym_name
- % to be already module qualified, which means that it does not
- % need the module qualification of the type, (b) it can compute the
- % arity from any list of the right length.
- %
-:- func make_cons_id_from_qualified_sym_name(sym_name, list(_)) = cons_id.
-
%-----------------------------------------------------------------------------%
% make_n_fresh_vars(Name, N, VarSet0, Vars, VarSet):
@@ -215,6 +199,7 @@
:- import_module pair.
:- import_module string.
:- import_module svmap.
+:- import_module term_io.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -577,46 +562,52 @@
cons_id_and_args_to_term(float_const(Float), [], Term) :-
term.context_init(Context),
Term = term.functor(term.float(Float), [], Context).
+cons_id_and_args_to_term(char_const(Char), [], Term) :-
+ SymName = unqualified(term_io.escaped_char(Char)),
+ construct_qualified_term(SymName, [], Term).
cons_id_and_args_to_term(string_const(String), [], Term) :-
term.context_init(Context),
Term = term.functor(term.string(String), [], Context).
-cons_id_and_args_to_term(cons(SymName, _Arity), Args, Term) :-
+cons_id_and_args_to_term(tuple_cons(_Arity), Args, Term) :-
+ SymName = unqualified("{}"),
+ construct_qualified_term(SymName, Args, Term).
+cons_id_and_args_to_term(cons(SymName, _Arity, _TypeCtor), Args, Term) :-
construct_qualified_term(SymName, Args, Term).
-cons_id_arity(cons(_, Arity)) = Arity.
-cons_id_arity(int_const(_)) = 0.
-cons_id_arity(string_const(_)) = 0.
-cons_id_arity(float_const(_)) = 0.
-cons_id_arity(implementation_defined_const(_)) = 0.
-cons_id_arity(pred_const(_, _)) =
- unexpected(this_file, "cons_id_arity: can't get arity of pred_const").
-cons_id_arity(type_ctor_info_const(_, _, _)) =
- unexpected(this_file,
- "cons_id_arity: can't get arity of type_ctor_info_const").
-cons_id_arity(base_typeclass_info_const(_, _, _, _)) =
- unexpected(this_file, "cons_id_arity: " ++
- "can't get arity of base_typeclass_info_const").
-cons_id_arity(type_info_cell_constructor(_)) =
- unexpected(this_file, "cons_id_arity: " ++
- "can't get arity of type_info_cell_constructor").
-cons_id_arity(typeclass_info_cell_constructor) =
- unexpected(this_file, "cons_id_arity: " ++
- "can't get arity of typeclass_info_cell_constructor").
-cons_id_arity(tabling_info_const(_)) =
- unexpected(this_file,
- "cons_id_arity: can't get arity of tabling_info_const").
-cons_id_arity(deep_profiling_proc_layout(_)) =
- unexpected(this_file, "cons_id_arity: " ++
- "can't get arity of deep_profiling_proc_layout").
-cons_id_arity(table_io_decl(_)) =
- unexpected(this_file, "cons_id_arity: can't get arity of table_io_decl").
+cons_id_arity(ConsId) = Arity :-
+ (
+ ConsId = cons(_, Arity, _)
+ ;
+ ConsId = tuple_cons(Arity)
+ ;
+ ( ConsId = int_const(_)
+ ; ConsId = float_const(_)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
+ ; ConsId = impl_defined_const(_)
+ ),
+ Arity = 0
+ ;
+ ( ConsId = closure_cons(_, _)
+ ; ConsId = type_ctor_info_const(_, _, _)
+ ; ConsId = base_typeclass_info_const(_, _, _, _)
+ ; ConsId = type_info_cell_constructor(_)
+ ; ConsId = typeclass_info_cell_constructor
+ ; ConsId = tabling_info_const(_)
+ ; ConsId = deep_profiling_proc_layout(_)
+ ; ConsId = table_io_decl(_)
+ ),
+ unexpected(this_file, "cons_id_arity: unexpected cons_id")
+ ).
-cons_id_maybe_arity(cons(_, Arity)) = yes(Arity).
+cons_id_maybe_arity(cons(_, Arity, _)) = yes(Arity).
+cons_id_maybe_arity(tuple_cons(Arity)) = yes(Arity).
cons_id_maybe_arity(int_const(_)) = yes(0).
-cons_id_maybe_arity(string_const(_)) = yes(0).
cons_id_maybe_arity(float_const(_)) = yes(0).
-cons_id_maybe_arity(implementation_defined_const(_)) = yes(0).
-cons_id_maybe_arity(pred_const(_, _)) = no.
+cons_id_maybe_arity(char_const(_)) = yes(0).
+cons_id_maybe_arity(string_const(_)) = yes(0).
+cons_id_maybe_arity(impl_defined_const(_)) = yes(0).
+cons_id_maybe_arity(closure_cons(_, _)) = no.
cons_id_maybe_arity(type_ctor_info_const(_, _, _)) = no.
cons_id_maybe_arity(base_typeclass_info_const(_, _, _, _)) = no.
cons_id_maybe_arity(type_info_cell_constructor(_)) = no.
@@ -625,35 +616,13 @@
cons_id_maybe_arity(deep_profiling_proc_layout(_)) = no.
cons_id_maybe_arity(table_io_decl(_)) = no.
-make_functor_cons_id(term.atom(Name), Arity) = cons(unqualified(Name), Arity).
+make_functor_cons_id(term.atom(Name), Arity) =
+ cons(unqualified(Name), Arity, cons_id_dummy_type_ctor).
make_functor_cons_id(term.integer(Int), _) = int_const(Int).
make_functor_cons_id(term.string(String), _) = string_const(String).
make_functor_cons_id(term.float(Float), _) = float_const(Float).
make_functor_cons_id(term.implementation_defined(Name), _) =
- implementation_defined_const(Name).
-
-make_cons_id(SymName0, Args, TypeCtor) = cons(SymName, Arity) :-
- % Use the module qualifier on the SymName, if there is one,
- % otherwise use the module qualifier on the Type, if there is one,
- % otherwise leave it unqualified.
- % XXX is that the right thing to do?
- (
- SymName0 = qualified(_, _),
- SymName = SymName0
- ;
- SymName0 = unqualified(ConsName),
- (
- TypeCtor = type_ctor(unqualified(_), _),
- SymName = SymName0
- ;
- TypeCtor = type_ctor(qualified(TypeModule, _), _),
- SymName = qualified(TypeModule, ConsName)
- )
- ),
- list.length(Args, Arity).
-
-make_cons_id_from_qualified_sym_name(SymName, Args) = cons(SymName, Arity) :-
- list.length(Args, Arity).
+ impl_defined_const(Name).
%-----------------------------------------------------------------------------%
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.128
diff -u -r1.128 purity.m
--- compiler/purity.m 10 Mar 2009 05:00:30 -0000 1.128
+++ compiler/purity.m 30 May 2009 05:51:08 -0000
@@ -185,6 +185,7 @@
:- import_module libs.options.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
@@ -916,7 +917,7 @@
map.lookup(VarTypes, Var, TypeOfVar),
Context = goal_info_get_context(GoalInfo),
(
- ConsId = cons(PName, _),
+ ConsId = cons(PName, _, _),
type_is_higher_order_details(TypeOfVar, TypePurity, PredOrFunc,
_EvalMethod, VarArgTypes)
->
@@ -937,7 +938,7 @@
pred_info_get_purity(CalleePredInfo, CalleePurity),
check_closure_purity(GoalInfo, TypePurity, CalleePurity, !Info)
;
- % If we can't find the type of the function, it's because
+ % If we can't find the type of the function, it is because
% typecheck couldn't give it one. Typechecking gives an error
% in this case, we just keep silent.
true
Index: compiler/qual_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/qual_info.m,v
retrieving revision 1.24
diff -u -r1.24 qual_info.m
--- compiler/qual_info.m 29 Jan 2008 04:59:42 -0000 1.24
+++ compiler/qual_info.m 5 Feb 2009 07:32:03 -0000
@@ -34,6 +34,7 @@
:- pred init_qual_info(mq_info::in, eqv_map::in, qual_info::out) is det.
% Update the qual_info when processing a new clause.
+ %
:- pred update_qual_info(tvar_name_map::in, tvarset::in,
vartypes::in, import_status::in,
qual_info::in, qual_info::out) is det.
@@ -264,7 +265,7 @@
:- pred record_used_functor(cons_id::in, qual_info::in, qual_info::out) is det.
record_used_functor(ConsId, !QualInfo) :-
- ( ConsId = cons(SymName, Arity) ->
+ ( ConsId = cons(SymName, Arity, _) ->
Id = item_name(SymName, Arity),
apply_to_recompilation_info(record_used_item(functor_item, Id, Id),
!QualInfo)
@@ -286,19 +287,19 @@
GoalInfo, Goal) :-
(
PredOrFunc = pf_predicate,
- Goal = hlds_goal(
- plain_call(PredId, invalid_proc_id, Args, not_builtin, no,
- SymName),
- GoalInfo)
+ GoalExpr = plain_call(PredId, invalid_proc_id, Args, not_builtin, no,
+ SymName),
+ Goal = hlds_goal(GoalExpr, GoalInfo)
;
PredOrFunc = pf_function,
pred_args_to_func_args(Args, FuncArgs, RetArg),
list.length(FuncArgs, Arity),
- ConsId = cons(SymName, Arity),
+ TypeCtor = cons_id_dummy_type_ctor,
+ ConsId = cons(SymName, Arity, TypeCtor),
Context = goal_info_get_context(GoalInfo),
- create_pure_atomic_complicated_unification(RetArg,
- rhs_functor(ConsId, no, FuncArgs), Context, umc_explicit, [],
- hlds_goal(GoalExpr, _)),
+ RHS = rhs_functor(ConsId, no, FuncArgs),
+ create_pure_atomic_complicated_unification(RetArg, RHS,
+ Context, umc_explicit, [], hlds_goal(GoalExpr, _)),
Goal = hlds_goal(GoalExpr, GoalInfo)
).
Index: compiler/rbmm.add_rbmm_goal_infos.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.add_rbmm_goal_infos.m,v
retrieving revision 1.6
diff -u -r1.6 rbmm.add_rbmm_goal_infos.m
--- compiler/rbmm.add_rbmm_goal_infos.m 21 Apr 2009 14:05:55 -0000 1.6
+++ compiler/rbmm.add_rbmm_goal_infos.m 30 May 2009 06:01:31 -0000
@@ -66,6 +66,7 @@
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
:- import_module transform_hlds.rbmm.points_to_graph.
Index: compiler/rbmm.execution_path.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.execution_path.m,v
retrieving revision 1.9
diff -u -r1.9 rbmm.execution_path.m
--- compiler/rbmm.execution_path.m 23 Dec 2008 01:37:40 -0000 1.9
+++ compiler/rbmm.execution_path.m 5 Feb 2009 07:13:34 -0000
@@ -32,6 +32,7 @@
:- import_module check_hlds.
:- import_module check_hlds.goal_path.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_pred.
:- import_module libs.
@@ -225,7 +226,7 @@
% Handle the unification on the switch var if it has been removed.
% We add a dummy program point for this unification.
(
- MainConsId = cons(_SymName, Arity),
+ MainConsId = cons(_SymName, Arity, _),
( Arity = 0 ->
append_to_each_execution_path(!.ExecPaths,
[[pair(ProgPoint, Switch)]], ExecPathsBeforeCase)
@@ -234,22 +235,24 @@
)
;
( MainConsId = int_const(_Int)
- ; MainConsId = string_const(_String)
; MainConsId = float_const(_Float)
+ ; MainConsId = char_const(_Char)
+ ; MainConsId = string_const(_String)
),
% need to add a dummy pp
append_to_each_execution_path(!.ExecPaths,
[[pair(ProgPoint, Switch)]], ExecPathsBeforeCase)
;
- ( MainConsId = implementation_defined_const(_)
- ; MainConsId = pred_const(_, _)
+ ( MainConsId = tuple_cons(_)
+ ; MainConsId = closure_cons(_, _)
+ ; MainConsId = impl_defined_const(_)
; MainConsId = type_ctor_info_const(_, _, _)
; MainConsId = base_typeclass_info_const(_, _, _, _)
; MainConsId = type_info_cell_constructor(_)
; MainConsId = typeclass_info_cell_constructor
; MainConsId = tabling_info_const(_)
- ; MainConsId = deep_profiling_proc_layout(_)
; MainConsId = table_io_decl(_)
+ ; MainConsId = deep_profiling_proc_layout(_)
),
unexpected(this_file,
"execution_paths_covered_cases: new cons_id encountered")
Index: compiler/rbmm.points_to_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.points_to_analysis.m,v
retrieving revision 1.10
diff -u -r1.10 rbmm.points_to_analysis.m
--- compiler/rbmm.points_to_analysis.m 21 Apr 2009 14:05:55 -0000 1.10
+++ compiler/rbmm.points_to_analysis.m 29 May 2009 04:53:46 -0000
@@ -49,6 +49,7 @@
:- import_module check_hlds.
:- import_module check_hlds.goal_path.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_pred.
:- import_module libs.
Index: compiler/rbmm.region_transformation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.region_transformation.m,v
retrieving revision 1.9
diff -u -r1.9 rbmm.region_transformation.m
--- compiler/rbmm.region_transformation.m 21 Apr 2009 14:05:55 -0000 1.9
+++ compiler/rbmm.region_transformation.m 30 May 2009 06:01:55 -0000
@@ -76,6 +76,7 @@
:- import_module check_hlds.purity.
:- import_module check_hlds.type_util.
:- import_module hlds.goal_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.instmap.
:- import_module hlds.pred_table.
@@ -83,6 +84,7 @@
:- import_module libs.
:- import_module libs.compiler_util.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
:- import_module transform_hlds.rbmm.points_to_graph.
@@ -659,10 +661,11 @@
expect(unify(OtherConsIds, []), this_file,
"NYI: region_transform_case for multi-cons-id cases"),
(
- ( MainConsId = cons(_, 0)
+ ( MainConsId = cons(_, 0, _)
; MainConsId = int_const(_)
- ; MainConsId = string_const(_)
; MainConsId = float_const(_)
+ ; MainConsId = char_const(_)
+ ; MainConsId = string_const(_)
),
Switch = hlds_goal(switch(_, _, _), Info)
->
Index: compiler/recompilation.usage.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.49
diff -u -r1.49 recompilation.usage.m
--- compiler/recompilation.usage.m 14 Jan 2009 08:38:46 -0000 1.49
+++ compiler/recompilation.usage.m 5 Feb 2009 08:36:24 -0000
@@ -731,16 +731,18 @@
find_matching_functors(ModuleInfo, SymName, Arity, ResolvedConstructors) :-
% Is it a constructor.
module_info_get_cons_table(ModuleInfo, Ctors),
- ( map.search(Ctors, cons(SymName, Arity), ConsDefns0) ->
+ ConsId = cons(SymName, Arity, cons_id_dummy_type_ctor),
+ ( map.search(Ctors, ConsId, ConsDefns0) ->
ConsDefns1 = ConsDefns0
;
ConsDefns1 = []
),
(
remove_new_prefix(SymName, SymNameMinusNew),
- map.search(Ctors, cons(SymNameMinusNew, Arity), ConsDefns2)
+ ConsIdMinumNew = cons(SymNameMinusNew, Arity, cons_id_dummy_type_ctor),
+ map.search(Ctors, ConsIdMinumNew, ConsDefns2)
->
- ConsDefns = list.append(ConsDefns1, ConsDefns2)
+ ConsDefns = ConsDefns1 ++ ConsDefns2
;
ConsDefns = ConsDefns1
),
@@ -775,8 +777,9 @@
->
MatchingFields = list.map(
(func(FieldDefn) = FieldCtor :-
- FieldDefn = hlds_ctor_field_defn(_, _, TypeCtor, ConsId, _),
- ( ConsId = cons(ConsName, ConsArity) ->
+ FieldDefn =
+ hlds_ctor_field_defn(_, _, TypeCtor, FieldConsId, _),
+ ( FieldConsId = cons(ConsName, ConsArity, _) ->
FieldCtor = resolved_functor_field(
type_ctor_to_item_name(TypeCtor),
item_name(ConsName, ConsArity))
@@ -1357,7 +1360,7 @@
find_items_used_by_bound_inst(BoundInst, !Info) :-
BoundInst = bound_functor(ConsId, ArgInsts),
- ( ConsId = cons(Name, Arity) ->
+ ( ConsId = cons(Name, Arity, _) ->
record_used_functor(Name - Arity, !Info)
;
true
Index: compiler/rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.90
diff -u -r1.90 rtti.m
--- compiler/rtti.m 22 Apr 2009 07:12:13 -0000 1.90
+++ compiler/rtti.m 29 May 2009 04:53:46 -0000
@@ -173,7 +173,7 @@
% the second, third and fourth components.
%
:- type type_ctor_details
- ---> enum(
+ ---> tcd_enum(
enum_axioms :: equality_axioms,
enum_functors :: list(enum_functor),
enum_value_table :: map(int, enum_functor),
@@ -182,7 +182,7 @@
enum_functor_number_mapping
:: list(int)
)
- ; foreign_enum(
+ ; tcd_foreign_enum(
foreign_enum_language :: foreign_language,
foreign_enum_axioms :: equality_axioms,
foreign_enum_functors :: list(foreign_enum_functor),
@@ -191,7 +191,7 @@
foreign_enum_functor_number_mapping
:: list(int)
)
- ; du(
+ ; tcd_du(
du_axioms :: equality_axioms,
du_functors :: list(du_functor),
du_value_table :: ptag_map,
@@ -199,7 +199,7 @@
du_functor_number_mapping
:: list(int)
)
- ; reserved(
+ ; tcd_reserved(
res_axioms :: equality_axioms,
res_functors :: list(maybe_reserved_functor),
res_value_table_res :: list(reserved_functor),
@@ -209,20 +209,20 @@
res_functor_number_mapping
:: list(int)
)
- ; notag(
+ ; tcd_notag(
notag_axioms :: equality_axioms,
notag_functor :: notag_functor
)
- ; eqv(
+ ; tcd_eqv(
eqv_type :: rtti_maybe_pseudo_type_info
)
- ; builtin(
+ ; tcd_builtin(
builtin_ctor :: builtin_ctor
)
- ; impl_artifact(
+ ; tcd_impl_artifact(
impl_ctor :: impl_ctor
)
- ; foreign(
+ ; tcd_foreign(
is_stable :: is_stable
).
@@ -1517,7 +1517,7 @@
type_ctor_rep_to_string(TypeCtorData, RepStr) :-
TypeCtorDetails = TypeCtorData ^ tcr_rep_details,
(
- TypeCtorDetails = enum(TypeCtorUserEq, _, _, _, IsDummy, _),
+ TypeCtorDetails = tcd_enum(TypeCtorUserEq, _, _, _, IsDummy, _),
(
IsDummy = yes,
expect(unify(TypeCtorUserEq, standard), this_file,
@@ -1534,7 +1534,7 @@
)
)
;
- TypeCtorDetails = foreign_enum(_, TypeCtorUserEq, _, _, _, _),
+ TypeCtorDetails = tcd_foreign_enum(_, TypeCtorUserEq, _, _, _, _),
(
TypeCtorUserEq = standard,
RepStr = "MR_TYPECTOR_REP_FOREIGN_ENUM"
@@ -1543,7 +1543,7 @@
RepStr = "MR_TYPECTOR_REP_FOREIGN_ENUM_USEREQ"
)
;
- TypeCtorDetails = du(TypeCtorUserEq, _, _, _, _),
+ TypeCtorDetails = tcd_du(TypeCtorUserEq, _, _, _, _),
(
TypeCtorUserEq = standard,
RepStr = "MR_TYPECTOR_REP_DU"
@@ -1552,7 +1552,7 @@
RepStr = "MR_TYPECTOR_REP_DU_USEREQ"
)
;
- TypeCtorDetails = reserved(TypeCtorUserEq, _, _, _, _, _),
+ TypeCtorDetails = tcd_reserved(TypeCtorUserEq, _, _, _, _, _),
(
TypeCtorUserEq = standard,
RepStr = "MR_TYPECTOR_REP_RESERVED_ADDR"
@@ -1561,7 +1561,7 @@
RepStr = "MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ"
)
;
- TypeCtorDetails = notag(TypeCtorUserEq, NotagFunctor),
+ TypeCtorDetails = tcd_notag(TypeCtorUserEq, NotagFunctor),
NotagEqvType = NotagFunctor ^ nt_arg_type,
(
TypeCtorUserEq = standard,
@@ -1583,7 +1583,7 @@
)
)
;
- TypeCtorDetails = eqv(EqvType),
+ TypeCtorDetails = tcd_eqv(EqvType),
(
EqvType = pseudo(_),
RepStr = "MR_TYPECTOR_REP_EQUIV"
@@ -1592,13 +1592,13 @@
RepStr = "MR_TYPECTOR_REP_EQUIV_GROUND"
)
;
- TypeCtorDetails = builtin(BuiltinCtor),
+ TypeCtorDetails = tcd_builtin(BuiltinCtor),
builtin_ctor_rep_to_string(BuiltinCtor, RepStr)
;
- TypeCtorDetails = impl_artifact(ImplCtor),
+ TypeCtorDetails = tcd_impl_artifact(ImplCtor),
impl_ctor_rep_to_string(ImplCtor, RepStr)
;
- TypeCtorDetails = foreign(IsStable),
+ TypeCtorDetails = tcd_foreign(IsStable),
ModuleName = TypeCtorData ^ tcr_module_name,
TypeName = TypeCtorData ^ tcr_type_name,
TypeArity = TypeCtorData ^ tcr_arity,
@@ -1676,12 +1676,12 @@
maybe_pseudo_type_info_or_self_to_rtti_data(self) =
rtti_data_pseudo_type_info(type_var(0)).
-type_ctor_details_num_ptags(enum(_, _, _, _, _, _)) = -1.
-type_ctor_details_num_ptags(foreign_enum(_, _, _, _, _, _)) = -1.
-type_ctor_details_num_ptags(du(_, _, PtagMap, _, _)) = LastPtag + 1 :-
+type_ctor_details_num_ptags(tcd_enum(_, _, _, _, _, _)) = -1.
+type_ctor_details_num_ptags(tcd_foreign_enum(_, _, _, _, _, _)) = -1.
+type_ctor_details_num_ptags(tcd_du(_, _, PtagMap, _, _)) = LastPtag + 1 :-
map.keys(PtagMap, Ptags),
list.last_det(Ptags, LastPtag).
-type_ctor_details_num_ptags(reserved(_, _, _, PtagMap, _, _)) = NumPtags :-
+type_ctor_details_num_ptags(tcd_reserved(_, _, _, PtagMap, _, _)) = NumPtags :-
map.keys(PtagMap, Ptags),
(
Ptags = [],
@@ -1691,25 +1691,25 @@
list.last_det(Ptags, LastPtag),
NumPtags = LastPtag + 1
).
-type_ctor_details_num_ptags(notag(_, _)) = -1.
-type_ctor_details_num_ptags(eqv(_)) = -1.
-type_ctor_details_num_ptags(builtin(_)) = -1.
-type_ctor_details_num_ptags(impl_artifact(_)) = -1.
-type_ctor_details_num_ptags(foreign(_)) = -1.
+type_ctor_details_num_ptags(tcd_notag(_, _)) = -1.
+type_ctor_details_num_ptags(tcd_eqv(_)) = -1.
+type_ctor_details_num_ptags(tcd_builtin(_)) = -1.
+type_ctor_details_num_ptags(tcd_impl_artifact(_)) = -1.
+type_ctor_details_num_ptags(tcd_foreign(_)) = -1.
-type_ctor_details_num_functors(enum(_, Functors, _, _, _, _)) =
+type_ctor_details_num_functors(tcd_enum(_, Functors, _, _, _, _)) =
list.length(Functors).
-type_ctor_details_num_functors(foreign_enum(_, _, Functors, _, _, _)) =
+type_ctor_details_num_functors(tcd_foreign_enum(_, _, Functors, _, _, _)) =
list.length(Functors).
-type_ctor_details_num_functors(du(_, Functors, _, _, _)) =
+type_ctor_details_num_functors(tcd_du(_, Functors, _, _, _)) =
list.length(Functors).
-type_ctor_details_num_functors(reserved(_, Functors, _, _, _, _)) =
+type_ctor_details_num_functors(tcd_reserved(_, Functors, _, _, _, _)) =
list.length(Functors).
-type_ctor_details_num_functors(notag(_, _)) = 1.
-type_ctor_details_num_functors(eqv(_)) = -1.
-type_ctor_details_num_functors(builtin(_)) = -1.
-type_ctor_details_num_functors(impl_artifact(_)) = -1.
-type_ctor_details_num_functors(foreign(_)) = -1.
+type_ctor_details_num_functors(tcd_notag(_, _)) = 1.
+type_ctor_details_num_functors(tcd_eqv(_)) = -1.
+type_ctor_details_num_functors(tcd_builtin(_)) = -1.
+type_ctor_details_num_functors(tcd_impl_artifact(_)) = -1.
+type_ctor_details_num_functors(tcd_foreign(_)) = -1.
du_arg_info_name(ArgInfo) = ArgInfo ^ du_arg_name.
Index: compiler/rtti_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_out.m,v
retrieving revision 1.78
diff -u -r1.78 rtti_out.m
--- compiler/rtti_out.m 30 Oct 2008 06:45:59 -0000 1.78
+++ compiler/rtti_out.m 25 Dec 2008 11:31:32 -0000
@@ -654,7 +654,7 @@
MaybeFunctorsName, MaybeLayoutName, HaveFunctorNumberMap,
!DeclSet, !IO) :-
(
- TypeCtorDetails = enum(_, EnumFunctors, EnumByRep, EnumByName,
+ TypeCtorDetails = tcd_enum(_, EnumFunctors, EnumByRep, EnumByName,
_IsDummy, FunctorNumberMap),
list.foldl2(output_enum_functor_defn(RttiTypeCtor), EnumFunctors,
!DeclSet, !IO),
@@ -668,7 +668,7 @@
MaybeFunctorsName = yes(type_ctor_enum_name_ordered_table),
HaveFunctorNumberMap = yes
;
- TypeCtorDetails = foreign_enum(Lang, _, ForeignEnumFunctors,
+ TypeCtorDetails = tcd_foreign_enum(Lang, _, ForeignEnumFunctors,
ForeignEnumByOrdinal, ForeignEnumByName, FunctorNumberMap),
expect(unify(Lang, lang_c), this_file,
"language other than C for foreign enumeration"),
@@ -684,7 +684,7 @@
MaybeFunctorsName = yes(type_ctor_foreign_enum_name_ordered_table),
HaveFunctorNumberMap = yes
;
- TypeCtorDetails = du(_, DuFunctors, DuByRep,
+ TypeCtorDetails = tcd_du(_, DuFunctors, DuByRep,
DuByName, FunctorNumberMap),
list.foldl2(output_du_functor_defn(RttiTypeCtor), DuFunctors,
!DeclSet, !IO),
@@ -696,7 +696,7 @@
MaybeFunctorsName = yes(type_ctor_du_name_ordered_table),
HaveFunctorNumberMap = yes
;
- TypeCtorDetails = reserved(_, MaybeResFunctors, ResFunctors,
+ TypeCtorDetails = tcd_reserved(_, MaybeResFunctors, ResFunctors,
DuByRep, MaybeResByName, FunctorNumberMap),
list.foldl2(output_maybe_res_functor_defn(RttiTypeCtor),
MaybeResFunctors, !DeclSet, !IO),
@@ -710,7 +710,7 @@
MaybeFunctorsName = yes(type_ctor_res_name_ordered_table),
HaveFunctorNumberMap = yes
;
- TypeCtorDetails = notag(_, NotagFunctor),
+ TypeCtorDetails = tcd_notag(_, NotagFunctor),
output_notag_functor_defn(RttiTypeCtor, NotagFunctor,
!DeclSet, !IO),
output_functor_number_map(RttiTypeCtor, [0], !DeclSet, !IO),
@@ -718,7 +718,7 @@
MaybeFunctorsName = yes(type_ctor_notag_functor_desc),
HaveFunctorNumberMap = yes
;
- TypeCtorDetails = eqv(EqvType),
+ TypeCtorDetails = tcd_eqv(EqvType),
output_maybe_pseudo_type_info_defn(EqvType, !DeclSet, !IO),
TypeData = maybe_pseudo_type_info_to_rtti_data(EqvType),
output_rtti_data_decls(TypeData, "", "", 0, _, !DeclSet, !IO),
@@ -733,17 +733,10 @@
MaybeFunctorsName = no,
HaveFunctorNumberMap = no
;
- TypeCtorDetails = builtin(_),
- MaybeLayoutName = no,
- MaybeFunctorsName = no,
- HaveFunctorNumberMap = no
- ;
- TypeCtorDetails = impl_artifact(_),
- MaybeLayoutName = no,
- MaybeFunctorsName = no,
- HaveFunctorNumberMap = no
- ;
- TypeCtorDetails = foreign(_),
+ ( TypeCtorDetails = tcd_builtin(_)
+ ; TypeCtorDetails = tcd_impl_artifact(_)
+ ; TypeCtorDetails = tcd_foreign(_)
+ ),
MaybeLayoutName = no,
MaybeFunctorsName = no,
HaveFunctorNumberMap = no
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.86
diff -u -r1.86 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 16 Jan 2009 02:31:26 -0000 1.86
+++ compiler/rtti_to_mlds.m 3 Feb 2009 02:28:19 -0000
@@ -523,7 +523,7 @@
FunctorInit, LayoutInit, NumberMapInit, Defns) :-
module_info_get_name(ModuleInfo, ModuleName),
(
- TypeCtorDetails = enum(_, EnumFunctors, EnumByValue, EnumByName,
+ TypeCtorDetails = tcd_enum(_, EnumFunctors, EnumByValue, EnumByName,
_IsDummy, FunctorNumberMap),
EnumFunctorDescs = list.map(
gen_enum_functor_desc(ModuleInfo, RttiTypeCtor), EnumFunctors),
@@ -540,8 +540,9 @@
type_ctor_functor_number_map),
Defns = EnumFunctorDescs ++ [ByValueDefn, ByNameDefn, NumberMapDefn]
;
- TypeCtorDetails = foreign_enum(ForeignEnumLang, _, ForeignEnumFunctors,
- ForeignEnumByOrdinal, ForeignEnumByName, FunctorNumberMap),
+ TypeCtorDetails = tcd_foreign_enum(ForeignEnumLang, _,
+ ForeignEnumFunctors, ForeignEnumByOrdinal, ForeignEnumByName,
+ FunctorNumberMap),
ForeignEnumFunctorDescs = list.map(
gen_foreign_enum_functor_desc(ModuleInfo, ForeignEnumLang,
RttiTypeCtor),
@@ -560,8 +561,8 @@
Defns = ForeignEnumFunctorDescs ++
[ByOrdinalDefn, ByNameDefn, NumberMapDefn]
;
- TypeCtorDetails = du(_, DuFunctors, DuByPtag,
- DuByName, FunctorNumberMap),
+ TypeCtorDetails = tcd_du(_, DuFunctors, DuByPtag, DuByName,
+ FunctorNumberMap),
DuFunctorDefns = list.map(
gen_du_functor_desc(ModuleInfo, RttiTypeCtor), DuFunctors),
ByPtagDefns = gen_du_ptag_ordered_table(ModuleInfo,
@@ -578,7 +579,7 @@
Defns = list.condense(DuFunctorDefns) ++
[ByNameDefn, NumberMapDefn | ByPtagDefns]
;
- TypeCtorDetails = reserved(_, MaybeResFunctors, ResFunctors,
+ TypeCtorDetails = tcd_reserved(_, MaybeResFunctors, ResFunctors,
DuByPtag, MaybeResByName, FunctorNumberMap),
MaybeResFunctorDefns = list.map(
gen_maybe_res_functor_desc(ModuleInfo, RttiTypeCtor),
@@ -597,7 +598,7 @@
Defns = [ByNameDefn, NumberMapDefn | ByValueDefns] ++
list.condense(MaybeResFunctorDefns)
;
- TypeCtorDetails = notag(_, NotagFunctor),
+ TypeCtorDetails = tcd_notag(_, NotagFunctor),
NumberMapDefn = gen_functor_number_map(RttiTypeCtor, [0]),
LayoutInit = gen_init_rtti_name(ModuleName, RttiTypeCtor,
type_ctor_notag_functor_desc),
@@ -609,26 +610,17 @@
NotagFunctor),
Defns = [NumberMapDefn | FunctorDefn]
;
- TypeCtorDetails = eqv(EqvType),
+ TypeCtorDetails = tcd_eqv(EqvType),
TypeRttiData = maybe_pseudo_type_info_to_rtti_data(EqvType),
gen_pseudo_type_info(ModuleInfo, TypeRttiData, LayoutInit, Defns),
% The type is a lie, but a safe one.
FunctorInit = gen_init_null_pointer(mlds_generic_type),
NumberMapInit = gen_init_null_pointer(mlds_generic_type)
;
- TypeCtorDetails = builtin(_),
- Defns = [],
- LayoutInit = gen_init_null_pointer(mlds_generic_type),
- FunctorInit = gen_init_null_pointer(mlds_generic_type),
- NumberMapInit = gen_init_null_pointer(mlds_generic_type)
- ;
- TypeCtorDetails = impl_artifact(_),
- Defns = [],
- LayoutInit = gen_init_null_pointer(mlds_generic_type),
- FunctorInit = gen_init_null_pointer(mlds_generic_type),
- NumberMapInit = gen_init_null_pointer(mlds_generic_type)
- ;
- TypeCtorDetails = foreign(_),
+ ( TypeCtorDetails = tcd_builtin(_)
+ ; TypeCtorDetails = tcd_impl_artifact(_)
+ ; TypeCtorDetails = tcd_foreign(_)
+ ),
Defns = [],
LayoutInit = gen_init_null_pointer(mlds_generic_type),
FunctorInit = gen_init_null_pointer(mlds_generic_type),
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.238
diff -u -r1.238 simplify.m
--- compiler/simplify.m 10 Mar 2009 05:00:30 -0000 1.238
+++ compiler/simplify.m 30 May 2009 05:51:36 -0000
@@ -150,6 +150,7 @@
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
@@ -1053,8 +1054,11 @@
simplify_info_get_instmap(!.Info, InstMap0),
simplify_info_get_module_info(!.Info, ModuleInfo0),
instmap_lookup_var(InstMap0, Var, VarInst),
- ( inst_is_bound_to_functors(ModuleInfo0, VarInst, Functors) ->
- functors_to_cons_ids(Functors, ConsIds0),
+ simplify_info_get_var_types(!.Info, VarTypes),
+ ( inst_is_bound_to_functors(ModuleInfo0, VarInst, BoundInsts) ->
+ map.lookup(VarTypes, Var, VarType),
+ type_to_ctor_det(VarType, VarTypeCtor),
+ list.map(bound_inst_to_cons_id(VarTypeCtor), BoundInsts, ConsIds0),
list.sort(ConsIds0, ConsIds),
delete_unreachable_cases(Cases0, ConsIds, Cases1),
MaybeConsIds = yes(ConsIds)
@@ -1087,13 +1091,11 @@
% existential type variables in the types of the constructor
% arguments or their typeinfos.
- simplify_info_get_var_types(!.Info, VarTypes1),
- map.lookup(VarTypes1, Var, Type),
+ map.lookup(VarTypes, Var, Type),
simplify_info_get_module_info(!.Info, ModuleInfo1),
( type_util.is_existq_cons(ModuleInfo1, Type, MainConsId) ->
GoalExpr = switch(Var, SwitchCanFail, Cases),
NonLocals = goal_info_get_nonlocals(GoalInfo0),
- simplify_info_get_var_types(!.Info, VarTypes),
merge_instmap_deltas(InstMap0, NonLocals, VarTypes,
InstMaps, NewDelta, ModuleInfo1, ModuleInfo2),
simplify_info_set_module_info(ModuleInfo2, !Info),
@@ -1146,7 +1148,6 @@
;
simplify_info_get_module_info(!.Info, ModuleInfo1),
NonLocals = goal_info_get_nonlocals(GoalInfo0),
- simplify_info_get_var_types(!.Info, VarTypes),
merge_instmap_deltas(InstMap0, NonLocals, VarTypes, InstMaps,
NewDelta, ModuleInfo1, ModuleInfo2),
simplify_info_set_module_info(ModuleInfo2, !Info),
@@ -1155,7 +1156,9 @@
),
list.length(Cases0, Cases0Length),
list.length(Cases, CasesLength),
- ( CasesLength \= Cases0Length ->
+ ( CasesLength = Cases0Length ->
+ true
+ ;
% If we pruned some cases, variables used by those cases may no longer
% be nonlocal to the switch. Also, the determinism may have changed
% (especially if we pruned all the cases). If the switch now can't
@@ -1165,8 +1168,6 @@
simplify_info_set_requantify(!Info),
simplify_info_set_rerun_det(!Info)
- ;
- true
).
:- pred simplify_goal_generic_call(
@@ -2158,7 +2159,9 @@
CmpGoal = hlds_goal(CmpExpr, CmpInfo),
% Construct the unification R = Inequality.
- ConsId = cons(qualified(BuiltinModule, Inequality), 0),
+ TypeCtor = type_ctor(
+ qualified(mercury_public_builtin_module, "comparison_result"), 0),
+ ConsId = cons(qualified(BuiltinModule, Inequality), 0, TypeCtor),
Bound = bound(shared, [bound_functor(ConsId, [])]),
UMode = ((Unique -> Bound) - (Bound -> Bound)),
RHS = rhs_functor(ConsId, no, []),
@@ -2417,9 +2420,14 @@
purity_pure, [X, Y], [], [], ModuleInfo, Context, CondLt),
Builtin = mercury_public_builtin_module,
- make_const_construction(Res, cons(qualified(Builtin, "="), 0), ReturnEq),
- make_const_construction(Res, cons(qualified(Builtin, "<"), 0), ReturnLt),
- make_const_construction(Res, cons(qualified(Builtin, ">"), 0), ReturnGt),
+ TypeCtor = type_ctor(
+ qualified(mercury_public_builtin_module, "comparison_result"), 0),
+ make_const_construction(Res, cons(qualified(Builtin, "="), 0, TypeCtor),
+ ReturnEq),
+ make_const_construction(Res, cons(qualified(Builtin, "<"), 0, TypeCtor),
+ ReturnLt),
+ make_const_construction(Res, cons(qualified(Builtin, ">"), 0, TypeCtor),
+ ReturnGt),
NonLocals = set.from_list([Res, X, Y]),
goal_info_set_nonlocals(NonLocals, !GoalInfo),
Index: compiler/size_prof.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/size_prof.m,v
retrieving revision 1.59
diff -u -r1.59 size_prof.m
--- compiler/size_prof.m 23 Dec 2008 01:37:40 -0000 1.59
+++ compiler/size_prof.m 30 May 2009 06:02:04 -0000
@@ -114,6 +114,7 @@
:- import_module check_hlds.simplify.
:- import_module check_hlds.type_util.
:- import_module hlds.goal_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_out.
:- import_module hlds.hlds_rtti.
@@ -123,6 +124,7 @@
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
:- import_module transform_hlds.term_norm.
@@ -667,7 +669,7 @@
no_construct_sub_info),
GoalExpr = unify(LHS, RHS, UniMode, Unification, UnifyContext)
;
- ConsId = cons(_Name, _Arity),
+ ConsId = cons(_Name, _Arity, _TypeCtor),
Args = [_ | _]
->
size_prof_process_cons_construct(LHS, RHS, UniMode, UnifyContext,
@@ -706,7 +708,9 @@
->
Goal0 = hlds_goal(GoalExpr, _)
;
- ConsId = cons(_Name, _Arity),
+ ( ConsId = cons(_Name, _Arity, _TypeCtor)
+ ; ConsId = tuple_cons(_Arity)
+ ),
Args = [_ | _]
->
size_prof_process_cons_deconstruct(Var, Args, ArgModes, Goal0,
@@ -721,10 +725,10 @@
%-----------------------------------------------------------------------------%
:- pred size_prof_process_cons_construct(prog_var::in, unify_rhs::in,
- unify_mode::in, unify_context::in, prog_var::in, mer_type::in, cons_id::in,
- list(prog_var)::in, list(uni_mode)::in, how_to_construct::in,
- cell_is_unique::in, hlds_goal_info::in, hlds_goal_expr::out,
- info::in, info::out) is det.
+ unify_mode::in, unify_context::in, prog_var::in, mer_type::in,
+ cons_id::in, list(prog_var)::in, list(uni_mode)::in,
+ how_to_construct::in, cell_is_unique::in, hlds_goal_info::in,
+ hlds_goal_expr::out, info::in, info::out) is det.
size_prof_process_cons_construct(LHS, RHS, UniMode, UnifyContext, Var, _Type,
ConsId, Args, ArgModes, How, Unique, GoalInfo0, GoalExpr, !Info) :-
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.71
diff -u -r1.71 special_pred.m
--- compiler/special_pred.m 11 Feb 2008 21:26:08 -0000 1.71
+++ compiler/special_pred.m 30 May 2009 05:55:50 -0000
@@ -114,6 +114,7 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
Index: compiler/ssdebug.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ssdebug.m,v
retrieving revision 1.19
diff -u -r1.19 ssdebug.m
--- compiler/ssdebug.m 19 Feb 2009 03:49:18 -0000 1.19
+++ compiler/ssdebug.m 20 Feb 2009 07:48:00 -0000
@@ -178,6 +178,7 @@
:- import_module check_hlds.polymorphism.
:- import_module check_hlds.purity.
:- import_module hlds.goal_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.instmap.
:- import_module hlds.pred_table.
@@ -802,13 +803,17 @@
make_switch_goal(SwitchVar, DoRetryGoal, DoNotRetryGoal, GoalInfo,
SwitchGoal) :-
SSDBModule = mercury_ssdb_builtin_module,
- ConsIdDoRetry = cons(qualified(SSDBModule, "do_retry"), 0),
- ConsIdDoNotRetry = cons(qualified(SSDBModule, "do_not_retry"), 0),
+ RetryTypeSymName = qualified(SSDBModule, "ssdb_retry"),
+ RetryTypeCtor = type_ctor(RetryTypeSymName, 0),
+ ConsIdDoRetry = cons(qualified(SSDBModule, "do_retry"), 0,
+ RetryTypeCtor),
+ ConsIdDoNotRetry = cons(qualified(SSDBModule, "do_not_retry"), 0,
+ RetryTypeCtor),
CaseDoRetry = case(ConsIdDoRetry, [], DoRetryGoal),
CaseDoNotRetry = case(ConsIdDoNotRetry, [], DoNotRetryGoal),
- SwitchGoal = hlds_goal(
- switch(SwitchVar, cannot_fail, [CaseDoRetry, CaseDoNotRetry]),
- GoalInfo).
+ SwitchGoalExpr = switch(SwitchVar, cannot_fail,
+ [CaseDoRetry, CaseDoNotRetry]),
+ SwitchGoal = hlds_goal(SwitchGoalExpr, GoalInfo).
% wrap_with_purity_scope(Purity, GoalInfo, Goal0, Goal):
%
@@ -887,7 +892,7 @@
TypeCtor = type_ctor(qualified(SSDBModule, "ssdb_proc_id"), 0),
svvarset.new_named_var("ProcId", ProcIdVar, !Varset),
- ConsId = cons(qualified(SSDBModule, "ssdb_proc_id"), 2),
+ ConsId = cons(qualified(SSDBModule, "ssdb_proc_id"), 2, TypeCtor),
construct_type(TypeCtor, [], ProcIdType),
svmap.det_insert(ProcIdVar, ProcIdType, !Vartypes),
construct_functor(ProcIdVar, ConsId, [ModuleNameVar, PredNameVar],
@@ -958,7 +963,9 @@
!ProcInfo, !PredInfo, !Varset, !Vartypes, !BoundVarDescs) :-
svvarset.new_named_var("EmptyVarList", Var, !Varset),
svmap.det_insert(Var, list_var_value_type, !Vartypes),
- ConsId = cons(qualified(unqualified("list"), "[]" ), 0),
+ ListTypeSymName = qualified(mercury_list_module, "list"),
+ ListTypeCtor = type_ctor(ListTypeSymName, 1),
+ ConsId = cons(qualified(mercury_list_module, "[]" ), 0, ListTypeCtor),
construct_functor(Var, ConsId, [], Goal).
make_arg_list(Pos0, InstMap, [VarToInspect | ListVar], Renaming, Var,
@@ -984,7 +991,9 @@
svvarset.new_named_var("FullListVar", Var, !Varset),
svmap.det_insert(Var, list_var_value_type, !Vartypes),
- ConsId = cons(qualified(unqualified("list"), "[|]" ), 2),
+ ListTypeSymName = qualified(mercury_list_module, "list"),
+ ListTypeCtor = type_ctor(ListTypeSymName, 1),
+ ConsId = cons(qualified(unqualified("list"), "[|]" ), 2, ListTypeCtor),
construct_functor(Var, ConsId, [VarDesc, Var0], Goal),
%XXX Optimize me: repeated appends are slow.
@@ -998,8 +1007,7 @@
SSDBModule = mercury_ssdb_builtin_module,
VarValueTypeCtor = type_ctor(qualified(SSDBModule, "var_value"), 0),
construct_type(VarValueTypeCtor, [], VarValueType),
-
- ListTypeCtor = type_ctor(qualified(unqualified("list"), "list"), 1),
+ ListTypeCtor = type_ctor(qualified(mercury_list_module, "list"), 1),
construct_type(ListTypeCtor, [VarValueType], ListVarValueType).
% Create the goal's argument description :
@@ -1017,13 +1025,15 @@
!ModuleInfo, !ProcInfo, !PredInfo, !VarSet, !VarTypes,
!BoundVarDescs) :-
SSDBModule = mercury_ssdb_builtin_module,
- TypeCtor = type_ctor(qualified(SSDBModule, "var_value"), 0),
+ VarValueTypeCtor = type_ctor(qualified(SSDBModule, "var_value"), 0),
+ construct_type(VarValueTypeCtor, [], VarValueType),
varset.lookup_name(!.VarSet, VarToInspect, VarName),
make_string_const_construction_alloc(VarName, yes("VarName"),
ConstructVarName, VarNameVar, !VarSet, !VarTypes),
make_int_const_construction_alloc(VarPos, yes("VarPos"),
ConstructVarPos, VarPosVar, !VarSet, !VarTypes),
+ svvarset.new_named_var("VarDesc", VarDesc, !VarSet),
( var_is_ground_in_instmap(!.ModuleInfo, InstMap, VarToInspect) ->
% Update proc_varset and proc_vartypes, without this, the
% polymorphism_make_type_info_var uses a prog_var which is
@@ -1051,10 +1061,9 @@
proc_info_get_vartypes(!.ProcInfo, !:VarTypes),
% Constructor of the variable's description.
- svvarset.new_named_var("VarDesc", VarDesc, !VarSet),
- ConsId = cons(qualified(SSDBModule, "bound_head_var"), 3),
- construct_type(TypeCtor, [], VarType),
- svmap.det_insert(VarDesc, VarType, !VarTypes),
+ ConsId = cons(qualified(SSDBModule, "bound_head_var"), 3,
+ VarValueTypeCtor),
+ svmap.det_insert(VarDesc, VarValueType, !VarTypes),
% Renaming contains the names of all instantiated arguments
% during the execution of the procedure's body.
@@ -1070,10 +1079,9 @@
[ConstructVarGoal],
svmap.det_insert(VarToInspect, VarDesc, !BoundVarDescs)
;
- svvarset.new_named_var("VarDesc", VarDesc, !VarSet),
- ConsId = cons(qualified(SSDBModule, "unbound_head_var"), 2),
- construct_type(TypeCtor, [], VarType),
- svmap.det_insert(VarDesc, VarType, !VarTypes),
+ ConsId = cons(qualified(SSDBModule, "unbound_head_var"), 2,
+ VarValueTypeCtor),
+ svmap.det_insert(VarDesc, VarValueType, !VarTypes),
construct_functor(VarDesc, ConsId, [VarNameVar, VarPosVar],
ConstructVarGoal),
Index: compiler/stack_opt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.37
diff -u -r1.37 stack_opt.m
--- compiler/stack_opt.m 27 Feb 2008 07:23:14 -0000 1.37
+++ compiler/stack_opt.m 7 Feb 2009 10:04:59 -0000
@@ -364,8 +364,8 @@
set(interval_id)
).
-:- pred use_cell(prog_var::in, list(prog_var)::in, cons_id::in, hlds_goal::in,
- interval_info::in, interval_info::out, stack_opt_info::in,
+:- pred use_cell(prog_var::in, list(prog_var)::in, cons_id::in,
+ hlds_goal::in, interval_info::in, interval_info::out, stack_opt_info::in,
stack_opt_info::out) is det.
use_cell(CellVar, FieldVarList, ConsId, Goal, !IntervalInfo, !StackOptInfo) :-
@@ -381,7 +381,7 @@
->
true
;
- ConsId = cons(_Name, _Arity),
+ ConsId = cons(_Name, _Arity, _TypeCtor),
IntParams = !.IntervalInfo ^ ii_interval_params,
VarTypes = IntParams ^ ip_var_types,
map.lookup(VarTypes, CellVar, Type),
@@ -532,8 +532,8 @@
BenefitNodes, CostNodes, ViaCellVars)
).
-:- pred record_matching_result(prog_var::in, cons_id::in, list(prog_var)::in,
- set(prog_var)::in, hlds_goal::in, set(anchor)::in,
+:- pred record_matching_result(prog_var::in, cons_id::in,
+ list(prog_var)::in, set(prog_var)::in, hlds_goal::in, set(anchor)::in,
set(interval_id)::in, interval_info::in, interval_info::out,
stack_opt_info::in, stack_opt_info::out) is det.
@@ -1054,7 +1054,7 @@
term.var_to_int(CellVar, CellVarNum),
io.write_int(CellVarNum, !IO),
io.write_string(" => ", !IO),
- mercury_output_cons_id(ConsId, does_not_need_brackets, !IO),
+ write_cons_id_and_arity(ConsId, !IO),
io.write_string("(", !IO),
list.map(term.var_to_int, ArgVars, ArgVarNums),
write_int_list(ArgVarNums, !IO),
@@ -1075,11 +1075,10 @@
io.write_string("\n", !IO),
term.var_to_int(CellVar, CellVarNum),
list.map(term.var_to_int, ArgVars, ArgVarNums),
- list.map(term.var_to_int, set.to_sorted_list(ViaCellVars),
- ViaCellVarNums),
+ list.map(term.var_to_int, set.to_sorted_list(ViaCellVars), ViaCellVarNums),
io.write_int(CellVarNum, !IO),
io.write_string(" => ", !IO),
- mercury_output_cons_id(ConsId, does_not_need_brackets, !IO),
+ write_cons_id_and_arity(ConsId, !IO),
io.write_string("(", !IO),
write_int_list(ArgVarNums, !IO),
io.write_string("): via cell ", !IO),
Index: compiler/stm_expand.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stm_expand.m,v
retrieving revision 1.5
diff -u -r1.5 stm_expand.m
--- compiler/stm_expand.m 10 Mar 2009 05:00:30 -0000 1.5
+++ compiler/stm_expand.m 30 May 2009 08:35:59 -0000
@@ -174,6 +174,23 @@
:- implementation.
+:- import_module check_hlds.inst_match.
+:- import_module check_hlds.mode_util.
+:- import_module check_hlds.polymorphism.
+:- import_module hlds.goal_util.
+:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_pred.
+:- import_module hlds.hlds_rtti.
+:- import_module hlds.instmap.
+:- import_module hlds.pred_table.
+:- import_module hlds.quantification.
+:- import_module libs.compiler_util.
+:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
+:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_mode.
+:- import_module parse_tree.prog_type.
+
:- import_module assoc_list.
:- import_module bool.
:- import_module int.
@@ -181,29 +198,14 @@
:- import_module list.
:- import_module map.
:- import_module maybe.
+:- import_module pair.
:- import_module set.
:- import_module string.
:- import_module svmap.
:- import_module svvarset.
:- import_module term.
-:- import_module pair.
:- import_module varset.
-:- import_module check_hlds.polymorphism.
-:- import_module check_hlds.inst_match.
-:- import_module check_hlds.mode_util.
-:- import_module hlds.goal_util.
-:- import_module hlds.hlds_goal.
-:- import_module hlds.hlds_pred.
-:- import_module hlds.hlds_rtti.
-:- import_module hlds.instmap.
-:- import_module hlds.pred_table.
-:- import_module hlds.quantification.
-:- import_module libs.compiler_util.
-:- import_module parse_tree.prog_type.
-:- import_module mdbcomp.prim_data.
-:- import_module parse_tree.prog_data.
-
%-----------------------------------------------------------------------------%
% Information about the predicate which contains the atomic goal along
@@ -546,8 +548,8 @@
order_vars_into_groups_2(ModuleInfo, Vars, InitInstmap, FinalInstmap,
!LocalVars, !InputVars, !OutputVars).
-:- pred common_goal_vars_from_list(list(stm_goal_vars)::in,
- stm_goal_vars::out) is det.
+:- pred common_goal_vars_from_list(list(stm_goal_vars)::in, stm_goal_vars::out)
+ is det.
common_goal_vars_from_list(GoalList, GoalVar) :-
ExtractInputSet = (pred(AGV::in, Input::out) is det :-
@@ -595,9 +597,9 @@
unexpected(this_file, "calc_pred_variables_list: lengths mismatch")
).
- % Arranges all variables from the goal and non-locals into local
- % variables, input variables and output variables. All variables that
- % appear in the list of IgnoreVarList are not included.
+ % Arranges all variables from the goal and non-locals into local variables,
+ % input variables and output variables. All variables that appear in the
+ % list of IgnoreVarList are not included.
%
:- pred calc_pred_variables(instmap::in, instmap::in,
hlds_goal::in, prog_var::in, prog_var::in, list(prog_var)::in,
@@ -605,7 +607,6 @@
calc_pred_variables(InitInstmap, FinalInstmap, HldsGoal,
InnerDI, InnerUO, IgnoreVarList, StmGoalVars, !StmInfo) :-
-
ModuleInfo = !.StmInfo ^ stm_info_module_info,
goal_vars(HldsGoal, GoalVars0),
@@ -668,8 +669,7 @@
).
% Strip the dummy predicates. At the very minimum, these predicates
- % should be in the atomic goal so the atomic goal must be a
- % conjunction.
+ % should be in the atomic goal so the atomic goal must be a conjunction.
%
:- pred strip_goal_calls(hlds_goal::in, hlds_goal::out,
prog_var::out, prog_var::out, prog_var::out, prog_var::out) is det.
@@ -730,16 +730,16 @@
(
OrElseGoals = [],
- % If no or_else goals, simply connect up the outer and inner variables
+ % If no or_else goals, simply connect up the outer and inner variables.
create_var_unify_stm(MainInnerDI, MainOuterDI,
- pair(mer_mode_uo, mer_mode_di), CopyDIVars, !StmInfo),
+ pair(uo_mode, di_mode), CopyDIVars, !StmInfo),
create_var_unify_stm(MainOuterUO, MainInnerUO,
- pair(mer_mode_uo, mer_mode_di), CopyUOVars, !StmInfo),
+ pair(uo_mode, di_mode), CopyUOVars, !StmInfo),
create_plain_conj([CopyDIVars, AtomicGoal, CopyUOVars], HldsGoal)
;
OrElseGoals = [_ | _],
- % Creates a call to an or_else branch predicate
+ % Creates a call to an or_else branch predicate.
calc_pred_variables_list(InitInstmap, FinalInstmap,
[AtomicGoal0 | OrElseGoals0], [MainInnerDI | OrElseInnerDIs],
[MainInnerUO | OrElseInnerUOs], [OuterDI, OuterUO],
@@ -747,8 +747,8 @@
GoalList = [AtomicGoal | OrElseGoals],
common_goal_vars_from_list(AtomicGoalVarList, AtomicGoalVars),
-% copy_input_vars_in_goallist(AtomicGoalVars, AtomicGoalVarList,
-% AtomicGoalVarList1),
+% copy_input_vars_in_goallist(AtomicGoalVars, AtomicGoalVarList,
+% AtomicGoalVarList1),
AtomicGoalVarList1 = AtomicGoalVarList,
trace [io(!IO)] (
@@ -763,23 +763,23 @@
get_input_output_types(AtomicGoalVars, !.StmInfo, _, OutputTypes),
make_return_type(OutputTypes, ResultType),
create_aux_variable_stm(ResultType, yes("res"), ResultVar, !StmInfo),
- CreateWrapperForEachGoal = (
- pred(Goal::in, GoalVars::in, PPID::out, SInfo0::in,
+ CreateWrapperForEachGoal =
+ ( pred(Goal::in, GoalVars::in, PPID::out, SInfo0::in,
SInfo::out) is det :-
- % These predicates should be plain predicates without code to
- % validate logs.
- create_simple_wrapper_pred(GoalVars, ResultType, ResultVar,
- Goal, PPID, _, SInfo0, SInfo)
- ),
+ % These predicates should be plain predicates without code to
+ % validate logs.
+ create_simple_wrapper_pred(GoalVars, ResultType, ResultVar,
+ Goal, PPID, _, SInfo0, SInfo)
+ ),
map2_in_foldl(CreateWrapperForEachGoal, GoalList, AtomicGoalVarList1,
PPIDList, !StmInfo),
create_or_else_pred(AtomicGoalVars, AtomicGoalVarList1, PPIDList,
MainInnerDI, MainInnerUO, OrElseCall, !StmInfo),
create_var_unify_stm(MainInnerDI, MainOuterDI,
- pair(mer_mode_uo, mer_mode_di), CopyDIVars, !StmInfo),
+ pair(uo_mode, di_mode), CopyDIVars, !StmInfo),
create_var_unify_stm(MainOuterUO, MainInnerUO,
- pair(mer_mode_uo, mer_mode_di), CopyUOVars, !StmInfo),
+ pair(uo_mode, di_mode), CopyUOVars, !StmInfo),
create_plain_conj([CopyDIVars, OrElseCall, CopyUOVars], HldsGoal)
).
@@ -792,7 +792,6 @@
create_top_level_goal(InitInstmap, FinalInstmap, OuterDI, OuterUO,
_InnerDI, _InnerUO, AtomicGoal0, OrElseGoals0, HldsGoal, !StmInfo) :-
-
strip_goal_calls(AtomicGoal0, AtomicGoal, _, _, MainInnerDI, MainInnerUO),
list.map5(strip_goal_calls, OrElseGoals0, OrElseGoals, _, _,
OrElseInnerDIs, OrElseInnerUOs),
@@ -828,11 +827,11 @@
get_input_output_modes(AtomicGoalVars, InputModes, OutputModes),
create_cloned_pred(InputVars ++ OutputVars ++ [OuterDI, OuterUO],
- InputTypes ++ OutputTypes ++ [stm_io_type, stm_io_type],
- InputModes ++ OutputModes ++ [mer_mode_di, mer_mode_uo], "toplevel",
+ InputTypes ++ OutputTypes ++ [io_io_type, io_io_type],
+ InputModes ++ OutputModes ++ [di_mode, uo_mode], "toplevel",
AtomicGoal, no, NewPredInfo0, HldsGoal, !StmInfo),
- create_var_unify(OuterUO, OuterDI, pair(mer_mode_uo, mer_mode_di),
+ create_var_unify(OuterUO, OuterDI, pair(uo_mode, di_mode),
CopyIOAssign, NewPredInfo0, NewPredInfo1),
create_plain_conj([WrapperCall, CopyIOAssign], TopLevelGoal),
@@ -859,9 +858,9 @@
%
% The RttiVar variable must contain ...
%
-:- pred template_if_exceptres_is_cons(prog_var::in, prog_var::in, cons_id::in,
- hlds_goal::in, hlds_goal::in, hlds_goal::out, stm_new_pred_info::in,
- stm_new_pred_info::out) is det.
+:- pred template_if_exceptres_is_cons(prog_var::in, prog_var::in,
+ cons_id::in, hlds_goal::in, hlds_goal::in, hlds_goal::out,
+ stm_new_pred_info::in, stm_new_pred_info::out) is det.
template_if_exceptres_is_cons(RttiVar, ExceptVar, RollbackExceptCons,
TrueGoal, FalseGoal, HldsGoal, !NewPredInfo) :-
@@ -870,18 +869,18 @@
create_aux_variable_assignment(RollbackExceptCons,
stm_rollback_exception_type, yes("RollbackExcpt"), AssignGoal,
RollbackExceptVar, !NewPredInfo),
- create_simple_call(module_univ_sym_name, "type_to_univ", pf_predicate,
+ create_simple_call(mercury_univ_module, "type_to_univ", pf_predicate,
mode_no(2), detism_semi, purity_pure,
[RttiVar, UnivPayloadVar, ExceptVar], [],
[pair(RttiVar, ground(shared, none)),
pair(ExceptVar, ground(shared, none)), pair(UnivPayloadVar, free)],
UnivCall, !NewPredInfo),
- create_simple_call(module_builtin_sym_name, "unify", pf_predicate,
+ create_simple_call(mercury_public_builtin_module, "unify", pf_predicate,
only_mode, detism_semi, purity_pure,
[RttiVar, RollbackExceptVar, UnivPayloadVar], [],
[], _UnifyCall, !NewPredInfo),
create_var_test(UnivPayloadVar, RollbackExceptVar,
- pair(mer_mode_in, mer_mode_in), TestGoal, !NewPredInfo),
+ pair(in_mode, in_mode), TestGoal, !NewPredInfo),
% XXX STM
% create_plain_conj([AssignGoal, UnivCall, TestGoal, UnifyCall], CondGoal),
create_plain_conj([AssignGoal, UnivCall, TestGoal], CondGoal),
@@ -916,11 +915,12 @@
HldsGoals, !NewPredInfo) :-
create_aux_variable(stm_valid_result_type, yes("ValidResult"),
IsValidVar, !NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_lock", pf_predicate,
+ create_simple_call(mercury_stm_builtin_module, "stm_lock", pf_predicate,
only_mode, detism_det, purity_impure, [], [], [], LockCall,
!NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_validate", pf_predicate,
- only_mode, detism_det, purity_impure, [StmVar, IsValidVar], [],
+ create_simple_call(mercury_stm_builtin_module, "stm_validate",
+ pf_predicate, only_mode, detism_det, purity_impure,
+ [StmVar, IsValidVar], [],
[pair(StmVar, ground(unique, none)), pair(IsValidVar, free)],
ValidCall, !NewPredInfo),
create_switch_disjunction(IsValidVar,
@@ -929,9 +929,9 @@
purity_impure, DisjGoal, !NewPredInfo),
(
UnlockAfterwards = yes,
- create_simple_call(module_stm_sym_name, "stm_unlock", pf_predicate,
- only_mode, detism_det, purity_impure, [], [], [], UnlockCall,
- !NewPredInfo),
+ create_simple_call(mercury_stm_builtin_module, "stm_unlock",
+ pf_predicate, only_mode, detism_det, purity_impure, [], [], [],
+ UnlockCall, !NewPredInfo),
HldsGoals = [LockCall, ValidCall, UnlockCall, DisjGoal]
;
UnlockAfterwards = no,
@@ -951,7 +951,7 @@
stm_valid_result_type, yes("IsValidConst"), AssignValidConst,
IsValidConstVar, !NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_lock", pf_predicate,
+ create_simple_call(mercury_stm_builtin_module, "stm_lock", pf_predicate,
only_mode, detism_det, purity_impure, [], [], [], LockCall,
!NewPredInfo),
@@ -961,7 +961,7 @@
NPI0::in, NPI::out) is det :-
create_aux_variable(stm_valid_result_type, yes("ValidResult"),
ValidResL, NPI0, NPI1),
- create_simple_call(module_stm_sym_name, "stm_validate",
+ create_simple_call(mercury_stm_builtin_module, "stm_validate",
pf_predicate, only_mode, detism_det, purity_impure,
[StmVarL, ValidResL], [], [pair(StmVarL, ground(unique, none)),
pair(ValidResL, free)], ValidGoalL, NPI1, NPI)),
@@ -969,10 +969,11 @@
list.map2_foldl(CreateValidate, StmVars, ValidCalls, IsValidVars,
!NewPredInfo),
- CreateValidTests = (pred(ValidRes::in, ValidTest::out, NPI0::in,
- NPI::out) is det :-
- create_var_test(ValidRes, IsValidConstVar,
- pair(mer_mode_in, mer_mode_in), ValidTest, NPI0, NPI)),
+ CreateValidTests =
+ (pred(ValidRes::in, ValidTest::out, NPI0::in, NPI::out) is det :-
+ create_var_test(ValidRes, IsValidConstVar,
+ pair(in_mode, in_mode), ValidTest, NPI0, NPI)
+ ),
list.map_foldl(CreateValidTests, IsValidVars, TestValidGoals,
!NewPredInfo),
@@ -983,9 +984,9 @@
(
UnlockAfterwards = yes,
- create_simple_call(module_stm_sym_name, "stm_unlock", pf_predicate,
- only_mode, detism_det, purity_impure, [], [], [], UnlockCall,
- !NewPredInfo),
+ create_simple_call(mercury_stm_builtin_module, "stm_unlock",
+ pf_predicate, only_mode, detism_det, purity_impure, [], [], [],
+ UnlockCall, !NewPredInfo),
HldsGoals = [AssignValidConst, LockCall] ++ ValidCalls ++
[UnlockCall, ITEGoal]
;
@@ -1026,7 +1027,7 @@
create_validate_exception_goal(StmVar, ExceptionVar, ReturnType, RecursiveCall,
HldsGoal, !NewPredInfo) :-
make_type_info(ReturnType, TypeInfoVar, CreateTypeInfoGoals, !NewPredInfo),
- create_simple_call(module_exception_sym_name, "rethrow", pf_predicate,
+ create_simple_call(mercury_exception_module, "rethrow", pf_predicate,
only_mode, detism_erroneous, purity_pure, [TypeInfoVar, ExceptionVar],
[],
[pair(TypeInfoVar, ground(shared, none)),
@@ -1048,15 +1049,16 @@
hlds_goal::out, stm_new_pred_info::in, stm_new_pred_info::out) is det.
create_retry_handler_branch(StmVar, RecCall, HldsGoal, !NewPredInfo) :-
- create_simple_call(module_stm_sym_name, "stm_block", pf_predicate,
+ create_simple_call(mercury_stm_builtin_module, "stm_block", pf_predicate,
only_mode, detism_det, purity_impure, [StmVar], [],
[pair(StmVar, ground(unique, none))], BlockGoal, !NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_unlock", pf_predicate,
+ create_simple_call(mercury_stm_builtin_module, "stm_unlock", pf_predicate,
only_mode, detism_det, purity_impure, [], [], [], UnlockGoal,
!NewPredInfo),
template_lock_and_validate(StmVar, no, BlockGoal, UnlockGoal,
LockAndValidateGoals, !NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_discard_transaction_log",
+ create_simple_call(mercury_stm_builtin_module,
+ "stm_discard_transaction_log",
pf_predicate, only_mode, detism_det, purity_impure,
[StmVar], [], [pair(StmVar, ground(clobbered, none))],
DropStateCall, !NewPredInfo),
@@ -1074,13 +1076,14 @@
create_test_on_exception(ExceptVar, StmVar, ReturnType, RecCall, HldsGoal,
!NewPredInfo) :-
- create_aux_variable(stm_univ_type, yes("ExceptUnivVar"), ExceptUnivVar,
+ create_aux_variable(univ_type, yes("ExceptUnivVar"), ExceptUnivVar,
!NewPredInfo),
- deconstruct_functor(ExceptVar, stm_exceptres_exception_functor,
+ deconstruct_functor(ExceptVar, exception_exception_functor,
[ExceptUnivVar], DeconstructException),
make_type_info(stm_rollback_exception_type, TypeInfoRollbackVar,
TypeInfoRollbackAssign, !NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_discard_transaction_log",
+ create_simple_call(mercury_stm_builtin_module,
+ "stm_discard_transaction_log",
pf_predicate, only_mode, detism_det, purity_impure, [StmVar], [],
[pair(StmVar, ground(clobbered, none))], DropStateGoal, !NewPredInfo),
@@ -1117,7 +1120,7 @@
create_closure(WrapperID, InputVars,
InputTypes ++ [ReturnType, stm_state_type, stm_state_type],
- InputModes ++ [mer_mode_out, mer_mode_di, mer_mode_uo],
+ InputModes ++ [out_mode, di_mode, uo_mode],
AtomicClosureVar, ClosureAssign, !NewPredInfo),
make_type_info(ReturnType, RttiTypeVar, RttiTypeVarAssign, !NewPredInfo),
@@ -1125,14 +1128,15 @@
% Creates the necessary exception types, based on the output type of
% the stm predicate.
- Exception_Result_Type = stm_exception_result_type(ReturnType),
- ExceptRes_Success_Functor = stm_exceptres_success_functor,
- ExceptRes_Failure_Functor = stm_exceptres_exception_functor,
+ Exception_Result_Type = exception_result_type(ReturnType),
+ ExceptRes_Success_Functor = exception_succeeded_functor,
+ ExceptRes_Failure_Functor = exception_exception_functor,
create_aux_variable(Exception_Result_Type, yes("ExceptionResult"),
ReturnExceptVar, !NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_create_transaction_log",
+ create_simple_call(mercury_stm_builtin_module,
+ "stm_create_transaction_log",
pf_predicate, only_mode, detism_det, purity_impure, [StmVarDI], [],
[pair(StmVarDI, ground(unique, none))], HldsGoal_StmCreate,
!NewPredInfo),
@@ -1140,7 +1144,7 @@
% TODO: Select mode based on determism of actual goal. 0 if determistic,
% 1 if cc_multi.
- create_simple_call(module_exception_sym_name, "unsafe_try_stm",
+ create_simple_call(mercury_exception_module, "unsafe_try_stm",
pf_predicate, mode_no(0), detism_cc_multi, purity_pure,
[RttiTypeVar, AtomicClosureVar, ReturnExceptVar, StmVarDI, StmVarUO],
[], [pair(RttiTypeVar, ground(shared, none)),
@@ -1185,8 +1189,8 @@
InputModes ++ OutputModes, "rollback", AtomicGoal, no, NewPredInfo0,
CallGoal, !StmInfo),
- create_rollback_pred_2(AtomicGoalVarList, CallGoal, AtomicGoal, OrElseGoals,
- NewPredInfo0, NewPredInfo, !StmInfo),
+ create_rollback_pred_2(AtomicGoalVarList, CallGoal,
+ AtomicGoal, OrElseGoals, NewPredInfo0, NewPredInfo, !StmInfo),
commit_new_pred(NewPredInfo, !StmInfo).
:- pred create_rollback_pred_2(list(stm_goal_vars)::in, hlds_goal::in,
@@ -1236,8 +1240,8 @@
apply_varset_to_preds(ProgVar, !NewPredVarSet, !NewPredVarTypes,
!OldPredVarSet, !OldPredVarTypes, !VarMapping) :-
map.lookup(!.OldPredVarTypes, ProgVar, ProgType),
-% delete_var(!.OldPredVarSet, ProgVar, !:OldPredVarSet),
-% map.delete(!.OldPredVarTypes, ProgVar, !:OldPredVarTypes),
+% delete_var(!.OldPredVarSet, ProgVar, !:OldPredVarSet),
+% map.delete(!.OldPredVarTypes, ProgVar, !:OldPredVarTypes),
new_var(NewProgVar, !NewPredVarSet),
map.det_insert(!.NewPredVarTypes, NewProgVar, ProgType,
!:NewPredVarTypes),
@@ -1357,7 +1361,7 @@
create_cloned_pred(InputVars ++ [ResultVar0, InnerDI, InnerUO0],
InputTypes ++ [ResultType, stm_state_type, stm_state_type],
- InputModes ++ [mer_mode_out, mer_mode_di, mer_mode_uo],
+ InputModes ++ [out_mode, di_mode, uo_mode],
"wrapper", !.AtomicGoal, no, !:NewPredInfo, CallGoal, !StmInfo),
rename_var_in_wrapper_pred("stm_ResultVar", ResultVar0, ResultType,
@@ -1402,8 +1406,8 @@
create_post_wrapper_goal(AtomicGoalVars, AtomicGoal, ResultType, ResultVar,
StmDI, StmUO, CopySTM, HldsGoal, StmInfo, !NewPredInfo) :-
- StmModuleName = module_stm_sym_name,
- ExceptionModuleName = module_exception_sym_name,
+ StmModuleName = mercury_stm_builtin_module,
+ ExceptionModuleName = mercury_exception_module,
construct_output(AtomicGoalVars, ResultType, ResultVar, StmInfo,
AssignResult, !NewPredInfo),
@@ -1464,12 +1468,14 @@
create_promise_purity_scope(PostAtomicGoal0, purity_pure, PostAtomicGoal),
% Creates the unification between StmUO and StmDI is needed.
- ( CopySTM = yes ->
- create_var_unify(StmUO, StmDI, pair(mer_mode_uo, mer_mode_di),
+ (
+ CopySTM = yes,
+ create_var_unify(StmUO, StmDI, pair(uo_mode, di_mode),
CopySTMAssign, !NewPredInfo),
TopLevelGoalList0 = [AtomicGoal] ++ AssignResult ++ [CopySTMAssign,
PostAtomicGoal]
;
+ CopySTM = no,
TopLevelGoalList0 = [AtomicGoal] ++ AssignResult ++
[PostAtomicGoal]
),
@@ -1503,7 +1509,7 @@
create_cloned_pred(InputVars ++ [ResultVar0, InnerDI, InnerUO0],
InputTypes ++ [ResultType, stm_state_type, stm_state_type],
- InputModes ++ [mer_mode_out, mer_mode_di, mer_mode_uo],
+ InputModes ++ [out_mode, di_mode, uo_mode],
"simple_wrapper", !.AtomicGoal, no, !:NewPredInfo, CallGoal, !StmInfo),
rename_var_in_wrapper_pred("stm_ResultVar", ResultVar0, ResultType,
@@ -1563,7 +1569,7 @@
% Creates the unification between StmUO and StmDI is needed.
( CopySTM = yes ->
- create_var_unify(StmUO, StmDI, pair(mer_mode_uo, mer_mode_di),
+ create_var_unify(StmUO, StmDI, pair(uo_mode, di_mode),
CopySTMAssign, !NewPredInfo),
TopLevelGoalList0 = Call1 ++ [CopySTMAssign, AtomicGoal] ++ Call2 ++
AssignResult
@@ -1591,13 +1597,13 @@
get_input_output_types(AtomicGoalVars, !.StmInfo, InputTypes, OutputTypes),
get_input_output_modes(AtomicGoalVars, InputModes, OutputModes),
-% MaybeDetism = yes(detism_cc_multi),
+% MaybeDetism = yes(detism_cc_multi),
MaybeDetism = no,
make_return_type(OutputTypes, ReturnType),
create_cloned_pred(InputVars ++ OutputVars ++ [StmDI, StmUO],
InputTypes ++ OutputTypes ++ [stm_state_type, stm_state_type],
- InputModes ++ OutputModes ++ [mer_mode_di, mer_mode_uo],
+ InputModes ++ OutputModes ++ [di_mode, uo_mode],
"or_else", true_goal, MaybeDetism, NewPredInfo0, CallGoal,
!StmInfo),
@@ -1771,7 +1777,7 @@
MakeMergeGoals = (pred(StmVar::in, ThreadSTMDI::in, ThreadSTMUO::in,
Goal::out, NPI0::in, NPI::out) is det :-
- create_simple_call(module_stm_sym_name, "stm_merge_nested_logs",
+ create_simple_call(mercury_stm_builtin_module, "stm_merge_nested_logs",
pf_predicate, only_mode, detism_det, purity_impure,
[StmVar, ThreadSTMDI, ThreadSTMUO], [],
[pair(StmVar, ground(unique, none)), pair(ThreadSTMDI, free),
@@ -1781,21 +1787,22 @@
map3_in_foldl(MakeMergeGoals, StmVars, MergeStmVarsIn, MergeStmVarsOut,
MergeGoals, !NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_unlock", pf_predicate,
+ create_simple_call(mercury_stm_builtin_module, "stm_unlock", pf_predicate,
only_mode, detism_det, purity_impure, [], [], [], UnlockCall,
!NewPredInfo),
create_aux_variable_assignment(stm_rollback_retry_functor,
stm_rollback_exception_type, yes("RetryCons"), AssignRetryCons,
RetryConsVar, !NewPredInfo),
- create_simple_call(module_exception_sym_name, "throw", pf_predicate,
+ create_simple_call(mercury_exception_module, "throw", pf_predicate,
only_mode, detism_erroneous, purity_pure, [ExceptionRttiVar,
RetryConsVar], [], [pair(ExceptionRttiVar, ground(shared, none)),
pair(RetryConsVar, ground(shared, none))], RetryCall,
!NewPredInfo),
% XXX STM
-% create_simple_call(module_stm_sym_name, "retry", pf_predicate, only_mode,
+% create_simple_call(mercury_stm_builtin_module, "retry",
+% pf_predicate, only_mode,
% detism_det, purity_pure, [OuterSTMUO], [],
% [pair(OuterSTMUO, ground(unique, none))], RetryCall, !NewPredInfo),
create_plain_conj(MergeGoals ++ [UnlockCall, AssignRetryCons, RetryCall],
@@ -1806,7 +1813,7 @@
create_aux_variable_assignment(stm_rollback_exception_functor,
stm_rollback_exception_type, yes("RollbackCons"), AssignRollbackCons,
RollbackConsVar, !NewPredInfo),
- create_simple_call(module_exception_sym_name, "throw", pf_predicate,
+ create_simple_call(mercury_exception_module, "throw", pf_predicate,
only_mode, detism_erroneous, purity_pure, [ExceptionRttiVar,
RollbackConsVar], [], [pair(ExceptionRttiVar, ground(shared, none)),
pair(RollbackConsVar, ground(shared, none))], ThrowCall,
@@ -1819,20 +1826,20 @@
create_plain_conj(HldsGoals, HldsGoal).
% Variables are:
- % StmGoalVars
- % ReturnType -- Return type of the or_else pred
- % ReturnValue -- Return variable of the or_else pred (not
- % decompressed)
- % OuterStmDIVar -- Outer STM DI Variable (in pred head)
- % OuterStmUOVar -- Outer STM UO Variable (in pred head)
- % RttiVar -- Variable holding type_info for ReturnType
- % RollbackExceptionRttiVar -- Variable holding type_info forr
- % "stm_builtin.rollback_exception_type"
- % WrapperID -- The predicate ID of the call to try
- % RetryBranch -- The goal to execute when a retry is called
- % InnerSTMVar -- The DI variable of the retry branch. It must
- % be created outside this predicate as it needs to be
- % known to the validate & merge branch.
+ %
+ % StmGoalVars
+ % ReturnType -- Return type of the or_else pred
+ % ReturnValue -- Return variable of the or_else pred (not decompressed)
+ % OuterStmDIVar -- Outer STM DI Variable (in pred head)
+ % OuterStmUOVar -- Outer STM UO Variable (in pred head)
+ % RttiVar -- Variable holding type_info for ReturnType
+ % RollbackExceptionRttiVar -- Variable holding type_info for
+ % "stm_builtin.rollback_exception_type"
+ % WrapperID -- The predicate ID of the call to try
+ % RetryBranch -- The goal to execute when a retry is called
+ % InnerSTMVar -- The DI variable of the retry branch. It must be created
+ % outside this predicate as it needs to be known to the validate & merge
+ % branch.
%
%
:- pred create_or_else_branch(stm_goal_vars::in, mer_type::in, prog_var::in,
@@ -1849,21 +1856,22 @@
create_aux_variable(stm_state_type, yes("InnerSTM0"), InnerSTM0Var,
!NewPredInfo),
- create_aux_variable(stm_exception_result_type(ReturnType), yes("ExcptRes"),
+ create_aux_variable(exception_result_type(ReturnType), yes("ExcptRes"),
ReturnExceptVar, !NewPredInfo),
create_closure(WrapperID, InputVars,
InputTypes ++ [ReturnType, stm_state_type, stm_state_type],
- InputModes ++ [mer_mode_out, mer_mode_di, mer_mode_uo],
+ InputModes ++ [out_mode, di_mode, uo_mode],
AtomicClosureVar, ClosureAssign, !NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_create_nested_transaction_log",
+ create_simple_call(mercury_stm_builtin_module,
+ "stm_create_nested_transaction_log",
pf_predicate, only_mode, detism_det, purity_impure,
[OuterStmDIVar, InnerSTM0Var], [],
[pair(OuterStmDIVar, ground(unique, none)), pair(InnerSTM0Var, free)],
CreateNestedLogCall, !NewPredInfo),
- create_simple_call(module_exception_sym_name, "unsafe_try_stm",
+ create_simple_call(mercury_exception_module, "unsafe_try_stm",
pf_predicate, mode_no(0), detism_cc_multi, purity_pure,
[RttiVar, AtomicClosureVar, ReturnExceptVar, InnerSTM0Var,InnerSTMVar],
[], [pair(RttiVar, ground(shared, none)),
@@ -1875,7 +1883,7 @@
% Successfull execution, deconstruct and return
deconstruct_output(AtomicGoalVars, ReturnType, ReturnExceptVar,
DeconstructGoal, StmInfo, !NewPredInfo),
- create_simple_call(module_stm_sym_name, "stm_merge_nested_logs",
+ create_simple_call(mercury_stm_builtin_module, "stm_merge_nested_logs",
pf_predicate, only_mode, detism_det, purity_impure,
[InnerSTMVar, OuterStmDIVar, OuterStmUOVar], [],
[pair(InnerSTMVar, ground(unique, none)),
@@ -1885,20 +1893,21 @@
create_plain_conj([DeconstructGoal, MergeNestedLogsCall], SuccessBranch),
% General exception: discard and throw upwards
- create_simple_call(module_stm_sym_name, "stm_discard_transaction_log",
+ create_simple_call(mercury_stm_builtin_module,
+ "stm_discard_transaction_log",
pf_predicate, only_mode, detism_det, purity_impure,
[InnerSTMVar], [], [pair(InnerSTMVar, ground(unique, none))],
DiscardCall, !NewPredInfo),
- create_simple_call(module_exception_sym_name, "rethrow",
+ create_simple_call(mercury_exception_module, "rethrow",
pf_predicate, only_mode, detism_erroneous, purity_pure,
[RttiVar, ReturnExceptVar], [], [pair(RttiVar, ground(shared, none)),
pair(ReturnExceptVar, ground(shared, none))], RethrowCall,
!NewPredInfo),
% Code to extract the exception result.
- create_aux_variable(stm_univ_type, yes("ExceptUnivVar"), ExceptUnivVar,
+ create_aux_variable(univ_type, yes("ExceptUnivVar"), ExceptUnivVar,
!NewPredInfo),
- deconstruct_functor(ReturnExceptVar, stm_exceptres_exception_functor,
+ deconstruct_functor(ReturnExceptVar, exception_exception_functor,
[ExceptUnivVar], DeconstructException),
create_plain_conj([DiscardCall, RethrowCall], NotRetryBranch),
@@ -1910,8 +1919,8 @@
create_plain_conj([DeconstructException, IfRetryGoal], ExceptionBranch),
create_switch_disjunction(ReturnExceptVar,
- [case(stm_exceptres_exception_functor, [], ExceptionBranch),
- case(stm_exceptres_success_functor, [], SuccessBranch)],
+ [case(exception_exception_functor, [], ExceptionBranch),
+ case(exception_succeeded_functor, [], SuccessBranch)],
detism_det, purity_impure, DisjGoal, !NewPredInfo),
create_plain_conj([CreateNestedLogCall, ClosureAssign, TryStmCall,
@@ -1933,13 +1942,10 @@
Types = [],
ReturnType = stm_dummy_output_type
;
- Types = [_ | _],
-
- ( Types = [SingleType] ->
- ReturnType = SingleType
- ;
- ReturnType = tuple_type(Types, kind_star)
- )
+ Types = [ReturnType]
+ ;
+ Types = [_, _ | _],
+ ReturnType = tuple_type(Types, kind_star)
).
% Creates the goals necessary for extracting the output variables from
@@ -1954,30 +1960,32 @@
get_input_output_varlist(AtomicGoalVars, _, OutputVars),
get_input_output_types(AtomicGoalVars, StmInfo, _, OutputTypes),
- ( OutputTypes = [] ->
+ (
+ OutputTypes = [],
% Extract the return type but do nothing with it. For reasons that
% I do not know, this is the bare minimum that is required without
% causing an exception in a later stage.
create_aux_variable(ReturnType, yes("BoringResult"), SucessResultVar,
!NewPredInfo),
- deconstruct_functor(ReturnExceptVar, stm_exceptres_success_functor,
+ deconstruct_functor(ReturnExceptVar, exception_succeeded_functor,
[SucessResultVar], HldsGoal)
-
- ; OutputTypes = [_] ->
+ ;
+ OutputTypes = [_],
% Wrapper returns a single value -- Simply get the value from the
% exception result and return.
OutVar = list.det_head(OutputVars),
- deconstruct_functor(ReturnExceptVar, stm_exceptres_success_functor,
+ deconstruct_functor(ReturnExceptVar, exception_succeeded_functor,
[OutVar], HldsGoal)
;
+ OutputTypes = [_, _ | _],
% Wrapper returns a tuple. Get the tuple result and return it.
make_type_info(ReturnType, _, MakeType, !NewPredInfo),
create_aux_variable(ReturnType, yes("SucessResult"), SucessResultVar,
!NewPredInfo),
- deconstruct_functor(ReturnExceptVar, stm_exceptres_success_functor,
+ deconstruct_functor(ReturnExceptVar, exception_succeeded_functor,
[SucessResultVar], DeconstructGoal),
deconstruct_tuple(SucessResultVar, OutputVars, UnifyOutputGoal),
@@ -1999,23 +2007,25 @@
get_input_output_varlist(AtomicGoalVars, _, OutputVars),
get_input_output_types(AtomicGoalVars, StmInfo, _, OutputTypes),
- ( OutputTypes = [] ->
+ (
+ OutputTypes = [],
% Since a value must be returned, simply return a value which will be
% discarded.
create_const_assign(ResultVar, stm_dummy_output_functor, HldsGoal),
HldsGoals = [HldsGoal]
-
- ; OutputTypes = [_] ->
+ ;
+ OutputTypes = [_],
% Wrapper returns a single value -- Simply get the value from the
% exception result and return.
OutVar = list.det_head(OutputVars),
- create_var_unify(ResultVar, OutVar, pair(mer_mode_out, mer_mode_in),
+ create_var_unify(ResultVar, OutVar, pair(out_mode, in_mode),
HldsGoal, !NewPredInfo),
HldsGoals = [HldsGoal]
;
+ OutputTypes = [_, _ | _],
% Wrapper returns a tuple. Creates a tuple from the output values.
make_type_info(ResultType, _, MakeType, !NewPredInfo),
@@ -2058,7 +2068,7 @@
proc_info_set_varset(NewPredVarSet, NewProcInfo0, NewProcInfo1),
proc_info_set_vartypes(NewPredVarTypes, NewProcInfo1, NewProcInfo2),
proc_info_set_headvars(NewHeadVars, NewProcInfo2, NewProcInfo),
- !:NewPredInfo = !.NewPredInfo ^ new_pred_proc_info := NewProcInfo.
+ !NewPredInfo ^ new_pred_proc_info := NewProcInfo.
%-----------------------------------------------------------------------------%
%
@@ -2088,7 +2098,7 @@
MaybeName = yes(Name ++ "_Aux_STM")
),
proc_info_create_var_from_type(Type, MaybeName, Var, ProcInfo0, ProcInfo),
- !:StmInfo = !.StmInfo ^ stm_info_proc_info := ProcInfo.
+ !StmInfo ^ stm_info_proc_info := ProcInfo.
% Creates an auxiliary variable with a specific type
%
@@ -2107,12 +2117,13 @@
),
proc_info_create_var_from_type(Type, MaybeName, Var, ProcInfo0, ProcInfo),
Cnt = Cnt0 + 1,
- !:NewPredInfo = !.NewPredInfo ^ new_pred_proc_info := ProcInfo,
- !:NewPredInfo = !.NewPredInfo ^ new_pred_var_cnt := Cnt.
+ !NewPredInfo ^ new_pred_proc_info := ProcInfo,
+ !NewPredInfo ^ new_pred_var_cnt := Cnt.
% Creates a goal which assigns a variable to a cons_id.
%
-:- pred create_const_assign(prog_var::in, cons_id::in, hlds_goal::out) is det.
+:- pred create_const_assign(prog_var::in, cons_id::in, hlds_goal::out)
+ is det.
create_const_assign(Var, Const, AssignmentGoal) :-
make_const_construction(Var, Const, AssignmentGoal).
@@ -2244,7 +2255,7 @@
ShroudPredProcID = shroud_pred_proc_id(PredProcID),
construct_higher_order_pred_type(purity_pure, lambda_normal, ArgTypes,
ClosureType),
- ClosureCons = pred_const(ShroudPredProcID, lambda_normal),
+ ClosureCons = closure_cons(ShroudPredProcID, lambda_normal),
create_aux_variable(ClosureType, yes("Closure"), ClosureVar, !NewPredInfo),
construct_functor(ClosureVar, ClosureCons, Args, ClosureAssignGoal0),
@@ -2559,6 +2570,7 @@
% Used by "get_input_output_modes".
%
:- pred set_list_val(X::in, Y::in, X::out) is det.
+
set_list_val(X, _, X).
% Get the list of modes corresponding to the input and output
@@ -2570,103 +2582,20 @@
get_input_output_modes(StmGoalVars, InputModes, OutputModes) :-
get_input_output_varlist(StmGoalVars, InputVars, OutputVars),
- list.map(set_list_val(mer_mode_in), InputVars, InputModes),
- list.map(set_list_val(mer_mode_out), OutputVars, OutputModes).
+ list.map(set_list_val(in_mode), InputVars, InputModes),
+ list.map(set_list_val(out_mode), OutputVars, OutputModes).
%-----------------------------------------------------------------------------%
-%
-% Constants of modules, types and functors that are useful in this source to
-% source transformation.
-%
-
- % Module names
- %
-:- func module_stm_sym_name = sym_name.
-:- func module_exception_sym_name = sym_name.
-:- func module_univ_sym_name = sym_name.
-:- func module_builtin_sym_name = sym_name.
-:- func module_io_sym_name = sym_name.
% Special (dummy) predicate names
%
:- func stm_inner_outer = sym_name.
:- func stm_outer_inner = sym_name.
- % Types
- %
-:- func stm_state_type = mer_type.
-:- func stm_valid_result_type = mer_type.
-:- func stm_rollback_exception_type = mer_type.
-:- func stm_dummy_output_type = mer_type.
-:- func stm_univ_type = mer_type.
-:- func stm_io_type = mer_type.
-:- func stm_exception_result_type(mer_type) = mer_type.
-
- % Function symbols (ie: cons_id)
- %
-:- func stm_validres_valid_functor = cons_id.
-:- func stm_validres_invalid_functor = cons_id.
-:- func stm_rollback_exception_functor = cons_id.
-:- func stm_rollback_retry_functor = cons_id.
-:- func stm_dummy_output_functor = cons_id.
-:- func stm_exceptres_success_functor = cons_id.
-:- func stm_exceptres_exception_functor = cons_id.
-
- % Modes
- %
-:- func mer_mode_in = mer_mode.
-:- func mer_mode_out = mer_mode.
-:- func mer_mode_di = mer_mode.
-:- func mer_mode_uo = mer_mode.
-
-module_stm_sym_name = mercury_stm_builtin_module.
-module_builtin_sym_name = mercury_public_builtin_module.
-module_exception_sym_name = unqualified("exception").
-module_univ_sym_name = unqualified("univ").
-module_io_sym_name = unqualified("io").
-
-stm_inner_outer = qualified(module_stm_sym_name, "stm_from_inner_to_outer").
-stm_outer_inner = qualified(module_stm_sym_name, "stm_from_outer_to_inner").
-
-stm_state_type =
- defined_type(qualified(module_stm_sym_name, "stm"), [], kind_star).
-stm_valid_result_type =
- defined_type(qualified(module_stm_sym_name, "stm_validation_result"),
- [], kind_star).
-stm_rollback_exception_type =
- defined_type(qualified(module_stm_sym_name, "rollback_exception"), [],
- kind_star).
-stm_dummy_output_type =
- defined_type(qualified(module_stm_sym_name, "stm_dummy_output"), [],
- kind_star).
-stm_univ_type =
- defined_type(qualified(module_univ_sym_name, "univ"), [], kind_star).
-stm_io_type =
- defined_type(qualified(module_io_sym_name, "state"), [], kind_star).
-
-stm_exception_result_type(SubType) =
- defined_type(qualified(module_exception_sym_name, "exception_result"),
- [SubType], kind_star).
-
-stm_validres_valid_functor =
- cons(qualified(module_stm_sym_name, "stm_transaction_valid"), 0).
-stm_validres_invalid_functor =
- cons(qualified(module_stm_sym_name, "stm_transaction_invalid"), 0).
-stm_rollback_exception_functor =
- cons(qualified(module_stm_sym_name, "rollback_invalid_transaction"), 0).
-stm_rollback_retry_functor =
- cons(qualified(module_stm_sym_name, "rollback_retry"), 0).
-stm_dummy_output_functor =
- cons(qualified(module_stm_sym_name, "stm_dummy_output"), 0).
-stm_exceptres_success_functor =
- cons(qualified(module_exception_sym_name, "succeeded"), 1).
-stm_exceptres_exception_functor =
- cons(qualified(module_exception_sym_name, "exception"), 1).
-
-mer_mode_in = user_defined_mode(qualified(unqualified("builtin"), "in"), []).
-mer_mode_out = user_defined_mode(qualified(unqualified("builtin"), "out"), []).
-mer_mode_di = user_defined_mode(qualified(unqualified("builtin"), "di"), []).
-mer_mode_uo = user_defined_mode(qualified(unqualified("builtin"), "uo"), []).
+stm_inner_outer =
+ qualified(mercury_stm_builtin_module, "stm_from_inner_to_outer_io").
+stm_outer_inner =
+ qualified(mercury_stm_builtin_module, "stm_from_outer_to_inner_io").
%-----------------------------------------------------------------------------%
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.70
diff -u -r1.70 stratify.m
--- compiler/stratify.m 10 Mar 2009 05:00:30 -0000 1.70
+++ compiler/stratify.m 12 Mar 2009 01:25:50 -0000
@@ -51,6 +51,7 @@
:- import_module check_hlds.mode_util.
:- import_module hlds.hlds_error_util.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
@@ -764,7 +765,7 @@
% happen as higher order constants have been transformed to
% lambda goals. See above.
Unification = construct(_, ConsId, _, _, _, _, _),
- ( ConsId = pred_const(ShroudedPredProcId, _) ->
+ ( ConsId = closure_cons(ShroudedPredProcId, _) ->
PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
set.insert(!.HasAT, PredProcId, !:HasAT)
;
@@ -886,7 +887,7 @@
% happen as higher order constants have been transformed to lambda
% goals. See above.
Unification = construct(_, ConsId, _, _, _, _, _),
- ( ConsId = pred_const(ShroudedPredProcId, _) ->
+ ( ConsId = closure_cons(ShroudedPredProcId, _) ->
PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
!:Calls = [PredProcId | !.Calls]
;
Index: compiler/structure_reuse.direct.detect_garbage.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/structure_reuse.direct.detect_garbage.m,v
retrieving revision 1.21
diff -u -r1.21 structure_reuse.direct.detect_garbage.m
--- compiler/structure_reuse.direct.detect_garbage.m 23 Dec 2008 01:37:41 -0000 1.21
+++ compiler/structure_reuse.direct.detect_garbage.m 5 Feb 2009 07:27:38 -0000
@@ -21,14 +21,14 @@
%-----------------------------------------------------------------------------%
- % Using the sharing table listing all the structure sharing of all
+ % Using the sharing table listing all the structure sharing of all
% the known procedures, return a table of all data structures that may
% become available for reuse (i.e. cells that may become dead) of a given
% procedure goal. The table also records the reuse condition associated
% with each of the dead cells.
%
-:- pred determine_dead_deconstructions(module_info::in, pred_info::in,
- proc_info::in, sharing_as_table::in, hlds_goal::in,
+:- pred determine_dead_deconstructions(module_info::in, pred_info::in,
+ proc_info::in, sharing_as_table::in, hlds_goal::in,
dead_cell_table::out) is det.
%-----------------------------------------------------------------------------%
@@ -45,7 +45,7 @@
:- import_module bool.
:- import_module io.
-:- import_module pair.
+:- import_module pair.
:- import_module set.
:- import_module string.
@@ -53,14 +53,14 @@
:- type detect_bg_info
---> detect_bg_info(
- module_info :: module_info,
- pred_info :: pred_info,
- proc_info :: proc_info,
+ module_info :: module_info,
+ pred_info :: pred_info,
+ proc_info :: proc_info,
sharing_table :: sharing_as_table,
very_verbose :: bool
).
-
-:- func detect_bg_info_init(module_info, pred_info, proc_info,
+
+:- func detect_bg_info_init(module_info, pred_info, proc_info,
sharing_as_table) = detect_bg_info.
detect_bg_info_init(ModuleInfo, PredInfo, ProcInfo, SharingTable) = BG :-
@@ -69,14 +69,14 @@
BG = detect_bg_info(ModuleInfo, PredInfo, ProcInfo, SharingTable,
VeryVerbose).
-determine_dead_deconstructions(ModuleInfo, PredInfo, ProcInfo, SharingTable,
- Goal, DeadCellTable) :-
+determine_dead_deconstructions(ModuleInfo, PredInfo, ProcInfo, SharingTable,
+ Goal, DeadCellTable) :-
Background = detect_bg_info_init(ModuleInfo, PredInfo, ProcInfo,
- SharingTable),
- % In this process we need to know the sharing at each program point,
+ SharingTable),
+ % In this process we need to know the sharing at each program point,
% which boils down to reconstructing that sharing information based on the
- % sharing recorded in the sharing table.
- determine_dead_deconstructions_2(Background, Goal,
+ % sharing recorded in the sharing table.
+ determine_dead_deconstructions_2(Background, Goal,
sharing_as_init, _, dead_cell_table_init, DeadCellTable),
% Add a newline after the "progress dots".
@@ -91,23 +91,23 @@
).
% Process a procedure goal, determining the sharing at each subgoal, as
- % well as constructing the table of dead cells.
+ % well as constructing the table of dead cells.
%
- % This means:
+ % This means:
% - at each program point: compute sharing
- % - at deconstruction unifications: check for a dead cell.
+ % - at deconstruction unifications: check for a dead cell.
%
-:- pred determine_dead_deconstructions_2(detect_bg_info::in, hlds_goal::in,
- sharing_as::in, sharing_as::out, dead_cell_table::in,
+:- pred determine_dead_deconstructions_2(detect_bg_info::in, hlds_goal::in,
+ sharing_as::in, sharing_as::out, dead_cell_table::in,
dead_cell_table::out) is det.
-determine_dead_deconstructions_2(Background, TopGoal, !SharingAs,
- !DeadCellTable) :-
- TopGoal = hlds_goal(GoalExpr, GoalInfo),
- ModuleInfo = Background ^ module_info,
- PredInfo = Background ^ pred_info,
- ProcInfo = Background ^ proc_info,
- SharingTable = Background ^ sharing_table,
+determine_dead_deconstructions_2(Background, TopGoal, !SharingAs,
+ !DeadCellTable) :-
+ TopGoal = hlds_goal(GoalExpr, GoalInfo),
+ ModuleInfo = Background ^ module_info,
+ PredInfo = Background ^ pred_info,
+ ProcInfo = Background ^ proc_info,
+ SharingTable = Background ^ sharing_table,
(
GoalExpr = conj(_, Goals),
list.foldl2(determine_dead_deconstructions_2_with_progress(Background),
@@ -122,38 +122,38 @@
GenDetails, CallArgs, Modes, GoalInfo, !SharingAs)
;
GoalExpr = unify(_, _, _, Unification, _),
- unification_verify_reuse(ModuleInfo, ProcInfo, GoalInfo,
- Unification, program_point_init(GoalInfo), !.SharingAs,
+ unification_verify_reuse(ModuleInfo, ProcInfo, GoalInfo,
+ Unification, program_point_init(GoalInfo), !.SharingAs,
!DeadCellTable),
!:SharingAs = add_unify_sharing(ModuleInfo, ProcInfo, Unification,
GoalInfo, !.SharingAs)
;
GoalExpr = disj(Goals),
- determine_dead_deconstructions_2_disj(Background, Goals, !SharingAs,
+ determine_dead_deconstructions_2_disj(Background, Goals, !SharingAs,
!DeadCellTable)
;
GoalExpr = switch(_, _, Cases),
- determine_dead_deconstructions_2_disj(Background,
+ determine_dead_deconstructions_2_disj(Background,
list.map(func(C) = G :- (G = C ^ case_goal), Cases), !SharingAs,
!DeadCellTable)
;
- % XXX To check and compare with the theory.
+ % XXX To check and compare with the theory.
GoalExpr = negation(_Goal)
;
GoalExpr = scope(Reason, SubGoal),
( Reason = from_ground_term(_, from_ground_term_construct) ->
true
;
- determine_dead_deconstructions_2(Background, SubGoal, !SharingAs,
+ determine_dead_deconstructions_2(Background, SubGoal, !SharingAs,
!DeadCellTable)
)
;
GoalExpr = if_then_else(_, IfGoal, ThenGoal, ElseGoal),
- determine_dead_deconstructions_2(Background, IfGoal, !.SharingAs,
+ determine_dead_deconstructions_2(Background, IfGoal, !.SharingAs,
IfSharingAs, !DeadCellTable),
- determine_dead_deconstructions_2(Background, ThenGoal, IfSharingAs,
+ determine_dead_deconstructions_2(Background, ThenGoal, IfSharingAs,
ThenSharingAs, !DeadCellTable),
- determine_dead_deconstructions_2(Background, ElseGoal, !.SharingAs,
+ determine_dead_deconstructions_2(Background, ElseGoal, !.SharingAs,
ElseSharingAs, !DeadCellTable),
!:SharingAs = sharing_as_least_upper_bound(ModuleInfo, ProcInfo,
ThenSharingAs, ElseSharingAs)
@@ -167,16 +167,16 @@
;
GoalExpr = shorthand(_),
% These should have been expanded out by now.
- unexpected(detect_garbage.this_file,
+ unexpected(detect_garbage.this_file,
"determine_dead_deconstructions_2: shorthand goal.")
).
:- pred determine_dead_deconstructions_2_with_progress(detect_bg_info::in,
- hlds_goal::in, sharing_as::in, sharing_as::out, dead_cell_table::in,
+ hlds_goal::in, sharing_as::in, sharing_as::out, dead_cell_table::in,
dead_cell_table::out) is det.
determine_dead_deconstructions_2_with_progress(Background, TopGoal,
- !SharingAs, !DeadCellTable) :-
+ !SharingAs, !DeadCellTable) :-
VeryVerbose = Background ^ very_verbose,
(
VeryVerbose = yes,
@@ -189,25 +189,25 @@
),
determine_dead_deconstructions_2(Background, TopGoal, !SharingAs,
!DeadCellTable).
-
-:- pred determine_dead_deconstructions_2_disj(detect_bg_info::in,
+
+:- pred determine_dead_deconstructions_2_disj(detect_bg_info::in,
hlds_goals::in, sharing_as::in, sharing_as::out,
dead_cell_table::in, dead_cell_table::out) is det.
-determine_dead_deconstructions_2_disj(Background, Goals,
- !SharingAs, !DeadCellTable) :-
- list.foldl2(determine_dead_deconstructions_2_disj_goal(Background,
+determine_dead_deconstructions_2_disj(Background, Goals,
+ !SharingAs, !DeadCellTable) :-
+ list.foldl2(determine_dead_deconstructions_2_disj_goal(Background,
!.SharingAs), Goals, !SharingAs, !DeadCellTable).
-:- pred determine_dead_deconstructions_2_disj_goal(detect_bg_info::in,
+:- pred determine_dead_deconstructions_2_disj_goal(detect_bg_info::in,
sharing_as::in, hlds_goal::in, sharing_as::in, sharing_as::out,
dead_cell_table::in, dead_cell_table::out) is det.
-determine_dead_deconstructions_2_disj_goal(Background, SharingBeforeDisj,
+determine_dead_deconstructions_2_disj_goal(Background, SharingBeforeDisj,
Goal, !SharingAs, !DeadCellTable) :-
- determine_dead_deconstructions_2(Background, Goal, SharingBeforeDisj,
+ determine_dead_deconstructions_2(Background, Goal, SharingBeforeDisj,
GoalSharing, !DeadCellTable),
- !:SharingAs = sharing_as_least_upper_bound(Background ^ module_info,
+ !:SharingAs = sharing_as_least_upper_bound(Background ^ module_info,
Background ^ proc_info, !.SharingAs, GoalSharing).
:- pred determine_dead_deconstructions_generic_call(module_info::in,
@@ -247,8 +247,8 @@
SetToTop = no
).
- % Verify whether the unification is a deconstruction in which the
- % deconstructed data structure becomes garbage (under some reuse
+ % Verify whether the unification is a deconstruction in which the
+ % deconstructed data structure becomes garbage (under some reuse
% conditions).
%
% XXX Different implementation from the reuse-branch implementation.
@@ -257,7 +257,7 @@
hlds_goal_info::in, unification::in, program_point::in,
sharing_as::in, dead_cell_table::in, dead_cell_table::out) is det.
-unification_verify_reuse(ModuleInfo, ProcInfo, GoalInfo, Unification,
+unification_verify_reuse(ModuleInfo, ProcInfo, GoalInfo, Unification,
PP, Sharing, !DeadCellTable):-
(
Unification = deconstruct(Var, ConsId, _, _, _, _),
@@ -265,8 +265,8 @@
LBU = goal_info_get_lbu(GoalInfo),
(
% Reuse is only relevant for real constructors, with
- % arity different from 0.
- ConsId = cons(_, Arity),
+ % arity different from 0.
+ ConsId = cons(_, Arity, _),
Arity \= 0,
% No-tag values don't have a cell to reuse.
@@ -286,7 +286,7 @@
% cell data structure based on Var is dead right after
% this deconstruction, hence, may be involved with
% structure reuse.
- NewCondition = reuse_condition_init(ModuleInfo,
+ NewCondition = reuse_condition_init(ModuleInfo,
ProcInfo, Var, LFU, LBU, Sharing),
dead_cell_table_set(PP, NewCondition, !DeadCellTable)
;
@@ -325,7 +325,7 @@
:- func this_file = string.
this_file = "structure_sharing.direct.detect_garbage.m".
-
+
%-----------------------------------------------------------------------------%
:- end_module transform_hlds.ctgc.structure_reuse.direct.detect_garbage.
%-----------------------------------------------------------------------------%
Index: compiler/superhomogeneous.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/superhomogeneous.m,v
retrieving revision 1.32
diff -u -r1.32 superhomogeneous.m
--- compiler/superhomogeneous.m 23 Dec 2008 01:37:41 -0000 1.32
+++ compiler/superhomogeneous.m 5 Feb 2009 07:52:44 -0000
@@ -758,7 +758,7 @@
( sym_name_and_args(RHS, FunctorName, FunctorArgsPrime) ->
FunctorArgs = FunctorArgsPrime,
list.length(FunctorArgs, Arity),
- ConsId = cons(FunctorName, Arity)
+ ConsId = cons(FunctorName, Arity, cons_id_dummy_type_ctor)
;
% float, int or string constant
% - any errors will be caught by typechecking
@@ -1054,7 +1054,8 @@
SubContexts = []
;
ArgContext = ac_functor(ConsId, MainContext, SubContexts0),
- SubContexts = [ConsId - ArgNum | SubContexts0]
+ SubContext = unify_sub_context(ConsId, ArgNum),
+ SubContexts = [SubContext | SubContexts0]
).
%-----------------------------------------------------------------------------%
Index: compiler/switch_detection.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_detection.m,v
retrieving revision 1.145
diff -u -r1.145 switch_detection.m
--- compiler/switch_detection.m 10 Mar 2009 05:00:31 -0000 1.145
+++ compiler/switch_detection.m 12 Mar 2009 01:25:50 -0000
@@ -79,6 +79,7 @@
:- import_module libs.options.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
+:- import_module parse_tree.prog_type.
:- import_module assoc_list.
:- import_module bool.
@@ -1029,13 +1030,14 @@
cases_to_switch(Var, VarTypes, AllowMulti, Cases0, InstMap, GoalExpr,
!ModuleInfo, !Requant) :-
instmap_lookup_var(InstMap, Var, VarInst),
+ map.lookup(VarTypes, Var, Type),
( inst_is_bound_to_functors(!.ModuleInfo, VarInst, Functors) ->
- functors_to_cons_ids(Functors, ConsIds),
+ type_to_ctor_det(Type, TypeCtor),
+ bound_insts_to_cons_ids(TypeCtor, Functors, ConsIds),
delete_unreachable_cases(Cases0, ConsIds, Cases1),
CanFail = compute_can_fail(ConsIds, Cases1)
;
Cases1 = Cases0,
- map.lookup(VarTypes, Var, Type),
( switch_type_num_functors(!.ModuleInfo, Type, NumFunctors) ->
% We could check for each cons_id of the type whether a case covers
% it, but given that type checking ensures that the set of covered
Index: compiler/switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_gen.m,v
retrieving revision 1.109
diff -u -r1.109 switch_gen.m
--- compiler/switch_gen.m 6 Jan 2009 03:56:27 -0000 1.109
+++ compiler/switch_gen.m 5 Feb 2009 07:03:40 -0000
@@ -371,7 +371,7 @@
; ConsTag = float_tag(_)
; ConsTag = foreign_tag(_, _)
; ConsTag = int_tag(_)
- ; ConsTag = pred_closure_tag(_, _, _)
+ ; ConsTag = closure_tag(_, _, _)
; ConsTag = shared_local_tag(_, _)
; ConsTag = shared_remote_tag(_, _)
; ConsTag = shared_with_reserved_addresses_tag(_, _)
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.41
diff -u -r1.41 switch_util.m
--- compiler/switch_util.m 11 Feb 2008 21:26:09 -0000 1.41
+++ compiler/switch_util.m 5 Feb 2009 07:03:44 -0000
@@ -208,6 +208,7 @@
:- implementation.
+:- import_module hlds.hlds_data.
:- import_module hlds.hlds_code_util.
:- import_module hlds.hlds_out.
:- import_module libs.
@@ -235,10 +236,10 @@
tag_cases(ModuleInfo, SwitchVarType, [Case | Cases],
[TaggedCase | TaggedCases], MaybeIntSwitchLimits) :-
Case = case(MainConsId, OtherConsIds, Goal),
- MainConsTag = cons_id_to_tag(ModuleInfo, SwitchVarType, MainConsId),
+ MainConsTag = cons_id_to_tag(ModuleInfo, MainConsId),
TaggedMainConsId = tagged_cons_id(MainConsId, MainConsTag),
( MainConsTag = int_tag(IntTag) ->
- list.map_foldl4(tag_cons_id_in_int_switch(ModuleInfo, SwitchVarType),
+ list.map_foldl4(tag_cons_id_in_int_switch(ModuleInfo),
OtherConsIds, TaggedOtherConsIds,
IntTag, LowerLimit1, IntTag, UpperLimit1,
1, NumValues1, is_int_switch, IsIntSwitch1),
@@ -255,8 +256,7 @@
MaybeIntSwitchLimits = not_int_switch
)
;
- list.map(tag_cons_id(ModuleInfo, SwitchVarType), OtherConsIds,
- TaggedOtherConsIds),
+ list.map(tag_cons_id(ModuleInfo), OtherConsIds, TaggedOtherConsIds),
TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal),
tag_cases_plain(ModuleInfo, SwitchVarType, Cases, TaggedCases),
MaybeIntSwitchLimits = not_int_switch
@@ -269,9 +269,8 @@
tag_cases_plain(ModuleInfo, SwitchVarType, [Case | Cases],
[TaggedCase | TaggedCases]) :-
Case = case(MainConsId, OtherConsIds, Goal),
- tag_cons_id(ModuleInfo, SwitchVarType, MainConsId, TaggedMainConsId),
- list.map(tag_cons_id(ModuleInfo, SwitchVarType),
- OtherConsIds, TaggedOtherConsIds),
+ tag_cons_id(ModuleInfo, MainConsId, TaggedMainConsId),
+ list.map(tag_cons_id(ModuleInfo), OtherConsIds, TaggedOtherConsIds),
TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal),
tag_cases_plain(ModuleInfo, SwitchVarType, Cases, TaggedCases).
@@ -285,30 +284,29 @@
[TaggedCase | TaggedCases], !LowerLimit, !UpperLimit, !NumValues,
!IsIntSwitch) :-
Case = case(MainConsId, OtherConsIds, Goal),
- tag_cons_id_in_int_switch(ModuleInfo, SwitchVarType,
- MainConsId, TaggedMainConsId, !LowerLimit, !UpperLimit,
- !NumValues, !IsIntSwitch),
- list.map_foldl4(tag_cons_id_in_int_switch(ModuleInfo, SwitchVarType),
+ tag_cons_id_in_int_switch(ModuleInfo, MainConsId, TaggedMainConsId,
+ !LowerLimit, !UpperLimit, !NumValues, !IsIntSwitch),
+ list.map_foldl4(tag_cons_id_in_int_switch(ModuleInfo),
OtherConsIds, TaggedOtherConsIds, !LowerLimit, !UpperLimit,
!NumValues, !IsIntSwitch),
TaggedCase = tagged_case(TaggedMainConsId, TaggedOtherConsIds, Goal),
tag_cases_in_int_switch(ModuleInfo, SwitchVarType, Cases, TaggedCases,
!LowerLimit, !UpperLimit, !NumValues, !IsIntSwitch).
-:- pred tag_cons_id(module_info::in, mer_type::in, cons_id::in,
- tagged_cons_id::out) is det.
+:- pred tag_cons_id(module_info::in, cons_id::in, tagged_cons_id::out) is det.
-tag_cons_id(ModuleInfo, SwitchVarType, ConsId, TaggedConsId) :-
- ConsTag = cons_id_to_tag(ModuleInfo, SwitchVarType, ConsId),
+tag_cons_id(ModuleInfo, ConsId, TaggedConsId) :-
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
TaggedConsId = tagged_cons_id(ConsId, ConsTag).
-:- pred tag_cons_id_in_int_switch(module_info::in, mer_type::in, cons_id::in,
- tagged_cons_id::out, int::in, int::out, int::in, int::out,
- int::in, int::out, is_int_switch::in, is_int_switch::out) is det.
+:- pred tag_cons_id_in_int_switch(module_info::in,
+ cons_id::in, tagged_cons_id::out,
+ int::in, int::out, int::in, int::out, int::in, int::out,
+ is_int_switch::in, is_int_switch::out) is det.
-tag_cons_id_in_int_switch(ModuleInfo, SwitchVarType, ConsId, TaggedConsId,
+tag_cons_id_in_int_switch(ModuleInfo, ConsId, TaggedConsId,
!LowerLimit, !UpperLimit, !NumValues, !IsIntSwitch) :-
- ConsTag = cons_id_to_tag(ModuleInfo, SwitchVarType, ConsId),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
TaggedConsId = tagged_cons_id(ConsId, ConsTag),
( ConsTag = int_tag(IntTag) ->
int.min(IntTag, !LowerLimit),
@@ -400,7 +398,7 @@
Cost = 2 * list.length(RAs) + estimate_switch_tag_test_cost(SubTag)
;
( Tag = no_tag
- ; Tag = pred_closure_tag(_, _, _)
+ ; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
; Tag = tabling_info_tag(_, _)
@@ -645,7 +643,7 @@
; Tag = float_tag(_)
; Tag = int_tag(_)
; Tag = foreign_tag(_, _)
- ; Tag = pred_closure_tag(_, _, _)
+ ; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
; Tag = tabling_info_tag(_, _)
@@ -723,7 +721,7 @@
; Tag = float_tag(_)
; Tag = int_tag(_)
; Tag = foreign_tag(_, _)
- ; Tag = pred_closure_tag(_, _, _)
+ ; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
; Tag = tabling_info_tag(_, _)
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.149
diff -u -r1.149 table_gen.m
--- compiler/table_gen.m 29 Apr 2009 03:38:12 -0000 1.149
+++ compiler/table_gen.m 30 May 2009 06:02:20 -0000
@@ -73,6 +73,7 @@
:- import_module ll_backend.
:- import_module ll_backend.continuation_info.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
@@ -755,10 +756,9 @@
purity_impure, Context, InactiveGoalInfo),
InactiveGoal = hlds_goal(InactiveGoalExpr, InactiveGoalInfo),
- TB = mercury_table_builtin_module,
SwitchArms = [
- case(cons(qualified(TB, "loop_active"), 0), [], ActiveGoal),
- case(cons(qualified(TB, "loop_inactive"), 0), [], InactiveGoal)
+ case(loop_active_cons_id, [], ActiveGoal),
+ case(loop_inactive_cons_id, [], InactiveGoal)
],
SwitchExpr = switch(StatusVar, cannot_fail, SwitchArms),
set.insert_list(InactiveNonLocals, [StatusVar, TableTipVar],
@@ -956,14 +956,10 @@
Detism, purity_impure, Context, InactiveGoalInfo),
InactiveGoal = hlds_goal(InactiveGoalExpr, InactiveGoalInfo),
- TB = mercury_table_builtin_module,
SwitchArms = [
- case(cons(qualified(TB, "memo_det_active"), 0), [],
- ActiveGoal),
- case(cons(qualified(TB, "memo_det_inactive"), 0), [],
- InactiveGoal),
- case(cons(qualified(TB, "memo_det_succeeded"), 0), [],
- SucceededGoal)
+ case(memo_det_active_cons_id, [], ActiveGoal),
+ case(memo_det_inactive_cons_id, [], InactiveGoal),
+ case(memo_det_succeeded_cons_id, [], SucceededGoal)
]
;
CodeModel = model_semi,
@@ -997,16 +993,11 @@
InactiveGoal = hlds_goal(InactiveGoalExpr, InactiveGoalInfo),
FailedGoal = fail_goal,
- TB = mercury_table_builtin_module,
SwitchArms = [
- case(cons(qualified(TB, "memo_semi_active"), 0), [],
- ActiveGoal),
- case(cons(qualified(TB, "memo_semi_inactive"), 0), [],
- InactiveGoal),
- case(cons(qualified(TB, "memo_semi_succeeded"), 0), [],
- SucceededGoal),
- case(cons(qualified(TB, "memo_semi_failed"), 0), [],
- FailedGoal)
+ case(memo_semi_active_cons_id, [], ActiveGoal),
+ case(memo_semi_inactive_cons_id, [], InactiveGoal),
+ case(memo_semi_succeeded_cons_id, [], SucceededGoal),
+ case(memo_semi_failed_cons_id, [], FailedGoal)
]
),
@@ -1119,16 +1110,11 @@
OutputVars = list.map(project_var, NumberedOutputVars),
InactiveInstmapDelta = bind_vars(OutputVars),
- TB = mercury_table_builtin_module,
SwitchArms = [
- case(cons(qualified(TB, "memo_non_active"), 0), [],
- InfiniteRecursionGoal),
- case(cons(qualified(TB, "memo_non_inactive"), 0), [],
- InactiveGoal),
- case(cons(qualified(TB, "memo_non_incomplete"), 0), [],
- NeedMinModelGoal),
- case(cons(qualified(TB, "memo_non_complete"), 0), [],
- RestoreAllAnswerGoal)
+ case(memo_non_active_cons_id, [], InfiniteRecursionGoal),
+ case(memo_non_inactive_cons_id, [], InactiveGoal),
+ case(memo_non_incomplete_cons_id, [], NeedMinModelGoal),
+ case(memo_non_complete_cons_id, [], RestoreAllAnswerGoal)
],
SwitchExpr = switch(StatusVar, cannot_fail, SwitchArms),
@@ -1519,14 +1505,10 @@
InactiveExpr = disj([MainGoal, ResumeGoal]),
InactiveGoal = hlds_goal(InactiveExpr, MainGoalInfo),
- TB = mercury_table_builtin_module,
SwitchArms = [
- case(cons(qualified(TB, "mm_inactive"), 0), [],
- InactiveGoal),
- case(cons(qualified(TB, "mm_complete"), 0), [],
- RestoreAllAnswerGoal),
- case(cons(qualified(TB, "mm_active"), 0), [],
- SuspendGoal)
+ case(mm_inactive_cons_id, [], InactiveGoal),
+ case(mm_active_cons_id, [], SuspendGoal),
+ case(mm_complete_cons_id, [], RestoreAllAnswerGoal)
],
SwitchExpr = switch(StatusVar, cannot_fail, SwitchArms),
goal_info_add_feature(feature_hide_debug_event,
@@ -1634,7 +1616,7 @@
!VarSet, !VarTypes, ConsumerVar),
ShroudedPredProcId = shroud_pred_proc_id(proc(GeneratorPredId, ProcId)),
- GeneratorConsId = pred_const(ShroudedPredProcId, lambda_normal),
+ GeneratorConsId = closure_cons(ShroudedPredProcId, lambda_normal),
make_const_construction(GeneratorPredVar, GeneratorConsId,
MakeGeneratorVarGoal),
@@ -3245,58 +3227,6 @@
make_string_const_construction_alloc(VarValue, yes(VarName), Goal, Var,
!VarSet, !VarTypes).
-:- func proc_table_info_type = mer_type.
-:- func trie_node_type = mer_type.
-:- func memo_non_record_type = mer_type.
-:- func subgoal_type = mer_type.
-:- func answer_block_type = mer_type.
-:- func loop_status_type = mer_type.
-:- func memo_det_status_type = mer_type.
-:- func memo_semi_status_type = mer_type.
-:- func memo_non_status_type = mer_type.
-:- func mm_status_type = mer_type.
-
-proc_table_info_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "ml_proc_table_info"), 0),
- [], Type).
-
-trie_node_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "ml_trie_node"), 0), [], Type).
-
-memo_non_record_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "memo_non_record"), 0), [], Type).
-
-subgoal_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "ml_subgoal"), 0), [], Type).
-
-answer_block_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "ml_answer_block"), 0), [], Type).
-
-loop_status_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "loop_status"), 0), [], Type).
-
-memo_det_status_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "memo_det_status"), 0), [], Type).
-
-memo_semi_status_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "memo_semi_status"), 0), [], Type).
-
-memo_non_status_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "memo_non_status"), 0), [], Type).
-
-mm_status_type = Type :-
- TB = mercury_table_builtin_module,
- construct_type(type_ctor(qualified(TB, "mm_status"), 0), [], Type).
-
%-----------------------------------------------------------------------------%
:- func consumer_type = mer_type.
@@ -3819,6 +3749,171 @@
%-----------------------------------------------------------------------------%
+:- func loop_inactive_cons_id = cons_id.
+:- func loop_active_cons_id = cons_id.
+
+loop_inactive_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "loop_inactive"),
+ TypeCtor = loop_status_type_ctor.
+loop_active_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "loop_active"),
+ TypeCtor = loop_status_type_ctor.
+
+:- func memo_det_inactive_cons_id = cons_id.
+:- func memo_det_active_cons_id = cons_id.
+:- func memo_det_succeeded_cons_id = cons_id.
+
+memo_det_inactive_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_det_inactive"),
+ TypeCtor = memo_det_status_type_ctor.
+memo_det_active_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_det_active"),
+ TypeCtor = memo_det_status_type_ctor.
+memo_det_succeeded_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_det_succeeded"),
+ TypeCtor = memo_det_status_type_ctor.
+
+:- func memo_semi_inactive_cons_id = cons_id.
+:- func memo_semi_active_cons_id = cons_id.
+:- func memo_semi_succeeded_cons_id = cons_id.
+:- func memo_semi_failed_cons_id = cons_id.
+
+memo_semi_inactive_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_semi_inactive"),
+ TypeCtor = memo_semi_status_type_ctor.
+memo_semi_active_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_semi_active"),
+ TypeCtor = memo_semi_status_type_ctor.
+memo_semi_succeeded_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_semi_succeeded"),
+ TypeCtor = memo_semi_status_type_ctor.
+memo_semi_failed_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_semi_failed"),
+ TypeCtor = memo_semi_status_type_ctor.
+
+:- func memo_non_inactive_cons_id = cons_id.
+:- func memo_non_active_cons_id = cons_id.
+:- func memo_non_incomplete_cons_id = cons_id.
+:- func memo_non_complete_cons_id = cons_id.
+
+memo_non_inactive_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_non_inactive"),
+ TypeCtor = memo_non_status_type_ctor.
+memo_non_active_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_non_active"),
+ TypeCtor = memo_non_status_type_ctor.
+memo_non_incomplete_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_non_incomplete"),
+ TypeCtor = memo_non_status_type_ctor.
+memo_non_complete_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "memo_non_complete"),
+ TypeCtor = memo_non_status_type_ctor.
+
+:- func mm_inactive_cons_id = cons_id.
+:- func mm_active_cons_id = cons_id.
+:- func mm_complete_cons_id = cons_id.
+
+mm_inactive_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "mm_inactive"),
+ TypeCtor = mm_status_type_ctor.
+mm_active_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "mm_active"),
+ TypeCtor = mm_status_type_ctor.
+mm_complete_cons_id = cons(SymName, 0, TypeCtor) :-
+ SymName = qualified(mercury_table_builtin_module, "mm_complete"),
+ TypeCtor = mm_status_type_ctor.
+
+:- func loop_status_type_ctor = type_ctor.
+
+loop_status_type_ctor = TypeCtor :-
+ TypeModule = mercury_table_builtin_module,
+ TypeSymName = qualified(TypeModule, "loop_status"),
+ TypeCtor = type_ctor(TypeSymName, 0).
+
+:- func memo_det_status_type_ctor = type_ctor.
+
+memo_det_status_type_ctor = TypeCtor :-
+ TypeModule = mercury_table_builtin_module,
+ TypeSymName = qualified(TypeModule, "memo_det_status"),
+ TypeCtor = type_ctor(TypeSymName, 0).
+
+:- func memo_semi_status_type_ctor = type_ctor.
+
+memo_semi_status_type_ctor = TypeCtor :-
+ TypeModule = mercury_table_builtin_module,
+ TypeSymName = qualified(TypeModule, "memo_semi_status"),
+ TypeCtor = type_ctor(TypeSymName, 0).
+
+:- func memo_non_status_type_ctor = type_ctor.
+
+memo_non_status_type_ctor = TypeCtor :-
+ TypeModule = mercury_table_builtin_module,
+ TypeSymName = qualified(TypeModule, "memo_non_status"),
+ TypeCtor = type_ctor(TypeSymName, 0).
+
+:- func mm_status_type_ctor = type_ctor.
+
+mm_status_type_ctor = TypeCtor :-
+ TypeModule = mercury_table_builtin_module,
+ TypeSymName = qualified(TypeModule, "mm_status"),
+ TypeCtor = type_ctor(TypeSymName, 0).
+
+%-----------------------------------------------------------------------------%
+
+:- func proc_table_info_type = mer_type.
+:- func trie_node_type = mer_type.
+:- func memo_non_record_type = mer_type.
+:- func subgoal_type = mer_type.
+:- func answer_block_type = mer_type.
+:- func loop_status_type = mer_type.
+:- func memo_det_status_type = mer_type.
+:- func memo_semi_status_type = mer_type.
+:- func memo_non_status_type = mer_type.
+:- func mm_status_type = mer_type.
+
+proc_table_info_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "ml_proc_table_info"), 0),
+ [], Type).
+
+trie_node_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "ml_trie_node"), 0), [], Type).
+
+memo_non_record_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "memo_non_record"), 0), [], Type).
+
+subgoal_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "ml_subgoal"), 0), [], Type).
+
+answer_block_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "ml_answer_block"), 0), [], Type).
+
+loop_status_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "loop_status"), 0), [], Type).
+
+memo_det_status_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "memo_det_status"), 0), [], Type).
+
+memo_semi_status_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "memo_semi_status"), 0), [], Type).
+
+memo_non_status_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "memo_non_status"), 0), [], Type).
+
+mm_status_type = Type :-
+ TB = mercury_table_builtin_module,
+ construct_type(type_ctor(qualified(TB, "mm_status"), 0), [], Type).
+
+%-----------------------------------------------------------------------------%
+
:- func proc_table_info_name = string.
:- func cur_table_node_name = string.
:- func next_table_node_name = string.
Index: compiler/term_constr_build.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_build.m,v
retrieving revision 1.22
diff -u -r1.22 term_constr_build.m
--- compiler/term_constr_build.m 23 Dec 2008 01:37:41 -0000 1.22
+++ compiler/term_constr_build.m 5 Feb 2009 07:42:18 -0000
@@ -684,6 +684,8 @@
% switch arm is for several cons_ids). They are of course in the HLDS,
% just not stored in a way we can derive them from the goal in the normal
% fashion unless there is actually a deconstruction unification present.
+ %
+ % XXX Why do we ignore OtherConsIds when it is not []?
(
OtherConsIds = [],
@@ -1075,9 +1077,8 @@
find_deconstruct_fail_bound(GoalExpr, Info, Polyhedron),
AbstractGoal = term_primitive(Polyhedron, [], []).
- % Given a deconstruction unification and assuming that it has
- % failed, find a bound on the size of the variable being
- % deconstructed.
+ % Given a deconstruction unification and assuming that it has failed,
+ % find a bound on the size of the variable being deconstructed.
%
:- pred find_deconstruct_fail_bound(hlds_goal_expr::in, traversal_info::in,
polyhedron::out) is semidet.
@@ -1085,10 +1086,12 @@
find_deconstruct_fail_bound(unify(_, _, _, Kind, _), Info, Polyhedron) :-
Kind = deconstruct(Var, ConsId, _, _, can_fail, _),
map.lookup(Info ^ tti_vartypes, Var, Type),
- prog_type.type_to_ctor_and_args(Type, TypeCtor, _),
+ type_to_ctor_det(Type, TypeCtor),
ModuleInfo = Info ^ tti_module_info,
type_util.type_constructors(ModuleInfo, Type, Constructors0),
- ( ConsId = cons(ConsName, ConsArity) ->
+ ( ConsId = cons(ConsName, ConsArity, ConsTypeCtor) ->
+ expect(unify(TypeCtor, ConsTypeCtor), this_file,
+ "find_deconstruct_fail_bound: mismatched type_ctors"),
FindComplement = (pred(Ctor::in) is semidet :-
Ctor = ctor(_, _, SymName, Args, _),
list.length(Args, Arity),
@@ -1152,7 +1155,7 @@
lower_bound(Norm, Module, TypeCtor, Constructor) = LowerBound :-
Constructor = ctor(_, _, SymName, Args, _),
Arity = list.length(Args),
- ConsId = cons(SymName, Arity),
+ ConsId = cons(SymName, Arity, TypeCtor),
LowerBound = functor_lower_bound(Norm, TypeCtor, ConsId, Module).
% Given a variable, its type and a set of constructors to which it
@@ -1179,7 +1182,7 @@
zero_size_type(Module, Arg ^ arg_type)
),
Arity = list.length(Args),
- ConsId = cons(SymName, Arity),
+ ConsId = cons(SymName, Arity, TypeCtor),
Bound = functor_lower_bound(Norm, TypeCtor, ConsId, Module),
( if Bound > !.B then !:B = Bound else true )
),
Index: compiler/term_norm.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_norm.m,v
retrieving revision 1.28
diff -u -r1.28 term_norm.m
--- compiler/term_norm.m 11 Feb 2008 21:26:10 -0000 1.28
+++ compiler/term_norm.m 5 Feb 2009 07:51:12 -0000
@@ -33,7 +33,7 @@
% This predicate sets the functor_info depending on the value of the
% termination_norm or termination2_norm option.
%
-:- func set_functor_info(globals.termination_norm, module_info) = functor_info.
+:- func set_functor_info(globals.termination_norm, module_info) = functor_info.
% This predicate computes the weight of a functor and the set of arguments
% of that functor whose sizes should be counted towards the size of the
@@ -46,7 +46,7 @@
% track of typeinfo related variables - it used to but intervening
% compiler passes tend to do things to the code in the mean time so the
% whole lot becomes inconsistent - in the end it's just easier to ignore
- % them).
+ % them).
%
:- pred functor_norm(functor_info::in, type_ctor::in, cons_id::in,
module_info::in, int::out, list(prog_var)::in, list(prog_var)::out,
@@ -58,9 +58,9 @@
% of the functor. (And if there were this function wouldn't tell you about
% it anyhow).
%
-:- func functor_lower_bound(functor_info, type_ctor, cons_id, module_info)
+:- func functor_lower_bound(functor_info, type_ctor, cons_id, module_info)
= int.
-
+
% Succeeds if all values of the given type are zero size (for all norms).
%
:- pred zero_size_type(module_info::in, mer_type::in) is semidet.
@@ -191,7 +191,7 @@
;
WeightInfo = weight(0, [])
),
- ConsId = cons(SymName, Arity),
+ ConsId = cons(SymName, Arity, TypeCtor),
svmap.det_insert(TypeCtor - ConsId, WeightInfo, !Weights).
:- pred find_weights_for_tuple(arity::in, weight_info::out) is det.
@@ -254,41 +254,46 @@
% Although the module info is not used in any of these norms, it could
% be needed for other norms, so it should not be removed.
-functor_norm(simple, _, ConsId, _, Int, !Args, !Modes) :-
+functor_norm(FunctorInfo, TypeCtor, ConsId, _ModuleInfo, Int, !Args, !Modes) :-
(
- ConsId = cons(_, Arity),
- Arity \= 0
- ->
- Int = 1
- ;
- Int = 0
- ).
-functor_norm(total, _, ConsId, _, Int, !Args, !Modes) :-
- ( ConsId = cons(_, Arity) ->
- Int = Arity
- ;
- Int = 0
- ).
-functor_norm(use_map(WeightMap), TypeCtor, ConsId, _, Int, !Args, !Modes) :-
- ( search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo) ->
- WeightInfo = weight(Int, _)
- ;
- Int = 0
- ).
-functor_norm(use_map_and_args(WeightMap), TypeCtor, ConsId, _, Int, !Args,
- !Modes) :-
- ( search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo) ->
- WeightInfo = weight(Int, UseArgList),
+ FunctorInfo = simple,
(
- functor_norm_filter_args(UseArgList, !Args, !Modes)
+ ConsId = cons(_, Arity, _),
+ Arity \= 0
->
- true
+ Int = 1
+ ;
+ Int = 0
+ )
+ ;
+ FunctorInfo = total,
+ ( ConsId = cons(_, Arity, _) ->
+ Int = Arity
+ ;
+ Int = 0
+ )
+ ;
+ FunctorInfo = use_map(WeightMap),
+ ( search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo) ->
+ WeightInfo = weight(Int, _)
;
- unexpected(this_file,
- "Unmatched lists in functor_norm_filter_args.")
+ Int = 0
)
;
- Int = 0
+ FunctorInfo = use_map_and_args(WeightMap),
+ ( search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo) ->
+ WeightInfo = weight(Int, UseArgList),
+ (
+ functor_norm_filter_args(UseArgList, !Args, !Modes)
+ ->
+ true
+ ;
+ unexpected(this_file,
+ "Unmatched lists in functor_norm_filter_args.")
+ )
+ ;
+ Int = 0
+ )
).
% This predicate will fail if the length of the input lists are not
@@ -308,20 +313,25 @@
%-----------------------------------------------------------------------------%
-functor_lower_bound(simple, _, ConsId, _) =
- ( if ConsId = cons(_, Arity), Arity \= 0 then 1 else 0).
-functor_lower_bound(total, _, ConsId, _) =
- ( if ConsId = cons(_, Arity) then Arity else 0 ).
-functor_lower_bound(use_map(WeightMap), TypeCtor, ConsId, _) = Weight :-
- ( if search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo)
- then WeightInfo = weight(Weight, _)
- else Weight = 0
- ).
-functor_lower_bound(use_map_and_args(WeightMap), TypeCtor, ConsId, _)
- = Weight :-
- ( if search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo)
- then WeightInfo = weight(Weight, _)
- else Weight = 0
+functor_lower_bound(FunctorInfo, TypeCtor, ConsId, _ModuleInfo) = Weight :-
+ (
+ FunctorInfo = simple,
+ Weight = ( if ConsId = cons(_, Arity, _), Arity \= 0 then 1 else 0 )
+ ;
+ FunctorInfo = total,
+ Weight = ( if ConsId = cons(_, Arity, _) then Arity else 0 )
+ ;
+ FunctorInfo = use_map(WeightMap),
+ ( if search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo)
+ then WeightInfo = weight(Weight, _)
+ else Weight = 0
+ )
+ ;
+ FunctorInfo = use_map_and_args(WeightMap),
+ ( if search_weight_table(WeightMap, TypeCtor, ConsId, WeightInfo)
+ then WeightInfo = weight(Weight, _)
+ else Weight = 0
+ )
).
%-----------------------------------------------------------------------------%
Index: compiler/try_expand.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/try_expand.m,v
retrieving revision 1.3
diff -u -r1.3 try_expand.m
--- compiler/try_expand.m 11 Mar 2009 06:32:24 -0000 1.3
+++ compiler/try_expand.m 30 May 2009 08:38:52 -0000
@@ -231,6 +231,7 @@
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
@@ -595,7 +596,7 @@
TmpTupleVar, !ProcInfo),
proc_info_create_var_from_type(OutputTupleType, yes("OutputTuple"),
TupleVar, !ProcInfo),
- deconstruct_functor(ResultVar, succeeded_cons_id, [TmpTupleVar],
+ deconstruct_functor(ResultVar, exception_succeeded_functor, [TmpTupleVar],
DeconstructSucceeded),
instmap_lookup_vars(Instmap, GoalOutputVars, TupleArgInsts),
make_output_tuple_inst_cast(TmpTupleVar, TupleVar, TupleArgInsts,
@@ -603,15 +604,15 @@
deconstruct_tuple(TupleVar, GoalOutputVars, DeconstructOutputs),
conj_list_to_goal([DeconstructSucceeded, CastOutputTuple,
DeconstructOutputs, Then], GoalInfo, DeconstructsThen),
- SucceededCase = case(succeeded_cons_id, [], DeconstructsThen),
+ SucceededCase = case(exception_succeeded_functor, [], DeconstructsThen),
% The `exception' case.
- ExceptionCase = case(exception_cons_id, [], ExcpHandling),
+ ExceptionCase = case(exception_exception_functor, [], ExcpHandling),
% The `failed' case.
(
MaybeElse1 = yes(Else1),
- FailedCase = case(failed_cons_id, [], Else1),
+ FailedCase = case(exception_failed_functor, [], Else1),
MaybeFailedCase = [FailedCase]
;
MaybeElse1 = no,
@@ -658,11 +659,11 @@
MagicCall = plain_call(_, _, [ResultVar], _, _, _),
Switch = switch(ResultVar, cannot_fail, Cases),
- lookup_case_goal(Cases, succeeded_cons_id, SucceededGoal),
+ lookup_case_goal(Cases, exception_succeeded_functor, SucceededGoal),
extract_from_succeeded_goal(ModuleInfo, SucceededGoal, Goal, Then,
MaybeElse),
- lookup_case_goal(Cases, exception_cons_id, ExcpHandling).
+ lookup_case_goal(Cases, exception_exception_functor, ExcpHandling).
% There are two forms we could extract when TryResult has the
% functor exception.succeeded/1.
@@ -693,7 +694,7 @@
Conjuncts0 = [DeconstructResult, TestNullTuple | Conjuncts1],
DeconstructResult = hlds_goal(unify(_ResultVar, _, _, _, _), _),
TestNullTuple = hlds_goal(unify(_, TestRHS, _, _, _), _),
- TestRHS = rhs_functor(cons(unqualified("{}"), 0), no, []),
+ TestRHS = rhs_functor(tuple_cons(0), no, []),
(
Conjuncts1 = [hlds_goal(IfThenElse, _) | Rest],
@@ -901,7 +902,7 @@
->
TupleArity = list.length(TupleArgInsts),
TupleInst = bound(shared, [
- bound_functor(cons(unqualified("{}"), TupleArity), TupleArgInsts)
+ bound_functor(tuple_cons(TupleArity), TupleArgInsts)
]),
generate_cast_with_insts(unsafe_type_inst_cast, TmpTupleVar, TupleVar,
ground_inst, TupleInst, term.context_init, CastOrUnify)
@@ -913,20 +914,6 @@
%-----------------------------------------------------------------------------%
-:- func succeeded_cons_id = cons_id.
-
-succeeded_cons_id = cons(qualified(mercury_exception_module, "succeeded"), 1).
-
-:- func failed_cons_id = cons_id.
-
-failed_cons_id = cons(qualified(mercury_exception_module, "failed"), 0).
-
-:- func exception_cons_id = cons_id.
-
-exception_cons_id = cons(qualified(mercury_exception_module, "exception"), 1).
-
-%-----------------------------------------------------------------------------%
-
try_expand_may_introduce_calls("try", 2).
try_expand_may_introduce_calls("try_io", 4).
try_expand_may_introduce_calls("unreachable", 0).
Index: compiler/type_constraints.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_constraints.m,v
retrieving revision 1.4
diff -u -r1.4 type_constraints.m
--- compiler/type_constraints.m 4 Jun 2009 05:15:41 -0000 1.4
+++ compiler/type_constraints.m 4 Jun 2009 06:27:37 -0000
@@ -44,6 +44,7 @@
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.program_representation.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_event.
@@ -68,6 +69,7 @@
:- import_module svset.
:- import_module svvarset.
:- import_module term.
+:- import_module term_io.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -1640,11 +1642,12 @@
Context, no, no)],
RelevantTVars = [LTVar]
;
- ConsId = cons(Name, Arity),
+ ConsId = cons(Name, Arity, _TypeCtor),
+ % The _TypeCtor field is not meaningful yet.
Arity = list.length(Args)
->
list.map_foldl(get_var_type, Args, ArgTypeVars, !TCInfo),
- % If it is a type constructor, create a disjunction
+ % If it is a data constructor, create a disjunction
% constraint with each possible type of the constructor.
( map.search(FuncEnv, ConsId, Cons_Defns) ->
list.map_foldl(
@@ -1653,7 +1656,7 @@
;
TypeConstraints = []
),
- % If it is a predicate constructor, create a disjunction
+ % If it is a closure constructor, create a disjunction
% constraint for each predicate it could refer to.
(
predicate_table_search_sym(PredEnv,
@@ -2063,9 +2066,9 @@
builtin_atomic_type(int_const(_), builtin_type_int).
builtin_atomic_type(float_const(_), builtin_type_float).
builtin_atomic_type(string_const(_), builtin_type_string).
-builtin_atomic_type(cons(unqualified(String), 0), builtin_type_character) :-
- string.char_to_string(_, String).
-builtin_atomic_type(implementation_defined_const(Name), Type) :-
+builtin_atomic_type(cons(unqualified(String), 0, _), builtin_type_char) :-
+ term_io.string_is_escaped_char(_, String).
+builtin_atomic_type(impl_defined_const(Name), Type) :-
(
( Name = "file"
; Name = "module"
@@ -2394,8 +2397,8 @@
;
Type = builtin_type(builtin_type_string),
Name = "string"
- ;
- Type = builtin_type(builtin_type_character),
+ ;
+ Type = builtin_type(builtin_type_char),
Name = "character"
;
Type = tuple_type(Subtypes, _),
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.97
diff -u -r1.97 type_ctor_info.m
--- compiler/type_ctor_info.m 3 Nov 2008 03:08:02 -0000 1.97
+++ compiler/type_ctor_info.m 5 Feb 2009 07:03:38 -0000
@@ -288,7 +288,7 @@
rtti_data::out) is det.
construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
- TypeCtorGenInfo = type_ctor_gen_info(_TypeCtor, ModuleName, TypeName,
+ TypeCtorGenInfo = type_ctor_gen_info(TypeCtor, ModuleName, TypeName,
TypeArity, _Status, HldsDefn, UnifyPredProcId, ComparePredProcId),
UnifyPredProcId = proc(UnifyPredId, UnifyProcId),
UnifyProcLabel = make_rtti_proc_label(ModuleInfo,
@@ -319,12 +319,12 @@
ModuleName = unqualified(ModuleStr1),
builtin_type_ctor(ModuleStr1, TypeName, TypeArity, BuiltinCtor)
->
- Details = builtin(BuiltinCtor)
+ Details = tcd_builtin(BuiltinCtor)
;
ModuleName = unqualified(ModuleStr),
impl_type_ctor(ModuleStr, TypeName, TypeArity, ImplCtor)
->
- Details = impl_artifact(ImplCtor)
+ Details = tcd_impl_artifact(ImplCtor)
;
(
TypeBody = hlds_abstract_type(_),
@@ -340,7 +340,7 @@
ExistTvars = [],
pseudo_type_info.construct_maybe_pseudo_type_info(RepnType,
UnivTvars, ExistTvars, MaybePseudoTypeInfo),
- Details = eqv(MaybePseudoTypeInfo)
+ Details = tcd_eqv(MaybePseudoTypeInfo)
;
TypeBody = hlds_foreign_type(ForeignBody),
foreign_type_body_to_exported_type(ModuleInfo, ForeignBody, _, _,
@@ -353,7 +353,7 @@
;
IsStable = is_not_stable
),
- Details = foreign(IsStable)
+ Details = tcd_foreign(IsStable)
;
TypeBody = hlds_eqv_type(Type),
% There can be no existentially typed args to an equivalence.
@@ -361,7 +361,7 @@
ExistTvars = [],
pseudo_type_info.construct_maybe_pseudo_type_info(Type,
UnivTvars, ExistTvars, MaybePseudoTypeInfo),
- Details = eqv(MaybePseudoTypeInfo)
+ Details = tcd_eqv(MaybePseudoTypeInfo)
;
TypeBody = hlds_du_type(Ctors, ConsTagMap, _CheaperTagTest,
DuTypeKind, MaybeUserEqComp, ReservedTag, ReservedAddr,
@@ -375,16 +375,16 @@
),
(
DuTypeKind = du_type_kind_mercury_enum,
- make_mercury_enum_details(Ctors, ConsTagMap, ReservedTag,
- EqualityAxioms, Details)
+ make_mercury_enum_details(TypeCtor, Ctors, ConsTagMap,
+ ReservedTag, EqualityAxioms, Details)
;
DuTypeKind = du_type_kind_foreign_enum(Lang),
- make_foreign_enum_details(Lang, Ctors, ConsTagMap, ReservedTag,
- EqualityAxioms, Details)
+ make_foreign_enum_details(TypeCtor, Lang, Ctors, ConsTagMap,
+ ReservedTag, EqualityAxioms, Details)
;
DuTypeKind = du_type_kind_direct_dummy,
- make_mercury_enum_details(Ctors, ConsTagMap, ReservedTag,
- EqualityAxioms, Details)
+ make_mercury_enum_details(TypeCtor, Ctors, ConsTagMap,
+ ReservedTag, EqualityAxioms, Details)
;
DuTypeKind = du_type_kind_notag(FunctorName, ArgType,
MaybeArgName),
@@ -392,7 +392,7 @@
MaybeArgName, EqualityAxioms, Details)
;
DuTypeKind = du_type_kind_general,
- make_du_details(Ctors, ConsTagMap, TypeArity,
+ make_du_details(TypeCtor, Ctors, ConsTagMap, TypeArity,
EqualityAxioms, ReservedAddr, ModuleInfo, Details)
)
)
@@ -560,7 +560,7 @@
pseudo_type_info.construct_maybe_pseudo_type_info(ArgType,
NumUnivTvars, ExistTvars, MaybePseudoTypeInfo),
Functor = notag_functor(FunctorName, MaybePseudoTypeInfo, MaybeArgName),
- Details = notag(EqualityAxioms, Functor).
+ Details = tcd_notag(EqualityAxioms, Functor).
%---------------------------------------------------------------------------%
@@ -568,18 +568,19 @@
% Make the functor and layout tables for an enum type.
%
-:- pred make_mercury_enum_details(list(constructor)::in, cons_tag_values::in,
- uses_reserved_tag::in, equality_axioms::in, type_ctor_details::out) is det.
+:- pred make_mercury_enum_details(type_ctor::in, list(constructor)::in,
+ cons_tag_values::in, uses_reserved_tag::in, equality_axioms::in,
+ type_ctor_details::out) is det.
-make_mercury_enum_details(Ctors, ConsTagMap, ReserveTag, EqualityAxioms,
- Details) :-
+make_mercury_enum_details(TypeCtor, Ctors, ConsTagMap, ReserveTag,
+ EqualityAxioms, Details) :-
(
ReserveTag = uses_reserved_tag,
unexpected(this_file, "enum with reserved tag")
;
ReserveTag = does_not_use_reserved_tag
),
- make_enum_functors(Ctors, 0, ConsTagMap, EnumFunctors),
+ make_enum_functors(TypeCtor, Ctors, 0, ConsTagMap, EnumFunctors),
ValueMap0 = map.init,
NameMap0 = map.init,
list.foldl2(make_enum_maps, EnumFunctors,
@@ -590,8 +591,8 @@
IsDummy = no
),
FunctorNumberMap = make_functor_number_map(Ctors),
- Details = enum(EqualityAxioms, EnumFunctors, ValueMap, NameMap, IsDummy,
- FunctorNumberMap).
+ Details = tcd_enum(EqualityAxioms, EnumFunctors, ValueMap, NameMap,
+ IsDummy, FunctorNumberMap).
% Create an enum_functor structure for each functor in an enum type.
% The functors are given to us in ordinal order (since that's how the HLDS
@@ -601,11 +602,11 @@
% sort this list on functor name, which is how the type functors structure
% is constructed.
%
-:- pred make_enum_functors(list(constructor)::in,
+:- pred make_enum_functors(type_ctor::in, list(constructor)::in,
int::in, cons_tag_values::in, list(enum_functor)::out) is det.
-make_enum_functors([], _, _, []).
-make_enum_functors([Functor | Functors], NextOrdinal, ConsTagMap,
+make_enum_functors(_, [], _, _, []).
+make_enum_functors(TypeCtor, [Functor | Functors], NextOrdinal, ConsTagMap,
[EnumFunctor | EnumFunctors]) :-
Functor = ctor(ExistTvars, Constraints, SymName, FunctorArgs, _Context),
expect(unify(ExistTvars, []), this_file,
@@ -615,13 +616,14 @@
list.length(FunctorArgs, Arity),
expect(unify(Arity, 0), this_file,
"functor in enum has nonzero arity"),
- ConsId = make_cons_id_from_qualified_sym_name(SymName, FunctorArgs),
+ ConsId = cons(SymName, list.length(FunctorArgs), TypeCtor),
map.lookup(ConsTagMap, ConsId, ConsTag),
expect(unify(ConsTag, int_tag(NextOrdinal)), this_file,
"mismatch on constant assigned to functor in enum"),
FunctorName = unqualify_name(SymName),
EnumFunctor = enum_functor(FunctorName, NextOrdinal),
- make_enum_functors(Functors, NextOrdinal + 1, ConsTagMap, EnumFunctors).
+ make_enum_functors(TypeCtor, Functors, NextOrdinal + 1, ConsTagMap,
+ EnumFunctors).
:- pred make_enum_maps(enum_functor::in,
map(int, enum_functor)::in, map(int, enum_functor)::out,
@@ -636,26 +638,26 @@
% Make the functor and layout tables for a foreign enum type.
%
-:- pred make_foreign_enum_details(foreign_language::in, list(constructor)::in,
- cons_tag_values::in, uses_reserved_tag::in, equality_axioms::in,
- type_ctor_details::out) is det.
+:- pred make_foreign_enum_details(type_ctor::in, foreign_language::in,
+ list(constructor)::in, cons_tag_values::in, uses_reserved_tag::in,
+ equality_axioms::in, type_ctor_details::out) is det.
-make_foreign_enum_details(Lang, Ctors, ConsTagMap, ReserveTag, EqualityAxioms,
- Details) :-
+make_foreign_enum_details(TypeCtor, Lang, Ctors, ConsTagMap, ReserveTag,
+ EqualityAxioms, Details) :-
(
ReserveTag = uses_reserved_tag,
unexpected(this_file, "foreign enum with reserved tag")
;
ReserveTag = does_not_use_reserved_tag
),
- make_foreign_enum_functors(Lang, Ctors, 0, ConsTagMap,
+ make_foreign_enum_functors(TypeCtor, Lang, Ctors, 0, ConsTagMap,
ForeignEnumFunctors),
OrdinalMap0 = map.init,
NameMap0 = map.init,
list.foldl2(make_foreign_enum_maps, ForeignEnumFunctors,
OrdinalMap0, OrdinalMap, NameMap0, NameMap),
FunctorNumberMap = make_functor_number_map(Ctors),
- Details = foreign_enum(Lang, EqualityAxioms, ForeignEnumFunctors,
+ Details = tcd_foreign_enum(Lang, EqualityAxioms, ForeignEnumFunctors,
OrdinalMap, NameMap, FunctorNumberMap).
% Create a foreign_enum_functor structure for each functor in an enum type.
@@ -666,11 +668,12 @@
% caller to sort this list on functor name, which is how the type functors
% structure is constructed.
%
-:- pred make_foreign_enum_functors(foreign_language::in, list(constructor)::in,
- int::in, cons_tag_values::in, list(foreign_enum_functor)::out) is det.
+:- pred make_foreign_enum_functors(type_ctor::in, foreign_language::in,
+ list(constructor)::in, int::in, cons_tag_values::in,
+ list(foreign_enum_functor)::out) is det.
-make_foreign_enum_functors(_, [], _, _, []).
-make_foreign_enum_functors(Lang, [Functor | Functors], NextOrdinal,
+make_foreign_enum_functors(_, _, [], _, _, []).
+make_foreign_enum_functors(TypeCtor, Lang, [Functor | Functors], NextOrdinal,
ConsTagMap, [ForeignEnumFunctor | ForeignEnumFunctors]) :-
Functor = ctor(ExistTvars, Constraints, SymName, FunctorArgs, _Context),
expect(unify(ExistTvars, []), this_file,
@@ -680,7 +683,7 @@
list.length(FunctorArgs, Arity),
expect(unify(Arity, 0), this_file,
"functor in foreign enum has nonzero arity"),
- ConsId = make_cons_id_from_qualified_sym_name(SymName, FunctorArgs),
+ ConsId = cons(SymName, list.length(FunctorArgs), TypeCtor),
map.lookup(ConsTagMap, ConsId, ConsTag),
(
ConsTag = foreign_tag(ForeignTagLang, ForeignTagValue0),
@@ -691,7 +694,7 @@
( ConsTag = string_tag(_)
; ConsTag = float_tag(_)
; ConsTag = int_tag(_)
- ; ConsTag = pred_closure_tag(_, _, _)
+ ; ConsTag = closure_tag(_, _, _)
; ConsTag = type_ctor_info_tag(_, _, _)
; ConsTag = base_typeclass_info_tag(_, _, _)
; ConsTag = tabling_info_tag(_, _)
@@ -710,8 +713,8 @@
FunctorName = unqualify_name(SymName),
ForeignEnumFunctor = foreign_enum_functor(FunctorName, NextOrdinal,
ForeignTagValue),
- make_foreign_enum_functors(Lang, Functors, NextOrdinal + 1, ConsTagMap,
- ForeignEnumFunctors).
+ make_foreign_enum_functors(TypeCtor, Lang, Functors, NextOrdinal + 1,
+ ConsTagMap, ForeignEnumFunctors).
:- pred make_foreign_enum_maps(foreign_enum_functor::in,
map(int, foreign_enum_functor)::in,
@@ -746,14 +749,14 @@
% Make the functor and layout tables for a du type
% (including reserved_addr types).
%
-:- pred make_du_details(list(constructor)::in, cons_tag_values::in, int::in,
- equality_axioms::in, uses_reserved_address::in, module_info::in,
- type_ctor_details::out) is det.
-
-make_du_details(Ctors, ConsTagMap, TypeArity, EqualityAxioms, ReservedAddr,
- ModuleInfo, Details) :-
- make_maybe_res_functors(Ctors, 0, ConsTagMap, TypeArity, ModuleInfo,
- MaybeResFunctors),
+:- pred make_du_details(type_ctor::in, list(constructor)::in,
+ cons_tag_values::in, int::in, equality_axioms::in,
+ uses_reserved_address::in, module_info::in, type_ctor_details::out) is det.
+
+make_du_details(TypeCtor, Ctors, ConsTagMap, TypeArity, EqualityAxioms,
+ ReservedAddr, ModuleInfo, Details) :-
+ make_maybe_res_functors(TypeCtor, Ctors, 0, ConsTagMap, TypeArity,
+ ModuleInfo, MaybeResFunctors),
DuFunctors = list.filter_map(is_du_functor, MaybeResFunctors),
ResFunctors = list.filter_map(is_reserved_functor, MaybeResFunctors),
list.foldl(make_du_ptag_ordered_table, DuFunctors,
@@ -765,15 +768,15 @@
"make_du_details: ReservedAddr is not does_not_use_reserved_addr"),
list.foldl(make_du_name_ordered_table, DuFunctors,
map.init, DuNameOrderedMap),
- Details = du(EqualityAxioms, DuFunctors, DuPtagTable, DuNameOrderedMap,
- FunctorNumberMap)
+ Details = tcd_du(EqualityAxioms, DuFunctors, DuPtagTable,
+ DuNameOrderedMap, FunctorNumberMap)
;
ResFunctors = [_ | _],
expect(unify(ReservedAddr, uses_reserved_address), this_file,
"make_du_details: ReservedAddr is not uses_reserved_addr"),
list.foldl(make_res_name_ordered_table, MaybeResFunctors,
map.init, ResNameOrderedMap),
- Details = reserved(EqualityAxioms, MaybeResFunctors,
+ Details = tcd_reserved(EqualityAxioms, MaybeResFunctors,
ResFunctors, DuPtagTable, ResNameOrderedMap, FunctorNumberMap)
).
@@ -793,17 +796,18 @@
% TagMap groups the rttis into groups depending on their primary tags;
% this is how the type layout structure is constructed.
%
-:- pred make_maybe_res_functors(list(constructor)::in, int::in,
+:- pred make_maybe_res_functors(type_ctor::in, list(constructor)::in, int::in,
cons_tag_values::in, int::in, module_info::in,
list(maybe_reserved_functor)::out) is det.
-make_maybe_res_functors([], _, _, _, _, []).
-make_maybe_res_functors([Functor | Functors], NextOrdinal, ConsTagMap,
- TypeArity, ModuleInfo, [MaybeResFunctor | MaybeResFunctors]) :-
- Functor = ctor(ExistTvars, Constraints, SymName, ConstructorArgs, _Context),
+make_maybe_res_functors(_, [], _, _, _, _, []).
+make_maybe_res_functors(TypeCtor, [Functor | Functors], NextOrdinal,
+ ConsTagMap, TypeArity, ModuleInfo,
+ [MaybeResFunctor | MaybeResFunctors]) :-
+ Functor = ctor(ExistTvars, Constraints, SymName, ConstructorArgs, _Ctxt),
list.length(ConstructorArgs, Arity),
FunctorName = unqualify_name(SymName),
- ConsId = make_cons_id_from_qualified_sym_name(SymName, ConstructorArgs),
+ ConsId = cons(SymName, list.length(ConstructorArgs), TypeCtor),
map.lookup(ConsTagMap, ConsId, ConsTag),
process_cons_tag(ConsTag, ConsRep),
list.map(generate_du_arg_info(TypeArity, ExistTvars),
@@ -833,8 +837,8 @@
ResFunctor = reserved_functor(FunctorName, NextOrdinal, ResRep),
MaybeResFunctor = res_func(ResFunctor)
),
- make_maybe_res_functors(Functors, NextOrdinal + 1, ConsTagMap, TypeArity,
- ModuleInfo, MaybeResFunctors).
+ make_maybe_res_functors(TypeCtor, Functors, NextOrdinal + 1, ConsTagMap,
+ TypeArity, ModuleInfo, MaybeResFunctors).
:- pred process_cons_tag(cons_tag::in, maybe_reserved_rep::out) is det.
@@ -866,7 +870,7 @@
; ConsTag = int_tag(_)
; ConsTag = foreign_tag(_, _)
; ConsTag = float_tag(_)
- ; ConsTag = pred_closure_tag(_, _, _)
+ ; ConsTag = closure_tag(_, _, _)
; ConsTag = type_ctor_info_tag(_, _, _)
; ConsTag = base_typeclass_info_tag(_, _, _)
; ConsTag = tabling_info_tag(_, _)
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.196
diff -u -r1.196 type_util.m
--- compiler/type_util.m 23 Apr 2009 05:57:11 -0000 1.196
+++ compiler/type_util.m 4 Jun 2009 23:09:45 -0000
@@ -237,7 +237,8 @@
:- pred get_existq_cons_defn(module_info::in, mer_type::in, cons_id::in,
ctor_defn::out) is semidet.
-:- pred is_existq_cons(module_info::in, mer_type::in, cons_id::in) is semidet.
+:- pred is_existq_cons(module_info::in, mer_type::in, cons_id::in)
+ is semidet.
% Check whether a type is a no_tag type (i.e. one with only one
% constructor, and whose one constructor has only one argument).
@@ -345,6 +346,7 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_util.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
@@ -990,6 +992,7 @@
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
map.member(TypeDefnBody ^ du_type_cons_tag_values, ConsId, _),
+ % XXX We should look it up in a type_ctor-specific table, not a global one.
module_info_get_cons_table(ModuleInfo, Ctors),
map.lookup(Ctors, ConsId, ConsDefns),
list.member(ConsDefn, ConsDefns),
@@ -1011,7 +1014,9 @@
is_existq_cons(ModuleInfo, VarType, ConsId, _).
get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn) :-
+ % XXX We should look it up in a type_ctor-specific table, not a global one.
module_info_get_cons_table(ModuleInfo, Ctors),
+
% will fail for builtin cons_ids.
map.search(Ctors, ConsId, ConsDefns),
MatchingCons =
@@ -1093,10 +1098,13 @@
%-----------------------------------------------------------------------------%
-maybe_get_cons_id_arg_types(ModuleInfo, MaybeType, ConsId0, Arity,
+maybe_get_cons_id_arg_types(ModuleInfo, MaybeType, ConsId, Arity,
MaybeTypes) :-
- ( ConsId0 = cons(_SymName, _) ->
- ConsId = ConsId0,
+ (
+ ( ConsId = cons(_SymName, _, _)
+ ; ConsId = tuple_cons(_)
+ )
+ ->
(
MaybeType = yes(Type),
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.439
diff -u -r1.439 typecheck.m
--- compiler/typecheck.m 29 Apr 2009 03:38:12 -0000 1.439
+++ compiler/typecheck.m 4 Jun 2009 23:12:47 -0000
@@ -127,6 +127,7 @@
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.program_representation.
:- import_module parse_tree.mercury_to_mercury.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.file_names. % undesirable dependency
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_event.
@@ -921,8 +922,9 @@
PredArity = pred_info_orig_arity(!.PredInfo),
adjust_func_arity(pf_function, FuncArity, PredArity),
FuncSymName = qualified(FuncModule, FuncName),
+ FuncConsId = cons(FuncSymName, FuncArity, cons_id_dummy_type_ctor),
create_pure_atomic_complicated_unification(FuncRetVal,
- rhs_functor(cons(FuncSymName, FuncArity), no, FuncArgs),
+ rhs_functor(FuncConsId, no, FuncArgs),
Context, umc_explicit, [], Goal0),
Goal0 = hlds_goal(GoalExpr, GoalInfo0),
NonLocals = proc_arg_vector_to_set(HeadVars),
@@ -1895,25 +1897,24 @@
list(prog_var)::in, goal_path::in,
typecheck_info::in, typecheck_info::out) is det.
-typecheck_unify_var_functor(Var, Functor, Args, GoalPath, !Info) :-
+typecheck_unify_var_functor(Var, ConsId, Args, GoalPath, !Info) :-
% Get the list of possible constructors that match this functor/arity.
% If there aren't any, report an undefined constructor error.
list.length(Args, Arity),
- typecheck_info_get_ctor_list(!.Info, Functor, Arity, GoalPath,
- ConsDefnList, InvalidConsDefnList),
+ typecheck_info_get_ctor_list(!.Info, ConsId, Arity, GoalPath,
+ ConsDefns, ConsErrors),
(
- ConsDefnList = [],
- Spec = report_error_undef_cons(!.Info, InvalidConsDefnList, Functor,
- Arity),
+ ConsDefns = [],
+ Spec = report_error_undef_cons(!.Info, ConsErrors, ConsId, Arity),
typecheck_info_add_error(Spec, !Info)
;
(
- ConsDefnList = [_]
+ ConsDefns = [_]
;
- ConsDefnList = [_, _ | _],
+ ConsDefns = [_, _ | _],
Context = !.Info ^ tc_info_context,
- Sources = list.map(project_cons_type_info_source, ConsDefnList),
- Symbol = overloaded_func(Functor, Sources),
+ Sources = list.map(project_cons_type_info_source, ConsDefns),
+ Symbol = overloaded_func(ConsId, Sources),
typecheck_info_add_overloaded_symbol(Symbol, Context, !Info)
),
@@ -1921,7 +1922,7 @@
% cross-product of the TypeAssignSet0 and the ConsDefnList.
TypeAssignSet0 = !.Info ^ tc_info_type_assign_set,
typecheck_unify_var_functor_get_ctors(TypeAssignSet0,
- !.Info, ConsDefnList, [], ConsTypeAssignSet),
+ !.Info, ConsDefns, [], ConsTypeAssignSet),
(
ConsTypeAssignSet = [],
TypeAssignSet0 = [_ | _]
@@ -1940,9 +1941,9 @@
ArgsTypeAssignSet = [],
ConsTypeAssignSet = [_ | _]
->
- FunctorSpec = report_error_functor_type(!.Info, Var, ConsDefnList,
- Functor, Arity, TypeAssignSet0),
- typecheck_info_add_error(FunctorSpec, !Info)
+ ConsIdSpec = report_error_functor_type(!.Info, Var, ConsDefns,
+ ConsId, Arity, TypeAssignSet0),
+ typecheck_info_add_error(ConsIdSpec, !Info)
;
true
),
@@ -1955,8 +1956,8 @@
TypeAssignSet = [],
ArgsTypeAssignSet = [_ | _]
->
- ArgSpec = report_error_functor_arg_types(!.Info, Var, ConsDefnList,
- Functor, Args, ArgsTypeAssignSet),
+ ArgSpec = report_error_functor_arg_types(!.Info, Var, ConsDefns,
+ ConsId, Args, ArgsTypeAssignSet),
typecheck_info_add_error(ArgSpec, !Info)
;
true
@@ -2016,8 +2017,8 @@
TypeAssign0, !ConsTypeAssignSet) :-
get_cons_stuff(ConsDefn, TypeAssign0, Info, ConsType, ArgTypes,
TypeAssign1),
- list.append([TypeAssign1 - cons_type(ConsType, ArgTypes)],
- !ConsTypeAssignSet),
+ ConsTypeAssign = TypeAssign1 - cons_type(ConsType, ArgTypes),
+ !:ConsTypeAssignSet = [ConsTypeAssign | !.ConsTypeAssignSet],
typecheck_unify_var_functor_get_ctors_2(ConsDefns, Info, TypeAssign0,
!ConsTypeAssignSet).
@@ -2167,7 +2168,9 @@
% Rename apart the type vars in the type of the constructor
% and the types of its arguments.
% (Optimize the common case of a non-polymorphic type)
- ( varset.is_empty(ConsTypeVarSet) ->
+ (
+ varset.is_empty(ConsTypeVarSet)
+ ->
ConsType = ConsType0,
ArgTypes = ArgTypes0,
TypeAssign2 = TypeAssign0,
@@ -2314,17 +2317,20 @@
% builtin_atomic_type(Const, TypeName):
%
- % If Const is a constant of a builtin atomic type, instantiates TypeName
- % to the name of that type, otherwise fails.
+ % If Const is *or can be* a constant of a builtin atomic type,
+ % set TypeName to the name of that type, otherwise fail.
%
:- pred builtin_atomic_type(cons_id::in, string::out) is semidet.
builtin_atomic_type(int_const(_), "int").
builtin_atomic_type(float_const(_), "float").
+builtin_atomic_type(char_const(_), "character").
builtin_atomic_type(string_const(_), "string").
-builtin_atomic_type(cons(unqualified(String), 0), "character") :-
- string.char_to_string(_, String).
-builtin_atomic_type(implementation_defined_const(Name), Type) :-
+builtin_atomic_type(cons(unqualified(String), 0, _), "character") :-
+ % We are before post-typecheck, so character constants have not yet been
+ % converted to char_consts.
+ term_io.string_is_escaped_char(_, String).
+builtin_atomic_type(impl_defined_const(Name), Type) :-
(
( Name = "file"
; Name = "module"
@@ -2337,13 +2343,13 @@
Type = "int"
).
- % builtin_pred_type(Info, Functor, Arity, GoalPath, PredConsInfoList):
+ % builtin_pred_type(Info, ConsId, Arity, GoalPath, PredConsInfoList):
%
- % If Functor/Arity is a constant of a pred type, instantiates
+ % If ConsId/Arity is a constant of a pred type, instantiates
% the output parameters, otherwise fails.
%
% Instantiates PredConsInfoList to the set of cons_type_info structures
- % for each predicate with name `Functor' and arity greater than
+ % for each predicate with name `ConsId' and arity greater than
% or equal to Arity. GoalPath is used to identify any constraints
% introduced.
%
@@ -2353,8 +2359,8 @@
:- pred builtin_pred_type(typecheck_info::in, cons_id::in, int::in,
goal_path::in, list(cons_type_info)::out) is semidet.
-builtin_pred_type(Info, Functor, Arity, GoalPath, PredConsInfoList) :-
- Functor = cons(SymName, _),
+builtin_pred_type(Info, ConsId, Arity, GoalPath, PredConsInfoList) :-
+ ConsId = cons(SymName, _, _),
ModuleInfo = Info ^ tc_info_module_info,
module_info_get_predicate_table(ModuleInfo, PredicateTable),
(
@@ -2455,9 +2461,9 @@
true
).
- % builtin_apply_type(Info, Functor, Arity, ConsTypeInfos):
+ % builtin_apply_type(Info, ConsId, Arity, ConsTypeInfos):
%
- % Succeed if Functor is the builtin apply/N or ''/N (N>=2),
+ % Succeed if ConsId is the builtin apply/N or ''/N (N>=2),
% which is used to invoke higher-order functions.
% If so, bind ConsTypeInfos to a singleton list containing
% the appropriate type for apply/N of the specified Arity.
@@ -2465,8 +2471,8 @@
:- pred builtin_apply_type(typecheck_info::in, cons_id::in, int::in,
list(cons_type_info)::out) is semidet.
-builtin_apply_type(_Info, Functor, Arity, ConsTypeInfos) :-
- Functor = cons(unqualified(ApplyName), _),
+builtin_apply_type(_Info, ConsId, Arity, ConsTypeInfos) :-
+ ConsId = cons(unqualified(ApplyName), _, _),
% XXX FIXME handle impure apply/N more elegantly (e.g. nicer syntax)
(
ApplyName = "apply",
@@ -2495,20 +2501,20 @@
[FuncType | ArgTypes], EmptyConstraints,
source_apply(ApplyNameToUse))].
- % builtin_field_access_function_type(Info, GoalPath, Functor,
+ % builtin_field_access_function_type(Info, GoalPath, ConsId,
% Arity, ConsTypeInfos):
%
- % Succeed if Functor is the name of one the automatically
+ % Succeed if ConsId is the name of one the automatically
% generated field access functions (fieldname, '<fieldname> :=').
%
:- pred builtin_field_access_function_type(typecheck_info::in, goal_path::in,
cons_id::in, arity::in, list(maybe_cons_type_info)::out) is semidet.
-builtin_field_access_function_type(Info, GoalPath, Functor, Arity,
+builtin_field_access_function_type(Info, GoalPath, ConsId, Arity,
MaybeConsTypeInfos) :-
% Taking the address of automatically generated field access functions
% is not allowed, so currying does have to be considered here.
- Functor = cons(Name, Arity),
+ ConsId = cons(Name, Arity, _),
ModuleInfo = Info ^ tc_info_module_info,
is_field_access_function_name(ModuleInfo, Name, Arity, AccessType,
FieldName),
@@ -2813,7 +2819,7 @@
% cons_type_infos.
typecheck_info_get_ctors(Info, Ctors),
(
- Functor = cons(_, _),
+ Functor = cons(_, _, _),
map.search(Ctors, Functor, HLDS_ConsDefns)
->
convert_cons_defn_list(Info, GoalPath, do_not_flip_constraints,
@@ -2839,9 +2845,9 @@
% the type definition (i.e. convert the existential quantifiers and
% constraints into universal ones).
(
- Functor = cons(Name, Arity),
+ Functor = cons(Name, Arity, FunctorTypeCtor),
remove_new_prefix(Name, OrigName),
- OrigFunctor = cons(OrigName, Arity),
+ OrigFunctor = cons(OrigName, Arity, FunctorTypeCtor),
map.search(Ctors, OrigFunctor, HLDS_ExistQConsDefns)
->
convert_cons_defn_list(Info, GoalPath, flip_constraints_for_new,
@@ -2883,7 +2889,11 @@
),
% Check if Functor is a tuple constructor.
- ( Functor = cons(unqualified("{}"), TupleArity) ->
+ (
+ ( Functor = cons(unqualified("{}"), TupleArity, _)
+ ; Functor = tuple_cons(TupleArity)
+ )
+ ->
% Make some fresh type variables for the argument types. These have
% kind `star' since there are values (namely the arguments of the
% tuple constructor) which have these types.
Index: compiler/typecheck_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck_errors.m,v
retrieving revision 1.42
diff -u -r1.42 typecheck_errors.m
--- compiler/typecheck_errors.m 15 Apr 2009 03:11:53 -0000 1.42
+++ compiler/typecheck_errors.m 29 May 2009 04:53:48 -0000
@@ -453,10 +453,10 @@
simple_call(CallId), words("is also overloaded here.")]
;
Symbol = overloaded_func(ConsId, Sources),
- ( ConsId = cons(SymName, Arity) ->
+ ( ConsId = cons(SymName, Arity, _) ->
ConsIdPiece = sym_name_and_arity(SymName / Arity)
;
- ConsIdPiece = fixed(cons_id_to_string(ConsId))
+ ConsIdPiece = fixed(cons_id_and_arity_to_string(ConsId))
),
StartPieces = [words("The function symbol"), ConsIdPiece,
suffix("."), nl,
@@ -801,7 +801,7 @@
% instead of
% Argument 1 (F) has type ...;
% argument 2 (A) has type ...
- Functor = cons(unqualified(""), Arity),
+ Functor = cons(unqualified(""), Arity, _),
Arity > 0
->
(
@@ -1004,7 +1004,7 @@
% Check for some special cases, so that we can give clearer error messages.
(
- Functor = cons(unqualified(FunctorName), FunctorArity),
+ Functor = cons(unqualified(FunctorName), FunctorArity, _),
expect(unify(Arity, FunctorArity), this_file,
"report_error_undef_cons: arity mismatch"),
(
@@ -1023,13 +1023,13 @@
FunctorComps = FunctorComps1,
ReportConsErrors = no
;
- Functor = cons(Constructor, FunctorArity),
+ Functor = cons(Constructor, FunctorArity, _),
expect(unify(Arity, FunctorArity), this_file,
"report_error_undef_cons: arity mismatch"),
typecheck_info_get_ctors(Info, ConsTable),
solutions.solutions(
(pred(N::out) is nondet :-
- map.member(ConsTable, cons(Constructor, N), _),
+ map.member(ConsTable, cons(Constructor, N, _), _),
N \= Arity
), ActualArities),
ActualArities = [_ | _]
@@ -1041,14 +1041,14 @@
;
strip_builtin_qualifier_from_cons_id(Functor, StrippedFunctor),
Pieces1 = [words("error: undefined symbol"),
- quote(cons_id_to_string(StrippedFunctor))],
+ quote(cons_id_and_arity_to_string(StrippedFunctor))],
(
- Functor = cons(Constructor, _),
+ Functor = cons(Constructor, _, _),
Constructor = qualified(ModQual, _)
->
Pieces2 = maybe_report_missing_import_addendum(Info, ModQual)
;
- Functor = cons(unqualified("[|]"), 2)
+ Functor = cons(unqualified("[|]"), 2, _)
->
Pieces2 = maybe_report_missing_import_addendum(Info,
unqualified("list"))
@@ -1222,7 +1222,7 @@
TVarsStr = mercury_vars_to_string(TVarSet, no, TVars),
Pieces2 = [words("variables"), quote(TVarsStr), words("occur")]
),
- ConsIdStr = cons_id_to_string(ConsId),
+ ConsIdStr = cons_id_and_arity_to_string(ConsId),
Pieces3 = [words("in the types of field"), sym_name(FieldName),
words("and some other field"),
words("in definition of constructor"),
@@ -1402,17 +1402,18 @@
strip_builtin_qualifier_from_cons_id(Functor, StrippedFunctor),
( Arity = 0 ->
Piece1 = words("constant"),
- ( Functor = cons(Name, _) ->
+ ( Functor = cons(Name, _, _) ->
Piece2 = sym_name(Name)
;
- Piece2 = quote(cons_id_to_string(StrippedFunctor))
+ Piece2 = quote(cons_id_and_arity_to_string(StrippedFunctor))
),
Pieces = [Piece1, Piece2]
- ; Functor = cons(unqualified(""), _) ->
+ ; Functor = cons(unqualified(""), _, _) ->
Pieces = [words("higher-order term (with arity"),
int_fixed(Arity - 1), suffix(")")]
;
- Pieces = [words("functor"), quote(cons_id_to_string(StrippedFunctor))]
+ Pieces = [words("functor"),
+ quote(cons_id_and_arity_to_string(StrippedFunctor))]
).
:- func type_of_var_to_pieces(type_assign_set, prog_var)
@@ -1460,7 +1461,7 @@
ConsInfo = cons_type_info(TVarSet, ExistQVars, ConsType, ArgTypes, _, _),
(
ArgTypes = [_ | _],
- ( Functor = cons(SymName, _Arity) ->
+ ( Functor = cons(SymName, _Arity, _) ->
% What we construct in Type is not really a type: it is a
% function symbol applied to a list of argument types. However
% *syntactically*, it looks like a type, and we already have
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.191
diff -u -r1.191 unify_gen.m
--- compiler/unify_gen.m 6 Jan 2009 03:56:27 -0000 1.191
+++ compiler/unify_gen.m 7 Feb 2009 10:04:59 -0000
@@ -295,9 +295,9 @@
maybe_cheaper_tag_test::in, test_sense::in, label::out, llds_code::out,
code_info::in, code_info::out) is det.
-generate_raw_tag_test(VarRval, VarType, VarName, ConsId, MaybeConsTag,
+generate_raw_tag_test(VarRval, _VarType, VarName, ConsId, MaybeConsTag,
CheaperTagTest, Sense, ElseLabel, Code, !CI) :-
- ConsIdName = hlds_out.cons_id_to_string(ConsId),
+ ConsIdName = cons_id_and_arity_to_string(ConsId),
% As an optimization, for data types with exactly two alternatives,
% one of which is a constant, we make sure that we test against the
% constant (negating the result of the test, if needed),
@@ -319,7 +319,8 @@
% Our caller has already computed ConsTag.
;
MaybeConsTag = no,
- ConsTag = cons_id_to_tag_for_type(!.CI, VarType, ConsId)
+ get_module_info(!.CI, ModuleInfo),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId)
),
raw_tag_test(VarRval, ConsTag, TestRval)
),
@@ -362,7 +363,7 @@
"foreign tag for language other than C"),
TestRval = binop(eq, Rval, const(llconst_foreign(ForeignVal, integer)))
;
- ConsTag = pred_closure_tag(_, _, _),
+ ConsTag = closure_tag(_, _, _),
% This should never happen, since the error will be detected
% during mode checking.
unexpected(this_file, "Attempted higher-order unification")
@@ -449,7 +450,8 @@
generate_construction(Var, ConsId, Args, Modes, HowToConstruct,
TakeAddr, MaybeSize, GoalInfo, Code, !CI) :-
- Tag = cons_id_to_tag_for_var(!.CI, Var, ConsId),
+ get_module_info(!.CI, ModuleInfo),
+ Tag = cons_id_to_tag(ModuleInfo, ConsId),
generate_construction_2(Tag, Var, Args, Modes, HowToConstruct,
TakeAddr, MaybeSize, GoalInfo, Code, !CI).
@@ -594,11 +596,11 @@
Var, Args, Modes, HowToConstruct, TakeAddr, MaybeSize, GoalInfo,
Code, !CI)
;
- ConsTag = pred_closure_tag(PredId, ProcId, EvalMethod),
+ ConsTag = closure_tag(PredId, ProcId, EvalMethod),
expect(unify(TakeAddr, []), this_file,
- "generate_construction_2: pred_closure_tag has take_addr"),
+ "generate_construction_2: closure_tag has take_addr"),
expect(unify(MaybeSize, no), this_file,
- "generate_construction_2: pred_closure_tag has size"),
+ "generate_construction_2: closure_tag has size"),
generate_closure(PredId, ProcId, EvalMethod, Var, Args, GoalInfo,
Code, !CI)
).
@@ -1029,7 +1031,8 @@
code_info::in, code_info::out) is det.
generate_det_deconstruction(Var, Cons, Args, Modes, Code, !CI) :-
- Tag = cons_id_to_tag_for_var(!.CI, Var, Cons),
+ get_module_info(!.CI, ModuleInfo),
+ Tag = cons_id_to_tag(ModuleInfo, Cons),
generate_det_deconstruction_2(Var, Cons, Args, Modes, Tag, Code, !CI).
:- pred generate_det_deconstruction_2(prog_var::in, cons_id::in,
@@ -1044,7 +1047,7 @@
; Tag = int_tag(_Int)
; Tag = foreign_tag(_, _)
; Tag = float_tag(_Float)
- ; Tag = pred_closure_tag(_, _, _)
+ ; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
; Tag = tabling_info_tag(_, _)
@@ -1264,12 +1267,11 @@
( NonLocal = TermVar ->
( GoalExpr = conj(plain_conj, Conjuncts) ->
get_module_info(!.CI, ModuleInfo),
- VarTypes = get_var_types(!.CI),
get_exprn_opts(!.CI, ExprnOpts),
UnboxedFloats = get_unboxed_floats(ExprnOpts),
get_static_cell_info(!.CI, StaticCellInfo0),
map.init(ActiveMap0),
- generate_ground_term_conjuncts(ModuleInfo, VarTypes, Conjuncts,
+ generate_ground_term_conjuncts(ModuleInfo, Conjuncts,
UnboxedFloats, StaticCellInfo0, StaticCellInfo,
ActiveMap0, ActiveMap),
map.to_assoc_list(ActiveMap, ActivePairs),
@@ -1293,26 +1295,26 @@
unexpected(this_file, "generate_ground_term: unexpected nonlocals")
).
-:- pred generate_ground_term_conjuncts(module_info::in, vartypes::in,
+:- pred generate_ground_term_conjuncts(module_info::in,
list(hlds_goal)::in, have_unboxed_floats::in,
static_cell_info::in, static_cell_info::out,
active_ground_term_map::in, active_ground_term_map::out) is det.
-generate_ground_term_conjuncts(_ModuleInfo, _VarTypes, [],
+generate_ground_term_conjuncts(_ModuleInfo, [],
_UnboxedFloats, !StaticCellInfo, !ActiveMap).
-generate_ground_term_conjuncts(ModuleInfo, VarTypes, [Goal | Goals],
+generate_ground_term_conjuncts(ModuleInfo, [Goal | Goals],
UnboxedFloats, !StaticCellInfo, !ActiveMap) :-
- generate_ground_term_conjunct(ModuleInfo, VarTypes, Goal, UnboxedFloats,
+ generate_ground_term_conjunct(ModuleInfo, Goal, UnboxedFloats,
!StaticCellInfo, !ActiveMap),
- generate_ground_term_conjuncts(ModuleInfo, VarTypes, Goals, UnboxedFloats,
+ generate_ground_term_conjuncts(ModuleInfo, Goals, UnboxedFloats,
!StaticCellInfo, !ActiveMap).
-:- pred generate_ground_term_conjunct(module_info::in, vartypes::in,
+:- pred generate_ground_term_conjunct(module_info::in,
hlds_goal::in, have_unboxed_floats::in,
static_cell_info::in, static_cell_info::out,
active_ground_term_map::in, active_ground_term_map::out) is det.
-generate_ground_term_conjunct(ModuleInfo, VarTypes, Goal, UnboxedFloats,
+generate_ground_term_conjunct(ModuleInfo, Goal, UnboxedFloats,
!StaticCellInfo, !ActiveMap) :-
Goal = hlds_goal(GoalExpr, _GoalInfo),
(
@@ -1320,8 +1322,7 @@
Unify = construct(Var, ConsId, Args, _, _, _, SubInfo),
SubInfo = no_construct_sub_info
->
- map.lookup(VarTypes, Var, Type),
- ConsTag = cons_id_to_tag(ModuleInfo, Type, ConsId),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
generate_ground_term_conjunct_tag(Var, ConsTag, Args, UnboxedFloats,
!StaticCellInfo, !ActiveMap)
;
@@ -1420,7 +1421,7 @@
ActiveGroundTerm = Rval - data_ptr,
svmap.det_insert(Var, ActiveGroundTerm, !ActiveMap)
;
- ( ConsTag = pred_closure_tag(_, _, _)
+ ( ConsTag = closure_tag(_, _, _)
; ConsTag = type_ctor_info_tag(_, _, _)
; ConsTag = base_typeclass_info_tag(_, _, _)
; ConsTag = tabling_info_tag(_, _)
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.203
diff -u -r1.203 unify_proc.m
--- compiler/unify_proc.m 21 Jul 2008 03:10:15 -0000 1.203
+++ compiler/unify_proc.m 30 May 2009 05:53:21 -0000
@@ -162,6 +162,7 @@
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
@@ -322,7 +323,7 @@
in_mode(InMode),
TypeCtor = type_ctor(_, TypeArity),
list.duplicate(TypeArity, InMode, TypeInfoModes),
- list.append(TypeInfoModes, ArgModes0, ArgModes),
+ ArgModes = TypeInfoModes ++ ArgModes0,
ArgLives = no, % XXX ArgLives should be part of the UnifyId
@@ -363,8 +364,8 @@
% The X == Y pretest on unifications makes sense only for in-in
% unifications, and if the initial insts are incompatible, then
- % casts in the pretest prevents mode analysis from discovering this
- % fact.
+ % casts in the pretest would prevent mode analysis from discovering
+ % this fact.
(
all [ArgMode] (
list.member(ArgMode, ArgModes)
@@ -539,11 +540,11 @@
MakeUnamedField = (func(ArgType) = ctor_arg(no, ArgType, Context)),
CtorArgs = list.map(MakeUnamedField, TupleArgTypes),
+ CtorSymName = unqualified("{}"),
Ctor = ctor(ExistQVars, ClassConstraints, CtorSymName, CtorArgs,
Context),
- CtorSymName = unqualified("{}"),
- ConsId = cons(CtorSymName, TupleArity),
+ ConsId = tuple_cons(TupleArity),
map.from_assoc_list([ConsId - single_functor_tag], ConsTagValues),
UnifyPred = no,
DuTypeKind = du_type_kind_general,
@@ -672,7 +673,7 @@
;
SpecialPredId = spec_pred_index,
( Args = [X, Index] ->
- generate_index_proc_body(TypeBody, X, Index,
+ generate_index_proc_body(Type, TypeBody, X, Index,
Context, Clause, !Info)
;
unexpected(this_file, "generate_clause_info: bad index args")
@@ -773,8 +774,8 @@
generate_unify_proc_body(Type, TypeBody, X, Y, Context, Clause, !Info) :-
info_get_module_info(!.Info, ModuleInfo),
+ type_to_ctor_det(Type, TypeCtor),
(
- type_to_ctor_det(Type, TypeCtor),
check_builtin_dummy_type_ctor(TypeCtor) = is_builtin_dummy_type_ctor
->
Goal = true_goal_with_context(Context),
@@ -808,13 +809,13 @@
quantify_clause_body([X, Y], Goal, Context, Clause, !Info)
;
IsDummyType = is_not_dummy_type,
- generate_du_unify_proc_body(Ctors, X, Y, Context, Clause,
- !Info)
+ generate_du_unify_proc_body(TypeCtor, Ctors, X, Y, Context,
+ Clause, !Info)
)
;
DuTypeKind = du_type_kind_general,
- generate_du_unify_proc_body(Ctors, X, Y, Context, Clause,
- !Info)
+ generate_du_unify_proc_body(TypeCtor, Ctors, X, Y, Context,
+ Clause, !Info)
)
;
TypeBody = hlds_eqv_type(EqvType),
@@ -931,8 +932,8 @@
goal_info_init(Context, GoalInfo),
CallGoal = hlds_goal(Call, GoalInfo),
- create_pure_atomic_complicated_unification(ResultVar, equal_functor,
- Context, umc_explicit, [], UnifyGoal),
+ create_pure_atomic_complicated_unification(ResultVar,
+ compare_functor("="), Context, umc_explicit, [], UnifyGoal),
Goal0 = hlds_goal(conj(plain_conj, [CallGoal, UnifyGoal]), GoalInfo)
;
MaybeCompare = no,
@@ -973,11 +974,11 @@
% of special preds to define only for the kinds of types which do not
% lead this predicate to abort.
%
-:- pred generate_index_proc_body(hlds_type_body::in,
+:- pred generate_index_proc_body(mer_type::in, hlds_type_body::in,
prog_var::in, prog_var::in, prog_context::in, clause::out,
unify_proc_info::in, unify_proc_info::out) is det.
-generate_index_proc_body(TypeBody, X, Index, Context, Clause, !Info) :-
+generate_index_proc_body(Type, TypeBody, X, Index, Context, Clause, !Info) :-
info_get_module_info(!.Info, ModuleInfo),
( type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, _) ->
% For non-canonical types, the generated comparison predicate either
@@ -1011,7 +1012,8 @@
"trying to create index proc for notag type")
;
DuTypeKind = du_type_kind_general,
- generate_du_index_proc_body(Ctors, X, Index, Context,
+ type_to_ctor_det(Type, TypeCtor),
+ generate_du_index_proc_body(TypeCtor, Ctors, X, Index, Context,
Clause, !Info)
)
;
@@ -1338,34 +1340,39 @@
% should therefore be inferred to be det.
% (tests/general/det_complicated_unify2.m tests this case.)
%
-:- pred generate_du_unify_proc_body(list(constructor)::in,
+:- pred generate_du_unify_proc_body(type_ctor::in, list(constructor)::in,
prog_var::in, prog_var::in, prog_context::in,
clause::out, unify_proc_info::in, unify_proc_info::out) is det.
-generate_du_unify_proc_body(Ctors, X, Y, Context, Clause, !Info) :-
+generate_du_unify_proc_body(TypeCtor, Ctors, X, Y, Context, Clause, !Info) :-
CanCompareAsInt = can_compare_constants_as_ints(!.Info),
- list.map_foldl(generate_du_unify_case(X, Y, Context, CanCompareAsInt),
- Ctors, Disjuncts, !Info),
+ list.map_foldl(generate_du_unify_case(TypeCtor, X, Y, Context,
+ CanCompareAsInt), Ctors, Disjuncts, !Info),
goal_info_init(GoalInfo0),
goal_info_set_context(Context, GoalInfo0, GoalInfo),
Goal0 = hlds_goal(disj(Disjuncts), GoalInfo),
maybe_wrap_with_pretest_equality(Context, X, Y, no, Goal0, Goal, !Info),
quantify_clause_body([X, Y], Goal, Context, Clause, !Info).
-:- pred generate_du_unify_case(prog_var::in, prog_var::in, prog_context::in,
- bool::in, constructor::in, hlds_goal::out,
+:- pred generate_du_unify_case(type_ctor::in, prog_var::in, prog_var::in,
+ prog_context::in, bool::in, constructor::in, hlds_goal::out,
unify_proc_info::in, unify_proc_info::out) is det.
-generate_du_unify_case(X, Y, Context, CanCompareAsInt, Ctor, Goal, !Info) :-
+generate_du_unify_case(TypeCtor, X, Y, Context, CanCompareAsInt, Ctor, Goal,
+ !Info) :-
Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes, _Ctxt),
list.length(ArgTypes, FunctorArity),
- FunctorConsId = cons(FunctorName, FunctorArity),
+ ( TypeCtor = type_ctor(unqualified("{}"), _) ->
+ FunctorConsId = tuple_cons(FunctorArity)
+ ;
+ FunctorConsId = cons(FunctorName, FunctorArity, TypeCtor)
+ ),
(
ArgTypes = [],
CanCompareAsInt = yes
->
- create_pure_atomic_complicated_unification(X,
- rhs_functor(FunctorConsId, no, []), Context,
+ RHS = rhs_functor(FunctorConsId, no, []),
+ create_pure_atomic_complicated_unification(X, RHS, Context,
umc_explicit, [], UnifyX_Goal),
info_new_named_var(int_type, "CastX", CastX, !Info),
info_new_named_var(int_type, "CastY", CastY, !Info),
@@ -1379,12 +1386,12 @@
;
make_fresh_vars(ArgTypes, ExistQTVars, Vars1, !Info),
make_fresh_vars(ArgTypes, ExistQTVars, Vars2, !Info),
- create_pure_atomic_complicated_unification(X,
- rhs_functor(FunctorConsId, no, Vars1),
- Context, umc_explicit, [], UnifyX_Goal),
- create_pure_atomic_complicated_unification(Y,
- rhs_functor(FunctorConsId, no, Vars2),
- Context, umc_explicit, [], UnifyY_Goal),
+ RHS1 = rhs_functor(FunctorConsId, no, Vars1),
+ RHS2 = rhs_functor(FunctorConsId, no, Vars2),
+ create_pure_atomic_complicated_unification(X, RHS1, Context,
+ umc_explicit, [], UnifyX_Goal),
+ create_pure_atomic_complicated_unification(Y, RHS2, Context,
+ umc_explicit, [], UnifyY_Goal),
unify_var_lists(ArgTypes, ExistQTVars, Vars1, Vars2, UnifyArgs_Goals,
!Info),
GoalList = [UnifyX_Goal, UnifyY_Goal | UnifyArgs_Goals]
@@ -1424,26 +1431,27 @@
% X = h(_),
% Index = 2
% ).
-:- pred generate_du_index_proc_body(list(constructor)::in,
+:- pred generate_du_index_proc_body(type_ctor::in, list(constructor)::in,
prog_var::in, prog_var::in, prog_context::in, clause::out,
unify_proc_info::in, unify_proc_info::out) is det.
-generate_du_index_proc_body(Ctors, X, Index, Context, Clause, !Info) :-
- list.map_foldl2(generate_du_index_case(X, Index, Context),
+generate_du_index_proc_body(TypeCtor, Ctors, X, Index, Context, Clause,
+ !Info) :-
+ list.map_foldl2(generate_du_index_case(TypeCtor, X, Index, Context),
Ctors, Disjuncts, 0, _, !Info),
goal_info_init(GoalInfo0),
goal_info_set_context(Context, GoalInfo0, GoalInfo),
Goal = hlds_goal(disj(Disjuncts), GoalInfo),
quantify_clause_body([X, Index], Goal, Context, Clause, !Info).
-:- pred generate_du_index_case(prog_var::in, prog_var::in, prog_context::in,
- constructor::in, hlds_goal::out, int::in, int::out,
+:- pred generate_du_index_case(type_ctor::in, prog_var::in, prog_var::in,
+ prog_context::in, constructor::in, hlds_goal::out, int::in, int::out,
unify_proc_info::in, unify_proc_info::out) is det.
-generate_du_index_case(X, Index, Context, Ctor, Goal, !N, !Info) :-
+generate_du_index_case(TypeCtor, X, Index, Context, Ctor, Goal, !N, !Info) :-
Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes, _Ctxt),
list.length(ArgTypes, FunctorArity),
- FunctorConsId = cons(FunctorName, FunctorArity),
+ FunctorConsId = cons(FunctorName, FunctorArity, TypeCtor),
make_fresh_vars(ArgTypes, ExistQTVars, ArgVars, !Info),
create_pure_atomic_complicated_unification(X,
rhs_functor(FunctorConsId, no, ArgVars),
@@ -1483,7 +1491,8 @@
CompareSpec),
list.length(Ctors, NumCtors),
( NumCtors =< CompareSpec ->
- generate_du_quad_compare_proc_body(Ctors, Res, X, Y,
+ type_to_ctor_det(Type, TypeCtor),
+ generate_du_quad_compare_proc_body(TypeCtor, Ctors, Res, X, Y,
Context, Goal0, !Info)
;
generate_du_linear_compare_proc_body(Type, Ctors, Res, X, Y,
@@ -1553,52 +1562,55 @@
% switch_detection and det_analysis to recognize the determinism of the
% predicate.
%
-:- pred generate_du_quad_compare_proc_body(list(constructor)::in,
- prog_var::in, prog_var::in, prog_var::in, prog_context::in,
- hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det.
+:- pred generate_du_quad_compare_proc_body(type_ctor::in,
+ list(constructor)::in, prog_var::in, prog_var::in, prog_var::in,
+ prog_context::in, hlds_goal::out,
+ unify_proc_info::in, unify_proc_info::out) is det.
-generate_du_quad_compare_proc_body(Ctors, R, X, Y, Context, Goal, !Info) :-
- generate_du_quad_compare_switch_on_x(Ctors, Ctors, R, X, Y,
+generate_du_quad_compare_proc_body(TypeCtor, Ctors, R, X, Y, Context, Goal,
+ !Info) :-
+ generate_du_quad_compare_switch_on_x(TypeCtor, Ctors, Ctors, R, X, Y,
Context, [], Cases, !Info),
goal_info_init(GoalInfo0),
goal_info_set_context(Context, GoalInfo0, GoalInfo),
disj_list_to_goal(Cases, GoalInfo, Goal).
-:- pred generate_du_quad_compare_switch_on_x(
+:- pred generate_du_quad_compare_switch_on_x(type_ctor::in,
list(constructor)::in, list(constructor)::in,
prog_var::in, prog_var::in, prog_var::in,
prog_context::in, list(hlds_goal)::in, list(hlds_goal)::out,
unify_proc_info::in, unify_proc_info::out) is det.
-generate_du_quad_compare_switch_on_x([], _RightCtors, _R, _X, _Y, _Context,
- !Cases, !Info).
-generate_du_quad_compare_switch_on_x([LeftCtor | LeftCtors], RightCtors,
- R, X, Y, Context, !Cases, !Info) :-
- generate_du_quad_compare_switch_on_y(LeftCtor, RightCtors, ">", R, X, Y,
- Context, !Cases, !Info),
- generate_du_quad_compare_switch_on_x(LeftCtors, RightCtors, R, X, Y,
- Context, !Cases, !Info).
+generate_du_quad_compare_switch_on_x(_TypeCtor, [], _RightCtors, _R, _X, _Y,
+ _Context, !Cases, !Info).
+generate_du_quad_compare_switch_on_x(TypeCtor, [LeftCtor | LeftCtors],
+ RightCtors, R, X, Y, Context, !Cases, !Info) :-
+ generate_du_quad_compare_switch_on_y(TypeCtor, LeftCtor, RightCtors,
+ ">", R, X, Y, Context, !Cases, !Info),
+ generate_du_quad_compare_switch_on_x(TypeCtor, LeftCtors, RightCtors,
+ R, X, Y, Context, !Cases, !Info).
-:- pred generate_du_quad_compare_switch_on_y(
+:- pred generate_du_quad_compare_switch_on_y(type_ctor::in,
constructor::in, list(constructor)::in, string::in,
prog_var::in, prog_var::in, prog_var::in, prog_context::in,
list(hlds_goal)::in, list(hlds_goal)::out,
unify_proc_info::in, unify_proc_info::out) is det.
-generate_du_quad_compare_switch_on_y(_LeftCtor, [],
+generate_du_quad_compare_switch_on_y(_TypeCtor, _LeftCtor, [],
_Cmp, _R, _X, _Y, _Context, !Cases, !Info).
-generate_du_quad_compare_switch_on_y(LeftCtor, [RightCtor | RightCtors],
- Cmp0, R, X, Y, Context, !Cases, !Info) :-
+generate_du_quad_compare_switch_on_y(TypeCtor, LeftCtor,
+ [RightCtor | RightCtors], Cmp0, R, X, Y, Context, !Cases, !Info) :-
( LeftCtor = RightCtor ->
- generate_compare_case(LeftCtor, R, X, Y, Context, quad, Case, !Info),
+ generate_compare_case(TypeCtor, LeftCtor, R, X, Y, Context, quad, Case,
+ !Info),
Cmp1 = "<"
;
- generate_asymmetric_compare_case(LeftCtor, RightCtor, Cmp0, R, X, Y,
- Context, Case, !Info),
+ generate_asymmetric_compare_case(TypeCtor, LeftCtor, RightCtor,
+ Cmp0, R, X, Y, Context, Case, !Info),
Cmp1 = Cmp0
),
- generate_du_quad_compare_switch_on_y(LeftCtor, RightCtors, Cmp1, R, X, Y,
- Context, [Case | !.Cases], !:Cases, !Info).
+ generate_du_quad_compare_switch_on_y(TypeCtor, LeftCtor, RightCtors,
+ Cmp1, R, X, Y, Context, [Case | !.Cases], !:Cases, !Info).
%-----------------------------------------------------------------------------%
@@ -1672,16 +1684,14 @@
build_call("builtin_int_gt", [X_Index, Y_Index], Context,
Call_Greater_Than, !Info),
- Builtin = mercury_public_builtin_module,
- make_const_construction(Res, cons(qualified(Builtin, "<"), 0),
- Return_Less_Than),
- make_const_construction(Res, cons(qualified(Builtin, ">"), 0),
- Return_Greater_Than),
+ make_const_construction(Res, compare_cons_id("<"), Return_Less_Than),
+ make_const_construction(Res, compare_cons_id(">"), Return_Greater_Than),
create_pure_atomic_complicated_unification(Res, rhs_var(R), Context,
umc_explicit, [], Return_R),
- generate_compare_cases(Ctors, R, X, Y, Context, Cases, !Info),
+ type_to_ctor_det(Type, TypeCtor),
+ generate_compare_cases(TypeCtor, Ctors, R, X, Y, Context, Cases, !Info),
CasesGoal = hlds_goal(disj(Cases), GoalInfo),
build_call("compare_error", [], Context, Abort, !Info),
@@ -1734,33 +1744,34 @@
% the constant. This is to allow dupelim to eliminate all but one of
% the code fragments implementing such switch arms.
%
-:- pred generate_compare_cases(list(constructor)::in, prog_var::in,
- prog_var::in, prog_var::in, prog_context::in, list(hlds_goal)::out,
- unify_proc_info::in, unify_proc_info::out) is det.
+:- pred generate_compare_cases(type_ctor::in, list(constructor)::in,
+ prog_var::in, prog_var::in, prog_var::in, prog_context::in,
+ list(hlds_goal)::out, unify_proc_info::in, unify_proc_info::out) is det.
-generate_compare_cases([], _R, _X, _Y, _Context, [], !Info).
-generate_compare_cases([Ctor | Ctors], R, X, Y, Context, [Case | Cases],
- !Info) :-
- generate_compare_case(Ctor, R, X, Y, Context, linear, Case, !Info),
- generate_compare_cases(Ctors, R, X, Y, Context, Cases, !Info).
+generate_compare_cases(_TypeCtor, [], _R, _X, _Y, _Context, [], !Info).
+generate_compare_cases(TypeCtor, [Ctor | Ctors], R, X, Y, Context,
+ [Case | Cases], !Info) :-
+ generate_compare_case(TypeCtor, Ctor, R, X, Y, Context, linear, Case,
+ !Info),
+ generate_compare_cases(TypeCtor, Ctors, R, X, Y, Context, Cases, !Info).
:- type linear_or_quad
---> linear
; quad.
-:- pred generate_compare_case(constructor::in, prog_var::in, prog_var::in,
- prog_var::in, prog_context::in, linear_or_quad::in,
+:- pred generate_compare_case(type_ctor::in, constructor::in, prog_var::in,
+ prog_var::in, prog_var::in, prog_context::in, linear_or_quad::in,
hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det.
-generate_compare_case(Ctor, R, X, Y, Context, Kind, Case, !Info) :-
+generate_compare_case(TypeCtor, Ctor, R, X, Y, Context, Kind, Case, !Info) :-
Ctor = ctor(ExistQTVars, _Constraints, FunctorName, ArgTypes, _Ctxt),
list.length(ArgTypes, FunctorArity),
- FunctorConsId = cons(FunctorName, FunctorArity),
+ FunctorConsId = cons(FunctorName, FunctorArity, TypeCtor),
(
ArgTypes = [],
- create_pure_atomic_complicated_unification(X,
- rhs_functor(FunctorConsId, no, []), Context, umc_explicit, [],
- UnifyX_Goal),
+ RHS = rhs_functor(FunctorConsId, no, []),
+ create_pure_atomic_complicated_unification(X, RHS, Context,
+ umc_explicit, [], UnifyX_Goal),
generate_return_equal(R, Context, EqualGoal),
(
Kind = linear,
@@ -1770,21 +1781,20 @@
GoalList = [UnifyX_Goal, EqualGoal]
;
Kind = quad,
- create_pure_atomic_complicated_unification(Y,
- rhs_functor(FunctorConsId, no, []), Context, umc_explicit, [],
- UnifyY_Goal),
+ create_pure_atomic_complicated_unification(Y, RHS, Context,
+ umc_explicit, [], UnifyY_Goal),
GoalList = [UnifyX_Goal, UnifyY_Goal, EqualGoal]
)
;
ArgTypes = [_ | _],
make_fresh_vars(ArgTypes, ExistQTVars, Vars1, !Info),
make_fresh_vars(ArgTypes, ExistQTVars, Vars2, !Info),
- create_pure_atomic_complicated_unification(X,
- rhs_functor(FunctorConsId, no, Vars1), Context, umc_explicit, [],
- UnifyX_Goal),
- create_pure_atomic_complicated_unification(Y,
- rhs_functor(FunctorConsId, no, Vars2), Context, umc_explicit, [],
- UnifyY_Goal),
+ RHS1 = rhs_functor(FunctorConsId, no, Vars1),
+ RHS2 = rhs_functor(FunctorConsId, no, Vars2),
+ create_pure_atomic_complicated_unification(X, RHS1, Context,
+ umc_explicit, [], UnifyX_Goal),
+ create_pure_atomic_complicated_unification(Y, RHS2, Context,
+ umc_explicit, [], UnifyY_Goal),
compare_args(ArgTypes, ExistQTVars, Vars1, Vars2, R,
Context, CompareArgs_Goal, !Info),
GoalList = [UnifyX_Goal, UnifyY_Goal, CompareArgs_Goal]
@@ -1793,29 +1803,28 @@
goal_info_set_context(Context, GoalInfo0, GoalInfo),
conj_list_to_goal(GoalList, GoalInfo, Case).
-:- pred generate_asymmetric_compare_case(constructor::in, constructor::in,
+:- pred generate_asymmetric_compare_case(type_ctor::in,
+ constructor::in, constructor::in,
string::in, prog_var::in, prog_var::in, prog_var::in, prog_context::in,
hlds_goal::out, unify_proc_info::in, unify_proc_info::out) is det.
-generate_asymmetric_compare_case(Ctor1, Ctor2, CompareOp, R, X, Y, Context,
- Case, !Info) :-
+generate_asymmetric_compare_case(TypeCtor, Ctor1, Ctor2, CompareOp, R, X, Y,
+ Context, Case, !Info) :-
Ctor1 = ctor(ExistQTVars1, _Constraints1, FunctorName1, ArgTypes1, _Ctxt1),
Ctor2 = ctor(ExistQTVars2, _Constraints2, FunctorName2, ArgTypes2, _Ctxt2),
list.length(ArgTypes1, FunctorArity1),
list.length(ArgTypes2, FunctorArity2),
- FunctorConsId1 = cons(FunctorName1, FunctorArity1),
- FunctorConsId2 = cons(FunctorName2, FunctorArity2),
+ FunctorConsId1 = cons(FunctorName1, FunctorArity1, TypeCtor),
+ FunctorConsId2 = cons(FunctorName2, FunctorArity2, TypeCtor),
make_fresh_vars(ArgTypes1, ExistQTVars1, Vars1, !Info),
make_fresh_vars(ArgTypes2, ExistQTVars2, Vars2, !Info),
- create_pure_atomic_complicated_unification(X,
- rhs_functor(FunctorConsId1, no, Vars1), Context, umc_explicit, [],
- UnifyX_Goal),
- create_pure_atomic_complicated_unification(Y,
- rhs_functor(FunctorConsId2, no, Vars2), Context, umc_explicit, [],
- UnifyY_Goal),
- Builtin = mercury_public_builtin_module,
- make_const_construction(R, cons(qualified(Builtin, CompareOp), 0),
- ReturnResult),
+ RHS1 = rhs_functor(FunctorConsId1, no, Vars1),
+ RHS2 = rhs_functor(FunctorConsId2, no, Vars2),
+ create_pure_atomic_complicated_unification(X, RHS1, Context,
+ umc_explicit, [], UnifyX_Goal),
+ create_pure_atomic_complicated_unification(Y, RHS2, Context,
+ umc_explicit, [], UnifyY_Goal),
+ make_const_construction(R, compare_cons_id(CompareOp), ReturnResult),
GoalList = [UnifyX_Goal, UnifyY_Goal, ReturnResult],
goal_info_init(GoalInfo0),
goal_info_set_context(Context, GoalInfo0, GoalInfo),
@@ -1902,7 +1911,7 @@
info_new_var(comparison_result_type, R1, !Info),
build_call(ComparePred, [R1, X, Y], Context, Do_Comparison, !Info),
- make_const_construction(R1, equal_cons_id, Check_Equal),
+ make_const_construction(R1, compare_cons_id("="), Check_Equal),
Check_Not_Equal = hlds_goal(negation(Check_Equal), GoalInfo),
create_pure_atomic_complicated_unification(R, rhs_var(R1),
@@ -1922,7 +1931,7 @@
hlds_goal::out) is det.
generate_return_equal(ResultVar, Context, Goal) :-
- make_const_construction(ResultVar, equal_cons_id, Goal0),
+ make_const_construction(ResultVar, compare_cons_id("="), Goal0),
goal_set_context(Context, Goal0, Goal).
%-----------------------------------------------------------------------------%
@@ -2097,9 +2106,7 @@
GoalInfo = ContextGoalInfo
;
MaybeCompareRes = yes(Res),
- Builtin = mercury_public_builtin_module,
- make_const_construction(Res, cons(qualified(Builtin, "="), 0),
- EqualGoal),
+ make_const_construction(Res, compare_cons_id("="), EqualGoal),
EqualGoal = hlds_goal(_, EqualGoalInfo),
InstmapDelta = goal_info_get_instmap_delta(EqualGoalInfo),
goal_info_set_instmap_delta(InstmapDelta,
@@ -2141,13 +2148,20 @@
%-----------------------------------------------------------------------------%
-:- func equal_cons_id = cons_id.
+:- func compare_type_ctor = type_ctor.
+
+compare_type_ctor = TypeCtor :-
+ Builtin = mercury_public_builtin_module,
+ TypeCtor = type_ctor(qualified(Builtin, "comparison_result"), 0).
+
+:- func compare_cons_id(string) = cons_id.
-equal_cons_id = cons(qualified(mercury_public_builtin_module, "="), 0).
+compare_cons_id(Name) = cons(SymName, 0, compare_type_ctor) :-
+ SymName = qualified(mercury_public_builtin_module, Name).
-:- func equal_functor = unify_rhs.
+:- func compare_functor(string) = unify_rhs.
-equal_functor = rhs_functor(equal_cons_id, no, []).
+compare_functor(Name) = rhs_functor(compare_cons_id(Name), no, []).
%-----------------------------------------------------------------------------%
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.130
diff -u -r1.130 unique_modes.m
--- compiler/unique_modes.m 10 Mar 2009 05:00:31 -0000 1.130
+++ compiler/unique_modes.m 12 Mar 2009 01:25:50 -0000
@@ -216,7 +216,7 @@
(
instmap_delta_is_reachable(DeltaInstMap),
instmap_delta_search_var(DeltaInstMap, Var, Inst),
- \+ inst_matches_final(Inst, Inst0, Type, ModuleInfo)
+ \+ inst_matches_final_typed(Inst, Inst0, Type, ModuleInfo)
->
select_changed_inst_vars(Vars, DeltaInstMap, ModeInfo, ChangedVars1),
ChangedVars = [Var | ChangedVars1]
Index: compiler/untupling.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/untupling.m,v
retrieving revision 1.31
diff -u -r1.31 untupling.m
--- compiler/untupling.m 23 Dec 2008 01:37:42 -0000 1.31
+++ compiler/untupling.m 5 Feb 2009 09:00:02 -0000
@@ -745,7 +745,7 @@
type_ctor_is_tuple(TypeCtor)
->
Arity = list.length(TypeArgs),
- ConsId = cons(unqualified("{}"), Arity),
+ ConsId = tuple_cons(Arity),
Expansion = expansion(ConsId, TypeArgs)
;
% Expand a discriminated union type if it has only a
@@ -763,7 +763,7 @@
\+ list.member(Type, ContainerTypes)
->
Arity = list.length(SingleCtorArgs),
- ConsId = cons(SingleCtorName, Arity),
+ ConsId = cons(SingleCtorName, Arity, TypeCtor),
ExpandedTypes = list.map(func(C) = C ^ arg_type, SingleCtorArgs),
Expansion = expansion(ConsId, ExpandedTypes)
;
Index: compiler/unused_imports.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_imports.m,v
retrieving revision 1.19
diff -u -r1.19 unused_imports.m
--- compiler/unused_imports.m 10 Mar 2009 05:00:31 -0000 1.19
+++ compiler/unused_imports.m 12 Mar 2009 01:25:50 -0000
@@ -463,7 +463,7 @@
cons_id_used_modules(Visibility, ConsId, !UsedModules) :-
(
- ( ConsId = cons(SymName, _)
+ ( ConsId = cons(SymName, _, _)
; ConsId = type_info_cell_constructor(type_ctor(SymName, _))
),
add_sym_name_module(Visibility, SymName, !UsedModules)
@@ -473,15 +473,17 @@
),
add_all_modules(Visibility, ModuleName, !UsedModules)
;
- ( ConsId = int_const(_)
- ; ConsId = string_const(_)
+ ( ConsId = tuple_cons(_)
+ ; ConsId = closure_cons(_, _)
+ ; ConsId = int_const(_)
; ConsId = float_const(_)
- ; ConsId = implementation_defined_const(_)
- ; ConsId = pred_const(_, _)
+ ; ConsId = char_const(_)
+ ; ConsId = string_const(_)
+ ; ConsId = impl_defined_const(_)
; ConsId = typeclass_info_cell_constructor
; ConsId = tabling_info_const(_)
- ; ConsId = deep_profiling_proc_layout(_)
; ConsId = table_io_decl(_)
+ ; ConsId = deep_profiling_proc_layout(_)
)
).
Index: compiler/xml_documentation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/xml_documentation.m,v
retrieving revision 1.22
diff -u -r1.22 xml_documentation.m
--- compiler/xml_documentation.m 21 Jul 2008 03:10:16 -0000 1.22
+++ compiler/xml_documentation.m 5 Feb 2009 08:21:43 -0000
@@ -441,7 +441,7 @@
mer_type(_, builtin_type(builtin_type_int)) = elem("int", [], []).
mer_type(_, builtin_type(builtin_type_float)) = elem("float", [], []).
mer_type(_, builtin_type(builtin_type_string)) = elem("string", [], []).
-mer_type(_, builtin_type(builtin_type_character)) = elem("character", [], []).
+mer_type(_, builtin_type(builtin_type_char)) = elem("character", [], []).
mer_type(TVarset, higher_order_type(Types, MaybeResult, _, _)) = Xml :-
XmlTypes = xml_list("higher_order_type_args", mer_type(TVarset), Types),
( MaybeResult = yes(ResultType),
@@ -625,20 +625,25 @@
:- func cons_id(cons_id) = xml.
-cons_id(cons(Name, Arity)) = elem("cons", [], [name(Name), arity(Arity)]).
+cons_id(cons(Name, Arity, _)) = elem("cons", [], [name(Name), arity(Arity)]).
+% XXX We could do better for tuple_cons and closure_cons.
+% The return values here are just a continuation of what we used to do.
+cons_id(tuple_cons(Arity)) =
+ elem("cons", [], [name(unqualified("{}")), arity(Arity)]).
cons_id(int_const(I)) = tagged_int("int", I).
-cons_id(string_const(S)) = tagged_string("string", S).
cons_id(float_const(F)) = tagged_float("float", F).
-cons_id(implementation_defined_const(_)) = nyi("implementation_defined_const").
-cons_id(pred_const(_, _)) = nyi("pred_const").
+cons_id(char_const(C)) = tagged_char("char", C).
+cons_id(string_const(S)) = tagged_string("string", S).
+cons_id(impl_defined_const(_)) = nyi("impl_defined_const").
+cons_id(closure_cons(_, _)) = nyi("closure_cons").
cons_id(type_ctor_info_const(_, _, _)) = nyi("type_ctor_info_const").
cons_id(base_typeclass_info_const(_,_,_,_)) = nyi("base_typeclass_info_const").
cons_id(type_info_cell_constructor(_)) = nyi("type_info_cell_constructor").
cons_id(typeclass_info_cell_constructor) =
nyi("typeclass_info_cell_constructor").
cons_id(tabling_info_const(_)) = nyi("tabling_info_const").
-cons_id(deep_profiling_proc_layout(_)) = nyi("deep_profiling_proc_layout").
cons_id(table_io_decl(_)) = nyi("table_io_decl").
+cons_id(deep_profiling_proc_layout(_)) = nyi("deep_profiling_proc_layout").
:- func arity(int) = xml.
@@ -785,10 +790,6 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-:- func tagged_string(string, string) = xml.
-
-tagged_string(E, S) = elem(E, [], [data(S)]).
-
:- func tagged_int(string, int) = xml.
tagged_int(E, I) = elem(E, [], [data(int_to_string(I))]).
@@ -797,6 +798,14 @@
tagged_float(E, F) = elem(E, [], [data(float_to_string(F))]).
+:- func tagged_char(string, char) = xml.
+
+tagged_char(E, C) = elem(E, [], [data(char_to_string(C))]).
+
+:- func tagged_string(string, string) = xml.
+
+tagged_string(E, S) = elem(E, [], [data(S)]).
+
%-----------------------------------------------------------------------------%
:- func xml_list(string, func(T) = xml, list(T)) = xml.
cvs diff: Diffing compiler/notes
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.143
diff -u -r1.143 compiler_design.html
--- compiler/notes/compiler_design.html 11 May 2009 04:56:45 -0000 1.143
+++ compiler/notes/compiler_design.html 4 Jun 2009 06:43:52 -0000
@@ -273,6 +273,9 @@
and mutable declarations), prog_io_sym_name.m (which handles parsing
symbol names and specifiers) and prog_io_util.m (which defines
types and predicates needed by the other prog_io*.m modules.
+ builtin_lib_types.m contains definitions about types, type constructors
+ and function symbols that the Mercury implementation needs to know
+ about.
<p>
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
Index: library/term_io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/term_io.m,v
retrieving revision 1.86
diff -u -r1.86 term_io.m
--- library/term_io.m 16 Apr 2009 01:45:09 -0000 1.86
+++ library/term_io.m 4 Jun 2009 06:11:05 -0000
@@ -1,5 +1,5 @@
%---------------------------------------------------------------------------%
-% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1994-2006 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
@@ -164,6 +164,12 @@
%
:- func term_io.escaped_char(char) = string.
+ % A reversible version of escaped_char.
+ %
+:- pred string_is_escaped_char(char, string).
+:- mode string_is_escaped_char(in, out) is det.
+:- mode string_is_escaped_char(out, in) is semidet.
+
% Given a string S, write S, with characters escaped if necessary,
% to stdout. The string is not enclosed in quotes.
%
@@ -205,6 +211,19 @@
%
:- pred is_mercury_punctuation_char(char::in) is semidet.
+ % encode_escaped_char(Char, Str):
+ %
+ % Succeed in one of two cases:
+ %
+ % - Char is 'x', and Str is "x", where x is a valid Mercury source
+ % character, or
+ % - Char is '\x' and Str is "\x", where '\x' is a valid character
+ % escape sequence.
+ %
+:- pred encode_escaped_char(char, string).
+:- mode encode_escaped_char(in, out) is semidet.
+:- mode encode_escaped_char(out, in) is semidet.
+
% for use by io.m.
:- type adjacent_to_graphic_token
@@ -716,14 +735,33 @@
).
term_io.escaped_char(Char) = String :-
+ string_is_escaped_char(Char, String).
+
+:- pragma promise_equivalent_clauses(string_is_escaped_char/2).
+
+string_is_escaped_char(Char::in, String::out) :-
( mercury_escape_special_char(Char, QuoteChar) ->
- String = string.append("\\",
- string.char_to_string(QuoteChar))
+ String = string.append("\\", string.char_to_string(QuoteChar))
; is_mercury_source_char(Char) ->
String = string.char_to_string(Char)
;
String = mercury_escape_char(Char)
).
+string_is_escaped_char(Char::out, String::in) :-
+ string.to_char_list(String, Chars),
+ (
+ Chars = [Char],
+ is_mercury_source_char(Char)
+ ;
+ Chars = ['\\', QuoteChar],
+ mercury_escape_special_char(Char, QuoteChar)
+ ;
+ Chars = ['\\', Char1, Char2, Char3],
+ NumChars = [Char1, Char2, Char3],
+ string.from_char_list(NumChars, NumString),
+ string.base_string_to_int(8, NumString, Int),
+ char.to_int(Char, Int)
+ ).
mercury_escape_char(Char) = EscapeCode :-
char.to_int(Char, Int),
@@ -786,6 +824,25 @@
%-----------------------------------------------------------------------------%
+:- pragma promise_equivalent_clauses(encode_escaped_char/2).
+
+encode_escaped_char(Char::in, Str::out) :-
+ ( mercury_escape_special_char(Char, EscapeChar) ->
+ string.from_char_list(['\\', EscapeChar], Str)
+ ; is_mercury_source_char(Char) ->
+ string.from_char_list([Char], Str)
+ ;
+ fail
+ ).
+encode_escaped_char(Char::out, Str::in) :-
+ string.to_char_list(Str, Chars),
+ (
+ Chars = [Char]
+ ;
+ Chars = ['\\', EscapedChar],
+ mercury_escape_special_char(Char, EscapedChar)
+ ).
+
% mercury_escape_special_char(Char, EscapeChar) is true iff Char
% is character for which there is a special backslash-escape character
% EscapeChar that can be used after a backslash in string literals or
@@ -794,7 +851,9 @@
% Note: the code here is similar to code in compiler/mercury_to_mercury.m;
% any changes here may require similar changes there.
%
-:- pred mercury_escape_special_char(char::in, char::out) is semidet.
+:- pred mercury_escape_special_char(char, char).
+:- mode mercury_escape_special_char(in, out) is semidet.
+:- mode mercury_escape_special_char(out, in) is semidet.
mercury_escape_special_char('''', '''').
mercury_escape_special_char('"', '"').
cvs diff: Diffing mdbcomp
Index: mdbcomp/prim_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/mdbcomp/prim_data.m,v
retrieving revision 1.34
diff -u -r1.34 prim_data.m
--- mdbcomp/prim_data.m 22 May 2009 02:51:21 -0000 1.34
+++ mdbcomp/prim_data.m 3 Jun 2009 12:46:31 -0000
@@ -345,6 +345,14 @@
%
:- func mercury_ssdb_builtin_module = sym_name.
+ % Returns the name of the list module.
+ %
+:- func mercury_list_module = sym_name.
+
+ % Returns the name of the string module.
+ %
+:- func mercury_string_module = sym_name.
+
% Returns the sym_name of the module with the given name in the
% Mercury standard library.
%
@@ -553,23 +561,29 @@
mercury_private_builtin_module = unqualified("private_builtin").
mercury_region_builtin_module = unqualified("region_builtin").
mercury_stm_builtin_module = unqualified("stm_builtin").
+% Exception is a non-builtin module needed by the STM system.
+mercury_exception_module = unqualified("exception").
+% Univ is a non-builtin module needed by the STM system.
+mercury_univ_module = unqualified("univ").
mercury_table_builtin_module = unqualified("table_builtin").
mercury_table_statistics_module = unqualified("table_statistics").
mercury_profiling_builtin_module = unqualified("profiling_builtin").
mercury_term_size_prof_builtin_module = unqualified("term_size_prof_builtin").
mercury_par_builtin_module = unqualified("par_builtin").
mercury_ssdb_builtin_module = unqualified("ssdb").
-mercury_std_lib_module_name(Name) = Name.
+mercury_list_module = unqualified("list").
+mercury_string_module = unqualified("string").
-% Additional non-builtin modules that are needed by the STM system.
-%
-mercury_exception_module = unqualified("exception").
-mercury_univ_module = unqualified("univ").
-
-is_std_lib_module_name(SymName, Name) :-
- Name = sym_name_to_string(SymName),
+is_std_lib_module_name(ModuleName, Name) :-
+ % -- not yet:
+ % ModuleName = qualified(unqualified("std"), UnqualifiedModuleName),
+ Name = sym_name_to_string(ModuleName),
mercury_std_library_module(Name).
+mercury_std_lib_module_name(ModuleName) = ModuleName.
+ % -- not yet:
+ % QualfiedModuleName = qualified(unqualified("std"), ModuleName),
+
any_mercury_builtin_module(Module) :-
( Module = mercury_public_builtin_module
; Module = mercury_private_builtin_module
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
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/par_conj
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/stm
cvs diff: Diffing tests/stm/orig
cvs diff: Diffing tests/stm/orig/stm-compiler
cvs diff: Diffing tests/stm/orig/stm-compiler/test1
cvs diff: Diffing tests/stm/orig/stm-compiler/test10
cvs diff: Diffing tests/stm/orig/stm-compiler/test2
cvs diff: Diffing tests/stm/orig/stm-compiler/test3
cvs diff: Diffing tests/stm/orig/stm-compiler/test4
cvs diff: Diffing tests/stm/orig/stm-compiler/test5
cvs diff: Diffing tests/stm/orig/stm-compiler/test6
cvs diff: Diffing tests/stm/orig/stm-compiler/test7
cvs diff: Diffing tests/stm/orig/stm-compiler/test8
cvs diff: Diffing tests/stm/orig/stm-compiler/test9
cvs diff: Diffing tests/stm/orig/stm-compiler-par
cvs diff: Diffing tests/stm/orig/stm-compiler-par/bm1
cvs diff: Diffing tests/stm/orig/stm-compiler-par/bm2
cvs diff: Diffing tests/stm/orig/stm-compiler-par/stmqueue
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test1
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test10
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test11
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test2
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test3
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test4
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test5
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test6
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test7
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test8
cvs diff: Diffing tests/stm/orig/stm-compiler-par/test9
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test1
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test2
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test3
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test4
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test5
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test6
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test7
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test8
cvs diff: Diffing tests/stm/orig/stm-compiler-par-asm_fast/test9
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list