[m-rev.] for review: constant structures for typeinfos and typeclass infos
Zoltan Somogyi
zs at unimelb.edu.au
Thu Jun 7 15:40:16 AEST 2012
This diff has been tested not just with bootcheck, but also by make test
on g12. It gets the same number of test case failures on g12 as a g12
workspace compiled with a current, unchanged Mercury compiler.
It is a big diff. Does anyone volunteer to review it? I would like to
commit it tomorrow, since I plan to work on extensions of this change
(such as removing the drawback mentioned below) on the weekend.
------------------------------------------
Heavily polymorphic code, such as that generated by g12, often builds the same
typeinfos and typeclass infos over and over again. We have long had caches
that avoid building a new typeinfo or typeclass info if some variable in the
current scope already contains the right value, but a program that has many
scopes may still build the same typeinfo or typeclass info many times.
If that typeinfo or typeclass info is a ground term, the code generators
will recognize that fact, and will turn all the constructions of that ground
term in different scopes into referencess to the same constant structure.
However, in the meantime, the program can be much bigger than necessary.
In the motivating test case for this change, a single call to fdic_post
is preceded by 133 goals that build the four typeclass infos it needs.
The main idea of this diff is to construct constant typeinfos and typeclass
infos out of line, in a separate data structure. Polymorphism then binds
variables representing typeinfo and typeclass infos to reference to these
constant structures. In the motivating example, this allows polymorphism.m
to insert just four goals before the call to fdic_post, the minimal possible
number: one for each typeclass info that predicate needs.
On Leslie's bug344 program, this change speeds up the compiler by a factor
of five to eight (reducing compile time from about 80 or 85 seconds to
10 or 15).
There is a drawback to this scheme, but it is minor. That drawback is that
once a constant structure is entered into our database of constant structures,
it cannot (yet) be removed. Even if all the references to a constant structure
are eliminated by optimizations, the structure will remain.
------------------------------------------
CHANGES IN THE FRONT END
compiler/const_struct.m:
A new module to look after our new database of constant structures.
Currently, its use is enable only on the LLDS and MLDS C backends.
compiler/hlds.m:
compiler/notes/compiler_design.html:
Add the new module to the HLDS package.
compiler/hlds_module.m:
Include the constant structure database in the module_info.
compiler/hlds_data.m:
Add two new cons_ids, which refer to typeinfos and typeclass infos
implemented as constant structures.
Move the code for calculating the number of extra instance args
in base_typeclass_infos here from base_typeclass_info.m, since
polymorphism.m now needs it too. We can now also eliminate the
duplicate copy of that code in higher_order.m.
Make an independent optimization: make the restrict_list_elements
function more efficient by avoiding redundant tests.
compiler/polymorphism.m:
When building typeinfo and typeclass infos, keep track of whether
the structure being built is constant. If it is, then put it in the
database of constant structures, and replace the code building it
with a simple reference to that new entry.
Since I now expect most goal sequences inserted before goals to be
short, consistent use lists of goals to represent these, since the
costs of conversions to and from cord form are unlikely to be paid back
by the higher efficiency of cord operations on longer sequences.
When we want to get the typeclass info of a superclass out of the
typeclass info of a subclass, if the typeclass info of the subclass
is known, do the extraction here. We used to do this optimization
only in higher_order.m, but doing so here reduces the size of the HLDS
between polymorphism.m and higher_order.m, and thus improves
compilation time.
Reorganize some of the structure of this module to make the above
changes possible. In particular, our new approach requires making
snapshots of the varsets and vartypes, and later restoring those
snapshots if the variables allocated turn out to be unnecessary,
due to all of them describing the components of a constant structure.
The correctness of such code is much easier to check if the taking
and restoring of each snapshot takes places in a single predicate.
Remove the code moved to higher_order.m.
Add some debugging code for now. If no issues arise in the next few
weeks, it can be deleted.
compiler/modecheck_unify.m:
Treat unifications whose right hand side has a cons_id referring to a
constant structure specially.
compiler/base_typeclass_info.m:
Replace the code that is now in num_extra_instance_args with a call
to that predicate.
Put the arguments of some predicates in a more logical order.
compiler/higher_order.m:
When looking up the components of existing typeclass infos, handle
cases where those typeclass infos are constant structures.
Give some types, fields and variables better names.
Avoid a redundant map search.
Avoid some redundant tests by providing separate predicates to handle
higher order calls and method calls.
Move the predicate is_typeclass_info_manipulator here from
polymorphism.m, since this is the only module that uses that predicate.
------------------------------------------
CHANGES IN THE LLDS BACKEND:
compiler/llds.m:
Add a type to map constant structure numbers to rvals together with
their LLDS types.
Introduce a type to represent rvals together with their LLDS types.
compiler/mercury_compile_llds_back_end.m:
Before we generate code for the predicates of the module, convert
the constant structures to typed LLDS rvals. Create a map mapping
each constant structure number to the corresponding typed rvals.
compiler/proc_gen.m:
Take that map, and put it into the code_info, to allow references
to those structures to be translated.
Put the arguments of some predicates into a more logical order.
compiler/code_info.m:
Include a map giving the representation of each constant structure
in the code_info.
compiler/unify_gen.m:
Add the predicates needed to convert the constant structures of a
module to LLDS rvals. For now, this code works only on the kinds of
constant structures generated by polymorphism.m.
Handle unifications whose right hand side is a reference to a constant
structure.
compiler/global_data.m:
compiler/stack_layout.m:
Use the new typed_rval type where relevant.
------------------------------------------
CHANGES IN THE MLDS BACKEND:
compiler/ml_proc_gen.m:
Before we generate code for the predicates of the module, convert
the constant structures to typed MLDS rvals. Create a map mapping
each constant structure number to the corresponding typed rvals.
Factor out some code into a predicate of its own.
compiler/ml_gen_info.m:
Include a map giving the representation of each constant structure
in the ml_gen_info.
Also add to the ml_gen_info an indication of what GC system we are
generating code for, since the code generator needs to know this often.
compiler/ml_unify_gen.m:
Add the predicates needed to convert the constant structures of a
module to MLDS rvals. For now, this code works only on the kinds of
constant structures generated by polymorphism.m.
Handle unifications whose right hand side is a reference to a constant
structure.
Simplify some existing code.
------------------------------------------
MINOR CHANGES:
mdbcomp/prim_data.m:
Add a predicate that gets both the module name and the base name
from a sym_name at the same time. This is used for minor speedups
in other code updated in this diff.
compiler/dead_proc_elim.m:
Scan constant structures for references to entities that need to be
kept alive.
compiler/term_constr_build.m:
compiler/term_traversal.m:
Do not build size constraints from references to constant structures.
The sizes of constant terms don't change, so they are irrelevant
when building constraints for finding argument size changes.
------------------------------------------
TRIVIAL CHANGES TO CONFORM TO OTHER CHANGES:
compiler/hlds_out_module.m:
Print out the constant structure database if asked.
doc/user_guide.tex:
Document how to ask for it.
compiler/hlds_out_util.m:
Print out the new cons_ids.
compiler/hlds_out_mode.m:
Print out the new cons_ids in insts.
Remove a compiler abort, to help debug a problem.
Improve the structure of a predicate.
compiler/hlds_out_goal.m:
Fix some missing newlines.
compiler/hlds_code_util.m:
Add some utility predicates needed by the modules above.
Conform to the changes above.
compiler/mlds_to_il.m:
Reorder some predicates.
Conform to the changes above.
compiler/bytecode_gen.m:
compiler/ctgc.selector.m:
compiler/dependency_graph.m:
compiler/erl_unify_gen.m:
compiler/export.m:
compiler/implementation_defined_literals.m:
compiler/inst_check.m:
compiler/llds_out_globals.m:
compiler/mercury_to_mercury.m:
compiler/ml_global_data.m:
compiler/ml_switch_gen.m:
compiler/ml_type_gen.m:
compiler/module_qual.m:
compiler/prog_rep.m:
compiler/prog_type.m:
compiler/prog_util.m:
compiler/rbmm.execution_path.m:
compiler/switch_gen.m:
compiler/switch_util.m:
compiler/type_ctor_info.m:
compiler/unused_imports.m:
compiler/var_locn.m:
compiler/xml_documentation.m:
Conform to the changes above.
------------------------------------------
OTHER INDEPENDENT CHANGES:
compiler/handle_options.m:
Add a dump option that is useful for debugging when working on
polymorphism.m and constant structures.
compiler/equiv_type_hlds.m:
Fix an old performance bug: make the code handling try goals keep
the old memory cells representing such goals, instead of rebuilding
them, if no changes took place inside them.
compiler/ml_accurate_gc.m:
Move a test earlier, to allow us to avoid more work in the common case.
compiler/erl_code_gen.m:
compiler/error_util.m:
compiler/hhf.m:
compiler/inst_util.m:
compiler/ml_code_util.m:
compiler/ml_util.m:
compiler/mlds_to_c.m:
compiler/modecheck_call.m:
compiler/modecheck_util.m:
compiler/post_typecheck.m:
compiler/size_prof.m:
compiler/stack_opt.m:
compiler/stratify.m:
compiler/unused_args.m:
compiler/post_type_analysis.m:
library/erland_rtti_implementation.m:
Minor cleanups.
------------------------------------------
CHANGES TO THE TEST SUITE:
tests/invalid/any_passed_as_ground.err_exp2:
tests/invalid/invalid_default_func_1.err_exp2:
tests/invalid/invalid_default_func_3.err_exp2:
tests/invalid/try_detism.err_exp2:
Add second expected output files for these tests. We need alternate
expected outputs because the numbers of some of the typeinfo variables
mentioned in error messages are different depending on whether or not
const structures are enabled.
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/extra
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/extra
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/libatomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops/doc
cvs diff: Diffing boehm_gc/libatomic_ops/src
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/armcc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops/tests
cvs diff: Diffing boehm_gc/libatomic_ops-1.2
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/m4
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/base_typeclass_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/base_typeclass_info.m,v
retrieving revision 1.54
diff -u -b -r1.54 base_typeclass_info.m
--- compiler/base_typeclass_info.m 5 Jun 2012 15:14:26 -0000 1.54
+++ compiler/base_typeclass_info.m 7 Jun 2012 05:32:26 -0000
@@ -32,6 +32,8 @@
%---------------------------------------------------------------------------%
+ % Generate all the base_typeclass_infos defined by the module.
+ %
:- pred generate_base_typeclass_info_rtti(module_info::in,
list(rtti_data)::out) is det.
@@ -63,35 +65,36 @@
%---------------------------------------------------------------------------%
-generate_base_typeclass_info_rtti(ModuleInfo, RttiDataList) :-
- module_info_get_name(ModuleInfo, ModuleName),
+generate_base_typeclass_info_rtti(ModuleInfo, RttiDatas) :-
module_info_get_instance_table(ModuleInfo, InstanceTable),
map.to_assoc_list(InstanceTable, AllInstances),
- gen_infos_for_classes(AllInstances, ModuleName, ModuleInfo,
- [], RttiDataList).
+ gen_infos_for_classes(ModuleInfo, AllInstances, [], RttiDatas).
+
+:- pred gen_infos_for_classes(module_info::in,
+ assoc_list(class_id, list(hlds_instance_defn))::in,
+ list(rtti_data)::in, list(rtti_data)::out) is det.
+
+gen_infos_for_classes(_ModuleInfo, [], !RttiDatas).
+gen_infos_for_classes(ModuleInfo, [Class | Classes], !RttiDatas) :-
+ Class = ClassId - InstanceDefns,
+ gen_infos_for_instances(ModuleInfo, ClassId, InstanceDefns, !RttiDatas),
+ gen_infos_for_classes(ModuleInfo, Classes, !RttiDatas).
+
+:- pred gen_infos_for_instances(module_info::in, class_id::in,
+ list(hlds_instance_defn)::in,
+ list(rtti_data)::in, list(rtti_data)::out) is det.
+
+gen_infos_for_instances(_, _, [], !RttiDatas).
+gen_infos_for_instances(ModuleInfo, ClassId,
+ [InstanceDefn | InstanceDefns], !RttiDatas) :-
+ % We could make this procedure tail recursive just by doing this call
+ % at the end of the clause, but keeping the declarations in instance
+ % order seems worthwhile on aesthetic grounds.
+ gen_infos_for_instances(ModuleInfo, ClassId, InstanceDefns, !RttiDatas),
-:- pred gen_infos_for_classes(
- assoc_list(class_id, list(hlds_instance_defn))::in, module_name::in,
- module_info::in, list(rtti_data)::in, list(rtti_data)::out) is det.
-
-gen_infos_for_classes([], _ModuleName, _ModuleInfo, !RttiDataList).
-gen_infos_for_classes([C|Cs], ModuleName, ModuleInfo, !RttiDataList) :-
- gen_infos_for_instance_list(C, ModuleName, ModuleInfo, !RttiDataList),
- gen_infos_for_classes(Cs, ModuleName, ModuleInfo, !RttiDataList).
-
- % XXX make it use an accumulator
-:- pred gen_infos_for_instance_list(
- pair(class_id, list(hlds_instance_defn))::in, module_name::in,
- module_info::in, list(rtti_data)::in, list(rtti_data)::out) is det.
-
-gen_infos_for_instance_list(_ - [], _, _, !RttiDataList).
-gen_infos_for_instance_list(ClassId - [InstanceDefn | Is], ModuleName,
- ModuleInfo, !RttiDataList) :-
- gen_infos_for_instance_list(ClassId - Is, ModuleName, ModuleInfo,
- !RttiDataList),
InstanceDefn = hlds_instance_defn(InstanceModule, ImportStatus,
- _TermContext, InstanceConstraints, InstanceTypes, _OriginalTypes, Body,
- PredProcIds, _Varset, _SuperClassProofs),
+ _TermContext, _InstanceConstraints, InstanceTypes, _OriginalTypes,
+ Body, _MaybePredProcIds, _Varset, _SuperClassProofs),
(
Body = instance_body_concrete(_),
% Only make the base_typeclass_info if the instance declaration
@@ -99,12 +102,11 @@
status_defined_in_this_module(ImportStatus) = yes
->
make_instance_string(InstanceTypes, InstanceString),
- gen_body(PredProcIds, InstanceTypes, InstanceConstraints,
- ModuleInfo, ClassId, BaseTypeClassInfo),
+ gen_body(ModuleInfo, ClassId, InstanceDefn, BaseTypeClassInfo),
TCName = generate_class_name(ClassId),
RttiData = rtti_data_base_typeclass_info(TCName, InstanceModule,
InstanceString, BaseTypeClassInfo),
- !:RttiDataList = [RttiData | !.RttiDataList]
+ !:RttiDatas = [RttiData | !.RttiDatas]
;
% The instance decl is from another module, or is abstract,
% so we don't bother including it.
@@ -113,40 +115,43 @@
%----------------------------------------------------------------------------%
-:- pred gen_body(maybe(list(hlds_class_proc))::in, list(mer_type)::in,
- list(prog_constraint)::in, module_info::in, class_id::in,
+:- pred gen_body(module_info::in, class_id::in, hlds_instance_defn::in,
base_typeclass_info::out) is det.
-gen_body(no, _, _, _, _, _) :-
- unexpected($module, $pred,
- "pred_proc_ids should have been filled in by check_typeclass.m").
-gen_body(yes(PredProcIds0), Types, Constraints, ModuleInfo, ClassId,
- BaseTypeClassInfo) :-
- type_vars_list(Types, TypeVars),
- get_unconstrained_tvars(TypeVars, Constraints, Unconstrained),
+gen_body(ModuleInfo, ClassId, InstanceDefn, BaseTypeClassInfo) :-
+ num_extra_instance_args(InstanceDefn, NumExtra),
+
+ Constraints = InstanceDefn ^ instance_constraints,
list.length(Constraints, NumConstraints),
- list.length(Unconstrained, NumUnconstrained),
- NumExtra = NumConstraints + NumUnconstrained,
+
+ MaybeInstancePredProcIds = InstanceDefn ^ instance_hlds_interface,
+ (
+ MaybeInstancePredProcIds = no,
+ unexpected($module, $pred,
+ "pred_proc_ids not filled in by check_typeclass.m")
+ ;
+ MaybeInstancePredProcIds = yes(InstancePredProcIds)
+ ),
ExtractPredProcId = (pred(HldsPredProc::in, PredProc::out) is det :-
(
HldsPredProc = hlds_class_proc(PredId, ProcId),
PredProc = proc(PredId, ProcId)
)),
- list.map(ExtractPredProcId, PredProcIds0, PredProcIds),
- construct_proc_labels(PredProcIds, ModuleInfo, ProcLabels),
+ list.map(ExtractPredProcId, InstancePredProcIds, PredProcIds),
+ construct_proc_labels(ModuleInfo, PredProcIds, ProcLabels),
gen_superclass_count(ClassId, ModuleInfo, SuperClassCount, ClassArity),
list.length(ProcLabels, NumMethods),
BaseTypeClassInfo = base_typeclass_info(NumExtra, NumConstraints,
SuperClassCount, ClassArity, NumMethods, ProcLabels).
-:- pred construct_proc_labels(list(pred_proc_id)::in,
- module_info::in, list(rtti_proc_label)::out) is det.
+:- pred construct_proc_labels(module_info::in, list(pred_proc_id)::in,
+ list(rtti_proc_label)::out) is det.
-construct_proc_labels([], _, []).
-construct_proc_labels([proc(PredId, ProcId) | Procs], ModuleInfo,
+construct_proc_labels(_, [], []).
+construct_proc_labels(ModuleInfo, [proc(PredId, ProcId) | PredProcIds],
[ProcLabel | ProcLabels]) :-
ProcLabel = make_rtti_proc_label(ModuleInfo, PredId, ProcId),
- construct_proc_labels(Procs, ModuleInfo, ProcLabels).
+ construct_proc_labels(ModuleInfo, PredProcIds, ProcLabels).
%----------------------------------------------------------------------------%
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.132
diff -u -b -r1.132 bytecode_gen.m
--- compiler/bytecode_gen.m 13 Feb 2012 00:11:33 -0000 1.132
+++ compiler/bytecode_gen.m 7 Jun 2012 05:32:26 -0000
@@ -552,13 +552,12 @@
get_var_type(ByteInfo, Var1, Var1Type),
get_var_type(ByteInfo, Var2, Var2Type),
(
- type_to_ctor_and_args(Var1Type, TypeCtor1, _),
- type_to_ctor_and_args(Var2Type, TypeCtor2, _)
+ type_to_ctor(Var1Type, TypeCtor1),
+ type_to_ctor(Var2Type, TypeCtor2)
->
( TypeCtor2 = TypeCtor1 ->
TypeCtor = TypeCtor1
- ; unexpected($module, $pred,
- "simple_test between different types")
+ ; unexpected($module, $pred, "simple_test between different types")
)
;
unexpected($module, $pred, "failed lookup of type id")
@@ -776,6 +775,12 @@
ConsId = typeclass_info_cell_constructor,
ByteConsId = byte_typeclass_info_cell_constructor
;
+ ConsId = type_info_const(_),
+ sorry($module, $pred, "bytecode doesn't implement type_info_const")
+ ;
+ ConsId = typeclass_info_const(_),
+ sorry($module, $pred, "bytecode doesn't implement typeclass_info_const")
+ ;
ConsId = tabling_info_const(_),
sorry($module, $pred, "bytecode cannot implement tabling")
;
@@ -817,6 +822,12 @@
map_cons_tag(base_typeclass_info_tag(_, _, _), _) :-
unexpected($module, $pred, "base_typeclass_info_tag cons tag " ++
"for non-base_typeclass_info_constant cons id").
+map_cons_tag(type_info_const_tag(_), _) :-
+ unexpected($module, $pred, "type_info_const cons tag " ++
+ "for non-type_info_const cons id").
+map_cons_tag(typeclass_info_const_tag(_), _) :-
+ unexpected($module, $pred, "typeclass_info_const cons tag " ++
+ "for non-typeclass_info_const cons id").
map_cons_tag(tabling_info_tag(_, _), _) :-
unexpected($module, $pred, "tabling_info_tag cons tag " ++
"for non-tabling_info_constant cons id").
Index: compiler/code_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/code_info.m,v
retrieving revision 1.399
diff -u -b -r1.399 code_info.m
--- compiler/code_info.m 24 Apr 2012 06:02:31 -0000 1.399
+++ compiler/code_info.m 7 Jun 2012 05:32:26 -0000
@@ -113,9 +113,9 @@
%
:- pred code_info_init(bool::in, globals::in, pred_id::in, proc_id::in,
pred_info::in, proc_info::in, abs_follow_vars::in, module_info::in,
- static_cell_info::in, resume_point_info::out, trace_slot_info::out,
- maybe(containing_goal_map)::in, list(string)::in, int::in, code_info::out)
- is det.
+ static_cell_info::in, const_struct_map::in, resume_point_info::out,
+ trace_slot_info::out, maybe(containing_goal_map)::in,
+ list(string)::in, int::in, code_info::out) is det.
% Get the globals table.
%
@@ -248,6 +248,8 @@
:- pred get_containing_goal_map_det(code_info::in, containing_goal_map::out)
is det.
+:- pred get_const_struct_map(code_info::in, const_struct_map::out) is det.
+
:- pred add_out_of_line_code(llds_code::in, code_info::in, code_info::out)
is det.
@@ -395,7 +397,11 @@
% The setting of --optimize-constructor-last-call-null.
cis_lcmc_null :: bool,
- cis_containing_goal_map :: maybe(containing_goal_map)
+ cis_containing_goal_map :: maybe(containing_goal_map),
+
+ % Maps the number of an entry in the module's const_struct_db
+ % to its rval.
+ cis_const_struct_map :: const_struct_map
).
:- type code_info_loc_dep
@@ -503,9 +509,9 @@
%---------------------------------------------------------------------------%
code_info_init(SaveSuccip, Globals, PredId, ProcId, PredInfo, ProcInfo,
- FollowVars, ModuleInfo, StaticCellInfo, ResumePoint, TraceSlotInfo,
- MaybeContainingGoalMap, TSRevStringTable, TSStringTableSize,
- CodeInfo) :-
+ FollowVars, ModuleInfo, StaticCellInfo, ConstStructMap, ResumePoint,
+ TraceSlotInfo, MaybeContainingGoalMap,
+ TSRevStringTable, TSStringTableSize, CodeInfo) :-
ProcLabel = make_proc_label(ModuleInfo, PredId, ProcId),
proc_info_get_initial_instmap(ProcInfo, ModuleInfo, InstMap),
proc_info_get_liveness_info(ProcInfo, Liveness),
@@ -602,7 +608,8 @@
OptRegionOps,
AutoComments,
LCMCNull,
- MaybeContainingGoalMap
+ MaybeContainingGoalMap,
+ ConstStructMap
),
code_info_loc_dep(
Liveness,
@@ -748,6 +755,7 @@
get_auto_comments(CI, CI ^ code_info_static ^ cis_auto_comments).
get_lcmc_null(CI, CI ^ code_info_static ^ cis_lcmc_null).
get_containing_goal_map(CI, CI ^ code_info_static ^ cis_containing_goal_map).
+get_const_struct_map(CI, CI ^ code_info_static ^ cis_const_struct_map).
get_forward_live_vars(CI, CI ^ code_info_loc_dep ^ cild_forward_live_vars).
get_instmap(CI, CI ^ code_info_loc_dep ^ cild_instmap).
get_zombies(CI, CI ^ code_info_loc_dep ^ cild_zombies).
@@ -969,7 +977,7 @@
:- pred get_threadscope_rev_string_table(code_info::in,
list(string)::out, int::out) is det.
-:- pred add_scalar_static_cell(assoc_list(rval, llds_type)::in,
+:- pred add_scalar_static_cell(list(typed_rval)::in,
data_id::out, code_info::in, code_info::out) is det.
:- pred add_scalar_static_cell_natural_types(list(rval)::in,
@@ -1077,7 +1085,7 @@
search_type_defn(CI, Type, TypeDefn) :-
get_module_info(CI, ModuleInfo),
- type_to_ctor_and_args_det(Type, TypeCtor, _),
+ type_to_ctor_det(Type, TypeCtor),
module_info_get_type_table(ModuleInfo, TypeTable),
search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn).
Index: compiler/ctgc.selector.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ctgc.selector.m,v
retrieving revision 1.33
diff -u -b -r1.33 ctgc.selector.m
--- compiler/ctgc.selector.m 23 May 2011 05:08:01 -0000 1.33
+++ compiler/ctgc.selector.m 7 Jun 2012 05:32:26 -0000
@@ -121,6 +121,8 @@
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
; ConsId = tabling_info_const(_)
; ConsId = table_io_decl(_)
; ConsId = deep_profiling_proc_layout(_)
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.144
diff -u -b -r1.144 dead_proc_elim.m
--- compiler/dead_proc_elim.m 5 Jun 2012 15:14:26 -0000 1.144
+++ compiler/dead_proc_elim.m 7 Jun 2012 05:32:26 -0000
@@ -78,6 +78,7 @@
:- import_module check_hlds.simplify.
:- import_module check_hlds.try_expand.
+:- import_module hlds.const_struct.
:- import_module hlds.hlds_clauses.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_error_util.
@@ -89,10 +90,12 @@
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
+:- import_module assoc_list.
:- import_module bool.
:- import_module int.
:- import_module io.
:- import_module maybe.
+:- import_module pair.
:- import_module queue.
:- import_module require.
:- import_module set_tree234.
@@ -165,7 +168,11 @@
module_info_get_class_table(!.ModuleInfo, Classes),
module_info_get_instance_table(!.ModuleInfo, Instances),
- dead_proc_initialize_class_methods(Classes, Instances, !Queue, !Needed).
+ dead_proc_initialize_class_methods(Classes, Instances, !Queue, !Needed),
+
+ module_info_get_const_struct_db(!.ModuleInfo, ConstStructDb),
+ const_struct_db_get_structs(ConstStructDb, ConstStructs),
+ dead_proc_initialize_const_structs(ConstStructs, !Queue, !Needed).
% Add all normally exported procedures within the listed predicates
% to the queue and map.
@@ -306,6 +313,46 @@
queue.put(Entity, !Queue),
map.set(Entity, not_eliminable, !Needed).
+:- pred dead_proc_initialize_const_structs(assoc_list(int, const_struct)::in,
+ entity_queue::in, entity_queue::out, needed_map::in, needed_map::out)
+ is det.
+
+dead_proc_initialize_const_structs([], !Queue, !Needed).
+dead_proc_initialize_const_structs([_ - ConstStruct | ConstStructs],
+ !Queue, !Needed) :-
+ ConstStruct = const_struct(ConsId, Args, _, _),
+ ( ConsId = type_ctor_info_const(Module, TypeName, Arity) ->
+ Entity = entity_type_ctor(Module, TypeName, Arity),
+ queue.put(Entity, !Queue),
+ map.set(Entity, not_eliminable, !Needed)
+ ;
+ true
+ ),
+ dead_proc_initialize_const_struct_args(Args, !Queue, !Needed),
+ dead_proc_initialize_const_structs(ConstStructs, !Queue, !Needed).
+
+:- pred dead_proc_initialize_const_struct_args(list(const_struct_arg)::in,
+ entity_queue::in, entity_queue::out, needed_map::in, needed_map::out)
+ is det.
+
+dead_proc_initialize_const_struct_args([], !Queue, !Needed).
+dead_proc_initialize_const_struct_args([Arg | Args], !Queue, !Needed) :-
+ (
+ Arg = csa_const_struct(_)
+ % Do nothing. Any processing takes place when
+ % dead_proc_initialize_const_structs looks at the referenced structure.
+ ;
+ Arg = csa_constant(ConsId, _),
+ ( ConsId = type_ctor_info_const(Module, TypeName, Arity) ->
+ Entity = entity_type_ctor(Module, TypeName, Arity),
+ queue.put(Entity, !Queue),
+ map.set(Entity, not_eliminable, !Needed)
+ ;
+ true
+ )
+ ),
+ dead_proc_initialize_const_struct_args(Args, !Queue, !Needed).
+
%-----------------------------------------------------------------------------%
:- pred dead_proc_examine(entity_queue::in, examined_set::in,
@@ -606,6 +653,8 @@
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
; ConsId = deep_profiling_proc_layout(_)
; ConsId = table_io_decl(_)
)
Index: compiler/dependency_graph.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/dependency_graph.m,v
retrieving revision 1.111
diff -u -b -r1.111 dependency_graph.m
--- compiler/dependency_graph.m 13 Feb 2012 00:11:36 -0000 1.111
+++ compiler/dependency_graph.m 7 Jun 2012 05:32:26 -0000
@@ -495,6 +495,8 @@
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
; ConsId = tabling_info_const(_)
; ConsId = table_io_decl(_)
; ConsId = deep_profiling_proc_layout(_)
Index: compiler/equiv_type_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/equiv_type_hlds.m,v
retrieving revision 1.73
diff -u -b -r1.73 equiv_type_hlds.m
--- compiler/equiv_type_hlds.m 23 Apr 2012 03:34:47 -0000 1.73
+++ compiler/equiv_type_hlds.m 7 Jun 2012 05:32:26 -0000
@@ -1339,9 +1339,15 @@
;
ShortHand0 = try_goal(MaybeIO, ResultVar, SubGoal0),
replace_in_goal(EqvMap, SubGoal0, SubGoal, Changed, !Info),
+ (
+ Changed = yes,
ShortHand = try_goal(MaybeIO, ResultVar, SubGoal),
GoalExpr = shorthand(ShortHand)
;
+ Changed = no,
+ GoalExpr = GoalExpr0
+ )
+ ;
ShortHand0 = bi_implication(_, _),
unexpected($module, $pred, "bi_implication")
)
Index: compiler/erl_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_gen.m,v
retrieving revision 1.44
diff -u -b -r1.44 erl_code_gen.m
--- compiler/erl_code_gen.m 13 Feb 2012 00:11:37 -0000 1.44
+++ compiler/erl_code_gen.m 7 Jun 2012 05:32:26 -0000
@@ -891,7 +891,7 @@
cons_id_size(ModuleInfo, Type, ConsId) = Size :-
(
- type_to_ctor_and_args(Type, TypeCtor, _),
+ type_to_ctor(Type, TypeCtor),
get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn)
->
Index: compiler/erl_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_unify_gen.m,v
retrieving revision 1.18
diff -u -b -r1.18 erl_unify_gen.m
--- compiler/erl_unify_gen.m 23 May 2011 05:08:02 -0000 1.18
+++ compiler/erl_unify_gen.m 7 Jun 2012 05:32:26 -0000
@@ -230,8 +230,7 @@
( cons_id_to_term(ConsId, Args, elds_anon_var, Pattern0, !Info) ->
Pattern = Pattern0
;
- unexpected($module, $pred,
- "erl_gen_semidet_deconstruct: undeconstructable object")
+ unexpected($module, $pred, "undeconstructable object")
),
%
% case Var of
@@ -293,7 +292,7 @@
Expr = elds_term(Term)
;
ConsId = impl_defined_const(_),
- unexpected($module, $pred, "cons_id_to_expr: impl_defined_const")
+ unexpected($module, $pred, "impl_defined_const")
;
ConsId = closure_cons(ShroudedPredProcId, lambda_normal),
pred_const_to_closure(ShroudedPredProcId, Args, Expr, !Info)
@@ -308,7 +307,7 @@
( sym_name_get_module_name(ClassName, ClassModuleName0) ->
ClassModuleName = ClassModuleName0
;
- unexpected($module, $pred, "cons_id_to_expr: class has no module name")
+ unexpected($module, $pred, "class has no module name")
),
ClassNameStr = unqualify_name(ClassName),
TCName = tc_name(ClassModuleName, ClassNameStr, Arity),
@@ -323,6 +322,12 @@
% tuples, so the layout will be the same as corresponding arrays in C.
Expr = elds_term(elds_tuple(exprs_from_vars(Args)))
;
+ ConsId = type_info_const(_),
+ unexpected($module, $pred, "type_info_const")
+ ;
+ ConsId = typeclass_info_const(_),
+ unexpected($module, $pred, "typeclass_info_const")
+ ;
( ConsId = tabling_info_const(_)
; ConsId = deep_profiling_proc_layout(_)
; ConsId = table_io_decl(_)
Index: compiler/error_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/error_util.m,v
retrieving revision 1.79
diff -u -b -r1.79 error_util.m
--- compiler/error_util.m 15 Jun 2011 01:05:33 -0000 1.79
+++ compiler/error_util.m 7 Jun 2012 05:32:26 -0000
@@ -1068,7 +1068,7 @@
Str = join_string_and_tail(Word, Components, TailStr)
;
Component = top_ctor_of_type(Type),
- ( type_to_ctor_and_args(Type, TypeCtor, _) ->
+ ( type_to_ctor(Type, TypeCtor) ->
TypeCtor = type_ctor(TypeCtorName, TypeCtorArity),
SymName = TypeCtorName / TypeCtorArity,
Word = sym_name_and_arity_to_word(SymName),
@@ -1189,7 +1189,7 @@
RevWords1 = [plain_word(Word) | RevWords0]
;
Component = top_ctor_of_type(Type),
- ( type_to_ctor_and_args(Type, TypeCtor, _) ->
+ ( type_to_ctor(Type, TypeCtor) ->
TypeCtor = type_ctor(TypeCtorName, TypeCtorArity),
SymName = TypeCtorName / TypeCtorArity,
NewWord = plain_word(sym_name_and_arity_to_word(SymName)),
Index: compiler/export.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.132
diff -u -b -r1.132 export.m
--- compiler/export.m 13 Feb 2012 00:11:37 -0000 1.132
+++ compiler/export.m 7 Jun 2012 05:32:26 -0000
@@ -923,6 +923,8 @@
; TagVal = closure_tag(_, _, _)
; TagVal = type_ctor_info_tag(_, _, _)
; TagVal = base_typeclass_info_tag(_, _, _)
+ ; TagVal = type_info_const_tag(_)
+ ; TagVal = typeclass_info_const_tag(_)
; TagVal = tabling_info_tag(_, _)
; TagVal = deep_profiling_proc_layout_tag(_, _)
; TagVal = table_io_decl_tag(_, _)
Index: compiler/global_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/global_data.m,v
retrieving revision 1.53
diff -u -b -r1.53 global_data.m
--- compiler/global_data.m 17 Oct 2011 04:31:28 -0000 1.53
+++ compiler/global_data.m 7 Jun 2012 05:32:26 -0000
@@ -24,7 +24,6 @@
:- import_module mdbcomp.prim_data. % for module_name
:- import_module parse_tree.prog_data.
-:- import_module assoc_list.
:- import_module bool.
:- import_module list.
:- import_module map.
@@ -84,7 +83,7 @@
:- func init_static_cell_info(module_name, have_unboxed_floats, bool)
= static_cell_info.
-:- pred add_scalar_static_cell(assoc_list(rval, llds_type)::in, data_id::out,
+:- pred add_scalar_static_cell(list(typed_rval)::in, data_id::out,
static_cell_info::in, static_cell_info::out) is det.
:- pred add_scalar_static_cell_natural_types(list(rval)::in, data_id::out,
@@ -156,6 +155,7 @@
:- import_module ll_backend.layout.
+:- import_module assoc_list.
:- import_module bimap.
:- import_module counter.
:- import_module int.
@@ -372,7 +372,7 @@
% so that the generated C structure isn't empty.
(
ArgsTypes0 = [],
- ArgsTypes = [const(llconst_int(-1)) - lt_integer]
+ ArgsTypes = [typed_rval(const(llconst_int(-1)), lt_integer)]
;
ArgsTypes0 = [_ | _],
ArgsTypes = ArgsTypes0
@@ -381,12 +381,12 @@
do_add_scalar_static_cell(ArgsTypes, CellType, CellTypeAndValue, DataId,
!Info).
-:- pred do_add_scalar_static_cell(assoc_list(rval, llds_type)::in,
+:- pred do_add_scalar_static_cell(list(typed_rval)::in,
common_cell_type::in, common_cell_value::in, data_id::out,
static_cell_info::in, static_cell_info::out) is det.
-do_add_scalar_static_cell(ArgsTypes, CellType, CellValue, DataId, !Info) :-
- assoc_list.keys(ArgsTypes, Args),
+do_add_scalar_static_cell(TypedArgs, CellType, CellValue, DataId, !Info) :-
+ Args = typed_rvals_project_rvals(TypedArgs),
some [!CellGroup] (
TypeNumMap0 = !.Info ^ sci_cell_type_num_map,
CellGroupMap0 = !.Info ^ sci_scalar_cell_group_map,
@@ -555,8 +555,8 @@
:- func pair_vector_element(list(llds_type), list(rval)) = common_cell_value.
-pair_vector_element(Types, Args) = plain_value(ArgsTypes) :-
- assoc_list.from_corresponding_lists(Args, Types, ArgsTypes).
+pair_vector_element(Types, Args) = plain_value(TypedArgs) :-
+ build_typed_rvals(Args, Types, TypedArgs).
%-----------------------------------------------------------------------------%
@@ -605,27 +605,27 @@
%-----------------------------------------------------------------------------%
-:- pred compute_cell_type(assoc_list(rval, llds_type)::in,
+:- pred compute_cell_type(list(typed_rval)::in,
common_cell_type::out, common_cell_value::out) is det.
-compute_cell_type(ArgsTypes, CellType, CellValue) :-
+compute_cell_type(TypedArgs, CellType, CellValue) :-
(
- ArgsTypes = [FirstArg - FirstArgType | LaterArgsTypes],
- threshold_group_types(FirstArgType, [FirstArg], LaterArgsTypes,
+ TypedArgs = [typed_rval(FirstArg, FirstArgType) | LaterTypedArgs],
+ threshold_group_types(FirstArgType, [FirstArg], LaterTypedArgs,
TypeGroups, TypeAndArgGroups),
- OldLength = list.length(ArgsTypes),
+ OldLength = list.length(TypedArgs),
NewLength = list.length(TypeAndArgGroups),
OldLength >= NewLength * 2
->
CellType = grouped_args_type(TypeGroups),
CellValue = grouped_args_value(TypeAndArgGroups)
;
- CellType = plain_type(assoc_list.values(ArgsTypes)),
- CellValue = plain_value(ArgsTypes)
+ CellType = plain_type(typed_rvals_project_types(TypedArgs)),
+ CellValue = plain_value(TypedArgs)
).
:- pred threshold_group_types(llds_type::in, list(rval)::in,
- assoc_list(rval, llds_type)::in, assoc_list(llds_type, int)::out,
+ list(typed_rval)::in, assoc_list(llds_type, int)::out,
list(common_cell_arg_group)::out) is semidet.
threshold_group_types(CurType, RevArgsSoFar, LaterArgsTypes, TypeGroups,
@@ -636,7 +636,7 @@
TypeGroups = [TypeGroup],
TypeAndArgGroups = [TypeAndArgGroup]
;
- LaterArgsTypes = [NextArg - NextType | MoreArgsTypes],
+ LaterArgsTypes = [typed_rval(NextArg, NextType) | MoreArgsTypes],
( CurType = NextType ->
threshold_group_types(CurType, [NextArg | RevArgsSoFar],
MoreArgsTypes, TypeGroups, TypeAndArgGroups)
@@ -684,9 +684,9 @@
).
:- pred associate_natural_type(have_unboxed_floats::in, arg_width::in,
- rval::in, pair(rval, llds_type)::out) is det.
+ rval::in, typed_rval::out) is det.
-associate_natural_type(UnboxFloat, ArgWidth, Rval, Rval - Type) :-
+associate_natural_type(UnboxFloat, ArgWidth, Rval, typed_rval(Rval, Type)) :-
natural_type(UnboxFloat, ArgWidth, Rval, Type).
%-----------------------------------------------------------------------------%
@@ -971,9 +971,9 @@
).
:- pred remap_plain_value(static_cell_remap_info::in,
- pair(rval, llds_type)::in, pair(rval, llds_type)::out) is det.
+ typed_rval::in, typed_rval::out) is det.
-remap_plain_value(Remap, Rval0 - Type, Rval - Type) :-
+remap_plain_value(Remap, typed_rval(Rval0, Type), typed_rval(Rval, Type)) :-
remap_rval(Remap, Rval0, Rval).
:- pred remap_arg_group_value(static_cell_remap_info::in,
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.380
diff -u -b -r1.380 handle_options.m
--- compiler/handle_options.m 13 Apr 2012 07:20:38 -0000 1.380
+++ compiler/handle_options.m 7 Jun 2012 05:32:26 -0000
@@ -3180,6 +3180,7 @@
convert_dump_alias("vars", "npBis"). % Var instantiations, liveness etc.
convert_dump_alias("statevar", "gvCP").
convert_dump_alias("lco", "agiuvzD").
+convert_dump_alias("poly", "vxX").
%-----------------------------------------------------------------------------%
:- end_module handle_options.
Index: compiler/hhf.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hhf.m,v
retrieving revision 1.47
diff -u -b -r1.47 hhf.m
--- compiler/hhf.m 13 Feb 2012 00:11:39 -0000 1.47
+++ compiler/hhf.m 7 Jun 2012 05:32:26 -0000
@@ -400,7 +400,7 @@
(
map.search(VarTypes0, Var, Type),
type_constructors(ModuleInfo, Type, Constructors),
- type_to_ctor_and_args(Type, TypeCtor, _)
+ type_to_ctor(Type, TypeCtor)
->
TypeCtor = type_ctor(TypeCtorSymName, _),
(
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.202
diff -u -b -r1.202 higher_order.m
--- compiler/higher_order.m 5 Jun 2012 15:14:26 -0000 1.202
+++ compiler/higher_order.m 7 Jun 2012 05:32:26 -0000
@@ -50,6 +50,7 @@
:- import_module check_hlds.polymorphism.
:- import_module check_hlds.type_util.
:- import_module check_hlds.unify_proc.
+:- import_module hlds.const_struct.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_args.
:- import_module hlds.hlds_clauses.
@@ -102,12 +103,12 @@
globals.lookup_int_option(Globals, higher_order_arg_limit, ArgLimit),
Params = ho_params(HigherOrder, TypeSpec, UserTypeSpec, SizeLimit,
ArgLimit),
- map.init(NewPreds0),
+ map.init(NewPredMap0),
map.init(GoalSizes0),
set.init(Requests0),
map.init(VersionInfo0),
some [!GlobalInfo] (
- !:GlobalInfo = higher_order_global_info(Requests0, NewPreds0,
+ !:GlobalInfo = higher_order_global_info(Requests0, NewPredMap0,
VersionInfo0, !.ModuleInfo, GoalSizes0, Params, counter.init(1)),
module_info_get_valid_predids(PredIds0, !ModuleInfo),
@@ -207,7 +208,7 @@
% Specialized versions for each predicate
% not changed by ho_traverse_proc_body.
- hogi_new_preds :: new_preds,
+ hogi_new_pred_map :: new_pred_map,
% Extra information about each specialized version.
hogi_version_info :: map(pred_proc_id, version_info),
@@ -227,7 +228,7 @@
hoi_global_info :: higher_order_global_info,
% Higher order variables with unique known values.
- hoi_pred_vars :: pred_vars,
+ hoi_known_var_map :: known_var_map,
% The pred_proc_id, pred_info and proc_info of the procedure
% whose body is being traversed.
@@ -311,9 +312,9 @@
% Used to hold the value of known higher order variables.
% If a variable is not in the map, it does not have a unique known value.
%
-:- type pred_vars == map(prog_var, ho_const).
+:- type known_var_map == map(prog_var, known_const).
-:- type new_preds == map(pred_proc_id, set(new_pred)).
+:- type new_pred_map == map(pred_proc_id, set(new_pred)).
% The list of vars is a list of the curried arguments, which must
% be explicitly passed to the specialized predicate.
@@ -321,8 +322,8 @@
% must be constants. For pred_consts and type_infos, non-constant
% arguments are passed through to any specialised version.
%
-:- type ho_const
- ---> constant(cons_id, list(prog_var)).
+:- type known_const
+ ---> known_const(cons_id, list(prog_var)).
:- type ho_params
---> ho_params(
@@ -354,7 +355,7 @@
% Higher-order or constant input variables for a
% specialised version.
- pred_vars,
+ known_var_map,
% The chain of specialized versions which caused this version
% to be created. For each element in the list with the same
@@ -454,10 +455,10 @@
higher_order_global_info::in, higher_order_global_info::out) is det.
ho_traverse_proc(MustRecompute, PredId, ProcId, !GlobalInfo) :-
- map.init(PredVars0),
+ map.init(KnownVarMap0),
module_info_pred_proc_info(!.GlobalInfo ^ hogi_module_info,
PredId, ProcId, PredInfo0, ProcInfo0),
- Info0 = higher_order_info(!.GlobalInfo, PredVars0, proc(PredId, ProcId),
+ Info0 = higher_order_info(!.GlobalInfo, KnownVarMap0, proc(PredId, ProcId),
PredInfo0, ProcInfo0, ho_unchanged),
ho_traverse_proc_body(MustRecompute, Info0, Info),
Info = higher_order_info(!:GlobalInfo, _, _, PredInfo, ProcInfo, _),
@@ -512,9 +513,9 @@
VersionInfoMap = !.Info ^ hoi_global_info ^ hogi_version_info,
(
map.search(VersionInfoMap, !.Info ^ hoi_pred_proc_id, VersionInfo),
- VersionInfo = version_info(_, _, PredVars, _)
+ VersionInfo = version_info(_, _, KnownVarMap, _)
->
- !Info ^ hoi_pred_vars := PredVars
+ !Info ^ hoi_known_var_map := KnownVarMap
;
true
),
@@ -565,15 +566,12 @@
GoalExpr0 = generic_call(GenericCall, Args, _, _, _),
% Check whether this call could be specialized.
(
- (
GenericCall = higher_order(Var, _, _, _),
- MaybeMethod = no
+ maybe_specialize_higher_order_call(Var, Args, Goal0, Goal, !Info)
;
GenericCall = class_method(Var, Method, _, _),
- MaybeMethod = yes(Method)
- ),
- maybe_specialize_higher_order_call(Var, MaybeMethod, Args,
- Goal0, Goals, !Info),
+ maybe_specialize_method_call(Var, Method, Args, Goal0, Goals,
+ !Info),
conj_list_to_goal(Goals, GoalInfo0, Goal)
;
( GenericCall = event_call(_)
@@ -747,25 +745,25 @@
ho_traverse_cases_2(PreInfo, Cases0, Cases, !PostInfos, !Info).
:- type pre_branch_info
- ---> pre_branch_info(pred_vars).
+ ---> pre_branch_info(known_var_map).
:- type reachability
---> reachable
; unreachable.
:- type post_branch_info
- ---> post_branch_info(pred_vars, reachability).
+ ---> post_branch_info(known_var_map, reachability).
:- pred get_pre_branch_info(higher_order_info::in, pre_branch_info::out)
is det.
-get_pre_branch_info(Info, pre_branch_info(Info ^ hoi_pred_vars)).
+get_pre_branch_info(Info, pre_branch_info(Info ^ hoi_known_var_map)).
:- pred set_pre_branch_info(pre_branch_info::in,
higher_order_info::in, higher_order_info::out) is det.
-set_pre_branch_info(pre_branch_info(PreInfo),
- Info, Info ^ hoi_pred_vars := PreInfo).
+set_pre_branch_info(pre_branch_info(KnownVarMap), !Info) :-
+ !Info ^ hoi_known_var_map := KnownVarMap.
:- pred get_post_branch_info_for_goal(higher_order_info::in, hlds_goal::in,
post_branch_info::out) is det.
@@ -777,13 +775,14 @@
;
Reachability = unreachable
),
- PostBranchInfo = post_branch_info(HOInfo ^ hoi_pred_vars, Reachability).
+ PostBranchInfo =
+ post_branch_info(HOInfo ^ hoi_known_var_map, Reachability).
:- pred set_post_branch_info(post_branch_info::in,
higher_order_info::in, higher_order_info::out) is det.
-set_post_branch_info(post_branch_info(PredVars, _),
- Info, Info ^ hoi_pred_vars := PredVars).
+set_post_branch_info(post_branch_info(KnownVarMap, _), !Info) :-
+ !Info ^ hoi_known_var_map := KnownVarMap.
% Merge a bunch of post_branch_infos into one.
%
@@ -853,10 +852,10 @@
Post = post_branch_info(map.init, unreachable)
).
-:- pred merge_common_var_const_list(assoc_list(prog_var, ho_const)::in,
- assoc_list(prog_var, ho_const)::in,
- assoc_list(prog_var, ho_const)::in,
- assoc_list(prog_var, ho_const)::out) is det.
+:- pred merge_common_var_const_list(assoc_list(prog_var, known_const)::in,
+ assoc_list(prog_var, known_const)::in,
+ assoc_list(prog_var, known_const)::in,
+ assoc_list(prog_var, known_const)::out) is det.
merge_common_var_const_list([], [], !List).
merge_common_var_const_list([], [_ | _], !MergedList) :-
@@ -892,15 +891,11 @@
IsInteresting = is_interesting_cons_id(Params, ConsId),
(
IsInteresting = yes,
- PredVars0 = !.Info ^ hoi_pred_vars,
- ( map.search(PredVars0, LVar, _) ->
+ KnownVarMap0 = !.Info ^ hoi_known_var_map,
% A variable cannot be constructed twice.
- unexpected($module, $pred, "variable constructed twice")
- ;
- map.det_insert(LVar, constant(ConsId, Args),
- PredVars0, PredVars),
- !Info ^ hoi_pred_vars := PredVars
- )
+ map.det_insert(LVar, known_const(ConsId, Args),
+ KnownVarMap0, KnownVarMap),
+ !Info ^ hoi_known_var_map := KnownVarMap
;
IsInteresting = no
)
@@ -925,16 +920,17 @@
),
IsInteresting = no
;
- ConsId = int_const(_),
% We need to keep track of int_consts so we can interpret
- % superclass_info_from_typeclass_info and
- % typeinfo_from_typeclass_info. We don't specialize based on them.
- IsInteresting = Params ^ param_do_user_type_spec
- ;
- ( ConsId = type_ctor_info_const(_, _, _)
+ % calls to the buildins superclass_info_from_typeclass_info and
+ % typeinfo_from_typeclass_info. We do not specialize based on
+ % integers alone.
+ ( ConsId = int_const(_)
+ ; ConsId = type_ctor_info_const(_, _, _)
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
),
IsInteresting = Params ^ param_do_user_type_spec
;
@@ -942,62 +938,74 @@
IsInteresting = Params ^ param_do_higher_order_spec
).
- % Process a higher-order call or class_method_call to see if it
- % could possibly be specialized.
+ % Process a higher-order call to see if it could possibly be specialized.
%
-:- pred maybe_specialize_higher_order_call(prog_var::in, maybe(int)::in,
- list(prog_var)::in, hlds_goal::in, list(hlds_goal)::out,
+:- pred maybe_specialize_higher_order_call(prog_var::in,
+ list(prog_var)::in, hlds_goal::in, hlds_goal::out,
higher_order_info::in, higher_order_info::out) is det.
-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.
+maybe_specialize_higher_order_call(PredVar, Args, Goal0, Goal, !Info) :-
+ % We can specialize calls to call/N if the closure has a known value.
(
- map.search(!.Info ^ hoi_pred_vars, PredVar,
- constant(ConsId, CurriedArgs)),
- (
- ConsId = closure_cons(ShroudedPredProcId, _),
- MaybeMethod = no
+ map.search(!.Info ^ hoi_known_var_map, PredVar,
+ known_const(ConsId, CurriedArgs)),
+ ConsId = closure_cons(ShroudedPredProcId, _)
->
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
- list.append(CurriedArgs, Args, AllArgs)
+ AllArgs = CurriedArgs ++ Args,
+ Goal0 = hlds_goal(_, GoalInfo),
+ construct_specialized_higher_order_call(PredId, ProcId, AllArgs,
+ GoalInfo, Goal, !Info)
;
+ % Non-specializable call/N.
+ Goal = Goal0
+ ).
+
+ % Process a class_method_call to see if it could possibly be specialized.
+ %
+:- pred maybe_specialize_method_call(prog_var::in, int::in,
+ list(prog_var)::in, hlds_goal::in, list(hlds_goal)::out,
+ higher_order_info::in, higher_order_info::out) is det.
+
+maybe_specialize_method_call(TypeClassInfoVar, Method, Args, Goal0, Goals,
+ !Info) :-
+ Goal0 = hlds_goal(_GoalExpr0, GoalInfo),
+ ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
+ % We can specialize calls to class_method_call/N if the typeclass_info
+ % has a known value.
+ (
+ % XXX We could duplicate this code, replacing the tests of
+ % ConsId and BaseConsId with equivalent tests on const_structs.
+ % However, how would we compute an equivalent of
+ % InstanceConstraintArgs?
+ map.search(!.Info ^ hoi_known_var_map, TypeClassInfoVar,
+ known_const(ConsId, TCIArgs)),
% A typeclass_info variable should consist of a known
% base_typeclass_info and some argument typeclass_infos.
-
ConsId = typeclass_info_cell_constructor,
- CurriedArgs = [BaseTypeClassInfo | OtherTypeClassArgs],
- map.search(!.Info ^ hoi_pred_vars, BaseTypeClassInfo,
- constant(BaseConsId, _)),
- BaseConsId =
- base_typeclass_info_const(_, ClassId, Instance, _),
- MaybeMethod = yes(Method),
- module_info_get_instance_table(ModuleInfo, Instances),
- map.lookup(Instances, ClassId, InstanceList),
+ TCIArgs = [BaseTypeClassInfo | OtherTypeClassInfoArgs],
+ map.search(!.Info ^ hoi_known_var_map, BaseTypeClassInfo,
+ known_const(BaseConsId, _)),
+ BaseConsId = base_typeclass_info_const(_, ClassId, Instance, _),
+
+ module_info_get_instance_table(ModuleInfo, InstanceTable),
+ map.lookup(InstanceTable, ClassId, InstanceList),
list.det_index1(InstanceList, Instance, InstanceDefn),
- InstanceDefn = hlds_instance_defn(_, _, _,
- InstanceConstraints, InstanceTypes0, _, _,
- yes(ClassInterface), _, _),
+ InstanceDefn = hlds_instance_defn(_, _, _, InstanceConstraints,
+ InstanceTypes0, _, _, yes(ClassInterface), _, _),
type_vars_list(InstanceTypes0, InstanceTvars),
get_unconstrained_tvars(InstanceTvars,
InstanceConstraints, UnconstrainedTVars),
NumArgsToExtract = list.length(InstanceConstraints)
+ list.length(UnconstrainedTVars),
- list.take(NumArgsToExtract, OtherTypeClassArgs,
+ list.take(NumArgsToExtract, OtherTypeClassInfoArgs,
InstanceConstraintArgs)
->
list.det_index1(ClassInterface, Method,
hlds_class_proc(PredId, ProcId)),
- list.append(InstanceConstraintArgs, Args, AllArgs)
- ;
- fail
- )
- ->
- construct_specialized_higher_order_call(PredId, ProcId,
- AllArgs, GoalInfo, Goal, !Info),
+ AllArgs = InstanceConstraintArgs ++ Args,
+ construct_specialized_higher_order_call(PredId, ProcId, AllArgs,
+ GoalInfo, Goal, !Info),
Goals = [Goal]
;
% Handle a class method call where we know which instance is being
@@ -1012,12 +1020,10 @@
% don't know which class constraints are redundant after type
% specialization.
- MaybeMethod = yes(Method),
-
CallerProcInfo0 = !.Info ^ hoi_proc_info,
CallerPredInfo0 = !.Info ^ hoi_pred_info,
proc_info_get_rtti_varmaps(CallerProcInfo0, CallerRttiVarMaps),
- rtti_varmaps_var_info(CallerRttiVarMaps, PredVar,
+ rtti_varmaps_var_info(CallerRttiVarMaps, TypeClassInfoVar,
typeclass_info_var(ClassConstraint)),
ClassConstraint = constraint(ClassName, ClassArgs),
list.length(ClassArgs, ClassArity),
@@ -1039,26 +1045,26 @@
AllArgs = Args
;
get_unconstrained_instance_type_infos(ModuleInfo,
- PredVar, UnconstrainedTVarTypes, 1,
+ TypeClassInfoVar, UnconstrainedTVarTypes, 1,
ArgTypeInfoGoals, ArgTypeInfoVars,
CallerProcInfo0, CallerProcInfo1),
FirstArgTypeclassInfo = list.length(UnconstrainedTVarTypes) + 1,
- get_arg_typeclass_infos(ModuleInfo, PredVar,
+ get_arg_typeclass_infos(ModuleInfo, TypeClassInfoVar,
InstanceConstraints, FirstArgTypeclassInfo,
ArgTypeClassInfoGoals, ArgTypeClassInfoVars,
CallerProcInfo1, CallerProcInfo),
list.condense([ArgTypeInfoVars, ArgTypeClassInfoVars, Args],
AllArgs),
- list.append(ArgTypeInfoGoals, ArgTypeClassInfoGoals, ExtraGoals)
+ ExtraGoals = ArgTypeInfoGoals ++ ArgTypeClassInfoGoals
),
!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)
+ Goals = ExtraGoals ++ [Goal]
;
- % Non-specializable call/N or class_method_call/N.
- Goals = [hlds_goal(GoalExpr0, GoalInfo)]
+ % Non-specializable class_method_call/N.
+ Goals = [Goal0]
).
:- pred find_matching_instance_method(list(hlds_instance_defn)::in, int::in,
@@ -1229,8 +1235,7 @@
GoalExpr = GoalExpr1,
!Info ^ hoi_changed := ho_changed
;
- polymorphism.is_typeclass_info_manipulator(ModuleInfo0,
- CalledPred, Manipulator)
+ is_typeclass_info_manipulator(ModuleInfo0, CalledPred, Manipulator)
->
interpret_typeclass_info_manipulator(Manipulator, Args0,
GoalExpr0, GoalExpr, !Info)
@@ -1255,7 +1260,7 @@
(
Result = specialized(ExtraTypeInfoGoals, GoalExpr1),
goal_to_conj_list(hlds_goal(GoalExpr1, GoalInfo), GoalList1),
- list.append(ExtraTypeInfoGoals, GoalList1, GoalList),
+ GoalList = ExtraTypeInfoGoals ++ GoalList1,
GoalExpr = conj(plain_conj, GoalList)
;
Result = not_specialized,
@@ -1279,7 +1284,7 @@
maybe_specialize_pred_const(hlds_goal(GoalExpr0, GoalInfo),
hlds_goal(GoalExpr, GoalInfo), !Info) :-
- NewPreds = !.Info ^ hoi_global_info ^ hogi_new_preds,
+ NewPredMap = !.Info ^ hoi_global_info ^ hogi_new_pred_map,
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
ProcInfo0 = !.Info ^ hoi_proc_info,
(
@@ -1294,7 +1299,7 @@
ConsId0 = closure_cons(ShroudedPredProcId, EvalMethod),
PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
proc(PredId, ProcId) = PredProcId,
- map.contains(NewPreds, PredProcId),
+ map.contains(NewPredMap, PredProcId),
proc_info_get_vartypes(ProcInfo0, VarTypes0),
map.lookup(VarTypes0, LVar, LVarType),
type_is_higher_order_details(LVarType, _, _, _, ArgTypes)
@@ -1302,7 +1307,7 @@
% Create variables to represent
proc_info_create_vars_from_types(ArgTypes, UncurriedArgs,
ProcInfo0, ProcInfo1),
- list.append(Args0, UncurriedArgs, Args1),
+ Args1 = Args0 ++ UncurriedArgs,
!Info ^ hoi_proc_info := ProcInfo1,
module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
@@ -1385,9 +1390,11 @@
:- type specialization_result
---> specialized(
- list(hlds_goal), % Goals to construct extra
- % type-infos.
- hlds_goal_expr % The specialized call.
+ % Goals to construct extra type-infos.
+ list(hlds_goal),
+
+ % The specialized call.
+ hlds_goal_expr
)
; not_specialized.
@@ -1414,13 +1421,13 @@
proc_info_get_vartypes(CallerProcInfo0, VarTypes),
proc_info_get_rtti_varmaps(CallerProcInfo0, RttiVarMaps),
find_higher_order_args(ModuleInfo0, CalleeStatus, Args0,
- CalleeArgTypes, VarTypes, RttiVarMaps, !.Info ^ hoi_pred_vars, 1,
+ CalleeArgTypes, VarTypes, RttiVarMaps, !.Info ^ hoi_known_var_map, 1,
[], HigherOrderArgs0),
proc(CallerPredId, _) = !.Info ^ hoi_pred_proc_id,
module_info_get_type_spec_info(ModuleInfo0, TypeSpecInfo),
TypeSpecInfo = type_spec_info(_, ForceVersions, _, _),
- IsUserSpecProc = ( set.member(CallerPredId, ForceVersions) -> yes ; no ),
+ set.is_member(CallerPredId, ForceVersions, IsUserSpecProc),
(
(
HigherOrderArgs0 = [_ | _]
@@ -1461,7 +1468,7 @@
construct_extra_type_infos(ExtraTypeInfoTypes,
ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
- list.append(ExtraTypeInfoVars, Args1, Args),
+ Args = ExtraTypeInfoVars ++ Args1,
CallGoal = plain_call(NewCalledPred, NewCalledProc, Args,
IsBuiltin, MaybeContext, NewName),
Result = specialized(ExtraTypeInfoGoals, CallGoal),
@@ -1495,7 +1502,7 @@
%
:- pred find_higher_order_args(module_info::in, import_status::in,
list(prog_var)::in, list(mer_type)::in, vartypes::in,
- rtti_varmaps::in, pred_vars::in, int::in, list(higher_order_arg)::in,
+ rtti_varmaps::in, known_var_map::in, int::in, list(higher_order_arg)::in,
list(higher_order_arg)::out) is det.
find_higher_order_args(_, _, [], _, _, _, _, _, !HOArgs).
@@ -1503,14 +1510,14 @@
unexpected($module, $pred, "length mismatch").
find_higher_order_args(ModuleInfo, CalleeStatus, [Arg | Args],
[CalleeArgType | CalleeArgTypes], VarTypes, RttiVarMaps,
- PredVars, ArgNo, !HOArgs) :-
+ KnownVarMap, ArgNo, !HOArgs) :-
NextArg = ArgNo + 1,
(
% We don't specialize arguments whose declared type is polymorphic.
% The closure they pass cannot possibly be called within the called
- % predicate, since that predicate doesn't know it's a closure
+ % predicate, since that predicate doesn't know it is a closure
% (without some dodgy use of type_to_univ and univ_to_type).
- map.search(PredVars, Arg, constant(ConsId, CurriedArgs)),
+ map.search(KnownVarMap, Arg, known_const(ConsId, CurriedArgs)),
% We don't specialize based on int_consts (we only keep track of them
% to interpret calls to the procedures which extract fields from
@@ -1542,7 +1549,7 @@
),
find_higher_order_args(ModuleInfo, CalleeStatus, CurriedArgs,
CurriedCalleeArgTypes, VarTypes, RttiVarMaps,
- PredVars, 1, [], HOCurriedArgs0),
+ KnownVarMap, 1, [], HOCurriedArgs0),
list.reverse(HOCurriedArgs0, HOCurriedArgs),
list.length(CurriedArgs, NumArgs),
(
@@ -1564,7 +1571,7 @@
true
),
find_higher_order_args(ModuleInfo, CalleeStatus, Args, CalleeArgTypes,
- VarTypes, RttiVarMaps, PredVars, NextArg, !HOArgs).
+ VarTypes, RttiVarMaps, KnownVarMap, NextArg, !HOArgs).
% Succeeds if the type substitution for a call makes any of the
% class constraints match an instance which was not matched before.
@@ -1613,15 +1620,16 @@
---> match(
new_pred,
+ % Was the match partial, if so, how many higher_order arguments
+ % matched.
maybe(int),
- % Was the match partial, if so, how many
- % higher_order arguments matched.
- list(prog_var),
% The arguments to the specialised call.
+ list(prog_var),
+
+ % Type variables for which extra type-infos must be added
+ % to the start of the argument list.
list(mer_type)
- % Type variables for which extra type-infos must be
- % added to the start of the argument list.
).
% WARNING - do not filter out higher-order arguments from the request
@@ -1641,7 +1649,7 @@
% of known higher-order arguments added.
ModuleInfo = Info ^ hoi_global_info ^ hogi_module_info,
- NewPreds = Info ^ hoi_global_info ^ hogi_new_preds,
+ NewPredMap = Info ^ hoi_global_info ^ hogi_new_pred_map,
Caller = Info ^ hoi_pred_proc_id,
PredInfo = Info ^ hoi_pred_info,
ProcInfo = Info ^ hoi_proc_info,
@@ -1668,7 +1676,7 @@
% Check to see if any of the specialized versions of the called pred
% apply here.
(
- map.search(NewPreds, proc(CalledPred, CalledProc), Versions0),
+ map.search(NewPredMap, proc(CalledPred, CalledProc), Versions0),
set.to_sorted_list(Versions0, Versions),
search_for_version(Info, Params, ModuleInfo, Request, Versions,
no, Match)
@@ -1711,9 +1719,9 @@
).
% Specializing type `T' to `list(U)' requires passing in the
- % type-info for `U'. This predicate works out which extra variables
- % to pass in given the argument list for the call. This needs to be
- % done even if --typeinfo-liveness is not set because the type-infos
+ % typeinfo for `U'. This predicate works out which extra variables
+ % to pass in given the argument list for the call. This needs to be done
+ % even if --typeinfo-liveness is not set because the type-infos
% may be needed when specializing calls inside the specialized version.
%
:- pred compute_extra_typeinfos(higher_order_info::in,
@@ -1764,7 +1772,7 @@
(pred(ClassArgType::in, ClassTVar::out) is semidet :-
ClassArgType = type_variable(ClassTVar, _)
), ClassArgTypes, ClassTVars),
- list.append(ClassTVars, !TVars)
+ !:TVars = ClassTVars ++ !.TVars
;
VarInfo = non_rtti_var
).
@@ -1902,7 +1910,7 @@
RequestConsId = RequestArg ^ hoa_cons_id,
RequestConsId = closure_cons(_, _)
).
-higher_order_args_match([RequestArg | Args1], [VersionArg | Args2],
+higher_order_args_match([RequestArg | RequestArgs], [VersionArg | VersionArgs],
Args, FullOrPartial) :-
RequestArg = higher_order_arg(ConsId1, ArgNo1, _, _, _, _, _,
RequestIsConst),
@@ -1912,16 +1920,16 @@
( ArgNo1 = ArgNo2 ->
ConsId1 = ConsId2,
RequestArg = higher_order_arg(_, _, NumArgs, CurriedArgs,
- CurriedArgTypes, CurriedArgRttiInfo, HOCurriedArgs1, _),
+ CurriedArgTypes, CurriedArgRttiInfo, HOCurriedRequestArgs, _),
VersionArg = higher_order_arg(_, _, NumArgs,
- _, _, _, HOCurriedArgs2, _),
- higher_order_args_match(HOCurriedArgs1, HOCurriedArgs2,
+ _, _, _, HOCurriedVersionArgs, _),
+ higher_order_args_match(HOCurriedRequestArgs, HOCurriedVersionArgs,
NewHOCurriedArgs, FullOrPartial),
- higher_order_args_match(Args1, Args2, Args3, _),
+ higher_order_args_match(RequestArgs, VersionArgs, TailArgs, _),
NewRequestArg = higher_order_arg(ConsId1, ArgNo1, NumArgs,
CurriedArgs, CurriedArgTypes, CurriedArgRttiInfo,
NewHOCurriedArgs, RequestIsConst `and` VersionIsConst),
- Args = [NewRequestArg | Args3]
+ Args = [NewRequestArg | TailArgs]
;
% Type-info arguments present in the request may be missing from the
% version if we are doing user-guided type specialization. All of the
@@ -1931,7 +1939,8 @@
% All the higher-order arguments must be present in the version
% otherwise we should create a new one.
ConsId1 \= closure_cons(_, _),
- higher_order_args_match(Args1, [VersionArg | Args2], Args, _),
+ higher_order_args_match(RequestArgs, [VersionArg | VersionArgs],
+ Args, _),
FullOrPartial = match_is_partial
).
@@ -1973,10 +1982,10 @@
higher_order_info::in, higher_order_info::out) is det.
maybe_add_alias(LVar, RVar, !Info) :-
- PredVars0 = !.Info ^ hoi_pred_vars,
- ( map.search(PredVars0, RVar, constant(A, B)) ->
- map.set(LVar, constant(A, B), PredVars0, PredVars),
- !Info ^ hoi_pred_vars := PredVars
+ KnownVarMap0 = !.Info ^ hoi_known_var_map,
+ ( map.search(KnownVarMap0, RVar, KnownConst) ->
+ map.det_insert(LVar, KnownConst, KnownVarMap0, KnownVarMap),
+ !Info ^ hoi_known_var_map := KnownVarMap
;
true
).
@@ -1992,6 +2001,33 @@
%-----------------------------------------------------------------------------%
+:- type typeclass_info_manipulator
+ ---> type_info_from_typeclass_info
+ ; superclass_from_typeclass_info
+ ; instance_constraint_from_typeclass_info.
+
+ % Succeed if the predicate is one of the predicates defined in
+ % library/private_builtin.m to extract type_infos or typeclass_infos
+ % from typeclass_infos.
+ %
+:- pred is_typeclass_info_manipulator(module_info::in, pred_id::in,
+ typeclass_info_manipulator::out) is semidet.
+
+is_typeclass_info_manipulator(ModuleInfo, PredId, TypeClassManipulator) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ mercury_private_builtin_module = pred_info_module(PredInfo),
+ PredName = pred_info_name(PredInfo),
+ (
+ PredName = "type_info_from_typeclass_info",
+ TypeClassManipulator = type_info_from_typeclass_info
+ ;
+ PredName = "superclass_from_typeclass_info",
+ TypeClassManipulator = superclass_from_typeclass_info
+ ;
+ PredName = "instance_constraint_from_typeclass_info",
+ TypeClassManipulator = instance_constraint_from_typeclass_info
+ ).
+
% Interpret a call to `type_info_from_typeclass_info',
% `superclass_from_typeclass_info' or
% `instance_constraint_from_typeclass_info'.
@@ -2004,76 +2040,149 @@
interpret_typeclass_info_manipulator(Manipulator, Args, Goal0, Goal, !Info) :-
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
- PredVars = !.Info ^ hoi_pred_vars,
+ KnownVarMap0 = !.Info ^ hoi_known_var_map,
(
- Args = [TypeClassInfoVar, IndexVar, TypeInfoVar],
- map.search(PredVars, TypeClassInfoVar,
- constant(_TypeClassInfoConsId, TypeClassInfoArgs)),
+ Args = [TypeClassInfoVar, IndexVar, OutputVar],
+ map.search(KnownVarMap0, TypeClassInfoVar,
+ known_const(TypeClassInfoConsId, TypeClassInfoArgs)),
+ find_typeclass_info_components(ModuleInfo, KnownVarMap0,
+ TypeClassInfoConsId, TypeClassInfoArgs,
+ _ModuleName, ClassId, InstanceNum, _Instance, OtherArgs),
- 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,
- BaseTypeClassInfoMaybeConst),
- BaseTypeClassInfoMaybeConst = constant(BaseTypeClassInfoConsId, _),
- BaseTypeClassInfoConsId =
- base_typeclass_info_const(_, ClassId, InstanceNum, _)
+ map.search(KnownVarMap0, IndexVar, IndexMaybeConst),
+ IndexMaybeConst = known_const(int_const(Index0), [])
->
- module_info_get_instance_table(ModuleInfo, Instances),
- map.lookup(Instances, ClassId, InstanceDefns),
- list.det_index1(InstanceDefns, InstanceNum, InstanceDefn),
- InstanceDefn = hlds_instance_defn(_, _, _, Constraints, InstanceTypes,
- _, _, _, _, _),
(
( Manipulator = type_info_from_typeclass_info
; Manipulator = superclass_from_typeclass_info
),
% polymorphism.m adds MR_typeclass_info_num_extra_instance_args
- % to the index. The calculation of NumExtra is from
- % base_typeclass_info.gen_body.
- type_vars_list(InstanceTypes, TypeVars),
- get_unconstrained_tvars(TypeVars, Constraints, Unconstrained),
- list.length(Constraints, NumConstraints),
- list.length(Unconstrained, NumUnconstrained),
- NumExtra = NumConstraints + NumUnconstrained,
+ % to the index.
+ module_info_get_instance_table(ModuleInfo, InstanceTable),
+ map.lookup(InstanceTable, ClassId, InstanceDefns),
+ list.det_index1(InstanceDefns, InstanceNum, InstanceDefn),
+ num_extra_instance_args(InstanceDefn, NumExtra),
Index = Index0 + NumExtra
;
Manipulator = instance_constraint_from_typeclass_info,
Index = Index0
),
- list.det_index1(OtherVars, Index, TypeInfoArg),
- maybe_add_alias(TypeInfoVar, TypeInfoArg, !Info),
- Uni = assign(TypeInfoVar, TypeInfoArg),
- Goal = unify(TypeInfoVar, rhs_var(TypeInfoArg), out_mode - in_mode,
+
+ (
+ OtherArgs = tci_arg_vars(OtherVars),
+ list.det_index1(OtherVars, Index, SelectedArg),
+ maybe_add_alias(OutputVar, SelectedArg, !Info),
+ Uni = assign(OutputVar, SelectedArg),
+ Goal = unify(OutputVar, rhs_var(SelectedArg), out_mode - in_mode,
Uni, unify_context(umc_explicit, [])),
ProcInfo0 = !.Info ^ hoi_proc_info,
proc_info_get_rtti_varmaps(ProcInfo0, RttiVarMaps0),
- rtti_var_info_duplicate_replace(TypeInfoArg, TypeInfoVar,
+ rtti_var_info_duplicate_replace(SelectedArg, OutputVar,
RttiVarMaps0, RttiVarMaps),
proc_info_set_rtti_varmaps(RttiVarMaps, ProcInfo0, ProcInfo),
+ !Info ^ hoi_proc_info := ProcInfo,
% Sanity check.
proc_info_get_vartypes(ProcInfo, VarTypes),
- map.lookup(VarTypes, TypeInfoVar, TypeInfoVarType),
- map.lookup(VarTypes, TypeInfoArg, TypeInfoArgType),
- ( TypeInfoVarType = TypeInfoArgType ->
+ map.lookup(VarTypes, OutputVar, OutputVarType),
+ map.lookup(VarTypes, SelectedArg, SelectedArgType),
+ ( OutputVarType = SelectedArgType ->
true
;
unexpected($module, $pred, "type mismatch")
+ )
+ ;
+ OtherArgs = tci_arg_consts(OtherConstArgs),
+ list.det_index1(OtherConstArgs, Index, SelectedConstArg),
+ (
+ SelectedConstArg = csa_constant(SelectedConsId, _),
+ SelectedConstInst = bound(shared, inst_test_results_fgtc,
+ [bound_functor(SelectedConsId, [])])
+ ;
+ SelectedConstArg = csa_const_struct(SelectedConstNum),
+ module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
+ lookup_const_struct_num(ConstStructDb, SelectedConstNum,
+ SelectedConstStruct),
+ SelectedConstStruct = const_struct(SelectedConstConsId, _, _,
+ SelectedConstInst),
+ (
+ ( SelectedConstConsId = type_info_cell_constructor(_)
+ ; SelectedConstConsId = type_info_const(_)
+ )
+ ->
+ SelectedConsId = type_info_const(SelectedConstNum)
+ ;
+ ( SelectedConstConsId = typeclass_info_cell_constructor
+ ; SelectedConstConsId = typeclass_info_const(_)
+ )
+ ->
+ SelectedConsId = typeclass_info_const(SelectedConstNum)
+ ;
+ unexpected($module, $pred, "bad SelectedConstStructConsId")
+ )
),
+ map.det_insert(OutputVar, known_const(SelectedConsId, []),
+ KnownVarMap0, KnownVarMap),
+ !Info ^ hoi_known_var_map := KnownVarMap,
- !Info ^ hoi_proc_info := ProcInfo,
-
+ SelectedConsIdRHS = rhs_functor(SelectedConsId, no, []),
+ UnifyMode = (free -> SelectedConstInst) -
+ (SelectedConstInst -> SelectedConstInst),
+ Uni = construct(OutputVar, SelectedConsId, [], [],
+ construct_dynamically, cell_is_shared, no_construct_sub_info),
+ Goal = unify(OutputVar, SelectedConsIdRHS, UnifyMode,
+ Uni, unify_context(umc_explicit, []))
+ % XXX do we need to update the rtti varmaps?
+ ),
!Info ^ hoi_changed := ho_changed
;
Goal = Goal0
).
+:- type type_class_info_args
+ ---> tci_arg_vars(list(prog_var))
+ ; tci_arg_consts(list(const_struct_arg)).
+
+:- pred find_typeclass_info_components(module_info::in, known_var_map::in,
+ cons_id::in, list(prog_var)::in,
+ module_name::out, class_id::out, int::out, string::out,
+ type_class_info_args::out) is semidet.
+
+find_typeclass_info_components(ModuleInfo, KnownVarMap,
+ TypeClassInfoConsId, TypeClassInfoArgs,
+ ModuleName, ClassId, InstanceNum, Instance, Args) :-
+ (
+ TypeClassInfoConsId = typeclass_info_cell_constructor,
+ % Extract the number of class constraints on the instance
+ % from the base_typeclass_info.
+ % If we have a variable for the base typeclass info,
+ % it cannot be bound to a constant structure, since
+ % as far as the HLDS is concerned, a base typeclass info
+ % is just a bare cons_id, and not a structure that needs a cell
+ % on the heap.
+ TypeClassInfoArgs = [BaseTypeClassInfoVar | OtherVars],
+
+ map.search(KnownVarMap, BaseTypeClassInfoVar,
+ BaseTypeClassInfoMaybeConst),
+ BaseTypeClassInfoMaybeConst = known_const(BaseTypeClassInfoConsId, _),
+ Args = tci_arg_vars(OtherVars)
+ ;
+ TypeClassInfoConsId = typeclass_info_const(TCIConstNum),
+ TypeClassInfoArgs = [],
+ module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
+ lookup_const_struct_num(ConstStructDb, TCIConstNum, TCIConstStruct),
+ TCIConstStruct = const_struct(TCIConstConsId, TCIConstArgs, _, _),
+ expect(unify(TCIConstConsId, typeclass_info_cell_constructor),
+ $module, $pred,
+ "TCIConstConsId != typeclass_info_cell_constructor"),
+ TCIConstArgs = [BaseTypeClassInfoConstArg | OtherConstArgs],
+ BaseTypeClassInfoConstArg = csa_constant(BaseTypeClassInfoConsId, _),
+ Args = tci_arg_consts(OtherConstArgs)
+ ),
+ BaseTypeClassInfoConsId =
+ base_typeclass_info_const(ModuleName, ClassId, InstanceNum, Instance).
+
%-----------------------------------------------------------------------------%
% Succeed if the called pred is "unify" or "compare" and is specializable,
@@ -2088,7 +2197,7 @@
OrigGoalInfo, HaveSpecialPreds, Goal, !Info) :-
ModuleInfo = !.Info ^ hoi_global_info ^ hogi_module_info,
ProcInfo0 = !.Info ^ hoi_proc_info,
- PredVars = !.Info ^ hoi_pred_vars,
+ KnownVarMap = !.Info ^ hoi_known_var_map,
proc_info_get_vartypes(ProcInfo0, VarTypes),
module_info_pred_info(ModuleInfo, CalledPred, CalledPredInfo),
mercury_public_builtin_module = pred_info_module(CalledPredInfo),
@@ -2109,9 +2218,9 @@
SpecialPredType \= tuple_type(_, _),
Args = [TypeInfoVar | SpecialPredArgs],
- map.search(PredVars, TypeInfoVar,
- constant(_TypeInfoConsId, TypeInfoVarArgs)),
- type_to_ctor_and_args(SpecialPredType, type_ctor(_, TypeArity), _),
+ map.search(KnownVarMap, TypeInfoVar,
+ known_const(_TypeInfoConsId, TypeInfoVarArgs)),
+ type_to_ctor(SpecialPredType, type_ctor(_, TypeArity)),
( TypeArity = 0 ->
TypeInfoArgs = []
;
@@ -2207,7 +2316,7 @@
% arguments.
CallArgs = SpecialPredArgs
;
- list.append(TypeInfoArgs, SpecialPredArgs, CallArgs)
+ CallArgs = TypeInfoArgs ++ SpecialPredArgs
),
Goal = plain_call(SpecialPredId, SpecialProcId, CallArgs, not_builtin,
MaybeContext, SymName).
@@ -2356,7 +2465,7 @@
PredId = PredId0,
ProcId = ProcId0
;
- type_to_ctor_and_args(Type, TypeCtor, _),
+ type_to_ctor(Type, TypeCtor),
special_pred_is_generated_lazily(ModuleInfo, TypeCtor),
(
SpecialId = spec_pred_compare,
@@ -2558,17 +2667,17 @@
higher_order_global_info::in, higher_order_global_info::out,
io::di, io::uo) is det.
-create_new_preds([], !NewPredList, !PredsToFix, !Info, !IO).
-create_new_preds([Request | Requests], !NewPredList, !PredsToFix, !Info,
- !IO) :-
+create_new_preds([], !NewPreds, !PredsToFix, !Info, !IO).
+create_new_preds([Request | Requests], !NewPreds, !PredsToFix, !Info, !IO) :-
Request = ho_request(CallingPredProcId, CalledPredProcId, _HOArgs,
_CallArgs, _, _CallerArgTypes, _, _, _, _),
set.insert(CallingPredProcId, !PredsToFix),
- ( map.search(!.Info ^ hogi_new_preds, CalledPredProcId, SpecVersions0) ->
(
% Check that we aren't redoing the same pred.
% SpecVersions0 are pred_proc_ids of the specialized versions
% of the current pred.
+ NewPredMap = !.Info ^ hogi_new_pred_map,
+ map.search(NewPredMap, CalledPredProcId, SpecVersions0),
set.member(Version, SpecVersions0),
version_matches(!.Info ^ hogi_params, !.Info ^ hogi_module_info,
Request, Version, _)
@@ -2576,13 +2685,9 @@
true
;
create_new_pred(Request, NewPred, !Info, !IO),
- list.cons(NewPred, !NewPredList)
- )
- ;
- create_new_pred(Request, NewPred, !Info, !IO),
- list.cons(NewPred, !NewPredList)
+ !:NewPreds = [NewPred | !.NewPreds]
),
- create_new_preds(Requests, !NewPredList, !PredsToFix, !Info, !IO).
+ create_new_preds(Requests, !NewPreds, !PredsToFix, !Info, !IO).
% If we weren't allowed to create a specialized version because the
% loop check failed, check whether the version was created for another
@@ -2595,7 +2700,7 @@
CallingPredProcId = Request ^ rq_caller,
CalledPredProcId = Request ^ rq_callee,
(
- map.search(Info ^ hogi_new_preds, CalledPredProcId, SpecVersions0),
+ map.search(Info ^ hogi_new_pred_map, CalledPredProcId, SpecVersions0),
some [Version] (
set.member(Version, SpecVersions0),
version_matches(Info ^ hogi_params, Info ^ hogi_module_info,
@@ -2724,15 +2829,15 @@
higher_order_global_info::in, higher_order_global_info::out) is det.
add_new_pred(CalledPredProcId, NewPred, !Info) :-
- NewPreds0 = !.Info ^ hogi_new_preds,
- ( map.search(NewPreds0, CalledPredProcId, SpecVersions0) ->
+ NewPredMap0 = !.Info ^ hogi_new_pred_map,
+ ( map.search(NewPredMap0, CalledPredProcId, SpecVersions0) ->
set.insert(NewPred, SpecVersions0, SpecVersions),
- map.det_update(CalledPredProcId, SpecVersions, NewPreds0, NewPreds)
+ map.det_update(CalledPredProcId, SpecVersions, NewPredMap0, NewPredMap)
;
SpecVersions = set.make_singleton_set(NewPred),
- map.det_insert(CalledPredProcId, SpecVersions, NewPreds0, NewPreds)
+ map.det_insert(CalledPredProcId, SpecVersions, NewPredMap0, NewPredMap)
),
- !Info ^ hogi_new_preds := NewPreds.
+ !Info ^ hogi_new_pred_map := NewPredMap.
:- pred maybe_write_request(bool::in, module_info::in, string::in,
sym_name::in, arity::in, arity::in, maybe(string)::in,
@@ -2967,10 +3072,10 @@
% Construct the constant input closures within the goal
% for the called procedure.
- map.init(PredVars0),
+ map.init(KnownVarMap0),
construct_higher_order_terms(ModuleInfo, HeadVars0, ExtraHeadVars,
ArgModes0, ExtraArgModes, HOArgs, !NewProcInfo,
- VarRenaming0, _, PredVars0, PredVars, ConstGoals),
+ VarRenaming0, _, KnownVarMap0, KnownVarMap, ConstGoals),
% XXX The substitutions used to be applied to the typeclass_info_varmap
% here rather than at the XXX above. Any new entries added in the code
@@ -2997,7 +3102,7 @@
| CallerParentVersions],
VersionInfo = version_info(OrigPredProcId, ArgsDepth,
- PredVars, ParentVersions),
+ KnownVarMap, ParentVersions),
map.det_insert(NewPredProcId, VersionInfo,
VersionInfoMap0, VersionInfoMap),
!GlobalInfo ^ hogi_version_info := VersionInfoMap,
@@ -3017,7 +3122,7 @@
proc_info_get_goal(!.NewProcInfo, Goal6),
Goal6 = hlds_goal(_, GoalInfo6),
goal_to_conj_list(Goal6, GoalList6),
- conj_list_to_goal(list.append(ConstGoals, GoalList6), GoalInfo6, Goal),
+ conj_list_to_goal(ConstGoals ++ GoalList6, GoalInfo6, Goal),
proc_info_set_goal(Goal, !NewProcInfo),
% Remove any imported structure sharing and reuse information for the
@@ -3038,9 +3143,9 @@
% more specific than the argument types returned by pred_info_argtypes
% if the procedure body binds some existentially quantified type variables.
% The types of the extra arguments added by construct_higher_order_terms
- % use the substitution computed based on the result pred_info_get_arg_types.
- % We may need to apply a substitution to the types of the new variables
- % in the vartypes in the proc_info.
+ % use the substitution computed based on the result
+ % pred_info_get_arg_types. We may need to apply a substitution
+ % to the types of the new variables in the vartypes in the proc_info.
%
% XXX We should apply this substitution to the variable types in any
% callers of this predicate, which may introduce other opportunities
@@ -3082,16 +3187,16 @@
:- pred update_var_types(pair(prog_var, mer_type)::in,
vartypes::in, vartypes::out) is det.
-update_var_types(VarAndType, !Map) :-
+update_var_types(VarAndType, !VarTypes) :-
VarAndType = Var - Type,
- map.det_update(Var, Type, !Map).
+ map.det_update(Var, Type, !VarTypes).
% Take an original list of headvars and arg_modes and return these
% with curried arguments added. The old higher-order arguments are
% left in. They may be needed in calls which could not be
% specialised. If not, unused_args.m can clean them up.
%
- % Build the initial pred_vars map which records higher-order and
+ % Build the initial known_var_map which records higher-order and
% type_info constants for a call to ho_traverse_proc_body.
%
% Build a var-var renaming from the requesting call's arguments to
@@ -3107,13 +3212,13 @@
list(prog_var)::out, list(mer_mode)::in, list(mer_mode)::out,
list(higher_order_arg)::in, proc_info::in, proc_info::out,
map(prog_var, prog_var)::in, map(prog_var, prog_var)::out,
- pred_vars::in, pred_vars::out, list(hlds_goal)::out) is det.
+ known_var_map::in, known_var_map::out, list(hlds_goal)::out) is det.
construct_higher_order_terms(_, _, [], _, [], [], !ProcInfo, !Renaming,
- !PredVars, []).
+ !KnownVarMap, []).
construct_higher_order_terms(ModuleInfo, HeadVars0, NewHeadVars, ArgModes0,
NewArgModes, [HOArg | HOArgs], !ProcInfo, !Renaming,
- !PredVars, ConstGoals) :-
+ !KnownVarMap, ConstGoals) :-
HOArg = higher_order_arg(ConsId, Index, NumArgs, CurriedArgs,
CurriedArgTypes, CurriedArgRttiInfo, CurriedHOArgs, IsConst),
@@ -3157,8 +3262,8 @@
IsConst = no,
% Make ho_traverse_proc_body pretend that the input higher-order
% argument is built using the new arguments as its curried arguments.
- map.det_insert(LVar, constant(ConsId, CurriedHeadVars1),
- !PredVars)
+ map.det_insert(LVar, known_const(ConsId, CurriedHeadVars1),
+ !KnownVarMap)
;
IsConst = yes
),
@@ -3174,13 +3279,13 @@
% Recursively construct the curried higher-order arguments.
construct_higher_order_terms(ModuleInfo, CurriedHeadVars1,
ExtraCurriedHeadVars, CurriedArgModes1, ExtraCurriedArgModes,
- CurriedHOArgs, !ProcInfo, !Renaming, !PredVars,
+ CurriedHOArgs, !ProcInfo, !Renaming, !KnownVarMap,
CurriedConstGoals),
% Construct the rest of the higher-order arguments.
construct_higher_order_terms(ModuleInfo, HeadVars0, NewHeadVars1,
ArgModes0, NewArgModes1, HOArgs, !ProcInfo,
- !Renaming, !PredVars, ConstGoals1),
+ !Renaming, !KnownVarMap, ConstGoals1),
(
IsConst = yes,
@@ -3215,7 +3320,7 @@
NewHeadVars),
list.condense([CurriedArgModes, ExtraCurriedArgModes, NewArgModes1],
NewArgModes),
- list.append(ConstGoals0, ConstGoals1, ConstGoals).
+ ConstGoals = ConstGoals0 ++ ConstGoals1.
% Add any new type-infos or typeclass-infos to the rtti_varmaps.
%
@@ -3366,40 +3471,40 @@
list(mer_mode)::in, list(prog_constraint)::in, list(prog_constraint)::in,
prog_constraints::out) is det.
-find_class_context(_, [], [], Univ0, Exist0, Constraints) :-
- list.reverse(Univ0, Univ),
- list.reverse(Exist0, Exist),
+find_class_context(_, [], [], !.RevUniv, !.RevExist, Constraints) :-
+ list.reverse(!.RevUniv, Univ),
+ list.reverse(!.RevExist, Exist),
Constraints = constraints(Univ, Exist).
find_class_context(_, [], [_ | _], _, _, _) :-
unexpected($module, $pred, "mismatched list length").
find_class_context(_, [_ | _], [], _, _, _) :-
unexpected($module, $pred, "mismatched list length").
find_class_context(ModuleInfo, [VarInfo | VarInfos], [Mode | Modes],
- !.Univ, !.Exist, Constraints) :-
+ !.RevUniv, !.RevExist, Constraints) :-
(
VarInfo = typeclass_info_var(Constraint),
( mode_is_input(ModuleInfo, Mode) ->
- maybe_add_constraint(Constraint, !Univ)
+ maybe_add_constraint(Constraint, !RevUniv)
;
- maybe_add_constraint(Constraint, !Exist)
+ maybe_add_constraint(Constraint, !RevExist)
)
;
VarInfo = type_info_var(_)
;
VarInfo = non_rtti_var
),
- find_class_context(ModuleInfo, VarInfos, Modes, !.Univ, !.Exist,
+ find_class_context(ModuleInfo, VarInfos, Modes, !.RevUniv, !.RevExist,
Constraints).
:- pred maybe_add_constraint(prog_constraint::in,
list(prog_constraint)::in, list(prog_constraint)::out) is det.
-maybe_add_constraint(Constraint, !Constraints) :-
+maybe_add_constraint(Constraint, !RevConstraints) :-
% Don't create duplicates.
- ( list.member(Constraint, !.Constraints) ->
+ ( list.member(Constraint, !.RevConstraints) ->
true
;
- list.cons(Constraint, !Constraints)
+ !:RevConstraints = [Constraint | !.RevConstraints]
).
%-----------------------------------------------------------------------------%
Index: compiler/hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds.m,v
retrieving revision 1.229
diff -u -b -r1.229 hlds.m
--- compiler/hlds.m 16 Apr 2012 08:13:18 -0000 1.229
+++ compiler/hlds.m 7 Jun 2012 05:32:26 -0000
@@ -20,6 +20,7 @@
% The HLDS data structure itself
:- include_module assertion.
+:- include_module const_struct.
:- include_module hlds_args.
:- include_module hlds_clauses.
:- include_module hlds_data.
Index: compiler/hlds_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_code_util.m,v
retrieving revision 1.47
diff -u -b -r1.47 hlds_code_util.m
--- compiler/hlds_code_util.m 26 Apr 2012 08:16:05 -0000 1.47
+++ compiler/hlds_code_util.m 7 Jun 2012 05:32:26 -0000
@@ -35,6 +35,15 @@
%
:- pred make_instance_string(list(mer_type)::in, string::out) is det.
+ % Given a type_ctor, return the cons_id that represents its type_ctor_info.
+ %
+:- func type_ctor_info_cons_id(type_ctor) = cons_id.
+
+ % Given a type_ctor, return the cons_id that represents its type_ctor_info.
+ %
+:- func base_typeclass_info_cons_id(instance_table,
+ prog_constraint, int, list(mer_type)) = cons_id.
+
% Succeeds iff this inst is one that can be used in a valid
% mutable declaration.
%
@@ -46,6 +55,7 @@
:- implementation.
:- import_module check_hlds.mode_util.
+:- import_module check_hlds.type_util.
:- import_module hlds.hlds_pred.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_type.
@@ -92,6 +102,12 @@
),
Tag = unshared_tag(0)
;
+ ConsId = type_info_const(TIConstNum),
+ Tag = type_info_const_tag(TIConstNum)
+ ;
+ ConsId = typeclass_info_const(TCIConstNum),
+ Tag = typeclass_info_const_tag(TCIConstNum)
+ ;
ConsId = tabling_info_const(ShroudedPredProcId),
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
Tag = tabling_info_tag(PredId, ProcId)
@@ -139,14 +155,28 @@
:- pred type_to_string(mer_type::in, string::out) is det.
type_to_string(Type, String) :-
- ( type_to_ctor_and_args(Type, TypeCtor, _) ->
+ type_to_ctor_det(Type, TypeCtor),
TypeCtor = type_ctor(TypeName, TypeArity),
TypeNameString = sym_name_to_string_sep(TypeName, "__"),
string.int_to_string(TypeArity, TypeArityString),
- String = TypeNameString ++ "__arity" ++ TypeArityString ++ "__"
- ;
- unexpected($module, $pred, "invalid type")
- ).
+ String = TypeNameString ++ "__arity" ++ TypeArityString ++ "__".
+
+%-----------------------------------------------------------------------------%
+
+type_ctor_info_cons_id(TypeCtor) = ConsId :-
+ type_ctor_module_name_arity(TypeCtor, ModuleName, Name, Arity),
+ ConsId = type_ctor_info_const(ModuleName, Name, Arity).
+
+base_typeclass_info_cons_id(InstanceTable, Constraint, InstanceNum,
+ InstanceTypes) = ConsId :-
+ Constraint = constraint(ClassName, ConstraintArgTypes),
+ ClassId = class_id(ClassName, list.length(ConstraintArgTypes)),
+ map.lookup(InstanceTable, ClassId, InstanceList),
+ list.det_index1(InstanceList, InstanceNum, InstanceDefn),
+ InstanceModuleName = InstanceDefn ^ instance_module,
+ make_instance_string(InstanceTypes, InstanceString),
+ ConsId = base_typeclass_info_const(InstanceModuleName, ClassId,
+ InstanceNum, InstanceString).
%----------------------------------------------------------------------------%
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.144
diff -u -b -r1.144 hlds_data.m
--- compiler/hlds_data.m 5 Jun 2012 15:14:26 -0000 1.144
+++ compiler/hlds_data.m 7 Jun 2012 05:32:26 -0000
@@ -34,6 +34,7 @@
:- implementation.
:- import_module check_hlds.type_util.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
:- import_module int.
@@ -615,6 +616,9 @@
% uniquely identifies the instance declaration (it is made from
% the type of the arguments to the instance decl).
+ ; type_info_const_tag(int)
+ ; typeclass_info_const_tag(int)
+
; tabling_info_tag(pred_id, proc_id)
% This is how we refer to the global structures containing
% tabling pointer variables and related data. The word just
@@ -646,7 +650,7 @@
; direct_arg_tag(tag_bits)
% This is for functors which can be distinguished with just a
% primary tag. The primary tag says which of the type's functors
- % (which must all be arity-1) this word represents. However, the
+ % (which must have arity 1) this word represents. However, the
% body of the word is not a pointer to a cell holding the argument;
% it IS the value of that argument, which must be an untagged
% pointer to a cell.
@@ -760,6 +764,8 @@
; Tag = reserved_address_tag(_)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = table_io_decl_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
@@ -789,6 +795,8 @@
; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
@@ -1296,6 +1304,8 @@
:- func restrict_list_elements(set(hlds_class_argpos), list(T)) = list(T).
:- type hlds_class_interface == list(hlds_class_proc).
+
+ % XXX Why is this type separate from the usual pred_proc_id?
:- type hlds_class_proc
---> hlds_class_proc(
pred_id,
@@ -1348,23 +1358,43 @@
instance_proofs :: constraint_proof_map
).
+ % Return the value of the MR_typeclass_info_num_extra_instance_args field
+ % in the base_typeclass_info of the given instance.
+ %
+:- pred num_extra_instance_args(hlds_instance_defn::in, int::out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
-restrict_list_elements(Elements, List) =
- restrict_list_elements_2(Elements, 1, List).
-
-:- func restrict_list_elements_2(set(hlds_class_argpos), hlds_class_argpos,
- list(T)) = list(T).
-
-restrict_list_elements_2(_, _, []) = [].
-restrict_list_elements_2(Elements, Index, [X | Xs]) =
- ( set.member(Index, Elements) ->
- [X | restrict_list_elements_2(Elements, Index + 1, Xs)]
- ;
- restrict_list_elements_2(Elements, Index + 1, Xs)
- ).
+restrict_list_elements(Elements, List) = RestrictedList :-
+ set.to_sorted_list(Elements, SortedElements),
+ restrict_list_elements_2(SortedElements, 1, List, RestrictedList).
+
+:- pred restrict_list_elements_2(list(hlds_class_argpos)::in,
+ hlds_class_argpos::in, list(T)::in, list(T)::out) is det.
+
+restrict_list_elements_2(_, _, [], []).
+restrict_list_elements_2([], _, [_ | _], []).
+restrict_list_elements_2([Posn | Posns], Index, [X | Xs], RestrictedXs) :-
+ ( Index = Posn ->
+ restrict_list_elements_2(Posns, Index + 1, Xs, TailRestrictedXs),
+ RestrictedXs = [X | TailRestrictedXs]
+ ; Index < Posn ->
+ restrict_list_elements_2([Posn | Posns], Index + 1, Xs, RestrictedXs)
+ ;
+ restrict_list_elements_2(Posns, Index + 1, [X | Xs], RestrictedXs)
+ ).
+
+num_extra_instance_args(InstanceDefn, NumExtra) :-
+ InstanceDefn = hlds_instance_defn(_InstanceModule, _ImportStatus,
+ _TermContext, InstanceConstraints, InstanceTypes, _OrigInstanceTypes,
+ _Body, _PredProcIds, _Varset, _SuperClassProofs),
+ type_vars_list(InstanceTypes, TypeVars),
+ get_unconstrained_tvars(TypeVars, InstanceConstraints, Unconstrained),
+ list.length(InstanceConstraints, NumConstraints),
+ list.length(Unconstrained, NumUnconstrained),
+ NumExtra = NumConstraints + NumUnconstrained.
%-----------------------------------------------------------------------------%
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.174
diff -u -b -r1.174 hlds_module.m
--- compiler/hlds_module.m 22 Aug 2011 04:23:13 -0000 1.174
+++ compiler/hlds_module.m 7 Jun 2012 05:32:26 -0000
@@ -26,6 +26,7 @@
:- import_module analysis.
:- import_module check_hlds.unify_proc.
+:- import_module hlds.const_struct.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred.
:- import_module hlds.pred_table.
@@ -525,6 +526,12 @@
:- pred module_info_set_event_set(event_set::in,
module_info::in, module_info::out) is det.
+:- pred module_info_get_const_struct_db(module_info::in,
+ const_struct_db::out) is det.
+
+:- pred module_info_set_const_struct_db(const_struct_db::in,
+ module_info::in, module_info::out) is det.
+
:- pred module_info_get_ts_rev_string_table(module_info::in, int::out,
list(string)::out) is det.
@@ -688,21 +695,21 @@
:- type module_info
---> module_info(
- mi_sub_info :: module_sub_info,
- mi_predicate_table :: predicate_table,
- mi_proc_requests :: proc_requests,
- mi_special_pred_map :: special_pred_map,
- mi_partial_qualifier_info :: partial_qualifier_info,
- mi_type_table :: type_table,
- mi_inst_table :: inst_table,
- mi_mode_table :: mode_table,
- mi_cons_table :: cons_table,
- mi_class_table :: class_table,
- mi_instance_table :: instance_table,
- mi_assertion_table :: assertion_table,
- mi_exclusive_table :: exclusive_table,
- mi_ctor_field_table :: ctor_field_table,
- mi_maybe_recompilation_info :: maybe(recompilation_info)
+/* 01 */ mi_sub_info :: module_sub_info,
+/* 02 */ mi_predicate_table :: predicate_table,
+/* 03 */ mi_proc_requests :: proc_requests,
+/* 04 */ mi_special_pred_map :: special_pred_map,
+/* 05 */ mi_partial_qualifier_info :: partial_qualifier_info,
+/* 06 */ mi_type_table :: type_table,
+/* 07 */ mi_inst_table :: inst_table,
+/* 08 */ mi_mode_table :: mode_table,
+/* 09 */ mi_cons_table :: cons_table,
+/* 10 */ mi_class_table :: class_table,
+/* 11 */ mi_instance_table :: instance_table,
+/* 12 */ mi_assertion_table :: assertion_table,
+/* 13 */ mi_exclusive_table :: exclusive_table,
+/* 14 */ mi_ctor_field_table :: ctor_field_table,
+/* 15 */ mi_maybe_recompilation_info :: maybe(recompilation_info)
).
:- type module_sub_info
@@ -835,6 +842,11 @@
msi_event_set :: event_set,
+ % The database of constant structures the code generator
+ % will generate independently, outside all the procedures
+ % of the program.
+ msi_const_struct_db :: const_struct_db,
+
% A table of strings used by some threadscope events.
% Currently threadscope events are introduced for each future
% in dep_par_conj.m which is why we need to record the table
@@ -896,6 +908,7 @@
set.init(InterfaceModuleSpecs),
ExportedEnums = [],
EventSet = event_set("", map.init),
+ const_struct_db_init(Globals, ConstStructDb),
TSStringTableSize = 0,
TSRevStringTable = [],
@@ -911,7 +924,8 @@
MaybeComplexityMap, ComplexityProcInfos,
AnalysisInfo, UserInitPredCNames, UserFinalPredCNames,
StructureReusePredIds, UsedModules, InterfaceModuleSpecs,
- ExportedEnums, EventSet, TSStringTableSize, TSRevStringTable),
+ ExportedEnums, EventSet, ConstStructDb,
+ TSStringTableSize, TSRevStringTable),
predicate_table_init(PredicateTable),
unify_proc.init_requests(Requests),
@@ -1044,6 +1058,7 @@
MI ^ mi_sub_info ^ msi_interface_module_specifiers).
module_info_get_exported_enums(MI, MI ^ mi_sub_info ^ msi_exported_enums).
module_info_get_event_set(MI, MI ^ mi_sub_info ^ msi_event_set).
+module_info_get_const_struct_db(MI, MI ^ mi_sub_info ^ msi_const_struct_db).
module_info_get_ts_rev_string_table(MI,
MI ^ mi_sub_info ^ msi_ts_string_table_size,
MI ^ mi_sub_info ^ msi_ts_rev_string_table).
@@ -1204,6 +1219,8 @@
!MI ^ mi_sub_info ^ msi_used_modules := UsedModules.
module_info_set_event_set(EventSet, !MI) :-
!MI ^ mi_sub_info ^ msi_event_set := EventSet.
+module_info_set_const_struct_db(ConstStructDb, !MI) :-
+ !MI ^ mi_sub_info ^ msi_const_struct_db := ConstStructDb.
module_info_set_ts_rev_string_table(Size, RevTable, !MI) :-
!MI ^ mi_sub_info ^ msi_ts_string_table_size := Size,
!MI ^ mi_sub_info ^ msi_ts_rev_string_table := RevTable.
Index: compiler/hlds_out_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out_goal.m,v
retrieving revision 1.18
diff -u -b -r1.18 hlds_out_goal.m
--- compiler/hlds_out_goal.m 23 Apr 2012 03:34:47 -0000 1.18
+++ compiler/hlds_out_goal.m 7 Jun 2012 05:32:26 -0000
@@ -968,7 +968,7 @@
do_write_goal(Info, Goal, ModuleInfo, VarSet, AppendVarNums,
Indent1, "\n", TypeQual, !IO),
write_indent(Indent, !IO),
- io.write_string(")", !IO)
+ io.write_string(")\n", !IO)
;
PredOrFunc = pf_function,
(
@@ -1000,7 +1000,7 @@
do_write_goal(Info, Goal, ModuleInfo, VarSet, AppendVarNums,
Indent1, "\n", TypeQual, !IO),
write_indent(Indent, !IO),
- io.write_string(")", !IO)
+ io.write_string(")\n", !IO)
),
(
MaybeType = yes(Type),
Index: compiler/hlds_out_mode.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out_mode.m,v
retrieving revision 1.8
diff -u -b -r1.8 hlds_out_mode.m
--- compiler/hlds_out_mode.m 23 Apr 2012 03:34:47 -0000 1.8
+++ compiler/hlds_out_mode.m 7 Jun 2012 05:32:26 -0000
@@ -489,9 +489,17 @@
:- func bound_insts_to_term(output_lang, prog_context, list(bound_inst))
= prog_term.
-bound_insts_to_term(_, _, []) = _ :-
- unexpected($module, $pred, "bound_insts_to_term([])").
-bound_insts_to_term(Lang, Context, [BoundInst | BoundInsts]) = Term :-
+bound_insts_to_term(_, Context, []) =
+ % This shouldn't happen, but when it does, the problem is a LOT easier
+ % to debug if there is a HLDS dump you can read.
+ term.functor(term.atom("EMPTY_BOUND_INSTS"), [], Context).
+bound_insts_to_term(Lang, Context, [BoundInst | BoundInsts]) =
+ bound_insts_to_term_2(Lang, Context, BoundInst, BoundInsts).
+
+:- func bound_insts_to_term_2(output_lang, prog_context,
+ bound_inst, list(bound_inst)) = prog_term.
+
+bound_insts_to_term_2(Lang, Context, BoundInst, BoundInsts) = Term :-
BoundInst = bound_functor(ConsId, Args),
ArgTerms = list.map(inst_to_term_with_context(Lang, Context), Args),
cons_id_and_args_to_term_full(ConsId, ArgTerms, FirstTerm),
@@ -499,10 +507,11 @@
BoundInsts = [],
Term = FirstTerm
;
- BoundInsts = [_ | _],
+ BoundInsts = [HeadBoundInst | TailBoundInsts],
+ SecondTerm = bound_insts_to_term_2(Lang, Context,
+ HeadBoundInst, TailBoundInsts),
construct_qualified_term_with_context(unqualified(";"),
- [FirstTerm, bound_insts_to_term(Lang, Context, BoundInsts)],
- Context, Term)
+ [FirstTerm, SecondTerm], Context, Term)
).
:- pred cons_id_and_args_to_term_full(cons_id::in, list(prog_term)::in,
@@ -567,6 +576,18 @@
FunctorName = "typeclass_info_cell_constructor",
Term = term.functor(term.string(FunctorName), [], Context)
;
+ ConsId = type_info_const(TIConstNum),
+ term.context_init(Context),
+ FunctorName = "type_info_const",
+ Arg = term.functor(term.integer(TIConstNum), [], Context),
+ Term = term.functor(term.string(FunctorName), [Arg], Context)
+ ;
+ ConsId = typeclass_info_const(TCIConstNum),
+ term.context_init(Context),
+ FunctorName = "typeclass_info_const",
+ Arg = term.functor(term.integer(TCIConstNum), [], Context),
+ Term = term.functor(term.string(FunctorName), [Arg], Context)
+ ;
ConsId = tabling_info_const(_),
term.context_init(Context),
FunctorName = "tabling_info_const",
Index: compiler/hlds_out_module.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out_module.m,v
retrieving revision 1.12
diff -u -b -r1.12 hlds_out_module.m
--- compiler/hlds_out_module.m 5 Jun 2012 15:14:26 -0000 1.12
+++ compiler/hlds_out_module.m 7 Jun 2012 05:32:26 -0000
@@ -41,6 +41,7 @@
:- implementation.
+:- import_module hlds.const_struct.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_out.hlds_out_goal.
:- import_module hlds.hlds_out.hlds_out_mode.
@@ -69,14 +70,6 @@
%
write_hlds(Indent, ModuleInfo, !IO) :-
- module_info_get_imported_module_specifiers(ModuleInfo, Imports),
- module_info_get_preds(ModuleInfo, PredTable),
- module_info_get_type_table(ModuleInfo, TypeTable),
- module_info_get_inst_table(ModuleInfo, InstTable),
- module_info_get_mode_table(ModuleInfo, ModeTable),
- module_info_get_class_table(ModuleInfo, ClassTable),
- module_info_get_instance_table(ModuleInfo, InstanceTable),
- module_info_get_table_struct_map(ModuleInfo, TableStructMap),
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_accumulating_option(Globals, dump_hlds_pred_id,
DumpPredIdStrs),
@@ -97,38 +90,46 @@
true
;
( string.contains_char(DumpOptions, 'I') ->
+ module_info_get_imported_module_specifiers(ModuleInfo, Imports),
write_imports(Indent, Imports, !IO)
;
true
),
( string.contains_char(DumpOptions, 'T') ->
+ module_info_get_type_table(ModuleInfo, TypeTable),
+ module_info_get_instance_table(ModuleInfo, InstanceTable),
+ module_info_get_class_table(ModuleInfo, ClassTable),
write_types(Info, Indent, TypeTable, !IO),
- io.write_string("\n", !IO),
write_classes(Info, Indent, ClassTable, !IO),
- io.write_string("\n", !IO),
- write_instances(Info, Indent, InstanceTable, !IO),
- io.write_string("\n", !IO)
+ write_instances(Info, Indent, InstanceTable, !IO)
;
true
),
( string.contains_char(DumpOptions, 'M') ->
+ module_info_get_inst_table(ModuleInfo, InstTable),
+ module_info_get_mode_table(ModuleInfo, ModeTable),
globals.lookup_int_option(Globals, dump_hlds_inst_limit,
InstLimit),
write_inst_table(Lang, Indent, InstLimit, InstTable, !IO),
- io.write_string("\n", !IO),
- write_mode_table(Indent, ModeTable, !IO),
- io.write_string("\n", !IO)
+ write_mode_table(Indent, ModeTable, !IO)
;
true
),
( string.contains_char(DumpOptions, 'Z') ->
- write_table_structs(ModuleInfo, TableStructMap, !IO),
- io.write_string("\n", !IO)
+ module_info_get_table_struct_map(ModuleInfo, TableStructMap),
+ write_table_structs(ModuleInfo, TableStructMap, !IO)
;
true
)
),
+ ( string.contains_char(DumpOptions, 'X') ->
+ module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
+ write_const_struct_db(ConstStructDb, !IO)
+ ;
+ true
+ ),
( string.contains_char(DumpOptions, 'x') ->
+ module_info_get_preds(ModuleInfo, PredTable),
write_preds(Info, Lang, Indent, ModuleInfo, PredTable, !IO)
;
true
@@ -183,7 +184,8 @@
write_indent(Indent, !IO),
io.write_string("%-------- Types --------\n", !IO),
get_all_type_ctor_defns(TypeTable, TypeAssocList),
- write_type_table_entries(Info, Indent, TypeAssocList, !IO).
+ write_type_table_entries(Info, Indent, TypeAssocList, !IO),
+ io.nl(!IO).
:- pred write_type_table_entries(hlds_out_info::in, int::in,
assoc_list(type_ctor, hlds_type_defn)::in, io::di, io::uo) is det.
@@ -658,7 +660,9 @@
map.foldl2(write_inst_name_maybe_inst(Lang, Limit), MostlyUniqInstMap,
0, NumMostlyUniqInsts, !IO),
io.format("Total number of mostly uniq insts: %d\n",
- [i(NumMostlyUniqInsts)], !IO).
+ [i(NumMostlyUniqInsts)], !IO),
+
+ io.nl(!IO).
:- pred write_user_inst(int::in, inst_id::in, hlds_inst_defn::in,
io::di, io::uo) is det.
@@ -803,10 +807,68 @@
write_indent(Indent, !IO),
io.write_string("%-------- Modes --------\n", !IO),
write_indent(Indent, !IO),
- io.write_string("%%% Not yet implemented, sorry.\n", !IO).
+ io.write_string("%%% Not yet implemented, sorry.\n", !IO),
% io.write_string("% ", !IO),
% io.print(ModeTable, !IO),
- % io.nl(!IO).
+ io.nl(!IO).
+
+%-----------------------------------------------------------------------------%
+%
+% Write out constant structs defined in the module.
+%
+
+:- pred write_const_struct_db(const_struct_db::in, io::di, io::uo) is det.
+
+write_const_struct_db(ConstStructDb, !IO) :-
+ const_struct_db_get_structs(ConstStructDb, ConstStructs),
+ io.write_string("%-------- Const structs --------\n\n", !IO),
+ list.foldl(write_const_struct, ConstStructs, !IO),
+ io.nl(!IO).
+
+:- pred write_const_struct(pair(int, const_struct)::in, io::di, io::uo) is det.
+
+write_const_struct(N - ConstStruct, !IO) :-
+ io.format("\nconst_struct %d:\n", [i(N)], !IO),
+ ConstStruct = const_struct(ConsId, ConstArgs, Type, Inst),
+ mercury_output_cons_id(ConsId, does_not_need_brackets, !IO),
+ (
+ ConstArgs = [],
+ io.nl(!IO)
+ ;
+ ConstArgs = [HeadConstArg | TailConstArgs],
+ io.write_string("(\n", !IO),
+ write_const_struct_args(HeadConstArg, TailConstArgs, !IO),
+ io.write_string(")\n", !IO)
+ ),
+ io.write_string("type: ", !IO),
+ mercury_output_type(varset.init, no, Type, !IO),
+ io.nl(!IO),
+ io.write_string("inst: ", !IO),
+ mercury_output_structured_inst(Inst, 0, output_debug, do_not_incl_addr,
+ varset.init, !IO).
+
+:- pred write_const_struct_args(const_struct_arg::in,
+ list(const_struct_arg)::in, io::di, io::uo) is det.
+
+write_const_struct_args(HeadConstArg, TailConstArgs, !IO) :-
+ io.write_string(" ", !IO),
+ (
+ HeadConstArg = csa_const_struct(N),
+ io.format("cs(%d)", [i(N)], !IO)
+ ;
+ HeadConstArg = csa_constant(ConsId, Type),
+ mercury_output_cons_id(ConsId, does_not_need_brackets, !IO),
+ io.write_string("\n with type ", !IO),
+ mercury_output_type(varset.init, no, Type, !IO)
+ ),
+ (
+ TailConstArgs = [],
+ io.write_string("\n", !IO)
+ ;
+ TailConstArgs = [HeadTailConstArg | TailTailConstArgs],
+ io.write_string(",\n", !IO),
+ write_const_struct_args(HeadTailConstArg, TailTailConstArgs, !IO)
+ ).
%-----------------------------------------------------------------------------%
%
Index: compiler/hlds_out_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out_util.m,v
retrieving revision 1.6
diff -u -b -r1.6 hlds_out_util.m
--- compiler/hlds_out_util.m 23 Apr 2012 03:34:47 -0000 1.6
+++ compiler/hlds_out_util.m 7 Jun 2012 05:32:26 -0000
@@ -696,6 +696,12 @@
term.atom("typeclass_info_cell_constructor"),
ArgVars, VarSet, AppendVarNums, next_to_graphic_token)
;
+ ConsId = type_info_const(TIConstNum),
+ Str = "type_info_const(" ++ int_to_string(TIConstNum) ++ ")"
+ ;
+ ConsId = typeclass_info_const(TCIConstNum),
+ Str = "typeclass_info_const(" ++ int_to_string(TCIConstNum) ++ ")"
+ ;
ConsId = tabling_info_const(ShroudedPredProcId),
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
proc_id_to_int(ProcId, ProcIdInt),
@@ -781,6 +787,12 @@
ConsId = typeclass_info_cell_constructor,
String = "<typeclass_info_cell_constructor>"
;
+ ConsId = type_info_const(_),
+ String = "<type_info_const>"
+ ;
+ ConsId = typeclass_info_const(_),
+ String = "<typeclass_info_const>"
+ ;
ConsId = tabling_info_const(PredProcId),
PredProcId = shrouded_pred_proc_id(PredId, ProcId),
String =
@@ -899,6 +911,12 @@
ConsId = typeclass_info_cell_constructor,
String = "<typeclass_info_cell_constructor>"
;
+ ConsId = type_info_const(_),
+ String = "<type_info_const>"
+ ;
+ ConsId = typeclass_info_const(_),
+ String = "<typeclass_info_const>"
+ ;
ConsId = tabling_info_const(PredProcId),
PredProcId = shrouded_pred_proc_id(PredId, ProcId),
String =
Index: compiler/implementation_defined_literals.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/implementation_defined_literals.m,v
retrieving revision 1.12
diff -u -b -r1.12 implementation_defined_literals.m
--- compiler/implementation_defined_literals.m 13 Feb 2012 00:11:40 -0000 1.12
+++ compiler/implementation_defined_literals.m 7 Jun 2012 05:32:26 -0000
@@ -109,6 +109,8 @@
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
; ConsId = tabling_info_const(_)
; ConsId = deep_profiling_proc_layout(_)
; ConsId = table_io_decl(_)
Index: compiler/inst_check.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_check.m,v
retrieving revision 1.17
diff -u -b -r1.17 inst_check.m
--- compiler/inst_check.m 23 Apr 2012 03:34:47 -0000 1.17
+++ compiler/inst_check.m 7 Jun 2012 05:32:26 -0000
@@ -320,6 +320,8 @@
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
; ConsId = tabling_info_const(_)
; ConsId = deep_profiling_proc_layout(_)
; ConsId = table_io_decl(_)
Index: compiler/inst_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/inst_util.m,v
retrieving revision 1.70
diff -u -b -r1.70 inst_util.m
--- compiler/inst_util.m 23 Apr 2012 03:34:47 -0000 1.70
+++ compiler/inst_util.m 7 Jun 2012 05:32:26 -0000
@@ -183,10 +183,11 @@
Detism = UnifyDetism
;
Inst0 = defined_inst(ThisInstPair),
- % It's ok to assume that the unification is deterministic here,
+ % It is ok to assume that the unification is deterministic here,
% because the only time that this will happen is when we get to the
% recursive case for a recursively defined inst. If the unification
- % as a whole is semidet then it must be semidet somewhere else too.
+ % as a whole is semidet, then this must be because it is semidet
+ % somewhere else too.
Detism = detism_det
),
Inst1 = Inst0
@@ -202,7 +203,7 @@
abstractly_unify_inst_2(Live, ExpandedInstA, ExpandedInstB, Real,
Inst0, Detism, !ModuleInfo),
- % If this unification cannot possible succeed, the correct inst
+ % If this unification cannot possibly succeed, the correct inst
% is not_reached.
( determinism_components(Detism, _, at_most_zero) ->
Inst1 = not_reached
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.382
diff -u -b -r1.382 llds.m
--- compiler/llds.m 13 Feb 2012 00:11:41 -0000 1.382
+++ compiler/llds.m 7 Jun 2012 05:32:26 -0000
@@ -132,6 +132,15 @@
tis_stats :: table_attr_statistics
).
+:- type typed_rval
+ ---> typed_rval(rval, llds_type).
+
+:- func typed_rvals_project_rvals(list(typed_rval)) = list(rval).
+:- func typed_rvals_project_types(list(typed_rval)) = list(llds_type).
+
+:- pred build_typed_rvals(list(rval)::in, list(llds_type)::in,
+ list(typed_rval)::out) is det.
+
:- type common_cell_type
---> plain_type(list(llds_type))
% The type is a structure with one field for each one
@@ -142,7 +151,7 @@
% at least two elements of the same llds_type.
:- type common_cell_value
- ---> plain_value(assoc_list(rval, llds_type))
+ ---> plain_value(list(typed_rval))
; grouped_args_value(list(common_cell_arg_group)).
:- type common_cell_arg_group
@@ -195,6 +204,12 @@
vcda_values :: list(common_cell_value)
).
+ % This maps the integer that identifies a constant structure
+ % (the key of a const_struct in const_struct_db ^ csdb_structs)
+ % to the rval representing the const_struct.
+ %
+:- type const_struct_map == map(int, typed_rval).
+
:- type comp_gen_c_module
---> comp_gen_c_module(
cgcm_name :: string,
@@ -1503,6 +1518,25 @@
%-----------------------------------------------------------------------------%
+typed_rvals_project_rvals([]) = [].
+typed_rvals_project_rvals([typed_rval(Rval, _Type) | TypedRvals]) =
+ [Rval | typed_rvals_project_rvals(TypedRvals)].
+
+typed_rvals_project_types([]) = [].
+typed_rvals_project_types([typed_rval(_Rval, Type) | TypedRvals]) =
+ [Type | typed_rvals_project_types(TypedRvals)].
+
+build_typed_rvals([], [], []).
+build_typed_rvals([_|_], [], _) :-
+ unexpected($module, $pred, "length mismatch").
+build_typed_rvals([], [_|_], _) :-
+ unexpected($module, $pred, "length mismatch").
+build_typed_rvals([Rval | Rvals], [Type | Types], [TypedRval | TypedRvals]) :-
+ TypedRval = typed_rval(Rval, Type),
+ build_typed_rvals(Rvals, Types, TypedRvals).
+
+%-----------------------------------------------------------------------------%
+
first_nonfixed_embedded_slot_addr(EmbeddedStackId, FixedSize) = Rval :-
EmbeddedStackId = embedded_stack_frame_id(MainStackId,
_FirstSlot, LastSlot),
Index: compiler/llds_out_global.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/llds_out_global.m,v
retrieving revision 1.5
diff -u -b -r1.5 llds_out_global.m
--- compiler/llds_out_global.m 8 Dec 2011 23:24:14 -0000 1.5
+++ compiler/llds_out_global.m 7 Jun 2012 05:32:26 -0000
@@ -499,8 +499,8 @@
common_cell_get_rvals(Value) = Rvals :-
(
- Value = plain_value(RvalsTypes),
- assoc_list.keys(RvalsTypes, Rvals)
+ Value = plain_value(TypedRvals),
+ Rvals = typed_rvals_project_rvals(TypedRvals)
;
Value = grouped_args_value(Groups),
RvalLists = list.map(common_group_get_rvals, Groups),
@@ -557,8 +557,8 @@
output_common_cell_value(Info, CellValue, !IO) :-
io.write_string("{\n", !IO),
(
- CellValue = plain_value(ArgsTypes),
- output_cons_args(Info, ArgsTypes, !IO)
+ CellValue = plain_value(TypedArgs),
+ output_cons_args(Info, TypedArgs, !IO)
;
CellValue = grouped_args_value(ArgGroups),
output_cons_arg_groups(Info, ArgGroups, !IO)
@@ -568,11 +568,12 @@
% Output the arguments, each on its own line, and with a cast appropriate
% to its type if that is necessary.
%
-:- pred output_cons_args(llds_out_info::in, assoc_list(rval, llds_type)::in,
+:- pred output_cons_args(llds_out_info::in, list(typed_rval)::in,
io::di, io::uo) is det.
output_cons_args(_, [], !IO).
-output_cons_args(Info, [Rval - Type | RvalsTypes], !IO) :-
+output_cons_args(Info, [TypedRval | TypedRvals], !IO) :-
+ TypedRval = typed_rval(Rval, Type),
(
direct_field_int_constant(Type) = yes,
Rval = const(llconst_int(N))
@@ -582,11 +583,11 @@
output_rval_as_type(Info, Rval, Type, !IO)
),
(
- RvalsTypes = [_ | _],
+ TypedRvals = [_ | _],
io.write_string(",\n", !IO),
- output_cons_args(Info, RvalsTypes, !IO)
+ output_cons_args(Info, TypedRvals, !IO)
;
- RvalsTypes = [],
+ TypedRvals = [],
io.write_string("\n", !IO)
).
Index: compiler/mercury_compile_llds_back_end.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile_llds_back_end.m,v
retrieving revision 1.16
diff -u -b -r1.16 mercury_compile_llds_back_end.m
--- compiler/mercury_compile_llds_back_end.m 31 May 2011 03:14:20 -0000 1.16
+++ compiler/mercury_compile_llds_back_end.m 7 Jun 2012 05:32:26 -0000
@@ -75,6 +75,7 @@
:- import_module ll_backend.stack_opt.
:- import_module ll_backend.store_alloc.
:- import_module ll_backend.transform_llds.
+:- import_module ll_backend.unify_gen.
:- import_module mdbcomp.program_representation.
:- import_module parse_tree.error_util.
:- import_module parse_tree.file_names.
@@ -200,21 +201,22 @@
list.condense(PredSCCs, OrderedPredIds),
MaybeDupProcMap = yes(map.init)
),
- llds_backend_pass_by_preds_loop_over_preds(OrderedPredIds,
- !HLDS, !GlobalData, MaybeDupProcMap, [], RevCodes, !IO),
+ generate_const_structs(!.HLDS, ConstStructMap, !GlobalData),
+ llds_backend_pass_by_preds_loop_over_preds(!HLDS, ConstStructMap,
+ OrderedPredIds, MaybeDupProcMap, [], RevCodes, !GlobalData, !IO),
list.reverse(RevCodes, Codes),
list.condense(Codes, LLDS).
-:- pred llds_backend_pass_by_preds_loop_over_preds(list(pred_id)::in,
- module_info::in, module_info::out, global_data::in, global_data::out,
+:- pred llds_backend_pass_by_preds_loop_over_preds(
+ module_info::in, module_info::out, const_struct_map::in, list(pred_id)::in,
maybe(map(mdbcomp.prim_data.proc_label, mdbcomp.prim_data.proc_label))::in,
- list(list(c_procedure))::in, list(list(c_procedure))::out, io::di, io::uo)
- is det.
+ list(list(c_procedure))::in, list(list(c_procedure))::out,
+ global_data::in, global_data::out, io::di, io::uo) is det.
-llds_backend_pass_by_preds_loop_over_preds([],
- !HLDS, !GlobalData, _, !RevCodes, !IO).
-llds_backend_pass_by_preds_loop_over_preds([PredId | PredIds],
- !HLDS, !GlobalData, !.MaybeDupProcMap, !RevCodes, !IO) :-
+llds_backend_pass_by_preds_loop_over_preds(!HLDS, _,
+ [], _, !RevCodes, !GlobalData, !IO).
+llds_backend_pass_by_preds_loop_over_preds(!HLDS, ConstStructMap,
+ [PredId | PredIds], !.MaybeDupProcMap, !RevCodes, !GlobalData, !IO) :-
module_info_get_preds(!.HLDS, PredTable),
map.lookup(PredTable, PredId, PredInfo),
ProcIds = pred_info_non_imported_procids(PredInfo),
@@ -247,14 +249,14 @@
globals.get_trace_level(Globals0, TraceLevel),
globals.set_trace_level_none(Globals0, Globals1),
module_info_set_globals(Globals1, !HLDS),
- llds_backend_pass_for_pred(ProcIds, PredId, PredInfo, !HLDS,
- !GlobalData, IdProcList, !IO),
+ llds_backend_pass_for_pred(!HLDS, ConstStructMap, PredId, PredInfo,
+ ProcIds, IdProcList, !GlobalData, !IO),
module_info_get_globals(!.HLDS, Globals2),
globals.set_trace_level(TraceLevel, Globals2, Globals),
module_info_set_globals(Globals, !HLDS)
;
- llds_backend_pass_for_pred(ProcIds, PredId, PredInfo, !HLDS,
- !GlobalData, IdProcList, !IO)
+ llds_backend_pass_for_pred(!HLDS, ConstStructMap,
+ PredId, PredInfo, ProcIds, IdProcList, !GlobalData, !IO)
),
(
!.MaybeDupProcMap = no,
@@ -270,33 +272,33 @@
maybe_report_stats(Stats, !IO)
),
!:RevCodes = [ProcList | !.RevCodes],
- llds_backend_pass_by_preds_loop_over_preds(PredIds, !HLDS, !GlobalData,
- !.MaybeDupProcMap, !RevCodes, !IO).
+ llds_backend_pass_by_preds_loop_over_preds(!HLDS, ConstStructMap, PredIds,
+ !.MaybeDupProcMap, !RevCodes, !GlobalData, !IO).
-:- pred llds_backend_pass_for_pred(list(proc_id)::in, pred_id::in,
- pred_info::in, module_info::in, module_info::out,
- global_data::in, global_data::out,
+:- pred llds_backend_pass_for_pred( module_info::in, module_info::out,
+ const_struct_map::in, pred_id::in, pred_info::in, list(proc_id)::in,
assoc_list(mdbcomp.prim_data.proc_label, c_procedure)::out,
- io::di, io::uo) is det.
+ global_data::in, global_data::out, io::di, io::uo) is det.
-llds_backend_pass_for_pred([], _, _, !HLDS, !GlobalData, [], !IO).
-llds_backend_pass_for_pred([ProcId | ProcIds], PredId, PredInfo, !HLDS,
- !GlobalData, [ProcLabel - ProcCode | ProcCodes], !IO) :-
+llds_backend_pass_for_pred(!HLDS, _, _, _, [], [], !GlobalData, !IO).
+llds_backend_pass_for_pred(!HLDS, ConstStructMap, PredId, PredInfo,
+ [ProcId | ProcIds], [ProcLabel - ProcCode | ProcCodes],
+ !GlobalData, !IO) :-
ProcLabel = make_proc_label(!.HLDS, PredId, ProcId),
pred_info_get_procedures(PredInfo, ProcTable),
map.lookup(ProcTable, ProcId, ProcInfo),
- llds_backend_pass_for_proc(PredInfo, ProcInfo, ProcId, PredId, !HLDS,
- !GlobalData, ProcCode, !IO),
- llds_backend_pass_for_pred(ProcIds, PredId, PredInfo, !HLDS, !GlobalData,
- ProcCodes, !IO).
-
-:- pred llds_backend_pass_for_proc(pred_info::in, proc_info::in,
- proc_id::in, pred_id::in, module_info::in, module_info::out,
- global_data::in, global_data::out, c_procedure::out, io::di, io::uo)
- is det.
+ llds_backend_pass_for_proc(!HLDS, ConstStructMap, PredId, PredInfo,
+ ProcId, ProcInfo, ProcCode, !GlobalData, !IO),
+ llds_backend_pass_for_pred(!HLDS, ConstStructMap, PredId, PredInfo,
+ ProcIds, ProcCodes, !GlobalData, !IO).
+
+:- pred llds_backend_pass_for_proc( module_info::in, module_info::out,
+ const_struct_map::in, pred_id::in, pred_info::in,
+ proc_id::in, proc_info::in, c_procedure::out,
+ global_data::in, global_data::out, io::di, io::uo) is det.
-llds_backend_pass_for_proc(PredInfo, !.ProcInfo, ProcId, PredId, !HLDS,
- !GlobalData, ProcCode, !IO) :-
+llds_backend_pass_for_proc(!HLDS, ConstStructMap, PredId, PredInfo,
+ ProcId, !.ProcInfo, ProcCode, !GlobalData, !IO) :-
PredProcId = proc(PredId, ProcId),
module_info_get_globals(!.HLDS, Globals),
globals.lookup_bool_option(Globals, optimize_saved_vars_const,
@@ -374,8 +376,8 @@
allocate_store_maps(final_allocation, !.HLDS, PredProcId, !ProcInfo),
write_proc_progress_message("% Generating low-level (LLDS) code for ",
PredId, ProcId, !.HLDS, !IO),
- generate_proc_code(PredInfo, !.ProcInfo, PredId, ProcId, !.HLDS,
- !GlobalData, ProcCode0),
+ generate_proc_code(!.HLDS, ConstStructMap, PredId, PredInfo,
+ ProcId, !.ProcInfo, !GlobalData, ProcCode0),
globals.lookup_bool_option(Globals, optimize, Optimize),
(
Optimize = yes,
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.357
diff -u -b -r1.357 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 5 Jun 2012 15:14:26 -0000 1.357
+++ compiler/mercury_to_mercury.m 7 Jun 2012 05:32:26 -0000
@@ -1668,6 +1668,14 @@
ConsId = typeclass_info_cell_constructor,
add_string("<typeclass_info_cell_constructor>", !U)
;
+ ConsId = type_info_const(TIConstNum),
+ add_string("<type_info_cell_constructor " ++
+ int_to_string(TIConstNum) ++ ">", !U)
+ ;
+ ConsId = typeclass_info_const(TCIConstNum),
+ add_string("<typeclass_info_cell_constructor " ++
+ int_to_string(TCIConstNum) ++ ">", !U)
+ ;
ConsId = tabling_info_const(_),
add_string("<tabling info>", !U)
;
Index: compiler/ml_accurate_gc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_accurate_gc.m,v
retrieving revision 1.8
diff -u -b -r1.8 ml_accurate_gc.m
--- compiler/ml_accurate_gc.m 22 Aug 2011 07:56:09 -0000 1.8
+++ compiler/ml_accurate_gc.m 7 Jun 2012 05:32:26 -0000
@@ -111,34 +111,41 @@
ml_gen_gc_statement_poly(VarName, DeclType, ActualType, Context,
GCStatement, !Info) :-
+ ml_gen_info_get_gc(!.Info, GC),
+ ( GC = gc_accurate ->
HowToGetTypeInfo = construct_from_type(ActualType),
- ml_gen_gc_statement_2(VarName, DeclType, HowToGetTypeInfo, Context,
- GCStatement, !Info).
+ ml_do_gen_gc_statement(VarName, DeclType, HowToGetTypeInfo, Context,
+ GCStatement, !Info)
+ ;
+ GCStatement = gc_no_stmt
+ ).
ml_gen_gc_statement_with_typeinfo(VarName, DeclType, TypeInfoRval, Context,
GCStatement, !Info) :-
+ ml_gen_info_get_gc(!.Info, GC),
+ ( GC = gc_accurate ->
HowToGetTypeInfo = already_provided(TypeInfoRval),
- ml_gen_gc_statement_2(VarName, DeclType, HowToGetTypeInfo, Context,
- GCStatement, !Info).
+ ml_do_gen_gc_statement(VarName, DeclType, HowToGetTypeInfo, Context,
+ GCStatement, !Info)
+ ;
+ GCStatement = gc_no_stmt
+ ).
:- type how_to_get_type_info
---> construct_from_type(mer_type)
; already_provided(mlds_rval).
-:- pred ml_gen_gc_statement_2(mlds_var_name::in, mer_type::in,
+:- pred ml_do_gen_gc_statement(mlds_var_name::in, mer_type::in,
how_to_get_type_info::in, prog_context::in,
mlds_gc_statement::out, ml_gen_info::in, ml_gen_info::out) is det.
-ml_gen_gc_statement_2(VarName, DeclType, HowToGetTypeInfo, Context,
+ml_do_gen_gc_statement(VarName, DeclType, HowToGetTypeInfo, Context,
GCStatement, !Info) :-
- ml_gen_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_globals(ModuleInfo, Globals),
- globals.get_gc_method(Globals, GC),
(
- GC = gc_accurate,
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
MLDS_DeclType = mercury_type_to_mlds_type(ModuleInfo, DeclType),
ml_type_might_contain_pointers_for_gc(MLDS_DeclType) = yes,
- % don't generate GC tracing code in no_type_info_builtins
+ % Don't generate GC tracing code in no_type_info_builtins.
ml_gen_info_get_pred_id(!.Info, PredId),
predicate_id(ModuleInfo, PredId, PredModule, PredName, PredArity),
\+ no_type_info_builtin(PredModule, PredName, PredArity)
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.159
diff -u -b -r1.159 ml_code_util.m
--- compiler/ml_code_util.m 6 Sep 2011 05:20:42 -0000 1.159
+++ compiler/ml_code_util.m 7 Jun 2012 05:32:26 -0000
@@ -1435,11 +1435,11 @@
)
).
-ml_gen_box_const_rval(ModuleInfo, Context, Type, DoubleWidth, Rval, BoxedRval,
- !GlobalData) :-
+ml_gen_box_const_rval(ModuleInfo, Context, MLDS_Type, DoubleWidth, Rval,
+ BoxedRval, !GlobalData) :-
(
- ( Type = mercury_type(type_variable(_, _), _, _)
- ; Type = mlds_generic_type
+ ( MLDS_Type = mercury_type(type_variable(_, _), _, _)
+ ; MLDS_Type = mlds_generic_type
)
->
BoxedRval = Rval
@@ -1448,8 +1448,8 @@
% floats specially. Boxed floats normally get heap allocated, whereas
% for other types boxing is just a cast (casts are OK in static
% initializers, but calls to malloc() are not).
- ( Type = mercury_type(builtin_type(builtin_type_float), _, _)
- ; Type = mlds_native_float_type
+ ( MLDS_Type = mercury_type(builtin_type(builtin_type_float), _, _)
+ ; MLDS_Type = mlds_native_float_type
),
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
@@ -1467,8 +1467,8 @@
module_info_get_name(ModuleInfo, ModuleName),
MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
Initializer = init_obj(Rval),
- ml_gen_static_scalar_const_addr(MLDS_ModuleName, "float", Type,
- Initializer, Context, ConstAddrRval, !GlobalData),
+ ml_gen_static_scalar_const_addr(MLDS_ModuleName, "float",
+ MLDS_Type, Initializer, Context, ConstAddrRval, !GlobalData),
% Return as the boxed rval the address of that constant,
% cast to mlds_generic_type.
@@ -1476,10 +1476,10 @@
;
% This is not a real box, but a cast. The "box" is required as it
% may be further cast to pointer types.
- BoxedRval = ml_unop(box(Type), Rval)
+ BoxedRval = ml_unop(box(MLDS_Type), Rval)
)
;
- BoxedRval = ml_unop(box(Type), Rval)
+ BoxedRval = ml_unop(box(MLDS_Type), Rval)
).
ml_gen_box_or_unbox_rval(ModuleInfo, SourceType, DestType, BoxPolicy, VarRval,
@@ -1564,7 +1564,7 @@
ConvInputStatements, ConvOutputStatements, !Info) :-
% First see if we can just convert the lval as an rval;
% if no boxing/unboxing is required, then ml_box_or_unbox_rval
- % will return its argument unchanged, and so we're done.
+ % will return its argument unchanged, and so we are done.
ml_gen_info_get_module_info(!.Info, ModuleInfo),
ml_gen_box_or_unbox_rval(ModuleInfo, CalleeType, CallerType, BoxPolicy,
ml_lval(VarLval), BoxedRval),
@@ -1581,15 +1581,14 @@
% Generate a declaration for the fresh variable.
%
- % Note that generating accurate GC tracing code for this
- % variable requires some care, because CalleeType might be a
- % type variable from the callee, not from the caller,
- % and we can't generate type_infos for type variables
- % from the callee. Hence we need to call the version of
- % ml_gen_gc_statement which takes two types:
- % the CalleeType is used to determine the type for the
- % temporary variable declaration, but the CallerType is
- % used to construct the type_info.
+ % Note that generating accurate GC tracing code for this variable
+ % requires some care, because CalleeType might be a type variable
+ % from the callee, not from the caller, and we can't generate
+ % type_infos for type variables from the callee. Hence we need to call
+ % the version of ml_gen_gc_statement which takes two types:
+ % the CalleeType is used to determine the type for the temporary
+ % variable declaration, but the CallerType is used to construct
+ % the type_info.
ml_gen_info_new_conv_var(ConvVarSeq, !Info),
VarName = mlds_var_name(VarNameStr, MaybeNum),
@@ -1600,9 +1599,9 @@
ml_gen_type(!.Info, CalleeType, MLDS_CalleeType),
(
ForClosureWrapper = yes,
- % For closure wrappers, the argument type_infos are
- % stored in the `type_params' local, so we need to
- % handle the GC tracing code specially
+ % For closure wrappers, the argument type_infos are stored in
+ % the `type_params' local, so we need to handle the GC tracing
+ % code specially.
( CallerType = type_variable(_, _) ->
ml_gen_local_for_output_arg(ArgVarName, CalleeType, ArgNum,
Context, ArgVarDecl, !Info)
@@ -1653,8 +1652,8 @@
ml_gen_local_for_output_arg(VarName, Type, ArgNum, Context, LocalVarDefn,
!Info) :-
% Generate a declaration for a corresponding local variable.
- % However, don't use the normal GC tracing code; instead,
- % we need to get the typeinfo from `type_params', using the following code:
+ % However, don't use the normal GC tracing code; instead, we need to get
+ % the typeinfo from `type_params', using the following code:
%
% MR_TypeInfo type_info;
% MR_MemoryList allocated_memory_cells = NULL;
@@ -1676,7 +1675,7 @@
ClosureLayoutPtrLval),
TypeParamsName = mlds_var_name("type_params", no),
- % This type is really MR_TypeInfoParams, but there's no easy way to
+ % This type is really MR_TypeInfoParams, but there is no easy way to
% represent that in the MLDS; using MR_Box instead works fine.
TypeParamsType = mlds_generic_type,
ml_gen_var_lval(!.Info, TypeParamsName, TypeParamsType, TypeParamsLval),
Index: compiler/ml_gen_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_gen_info.m,v
retrieving revision 1.5
diff -u -b -r1.5 ml_gen_info.m
--- compiler/ml_gen_info.m 24 Jan 2012 05:23:07 -0000 1.5
+++ compiler/ml_gen_info.m 7 Jun 2012 05:32:26 -0000
@@ -44,13 +44,14 @@
% information accumulated by the code generator so far during the
% processing of previous procedures.
%
-:- func ml_gen_info_init(module_info, pred_id, proc_id, proc_info,
- ml_global_data) = ml_gen_info.
+:- func ml_gen_info_init(module_info, ml_const_struct_map, pred_id, proc_id,
+ proc_info, ml_global_data) = ml_gen_info.
:- pred ml_gen_info_get_module_info(ml_gen_info::in, module_info::out) is det.
:- pred ml_gen_info_get_high_level_data(ml_gen_info::in, bool::out) is det.
:- pred ml_gen_info_get_target(ml_gen_info::in, compilation_target::out)
is det.
+:- pred ml_gen_info_get_gc(ml_gen_info::in, gc_method::out) is det.
:- pred ml_gen_info_get_pred_id(ml_gen_info::in, pred_id::out) is det.
:- pred ml_gen_info_get_proc_id(ml_gen_info::in, proc_id::out) is det.
:- pred ml_gen_info_get_varset(ml_gen_info::in, prog_varset::out) is det.
@@ -156,6 +157,8 @@
:- type ml_ground_term_map == map(prog_var, ml_ground_term).
+:- type ml_const_struct_map == map(int, ml_ground_term).
+
% Set the `const' variable name corresponding to the given HLDS variable.
%
:- pred ml_gen_info_set_const_var(prog_var::in, ml_ground_term::in,
@@ -236,6 +239,12 @@
:- pred ml_gen_info_set_const_var_map(map(prog_var, ml_ground_term)::in,
ml_gen_info::in, ml_gen_info::out) is det.
+ % Get the map of the constant ground structures generated by ml_code_gen
+ % before we start generating code for procedures.
+ %
+:- pred ml_gen_info_get_const_struct_map(ml_gen_info::in,
+ map(int, ml_ground_term)::out) is det.
+
% The ml_gen_info contains a list of extra definitions of functions or
% global constants which should be inserted before the definition of the
% function for the current procedure. This is used for the definitions
@@ -318,32 +327,36 @@
% structure taken from the module_info.
/* 1 */ mgsi_high_level_data :: bool,
/* 2 */ mgsi_target :: compilation_target,
+/* 3 */ mgsi_gc :: gc_method,
% The identity of the procedure we are generating code for.
-/* 3 */ mgsi_pred_id :: pred_id,
-/* 4 */ mgsi_proc_id :: proc_id,
+/* 4 */ mgsi_pred_id :: pred_id,
+/* 5 */ mgsi_proc_id :: proc_id,
-/* 5 */ mgsi_func_counter :: counter,
-/* 6 */ mgsi_label_counter :: counter,
-/* 7 */ mgsi_aux_var_counter :: counter,
-/* 8 */ mgsi_cond_var_counter :: counter,
-/* 9 */ mgsi_conv_var_counter :: counter,
+/* 6 */ mgsi_func_counter :: counter,
+/* 7 */ mgsi_label_counter :: counter,
+/* 8 */ mgsi_aux_var_counter :: counter,
+/* 9 */ mgsi_cond_var_counter :: counter,
+/* 10 */ mgsi_conv_var_counter :: counter,
-/* 10 */ mgsi_const_var_map :: map(prog_var, ml_ground_term),
+/* 11 */ mgsi_const_var_map :: map(prog_var, ml_ground_term),
+/* 12 */ mgsi_const_struct_map :: map(int, ml_ground_term),
-/* 11 */ mgsi_closure_wrapper_defns :: list(mlds_defn),
+/* 13 */ mgsi_closure_wrapper_defns :: list(mlds_defn),
% A partial mapping from vars to lvals, used to override
% the normal lval that we use for a variable.
-/* 12 */ mgsi_success_cont_stack :: stack(success_cont),
+/* 14 */ mgsi_success_cont_stack :: stack(success_cont),
-/* 13 */ mgsi_env_var_names :: set(string)
+/* 15 */ mgsi_env_var_names :: set(string)
).
-ml_gen_info_init(ModuleInfo, PredId, ProcId, ProcInfo, GlobalData) = Info :-
+ml_gen_info_init(ModuleInfo, ConstStructMap, PredId, ProcId, ProcInfo,
+ GlobalData) = Info :-
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
globals.get_target(Globals, CompilationTarget),
+ globals.get_gc_method(Globals, GC),
proc_info_get_headvars(ProcInfo, HeadVars),
proc_info_get_varset(ProcInfo, VarSet),
@@ -372,6 +385,7 @@
SubInfo = ml_gen_sub_info(
HighLevelData,
CompilationTarget,
+ GC,
PredId,
ProcId,
FuncLabelCounter,
@@ -380,6 +394,7 @@
CondVarCounter,
ConvVarCounter,
ConstVarMap,
+ ConstStructMap,
ClosureWrapperDefns,
SuccContStack,
EnvVarNames
@@ -407,6 +422,7 @@
ml_gen_info_get_high_level_data(Info,
Info ^ mgi_sub_info ^ mgsi_high_level_data).
ml_gen_info_get_target(Info, Info ^ mgi_sub_info ^ mgsi_target).
+ml_gen_info_get_gc(Info, Info ^ mgi_sub_info ^ mgsi_gc).
ml_gen_info_get_pred_id(Info, Info ^ mgi_sub_info ^ mgsi_pred_id).
ml_gen_info_get_proc_id(Info, Info ^ mgi_sub_info ^ mgsi_proc_id).
ml_gen_info_get_varset(Info, Info ^ mgi_varset).
@@ -426,6 +442,8 @@
Info ^ mgi_sub_info ^ mgsi_conv_var_counter).
ml_gen_info_get_const_var_map(Info,
Info ^ mgi_sub_info ^ mgsi_const_var_map).
+ml_gen_info_get_const_struct_map(Info,
+ Info ^ mgi_sub_info ^ mgsi_const_struct_map).
ml_gen_info_get_success_cont_stack(Info,
Info ^ mgi_sub_info ^ mgsi_success_cont_stack).
ml_gen_info_get_closure_wrapper_defns(Info,
Index: compiler/ml_global_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_global_data.m,v
retrieving revision 1.12
diff -u -b -r1.12 ml_global_data.m
--- compiler/ml_global_data.m 6 Sep 2011 05:20:42 -0000 1.12
+++ compiler/ml_global_data.m 7 Jun 2012 05:32:26 -0000
@@ -778,6 +778,12 @@
ConsId = typeclass_info_cell_constructor,
TypeStr = "typeclass_info"
;
+ ConsId = type_info_const(_),
+ TypeStr = "type_info_const"
+ ;
+ ConsId = typeclass_info_const(_),
+ TypeStr = "typeclass_info_const"
+ ;
( ConsId = int_const(_)
; ConsId = float_const(_)
; ConsId = char_const(_)
Index: compiler/ml_proc_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_proc_gen.m,v
retrieving revision 1.17
diff -u -b -r1.17 ml_proc_gen.m
--- compiler/ml_proc_gen.m 22 Aug 2011 07:56:09 -0000 1.17
+++ compiler/ml_proc_gen.m 7 Jun 2012 05:32:26 -0000
@@ -46,6 +46,7 @@
:- import_module ml_backend.ml_gen_info.
:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_type_gen.
+:- import_module ml_backend.ml_unify_gen.
:- import_module ml_backend.ml_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_foreign.
@@ -192,12 +193,43 @@
:- pred ml_gen_defns(module_info::in, module_info::out,
list(mlds_defn)::out, ml_global_data::out) is det.
-ml_gen_defns(!ModuleInfo, Defns, GlobalData) :-
+ml_gen_defns(!ModuleInfo, Defns, !:GlobalData) :-
ml_gen_types(!.ModuleInfo, TypeDefns),
ml_gen_table_structs(!.ModuleInfo, TableStructDefns),
- ml_gen_preds(!ModuleInfo, PredDefns, GlobalData),
+ ml_gen_init_common_data(!.ModuleInfo, !:GlobalData),
+ ml_gen_const_structs(!.ModuleInfo, ConstStructMap, !GlobalData),
+ ml_gen_preds(!ModuleInfo, ConstStructMap, PredDefns, !GlobalData),
Defns = TypeDefns ++ TableStructDefns ++ PredDefns.
+:- pred ml_gen_init_common_data(module_info::in, ml_global_data::out) is det.
+
+ml_gen_init_common_data(ModuleInfo, GlobalData) :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ (
+ ( Target = target_c
+ ; Target = target_csharp
+ ; Target = target_java
+ ),
+ UseCommonCells = use_common_cells
+ ;
+ ( Target = target_asm
+ ; Target = target_il
+ ; Target = target_erlang
+ ; Target = target_x86_64
+ ),
+ UseCommonCells = do_not_use_common_cells
+ ),
+ globals.lookup_bool_option(Globals, unboxed_float, UnboxedFloats),
+ (
+ UnboxedFloats = yes,
+ HaveUnboxedFloats = have_unboxed_floats
+ ;
+ UnboxedFloats = no,
+ HaveUnboxedFloats = do_not_have_unboxed_floats
+ ),
+ GlobalData = ml_global_data_init(UseCommonCells, HaveUnboxedFloats).
+
%-----------------------------------------------------------------------------%
%
% For each pragma foreign_export declaration we associate with it the
@@ -261,44 +293,22 @@
% (and functions) in the HLDS.
%
:- pred ml_gen_preds(module_info::in, module_info::out,
- list(mlds_defn)::out, ml_global_data::out) is det.
+ ml_const_struct_map::in, list(mlds_defn)::out,
+ ml_global_data::in, ml_global_data::out) is det.
-ml_gen_preds(!ModuleInfo, PredDefns, GlobalData) :-
+ml_gen_preds(!ModuleInfo, ConstStructMap, PredDefns, !GlobalData) :-
module_info_get_preds(!.ModuleInfo, PredTable),
map.keys(PredTable, PredIds),
- module_info_get_globals(!.ModuleInfo, Globals),
- globals.get_target(Globals, Target),
- (
- ( Target = target_c
- ; Target = target_csharp
- ; Target = target_java
- ),
- UseCommonCells = use_common_cells
- ;
- ( Target = target_asm
- ; Target = target_il
- ; Target = target_erlang
- ; Target = target_x86_64
- ),
- UseCommonCells = do_not_use_common_cells
- ),
- globals.lookup_bool_option(Globals, unboxed_float, UnboxedFloats),
- (
- UnboxedFloats = yes,
- HaveUnboxedFloats = have_unboxed_floats
- ;
- UnboxedFloats = no,
- HaveUnboxedFloats = do_not_have_unboxed_floats
- ),
- GlobalData0 = ml_global_data_init(UseCommonCells, HaveUnboxedFloats),
- ml_gen_preds_2(!ModuleInfo, PredIds, [], PredDefns,
- GlobalData0, GlobalData).
+ ml_gen_preds_acc(!ModuleInfo, ConstStructMap, PredIds, [], PredDefns,
+ !GlobalData).
-:- pred ml_gen_preds_2(module_info::in, module_info::out, list(pred_id)::in,
+:- pred ml_gen_preds_acc(module_info::in, module_info::out,
+ ml_const_struct_map::in, list(pred_id)::in,
list(mlds_defn)::in, list(mlds_defn)::out,
ml_global_data::in, ml_global_data::out) is det.
-ml_gen_preds_2(!ModuleInfo, PredIds0, !Defns, !GlobalDefns) :-
+ml_gen_preds_acc(!ModuleInfo, ConstStructMap, PredIds0,
+ !Defns, !GlobalDefns) :-
(
PredIds0 = [PredId | PredIds],
module_info_get_preds(!.ModuleInfo, PredTable),
@@ -316,10 +326,11 @@
->
true
;
- ml_gen_pred(!ModuleInfo, PredId, PredInfo, ImportStatus, !Defns,
- !GlobalDefns)
+ ml_gen_pred(!ModuleInfo, ConstStructMap, PredId, PredInfo,
+ ImportStatus, !Defns, !GlobalDefns)
),
- ml_gen_preds_2(!ModuleInfo, PredIds, !Defns, !GlobalDefns)
+ ml_gen_preds_acc(!ModuleInfo, ConstStructMap, PredIds,
+ !Defns, !GlobalDefns)
;
PredIds0 = []
).
@@ -327,13 +338,13 @@
% Generate MLDS definitions for all the non-imported procedures
% of a given predicate (or function).
%
-:- pred ml_gen_pred(module_info::in, module_info::out, pred_id::in,
- pred_info::in, import_status::in,
+:- pred ml_gen_pred(module_info::in, module_info::out, ml_const_struct_map::in,
+ pred_id::in, pred_info::in, import_status::in,
list(mlds_defn)::in, list(mlds_defn)::out,
ml_global_data::in, ml_global_data::out) is det.
-ml_gen_pred(!ModuleInfo, PredId, PredInfo, ImportStatus, !Defns,
- !GlobalData) :-
+ml_gen_pred(!ModuleInfo, ConstStructMap, PredId, PredInfo, ImportStatus,
+ !Defns, !GlobalData) :-
( ImportStatus = status_external(_) ->
ProcIds = pred_info_procids(PredInfo)
;
@@ -347,29 +358,34 @@
write_pred_progress_message("% Generating MLDS code for ",
PredId, !.ModuleInfo, !IO)
),
- ml_gen_procs(!ModuleInfo, PredId, ProcIds, !Defns, !GlobalData)
+ ml_gen_procs(!ModuleInfo, ConstStructMap, PredId, ProcIds,
+ !Defns, !GlobalData)
).
:- pred ml_gen_procs(module_info::in, module_info::out,
- pred_id::in, list(proc_id)::in,
+ ml_const_struct_map::in, pred_id::in, list(proc_id)::in,
list(mlds_defn)::in, list(mlds_defn)::out,
ml_global_data::in, ml_global_data::out) is det.
-ml_gen_procs(!ModuleInfo, _, [], !Defns, !GlobalData).
-ml_gen_procs(!ModuleInfo, PredId, [ProcId | ProcIds], !Defns, !GlobalData) :-
- ml_gen_proc(!ModuleInfo, PredId, ProcId, !Defns, !GlobalData),
- ml_gen_procs(!ModuleInfo, PredId, ProcIds, !Defns, !GlobalData).
+ml_gen_procs(!ModuleInfo, _, _, [], !Defns, !GlobalData).
+ml_gen_procs(!ModuleInfo, ConstStructMap, PredId, [ProcId | ProcIds],
+ !Defns, !GlobalData) :-
+ ml_gen_proc(!ModuleInfo, ConstStructMap, PredId, ProcId,
+ !Defns, !GlobalData),
+ ml_gen_procs(!ModuleInfo, ConstStructMap, PredId, ProcIds,
+ !Defns, !GlobalData).
%-----------------------------------------------------------------------------%
%
% Code for handling individual procedures.
%
-:- pred ml_gen_proc(module_info::in, module_info::out,
+:- pred ml_gen_proc(module_info::in, module_info::out, ml_const_struct_map::in,
pred_id::in, proc_id::in, list(mlds_defn)::in, list(mlds_defn)::out,
ml_global_data::in, ml_global_data::out) is det.
-ml_gen_proc(!ModuleInfo, PredId, ProcId, !Defns, !GlobalData) :-
+ml_gen_proc(!ModuleInfo, ConstStructMap, PredId, ProcId,
+ !Defns, !GlobalData) :-
% The specification of the HLDS allows goal_infos to overestimate
% the set of non-locals. Such overestimates are bad for us for two reasons:
%
@@ -400,8 +416,8 @@
Context = goal_info_get_context(GoalInfo),
some [!Info] (
- !:Info = ml_gen_info_init(!.ModuleInfo, PredId, ProcId, ProcInfo,
- !.GlobalData),
+ !:Info = ml_gen_info_init(!.ModuleInfo, ConstStructMap,
+ PredId, ProcId, ProcInfo, !.GlobalData),
( ImportStatus = status_external(_) ->
% For Mercury procedures declared `:- external', we generate an
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.60
diff -u -b -r1.60 ml_switch_gen.m
--- compiler/ml_switch_gen.m 15 Aug 2011 06:23:14 -0000 1.60
+++ compiler/ml_switch_gen.m 7 Jun 2012 05:32:26 -0000
@@ -571,6 +571,8 @@
; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.101
diff -u -b -r1.101 ml_type_gen.m
--- compiler/ml_type_gen.m 6 Sep 2011 05:20:42 -0000 1.101
+++ compiler/ml_type_gen.m 7 Jun 2012 05:32:26 -0000
@@ -320,6 +320,8 @@
; TagVal = closure_tag(_, _, _)
; TagVal = type_ctor_info_tag(_, _, _)
; TagVal = base_typeclass_info_tag(_, _, _)
+ ; TagVal = type_info_const_tag(_)
+ ; TagVal = typeclass_info_const_tag(_)
; TagVal = tabling_info_tag(_, _)
; TagVal = deep_profiling_proc_layout_tag(_, _)
; TagVal = table_io_decl_tag(_, _)
@@ -865,6 +867,8 @@
; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
@@ -1245,6 +1249,8 @@
; TagVal = closure_tag(_, _, _)
; TagVal = type_ctor_info_tag(_, _, _)
; TagVal = base_typeclass_info_tag(_, _, _)
+ ; TagVal = type_info_const_tag(_)
+ ; TagVal = typeclass_info_const_tag(_)
; TagVal = tabling_info_tag(_, _)
; TagVal = deep_profiling_proc_layout_tag(_, _)
; TagVal = table_io_decl_tag(_, _)
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.164
diff -u -b -r1.164 ml_unify_gen.m
--- compiler/ml_unify_gen.m 12 Dec 2011 16:15:14 -0000 1.164
+++ compiler/ml_unify_gen.m 7 Jun 2012 05:32:26 -0000
@@ -42,6 +42,7 @@
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module ml_backend.ml_gen_info.
+:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.mlds.
:- import_module parse_tree.prog_data.
@@ -114,6 +115,9 @@
:- pred ml_gen_ground_term(prog_var::in, hlds_goal::in,
list(statement)::out, ml_gen_info::in, ml_gen_info::out) is det.
+:- pred ml_gen_const_structs(module_info::in, ml_const_struct_map::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -125,6 +129,7 @@
:- import_module backend_libs.type_class_info.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
+:- import_module hlds.const_struct.
:- import_module hlds.hlds_code_util.
:- import_module hlds.hlds_out.
:- import_module hlds.hlds_out.hlds_out_util.
@@ -135,7 +140,6 @@
:- import_module ml_backend.ml_closure_gen.
:- import_module ml_backend.ml_code_gen.
:- import_module ml_backend.ml_code_util.
-:- import_module ml_backend.ml_global_data.
:- import_module ml_backend.ml_target_util.
:- import_module ml_backend.ml_type_gen.
:- import_module ml_backend.ml_util.
@@ -342,7 +346,8 @@
Tag = direct_arg_tag(Ptag),
ml_variable_type(!.Info, Var, VarType),
ml_gen_direct_arg_construct(ModuleInfo, ArgMode, Ptag,
- ArgLval, ArgType, VarLval, VarType, Context, Statements)
+ ArgLval, ArgType, VarLval, VarType, Context,
+ Statements)
)
)
;
@@ -375,6 +380,20 @@
ml_gen_closure(PredId, ProcId, Var, Args, ArgModes, HowToConstruct,
Context, Statements, !Info)
;
+ ( Tag = type_info_const_tag(ConstNum)
+ ; Tag = typeclass_info_const_tag(ConstNum)
+ ),
+ ml_gen_info_get_const_struct_map(!.Info, ConstStructMap),
+ map.lookup(ConstStructMap, ConstNum, GroundTerm0),
+ GroundTerm0 = ml_ground_term(Rval, _Type, _MLDS_Type),
+ ml_gen_var(!.Info, Var, VarLval),
+ ml_gen_info_get_module_info(!.Info, ModuleInfo),
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
+ GroundTerm = ml_ground_term(Rval, Type, MLDS_Type),
+ ml_gen_info_set_const_var(Var, GroundTerm, !Info),
+ Statement = ml_gen_assign(VarLval, Rval, Context),
+ Statements = [Statement]
+ ;
% Constants.
( Tag = int_tag(_)
; Tag = foreign_tag(_, _)
@@ -461,7 +480,8 @@
ml_gen_info_get_module_info(!.Info, ModuleInfo),
ml_gen_pred_label(ModuleInfo, PredId, ProcId, PredLabel, PredModule),
DataAddr = data_addr(PredModule,
- mlds_tabling_ref(mlds_proc_label(PredLabel, ProcId), tabling_info)),
+ mlds_tabling_ref(mlds_proc_label(PredLabel, ProcId),
+ tabling_info)),
Rval = ml_unop(cast(MLDS_VarType),
ml_const(mlconst_data_addr(DataAddr)))
;
@@ -483,25 +503,16 @@
;
% These tags, which are not (necessarily) constants, are handled
% in ml_gen_construct, so we don't need to handle them here.
- (
- Tag = no_tag,
- unexpected($module, $pred, "no_tag")
- ;
- Tag = single_functor_tag,
- unexpected($module, $pred, "single_functor")
- ;
- Tag = unshared_tag(_),
- unexpected($module, $pred, "unshared_tag")
- ;
- Tag = direct_arg_tag(_),
- unexpected($module, $pred, "direct_arg_tag")
- ;
- Tag = shared_remote_tag(_, _),
- unexpected($module, $pred, "shared_remote_tag")
- ;
- Tag = closure_tag(_, _, _),
- unexpected($module, $pred, "closure_tag")
- )
+ ( Tag = no_tag
+ ; Tag = single_functor_tag
+ ; Tag = unshared_tag(_)
+ ; Tag = direct_arg_tag(_)
+ ; Tag = shared_remote_tag(_, _)
+ ; Tag = closure_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
+ ),
+ unexpected($module, $pred, "unexpected tag")
).
%-----------------------------------------------------------------------------%
@@ -662,17 +673,18 @@
list(int)::in, prog_context::in, list(statement)::out,
ml_gen_info::in, ml_gen_info::out) is det.
-ml_gen_new_object_dynamically(MaybeConsId, MaybeCtorName, MaybeTag, ExplicitSecTag,
- _Var, VarLval, VarType, MLDS_Type, ExtraRvals, ExtraTypes,
- ArgVars0, ArgTypes0, ArgModes0, TakeAddr, Context, Statements, !Info) :-
-
+ml_gen_new_object_dynamically(MaybeConsId, MaybeCtorName, MaybeTag,
+ ExplicitSecTag, _Var, VarLval, VarType, MLDS_Type,
+ ExtraRvals, ExtraTypes, ArgVars0, ArgTypes0, ArgModes0, TakeAddr,
+ Context, Statements, !Info) :-
% Fixup type_info_cell_constructor argument lists for the Java backend.
- % (See below for an explanation.)
- maybe_fixup_type_info_cell_constructor_args(!.Info, MaybeConsId,
+ % (See the documention of the callee for an explanation.)
+ ml_gen_info_get_target(!.Info, Target),
+ maybe_fixup_type_info_cell_constructor_args(Target, MaybeConsId,
ArgVars0, ArgVars),
- maybe_fixup_type_info_cell_constructor_args(!.Info, MaybeConsId,
+ maybe_fixup_type_info_cell_constructor_args(Target, MaybeConsId,
ArgTypes0, ArgTypes),
- maybe_fixup_type_info_cell_constructor_args(!.Info, MaybeConsId,
+ maybe_fixup_type_info_cell_constructor_args(Target, MaybeConsId,
ArgModes0, ArgModes),
% Find out the types of the constructor arguments and generate rvals
@@ -758,12 +770,13 @@
% Find out the types of the constructor arguments.
ml_gen_info_get_module_info(!.Info, ModuleInfo),
ml_gen_info_get_high_level_data(!.Info, HighLevelData),
+ ml_gen_info_get_target(!.Info, Target),
% Fixup type_info_cell_constructor argument lists for the Java backend.
- % (See below for an explanation.)
- maybe_fixup_type_info_cell_constructor_args(!.Info, MaybeConsId,
+ % (See the documention of the callee for an explanation.)
+ maybe_fixup_type_info_cell_constructor_args(Target, MaybeConsId,
ArgVars0, ArgVars),
- maybe_fixup_type_info_cell_constructor_args(!.Info, MaybeConsId,
+ maybe_fixup_type_info_cell_constructor_args(Target, MaybeConsId,
ArgTypes0, ArgTypes),
get_maybe_cons_id_arg_types(ModuleInfo, MaybeConsId, ArgTypes, VarType,
@@ -795,7 +808,7 @@
ml_gen_box_or_unbox_const_rval_list_hld(ModuleInfo, ArgTypes,
FieldTypes, ArgRvals0, Context, ArgRvals1, !GlobalData),
% For --high-level-data, the ExtraRvals should already have
- % the right type, so we don't need to worry about boxing
+ % the right type, so we do not need to worry about boxing
% or unboxing them.
ExtraArgRvals = ExtraRvals
),
@@ -808,7 +821,6 @@
MaybeCtorName = no,
UsesBaseClass = tag_uses_base_class
),
- ml_gen_info_get_target(!.Info, Target),
ConstType = get_const_type_for_cons_id(Target, HighLevelData,
MLDS_Type, UsesBaseClass, MaybeConsId),
% XXX If the secondary tag is in a base class, then ideally its
@@ -879,11 +891,10 @@
% XXX it might be better to modify polymoprhism.m so that it never
% inserts the arity argument in the first place.
%
-:- pred maybe_fixup_type_info_cell_constructor_args(ml_gen_info::in,
+:- pred maybe_fixup_type_info_cell_constructor_args(compilation_target::in,
maybe(cons_id)::in, list(T)::in, list(T)::out) is det.
-maybe_fixup_type_info_cell_constructor_args(Info, MaybeConsId, !Args) :-
- ml_gen_info_get_target(Info, Target),
+maybe_fixup_type_info_cell_constructor_args(Target, MaybeConsId, !Args) :-
( Target = target_java ->
(
MaybeConsId = no
@@ -1016,13 +1027,12 @@
globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
(
HighLevelData = no,
- % XXX
- % I am not sure that the types specified here are always the right ones,
- % particularly in cases where the field whose address we are taking has
- % a non-du type such as int or float. However, I can't think of a test case
- % in which a predicate fills in a field of such a type after a *recursive*
- % call, since recursive calls tend to generate values of recursive (i.e.
- % discriminated union) types. -zs
+ % XXX I am not sure that the types specified here are always the right
+ % ones, particularly in cases where the field whose address we are
+ % taking has a non-du type such as int or float. However, I can't think
+ % of a test case in which a predicate fills in a field of such a type
+ % after a *recursive* call, since recursive calls tend to generate
+ % values of recursive (i.e. discriminated union) types. -zs
Offset = offset(OffsetInt),
SourceRval = ml_mem_addr(ml_field(MaybeTag, ml_lval(CellLval),
ml_field_offset(ml_const(mlconst_int(OffsetInt))),
@@ -1068,7 +1078,7 @@
->
ConstType = mlds_array_type(mlds_generic_type)
;
- % Check if we're constructing a value for a discriminated union
+ % Check if we are constructing a value for a discriminated union
% where the specified cons_id which is represented as a derived
% class that is derived from the base class for this discriminated
% union type.
@@ -1079,7 +1089,7 @@
MLDS_Type = mlds_class_type(QualTypeName, TypeArity, _)
;
MLDS_Type = mercury_type(MercuryType, ctor_cat_user(_), _),
- type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes),
+ type_to_ctor(MercuryType, TypeCtor),
ml_gen_type_name(TypeCtor, QualTypeName, TypeArity)
)
->
@@ -1102,7 +1112,7 @@
% declarating static constants we want just the class type,
% not the pointer type.
MLDS_Type = mercury_type(MercuryType, ctor_cat_user(_), _),
- type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes)
+ type_to_ctor(MercuryType, TypeCtor)
->
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
ConstType = mlds_class_type(ClassName, ClassArity, mlds_class)
@@ -1172,7 +1182,7 @@
ConsArgTypes, ConsArgWidths)
;
MaybeConsId = no,
- % It's a closure. In this case, the arguments are all boxed.
+ % It is a closure. In this case, the arguments are all boxed.
Length = list.length(ArgTypes),
ConsArgTypes = ml_make_boxed_types(Length),
ConsArgWidths = list.duplicate(Length, full_word)
@@ -1209,15 +1219,15 @@
ConsArgTypes = ExtraArgTypes ++ ConsArgTypes0,
ConsArgWidths = ExtraArgWidths ++ ConsArgWidths0
;
- % If we didn't find a constructor definition, maybe that is because
- % this type was a built-in tuple type.
+ % If we did not find a constructor definition, maybe that is
+ % because this type was a built-in tuple type.
type_is_tuple(Type, _)
->
% In this case, the argument types are all fresh variables.
- % Note that we don't need to worry about using the right varset
+ % Note that we do not need to worry about using the right varset
% here, since all we really care about at this point is whether
- % something is a type variable or not, not which type variable it
- % is.
+ % something is a type variable or not, not which type variable
+ % it is.
Length = list.length(ArgTypes),
ConsArgTypes = ml_make_boxed_types(Length),
ConsArgWidths = list.duplicate(Length, full_word)
@@ -1314,20 +1324,12 @@
ml_global_data::in, ml_global_data::out) is det.
ml_gen_box_const_rval_list_lld(_, _, [], [], !GlobalData).
-ml_gen_box_const_rval_list_lld(ModuleInfo, Context, [GroundTerm - ArgWidth | GroundTerms],
- [BoxedRval | BoxedRvals], !GlobalData) :-
- GroundTerm = ml_ground_term(Rval, _MercuryType, Type),
- (
- ArgWidth = double_word,
- DoubleWidth = yes
- ;
- ( ArgWidth = full_word
- ; ArgWidth = partial_word_first(_)
- ; ArgWidth = partial_word_shifted(_, _)
- ),
- DoubleWidth = no
- ),
- ml_gen_box_const_rval(ModuleInfo, Context, Type, DoubleWidth, Rval,
+ml_gen_box_const_rval_list_lld(ModuleInfo, Context,
+ [GroundTerm - ArgWidth | GroundTerms], [BoxedRval | BoxedRvals],
+ !GlobalData) :-
+ GroundTerm = ml_ground_term(Rval, _MercuryType, MLDS_Type),
+ arg_width_is_double(ArgWidth, DoubleWidth),
+ ml_gen_box_const_rval(ModuleInfo, Context, MLDS_Type, DoubleWidth, Rval,
BoxedRval, !GlobalData),
ml_gen_box_const_rval_list_lld(ModuleInfo, Context, GroundTerms,
BoxedRvals, !GlobalData).
@@ -1337,14 +1339,15 @@
ml_global_data::in, ml_global_data::out) is det.
ml_gen_box_extra_const_rval_list_lld(_, _, [], [], [], !GlobalData).
-ml_gen_box_extra_const_rval_list_lld(ModuleInfo, Context, [Type | Types],
- [Rval | Rvals], [BoxedRval | BoxedRvals], !GlobalData) :-
+ml_gen_box_extra_const_rval_list_lld(ModuleInfo, Context,
+ [MLDS_Type | MLDS_Types], [Rval | Rvals], [BoxedRval | BoxedRvals],
+ !GlobalData) :-
% Extras are always a single word.
DoubleWidth = no,
- ml_gen_box_const_rval(ModuleInfo, Context, Type, DoubleWidth, Rval,
- BoxedRval, !GlobalData),
- ml_gen_box_extra_const_rval_list_lld(ModuleInfo, Context, Types, Rvals,
- BoxedRvals, !GlobalData).
+ ml_gen_box_const_rval(ModuleInfo, Context, MLDS_Type, DoubleWidth,
+ Rval, BoxedRval, !GlobalData),
+ ml_gen_box_extra_const_rval_list_lld(ModuleInfo, Context, MLDS_Types,
+ Rvals, BoxedRvals, !GlobalData).
ml_gen_box_extra_const_rval_list_lld(_, _, [], [_ | _], _, !GlobalData) :-
unexpected($module, $pred, "length mismatch").
ml_gen_box_extra_const_rval_list_lld(_, _, [_ | _], [], _, !GlobalData) :-
@@ -1544,16 +1547,21 @@
; Tag = int_tag(_Int)
; Tag = foreign_tag(_, _)
; Tag = float_tag(_Float)
- ; Tag = closure_tag(_, _, _)
+ ; Tag = shared_local_tag(_Bits1, _Num1)
+ ; Tag = reserved_address_tag(_)
+ ),
+ Statements = []
+ ;
+ ( Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
- ; Tag = shared_local_tag(_Bits1, _Num1)
- ; Tag = reserved_address_tag(_)
),
- Statements = []
+ unexpected($module, $pred, "unexpected tag")
;
Tag = no_tag,
(
@@ -1643,6 +1651,8 @@
; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
@@ -1934,7 +1944,7 @@
->
true
;
- % Both input: it's a test unification.
+ % Both input: it is a test unification.
LeftMode = top_in,
RightMode = top_in
->
@@ -1943,7 +1953,7 @@
% unification.
unexpected($module, $pred, "test in arg of [de]construction")
;
- % Input - output: it's an assignment to the RHS.
+ % Input - output: it is an assignment to the RHS.
LeftMode = top_in,
RightMode = top_out
->
@@ -1979,7 +1989,7 @@
),
!:Statements = [Statement | !.Statements]
;
- % Output - input: it's an assignment to the LHS.
+ % Output - input: it is an assignment to the LHS.
LeftMode = top_out,
RightMode = top_in
->
@@ -2065,7 +2075,7 @@
->
unexpected($module, $pred, "dummy unify")
;
- % Both input: it's a test unification.
+ % Both input: it is a test unification.
LeftMode = top_in,
RightMode = top_in
->
@@ -2074,13 +2084,13 @@
% unification.
unexpected($module, $pred, "test in arg of [de]construction")
;
- % Input - output: it's an assignment to the RHS.
+ % Input - output: it is an assignment to the RHS.
LeftMode = top_in,
RightMode = top_out
->
unexpected($module, $pred, "left-to-right data flow in construction")
;
- % Output - input: it's an assignment to the LHS.
+ % Output - input: it is an assignment to the LHS.
LeftMode = top_out,
RightMode = top_in
->
@@ -2117,7 +2127,7 @@
->
unexpected($module, $pred, "dummy unify")
;
- % Both input: it's a test unification.
+ % Both input: it is a test unification.
LeftMode = top_in,
RightMode = top_in
->
@@ -2126,7 +2136,7 @@
% unification.
unexpected($module, $pred, "test in arg of [de]construction")
;
- % Input - output: it's an assignment to the RHS.
+ % Input - output: it is an assignment to the RHS.
LeftMode = top_in,
RightMode = top_out
->
@@ -2138,7 +2148,7 @@
Statement = ml_gen_assign(ArgLval, CastRval, Context),
Statements = [Statement]
;
- % Output - input: it's an assignment to the LHS.
+ % Output - input: it is an assignment to the LHS.
LeftMode = top_out,
RightMode = top_in
->
@@ -2255,6 +2265,8 @@
( Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
@@ -2353,7 +2365,7 @@
ml_gen_hl_tag_field_id(ModuleInfo, Type) = FieldId :-
FieldName = "data_tag",
% Figure out the type name and arity.
- type_to_ctor_and_args_det(Type, TypeCtor, _),
+ type_to_ctor_det(Type, TypeCtor),
ml_gen_type_name(TypeCtor, QualifiedTypeName, TypeArity),
QualifiedTypeName = qual(MLDS_Module, TypeQualKind, TypeName),
@@ -2414,7 +2426,7 @@
mlds_class_name, arity, mlds_field_name) = mlds_field_id.
ml_gen_field_id(Target, Type, Tag, ConsName, ConsArity, FieldName) = FieldId :-
- type_to_ctor_and_args_det(Type, TypeCtor, _),
+ type_to_ctor_det(Type, TypeCtor),
ml_gen_type_name(TypeCtor, QualTypeName, TypeArity),
QualTypeName = qual(MLDS_Module, QualKind, TypeName),
TypeQualifier = mlds_append_class_qualifier(Target, MLDS_Module, QualKind,
@@ -2423,7 +2435,7 @@
UsesBaseClass = ml_tag_uses_base_class(Tag),
(
UsesBaseClass = tag_uses_base_class,
- % In this case, there's only one functor for the type (other than
+ % In this case, there is only one functor for the type (other than
% reserved_address constants), and so the class name is determined
% by the type name.
ClassPtrType = mlds_ptr_type(mlds_class_type(QualTypeName,
@@ -2568,6 +2580,8 @@
;
( ConsTag = type_ctor_info_tag(_, _, _)
; ConsTag = base_typeclass_info_tag(_, _, _)
+ ; ConsTag = type_info_const_tag(_)
+ ; ConsTag = typeclass_info_const_tag(_)
; ConsTag = deep_profiling_proc_layout_tag(_, _)
; ConsTag = tabling_info_tag(_, _)
; ConsTag = table_io_decl_tag(_, _)
@@ -2677,17 +2691,17 @@
% then polymorphism should have changed its scope_reason
% away from from_ground_term_construct.
expect(unify(NumExtraArgs, 0), $module, $pred,
- "xxx: extra args in from_ground_term_construct scope")
+ "extra args in from_ground_term_construct scope")
;
% If we didn't find a constructor definition, maybe that is because
% this type was a built-in tuple type.
type_is_tuple(VarType, _)
->
% In this case, the argument types are all fresh variables.
- % Note that we don't need to worry about using the right varset
+ % Note that we do not need to worry about using the right varset
% here, since all we really care about at this point is whether
- % something is a type variable or not, not which type variable it
- % is.
+ % something is a type variable or not, not which type variable
+ % it is.
Length = list.length(Args),
ConsArgTypes = ml_make_boxed_types(Length),
ConsArgWidths = list.duplicate(Length, full_word)
@@ -2832,6 +2846,348 @@
%-----------------------------------------------------------------------------%
+ml_gen_const_structs(ModuleInfo, ConstStructMap, !GlobalData) :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
+ globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
+ Info = ml_const_struct_info(ModuleInfo, Target, HighLevelData),
+
+ module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
+ const_struct_db_get_structs(ConstStructDb, ConstStructs),
+ list.foldl2(ml_gen_const_struct(Info), ConstStructs,
+ map.init, ConstStructMap, !GlobalData).
+
+:- type ml_const_struct_info
+ ---> ml_const_struct_info(
+ mcsi_module_info :: module_info,
+ mcsi_target :: compilation_target,
+ mcsi_high_level_data :: bool
+ ).
+
+:- pred ml_gen_const_struct(ml_const_struct_info::in,
+ pair(int, const_struct)::in,
+ ml_const_struct_map::in, ml_const_struct_map::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_const_struct(Info, ConstNum - ConstStruct, !ConstStructMap,
+ !GlobalData) :-
+ ConstStruct = const_struct(ConsId, Args, Type, _Inst),
+ ModuleInfo = Info ^ mcsi_module_info,
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
+ ml_gen_const_struct_tag(Info, ConstNum, Type, MLDS_Type, ConsId, ConsTag,
+ Args, !ConstStructMap, !GlobalData).
+
+:- pred ml_gen_const_struct_tag(ml_const_struct_info::in, int::in,
+ mer_type::in, mlds_type::in, cons_id::in, cons_tag::in,
+ list(const_struct_arg)::in,
+ ml_const_struct_map::in, ml_const_struct_map::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_const_struct_tag(Info, ConstNum, Type, MLDS_Type, ConsId, ConsTag,
+ Args, !ConstStructMap, !GlobalData) :-
+ (
+ ConsTag = shared_with_reserved_addresses_tag(_, ThisTag),
+ % Whether or not some other constructors in the type are represented
+ % by reserved addresses makes a difference only when deconstructing
+ % the term, not when constructing it.
+ ml_gen_const_struct_tag(Info, ConstNum, Type, MLDS_Type, ConsId,
+ ThisTag, Args, !ConstStructMap, !GlobalData)
+ ;
+ ( ConsTag = no_tag
+ ; ConsTag = direct_arg_tag(_)
+ ),
+ (
+ Args = [_Arg],
+ unexpected($module, $pred, "NYI")
+ ;
+ ( Args = []
+ ; Args = [_, _ | _]
+ ),
+ unexpected($module, $pred, "no_tag arity != 1")
+ )
+ ;
+ % Ordinary compound terms.
+ % This code (loosely) follows the code of ml_gen_compound.
+ (
+ ConsTag = single_functor_tag,
+ Ptag = 0,
+ ExtraInitializers = []
+ ;
+ ConsTag = unshared_tag(Ptag),
+ ExtraInitializers = []
+ ;
+ ConsTag = shared_remote_tag(Ptag, Stag),
+ Target = Info ^ mcsi_target,
+ UsesConstructors = ml_target_uses_constructors(Target),
+ (
+ UsesConstructors = no,
+ StagRval0 = ml_const(mlconst_int(Stag)),
+ HighLevelData = Info ^ mcsi_high_level_data,
+ (
+ HighLevelData = no,
+ % XXX why is this cast here?
+ StagRval = ml_unop(box(mlds_native_char_type), StagRval0)
+ ;
+ HighLevelData = yes,
+ StagRval = StagRval0
+ ),
+ ExtraInitializers = [init_obj(StagRval)]
+ ;
+ UsesConstructors = yes,
+ ExtraInitializers = []
+ )
+ ),
+ ml_gen_const_static_compound(Info, ConstNum, Type, MLDS_Type,
+ ConsId, ConsTag, Ptag, ExtraInitializers, Args,
+ !ConstStructMap, !GlobalData)
+ ;
+ % These tags don't build heap cells.
+ ( ConsTag = int_tag(_)
+ ; ConsTag = float_tag(_)
+ ; ConsTag = string_tag(_)
+ ; ConsTag = reserved_address_tag(_)
+ ; ConsTag = shared_local_tag(_, _)
+ ; ConsTag = foreign_tag(_, _)
+ ; ConsTag = type_ctor_info_tag(_, _, _)
+ ; ConsTag = base_typeclass_info_tag(_, _, _)
+ % These tags should never occur in constant data.
+ ; ConsTag = closure_tag(_, _, _)
+ ; ConsTag = tabling_info_tag(_, _)
+ % These tags should never occur in constant data in this position.
+ ; ConsTag = type_info_const_tag(_)
+ ; ConsTag = typeclass_info_const_tag(_)
+ % These tags should never occur in MLDS grades.
+ ; ConsTag = deep_profiling_proc_layout_tag(_, _)
+ ; ConsTag = table_io_decl_tag(_, _)
+ ),
+ unexpected($module, $pred, "unexpected tag")
+ ).
+
+:- pred ml_gen_const_static_compound(ml_const_struct_info::in,
+ int::in, mer_type::in, mlds_type::in, cons_id::in, cons_tag::in,
+ int::in, list(mlds_initializer)::in, list(const_struct_arg)::in,
+ ml_const_struct_map::in, ml_const_struct_map::out,
+ ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_const_static_compound(Info, ConstNum, Type, MLDS_Type, ConsId, ConsTag,
+ Ptag, ExtraInitializers, Args, !ConstStructMap, !GlobalData) :-
+ % This code (loosely) follows the code of
+ % ml_gen_ground_term_conjunct_compound.
+
+ Target = Info ^ mcsi_target,
+ ModuleInfo = Info ^ mcsi_module_info,
+ (
+ ConsId = cons(_, _, _),
+ \+ is_introduced_type_info_type(Type)
+ ->
+ % Determine the type_ctor, and then look up the data constructor.
+ type_to_ctor_det(Type, TypeCtor),
+ (
+ type_util.get_cons_defn(ModuleInfo, TypeCtor, ConsId, ConsDefn)
+ ->
+ ConsArgDefns = ConsDefn ^ cons_args,
+ % XXX the compiler crashes if you try to write this with list.map2
+ % ConsArgTypes = list.map(func(C) = C ^ arg_type, ConsArgDefns),
+ ConsArgWidths = list.map(func(C) = C ^ arg_width, ConsArgDefns),
+ NumExtraArgs = list.length(Args) - list.length(ConsArgDefns),
+ % If the scope contains existentially typed constructions,
+ % then polymorphism should have changed its scope_reason
+ % away from from_ground_term_construct.
+ expect(unify(NumExtraArgs, 0), $module, $pred,
+ "extra args in static const struct")
+ ;
+ % If we didn't find a constructor definition, maybe that is because
+ % this type was a built-in tuple type.
+ type_is_tuple(Type, _)
+ ->
+ % In this case, the argument types are all fresh variables.
+ % Note that we do not need to worry about using the right varset
+ % here, since all we really care about at this point is whether
+ % something is a type variable or not, not which type variable
+ % it is.
+ Length = list.length(Args),
+ % ConsArgTypes = ml_make_boxed_types(Length),
+ ConsArgWidths = list.duplicate(Length, full_word)
+ ;
+ % Type_util.get_cons_defn shouldn't have failed.
+ unexpected($module, $pred, "get_cons_defn failed")
+ )
+ ;
+ Length = list.length(Args),
+ % ConsArgTypes = ArgTypes,
+ ConsArgWidths = list.duplicate(Length, full_word)
+ ),
+ HighLevelData = Info ^ mcsi_high_level_data,
+ (
+ HighLevelData = yes,
+ unexpected($module, $pred, "HighLevelData NYI")
+ ;
+ HighLevelData = no,
+ assoc_list.from_corresponding_lists(Args, ConsArgWidths,
+ ArgConsArgWidths),
+ ml_gen_const_struct_args(Info, !.ConstStructMap,
+ ArgConsArgWidths, ArgRvals1, !GlobalData)
+ ),
+ pack_args(ml_shift_combine_rval, ConsArgWidths, ArgRvals1, ArgRvals,
+ unit, _, unit, _),
+ ArgInitializers = list.map(func(Init) = init_obj(Init), ArgRvals),
+
+ % By construction, boxing the rvals in ExtraInitializers would be a no-op.
+ SubInitializers = ExtraInitializers ++ ArgInitializers,
+
+ % Generate a local static constant for this term.
+ ConstType = get_const_type_for_cons_id(Target, HighLevelData, MLDS_Type,
+ ml_tag_uses_base_class(ConsTag), yes(ConsId)),
+ % XXX If the secondary tag is in a base class, then ideally its
+ % initializer should be wrapped in `init_struct([init_obj(X)])'
+ % rather than just `init_obj(X)' -- the fact that we don't leads to
+ % some warnings from GNU C about missing braces in initializers.
+ ( ConstType = mlds_array_type(_) ->
+ Initializer = init_array(SubInitializers)
+ ;
+ Initializer = init_struct(ConstType, SubInitializers)
+ ),
+ module_info_get_name(ModuleInfo, ModuleName),
+ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName),
+ ml_gen_static_scalar_const_addr(MLDS_ModuleName, "const_var", ConstType,
+ Initializer, term.context_init, ConstDataAddrRval, !GlobalData),
+
+ % Assign the (possibly tagged) address of the local static constant
+ % to the variable.
+ ( Ptag = 0 ->
+ TaggedRval = ConstDataAddrRval
+ ;
+ TaggedRval = ml_mkword(Ptag, ConstDataAddrRval)
+ ),
+ Rval = ml_unop(cast(MLDS_Type), TaggedRval),
+ GroundTerm = ml_ground_term(Rval, Type, MLDS_Type),
+ map.det_insert(ConstNum, GroundTerm, !ConstStructMap).
+
+:- pred ml_gen_const_struct_args(ml_const_struct_info::in,
+ ml_const_struct_map::in, assoc_list(const_struct_arg, arg_width)::in,
+ list(mlds_rval)::out, ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_const_struct_args(_, _, [], [], !GlobalData).
+ml_gen_const_struct_args(Info, ConstStructMap,
+ [Arg - ConsArgWidth | ArgConsArgWidths], [ArgRval | ArgRvals],
+ !GlobalData) :-
+ ml_gen_const_struct_arg(Info, ConstStructMap,
+ Arg, ConsArgWidth, ArgRval, !GlobalData),
+ ml_gen_const_struct_args(Info, ConstStructMap,
+ ArgConsArgWidths, ArgRvals, !GlobalData).
+
+:- pred ml_gen_const_struct_arg(ml_const_struct_info::in,
+ ml_const_struct_map::in, const_struct_arg::in, arg_width::in,
+ mlds_rval::out, ml_global_data::in, ml_global_data::out) is det.
+
+ml_gen_const_struct_arg(Info, ConstStructMap,
+ ConstArg, ConsArgWidth, Rval, !GlobalData) :-
+ ModuleInfo = Info ^ mcsi_module_info,
+ (
+ ConstArg = csa_const_struct(StructNum),
+ map.lookup(ConstStructMap, StructNum, GroundTerm),
+ GroundTerm = ml_ground_term(Rval0, _Type, MLDS_Type)
+ ;
+ ConstArg = csa_constant(ConsId, Type),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type),
+ ml_gen_const_struct_arg_tag(ModuleInfo, ConsId, ConsTag,
+ Type, MLDS_Type, Rval0)
+ ),
+ arg_width_is_double(ConsArgWidth, DoubleWidth),
+ ml_gen_box_const_rval(ModuleInfo, term.context_init, MLDS_Type,
+ DoubleWidth, Rval0, Rval, !GlobalData).
+
+:- pred ml_gen_const_struct_arg_tag(module_info::in, cons_id::in, cons_tag::in,
+ mer_type::in, mlds_type::in, mlds_rval::out) is det.
+
+ml_gen_const_struct_arg_tag(ModuleInfo, ConsId, ConsTag, Type, MLDS_Type,
+ Rval) :-
+ (
+ ConsTag = int_tag(Int),
+ ( Type = int_type ->
+ Rval = ml_const(mlconst_int(Int))
+ ; Type = char_type ->
+ Rval = ml_const(mlconst_char(Int))
+ ;
+ Rval = ml_const(mlconst_enum(Int, MLDS_Type))
+ )
+ ;
+ ConsTag = float_tag(Float),
+ Rval = ml_const(mlconst_float(Float))
+ ;
+ ConsTag = string_tag(String),
+ Rval = ml_const(mlconst_string(String))
+ ;
+ ConsTag = reserved_address_tag(ResAddr),
+ Rval = ml_gen_reserved_address(ModuleInfo, ResAddr, MLDS_Type)
+ ;
+ ConsTag = shared_local_tag(Ptag, Stag),
+ Rval = ml_unop(cast(MLDS_Type), ml_mkword(Ptag,
+ ml_unop(std_unop(mkbody), ml_const(mlconst_int(Stag)))))
+ ;
+ ConsTag = foreign_tag(ForeignLang, ForeignTag),
+ Rval = ml_const(mlconst_foreign(ForeignLang, ForeignTag, MLDS_Type))
+ ;
+ ConsTag = type_ctor_info_tag(ModuleName0, TypeName, TypeArity),
+ ModuleName = fixup_builtin_module(ModuleName0),
+ MLDS_Module = mercury_module_name_to_mlds(ModuleName),
+ RttiTypeCtor = rtti_type_ctor(ModuleName, TypeName, TypeArity),
+ DataAddr = data_addr(MLDS_Module,
+ mlds_rtti(ctor_rtti_id(RttiTypeCtor, type_ctor_type_ctor_info))),
+ Rval = ml_unop(cast(MLDS_Type), ml_const(mlconst_data_addr(DataAddr)))
+ ;
+ ConsTag = base_typeclass_info_tag(ModuleName, ClassId, Instance),
+ MLDS_Module = mercury_module_name_to_mlds(ModuleName),
+ TCName = generate_class_name(ClassId),
+ DataAddr = data_addr(MLDS_Module, mlds_rtti(tc_rtti_id(TCName,
+ type_class_base_typeclass_info(ModuleName, Instance)))),
+ Rval = ml_unop(cast(MLDS_Type), ml_const(mlconst_data_addr(DataAddr)))
+ ;
+ ConsTag = shared_with_reserved_addresses_tag(_, ThisTag),
+ % Whether or not some other constructors in the type are represented
+ % by reserved addresses makes a difference only when deconstructing
+ % the term, not when constructing it.
+ ml_gen_const_struct_arg_tag(ModuleInfo, ConsId, ThisTag,
+ Type, MLDS_Type, Rval)
+ ;
+ % Instead of these tags in csa_constants, polymorphism.m builds
+ % csa_const_structs.
+ ( ConsTag = type_info_const_tag(_)
+ ; ConsTag = typeclass_info_const_tag(_)
+ % These tags build heap cells, not constants.
+ ; ConsTag = no_tag
+ ; ConsTag = direct_arg_tag(_)
+ ; ConsTag = single_functor_tag
+ ; ConsTag = unshared_tag(_)
+ ; ConsTag = shared_remote_tag(_, _)
+ % These tag should never occur in constant data.
+ ; ConsTag = closure_tag(_, _, _)
+ ; ConsTag = tabling_info_tag(_, _)
+ % These tags should never occur in MLDS grades.
+ ; ConsTag = deep_profiling_proc_layout_tag(_, _)
+ ; ConsTag = table_io_decl_tag(_, _)
+ ),
+ unexpected($module, $pred, "unexpected tag")
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred arg_width_is_double(arg_width::in, bool::out) is det.
+
+arg_width_is_double(ArgWidth, DoubleWidth) :-
+ (
+ ArgWidth = double_word,
+ DoubleWidth = yes
+ ;
+ ( ArgWidth = full_word
+ ; ArgWidth = partial_word_first(_)
+ ; ArgWidth = partial_word_shifted(_, _)
+ ),
+ DoubleWidth = no
+ ).
+
:- pred ml_expand_double_word_rvals(list(arg_width)::in, list(arg_width)::out,
assoc_list(mlds_rval, mlds_type)::in,
assoc_list(mlds_rval, mlds_type)::out) is det.
@@ -2899,8 +3255,8 @@
:- func ml_lshift(mlds_rval, int) = mlds_rval.
ml_lshift(Rval0, Shift) = Rval :-
- % We may get nulls from unfilled fields. Replace them with zeroes so we
- % don't get type errors from the C compiler.
+ % We may get nulls from unfilled fields. Replace them with zeroes
+ % so we don't get type errors from the C compiler.
( Rval0 = ml_const(mlconst_null(_)) ->
Rval = ml_const(mlconst_int(0))
; Shift = 0 ->
Index: compiler/ml_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_util.m,v
retrieving revision 1.73
diff -u -b -r1.73 ml_util.m
--- compiler/ml_util.m 20 May 2011 04:16:48 -0000 1.73
+++ compiler/ml_util.m 7 Jun 2012 05:32:26 -0000
@@ -846,7 +846,7 @@
%-----------------------------------------------------------------------------%
type_needs_lowlevel_rep(Target, Type) :-
- type_to_ctor_and_args(Type, TypeCtor, _Args),
+ type_to_ctor(Type, TypeCtor),
type_ctor_needs_lowlevel_rep(Target, TypeCtor).
% XXX Do we need to do the same for the Java back-end?
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.262
diff -u -b -r1.262 mlds_to_c.m
--- compiler/mlds_to_c.m 8 Dec 2011 23:24:14 -0000 1.262
+++ compiler/mlds_to_c.m 7 Jun 2012 05:32:26 -0000
@@ -1833,7 +1833,7 @@
ClassType = Type
;
Type = mercury_type(MercuryType, ctor_cat_user(_), _),
- type_to_ctor_and_args(MercuryType, TypeCtor, _ArgsTypes),
+ type_to_ctor(MercuryType, TypeCtor),
ml_gen_type_name(TypeCtor, ClassName, ClassArity),
ClassType = mlds_class_type(ClassName, ClassArity, mlds_class)
)
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.227
diff -u -b -r1.227 mlds_to_il.m
--- compiler/mlds_to_il.m 26 Mar 2012 00:43:32 -0000 1.227
+++ compiler/mlds_to_il.m 7 Jun 2012 05:32:26 -0000
@@ -3263,7 +3263,7 @@
:- func mercury_type_to_highlevel_class_type(mer_type) = il_type.
mercury_type_to_highlevel_class_type(MercuryType) = ILType :-
- type_to_ctor_and_args_det(MercuryType, TypeCtor, _Args),
+ type_to_ctor_det(MercuryType, TypeCtor),
ml_gen_type_name(TypeCtor, ClassName, Arity),
ILType = il_type([], class(
mlds_class_name_to_ilds_class_name(ClassName, Arity))).
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.223
diff -u -b -r1.223 mode_util.m
--- compiler/mode_util.m 24 Apr 2012 11:22:03 -0000 1.223
+++ compiler/mode_util.m 7 Jun 2012 05:32:26 -0000
@@ -299,7 +299,7 @@
% Is this a no_tag type?
type_is_no_tag_type(ModuleInfo, Type, FunctorName, ArgType),
% Avoid infinite recursion.
- type_to_ctor_and_args(Type, TypeCtor, _TypeArgs),
+ type_to_ctor(Type, TypeCtor),
\+ list.member(TypeCtor, ContainingTypes)
->
% The arg_mode will be determined by the mode and type of the
@@ -1646,6 +1646,8 @@
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
; ConsId = tabling_info_const(_)
; ConsId = table_io_decl(_)
; ConsId = deep_profiling_proc_layout(_)
@@ -1669,6 +1671,21 @@
get_arg_lives(ModuleInfo, Modes, IsLives).
%-----------------------------------------------------------------------------%
+
+fixup_instmap_switch_var(Var, InstMap0, InstMap, Goal0, Goal) :-
+ Goal0 = hlds_goal(GoalExpr, GoalInfo0),
+ InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
+ instmap_lookup_var(InstMap0, Var, Inst0),
+ instmap_lookup_var(InstMap, Var, Inst),
+ ( Inst = Inst0 ->
+ GoalInfo = GoalInfo0
+ ;
+ instmap_delta_set_var(Var, Inst, InstMapDelta0, InstMapDelta),
+ goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo)
+ ),
+ Goal = hlds_goal(GoalExpr, GoalInfo).
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
normalise_insts(_, [], [], []).
@@ -1723,21 +1740,6 @@
%-----------------------------------------------------------------------------%
-fixup_instmap_switch_var(Var, InstMap0, InstMap, Goal0, Goal) :-
- Goal0 = hlds_goal(GoalExpr, GoalInfo0),
- InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
- instmap_lookup_var(InstMap0, Var, Inst0),
- instmap_lookup_var(InstMap, Var, Inst),
- ( Inst = Inst0 ->
- GoalInfo = GoalInfo0
- ;
- instmap_delta_set_var(Var, Inst, InstMapDelta0, InstMapDelta),
- goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo)
- ),
- Goal = hlds_goal(GoalExpr, GoalInfo).
-
-%-----------------------------------------------------------------------------%
-
partition_args(_, [], [_ | _], _, _) :-
unexpected($module, $pred, "length mismatch").
partition_args(_, [_ | _], [], _, _) :-
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_call.m,v
retrieving revision 1.91
diff -u -b -r1.91 modecheck_call.m
--- compiler/modecheck_call.m 13 Feb 2012 00:11:42 -0000 1.91
+++ compiler/modecheck_call.m 7 Jun 2012 05:32:26 -0000
@@ -177,7 +177,8 @@
modecheck_find_matching_modes(ProcIds, PredId, Procs, ArgVars0,
[], RevMatchingProcIds, WaitingVars0, WaitingVars1, !ModeInfo),
- ( RevMatchingProcIds = [],
+ (
+ RevMatchingProcIds = [],
no_matching_modes(PredId, ArgVars0, DeterminismKnown,
WaitingVars1, TheProcId, !ModeInfo),
ArgVars = ArgVars0,
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.146
diff -u -b -r1.146 modecheck_unify.m
--- compiler/modecheck_unify.m 23 Apr 2012 03:34:48 -0000 1.146
+++ compiler/modecheck_unify.m 7 Jun 2012 05:32:26 -0000
@@ -56,6 +56,7 @@
:- import_module check_hlds.type_util.
:- import_module check_hlds.unify_proc.
:- import_module check_hlds.unique_modes.
+:- import_module hlds.const_struct.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
@@ -145,6 +146,8 @@
)
).
+%-----------------------------------------------------------------------------%
+
:- pred modecheck_unification_var(prog_var::in, prog_var::in, unification::in,
unify_context::in, hlds_goal_info::in, hlds_goal_expr::out,
mode_info::in, mode_info::out) is det.
@@ -241,16 +244,19 @@
UnifyGoalExpr = unify(X, rhs_var(Y), Modes, Unification, UnifyContext)
).
+%-----------------------------------------------------------------------------%
+
:- pred modecheck_unification_functor(prog_var::in, cons_id::in,
is_existential_construction::in, list(prog_var)::in, unification::in,
unify_context::in, hlds_goal_info::in, hlds_goal_expr::out,
mode_info::in, mode_info::out) is det.
-modecheck_unification_functor(X0, ConsId0, IsExistConstruction, ArgVars0,
- Unification0, UnifyContext, GoalInfo0, Goal, !ModeInfo) :-
+modecheck_unification_functor(X, ConsId, IsExistConstruction, ArgVars0,
+ Unification0, UnifyContext, GoalInfo0, GoalExpr, !ModeInfo) :-
mode_info_get_var_types(!.ModeInfo, VarTypes0),
- map.lookup(VarTypes0, X0, TypeOfX),
+ map.lookup(VarTypes0, X, TypeOfX),
+ (
% We replace any unifications with higher-order pred constants
% by lambda expressions. For example, we replace
%
@@ -266,32 +272,42 @@
% Note that any changes to this code here will probably need to be
% duplicated there too.
- (
- % Check if the variable has a higher-order type.
type_is_higher_order_details(TypeOfX, Purity, _, EvalMethod,
PredArgTypes),
- ConsId0 = closure_cons(ShroudedPredProcId, _)
+ ConsId = closure_cons(ShroudedPredProcId, _)
->
% Convert the pred term to a lambda expression.
mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
mode_info_get_varset(!.ModeInfo, VarSet0),
mode_info_get_context(!.ModeInfo, Context),
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
- convert_pred_to_lambda_goal(Purity, EvalMethod, X0, PredId, ProcId,
+ convert_pred_to_lambda_goal(Purity, EvalMethod, X, PredId, ProcId,
ArgVars0, PredArgTypes, UnifyContext, GoalInfo0, Context,
ModuleInfo0, Functor0, VarSet0, VarSet, VarTypes0, VarTypes),
mode_info_set_varset(VarSet, !ModeInfo),
mode_info_set_var_types(VarTypes, !ModeInfo),
% Modecheck this unification in its new form.
- modecheck_unification(X0, Functor0, Unification0, UnifyContext,
- GoalInfo0, Goal, !ModeInfo)
+ modecheck_unification(X, Functor0, Unification0, UnifyContext,
+ GoalInfo0, GoalExpr, !ModeInfo)
;
- % It is not a higher-order pred unification, so just call
- % modecheck_unify_functor to do the ordinary thing.
- modecheck_unify_functor(X0, TypeOfX, ConsId0,
- IsExistConstruction, ArgVars0, Unification0,
- UnifyContext, GoalInfo0, Goal, !ModeInfo)
+ % Right hand sides that represent constant structures need to be
+ % handled specially, because the term is inherently shared.
+ cons_id_is_const_struct(ConsId, ConstNum)
+ ->
+ expect(unify(IsExistConstruction, no), $module, $pred,
+ "const struct construction is existential"),
+ expect(unify(ArgVars0, []), $module, $pred,
+ "const struct construction has args"),
+ modecheck_unify_const_struct(X, ConsId, ConstNum, UnifyContext,
+ GoalExpr, !ModeInfo)
+ ;
+ % It is not a higher-order pred unification or a unification with a
+ % constant structure, so just call modecheck_unify_functor to do
+ % the ordinary thing.
+ modecheck_unify_functor(X, TypeOfX, ConsId, IsExistConstruction,
+ ArgVars0, Unification0, UnifyContext, GoalInfo0, GoalExpr,
+ !ModeInfo)
).
:- pred modecheck_unification_rhs_lambda(prog_var::in,
@@ -574,6 +590,64 @@
unexpected($module, $pred, "expecting single call")
).
+%-----------------------------------------------------------------------------%
+
+:- pred modecheck_unify_const_struct(prog_var::in, cons_id::in, int::in,
+ unify_context::in, hlds_goal_expr::out,
+ mode_info::in, mode_info::out) is det.
+
+modecheck_unify_const_struct(X, ConsId, ConstNum, UnifyContext,
+ UnifyGoalExpr, !ModeInfo) :-
+ mode_info_get_instmap(!.ModeInfo, InstMap),
+ instmap_lookup_var(InstMap, X, InstOfX),
+ mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
+ module_info_get_const_struct_db(ModuleInfo0, ConstStructDb),
+ lookup_const_struct_num(ConstStructDb, ConstNum, ConstStruct),
+ ConstStruct = const_struct(_, _, _, InstOfY),
+ ( inst_is_free(ModuleInfo0, InstOfX) ->
+ Inst = InstOfY,
+ modecheck_set_var_inst(X, Inst, yes(InstOfY), !ModeInfo),
+ Unification = construct(X, ConsId, [], [], construct_statically,
+ cell_is_shared, no_construct_sub_info),
+ ModeOfX = (InstOfX -> Inst),
+ ModeOfY = (InstOfY -> Inst),
+ Modes = ModeOfX - ModeOfY,
+ UnifyGoalExpr = unify(X, rhs_functor(ConsId, no, []), Modes,
+ Unification, UnifyContext)
+ ;
+% abstractly_unify_inst(LiveX, InstOfX, InstOfY, real_unify,
+% UnifyInst, Det1, ModuleInfo0, ModuleInfo1)
+% ->
+% Inst = UnifyInst,
+% Det = Det1,
+% mode_info_set_module_info(ModuleInfo1, !ModeInfo),
+% modecheck_set_var_inst(Y, Inst, yes(InstOfX), !ModeInfo),
+% ModeOfX = (InstOfX -> Inst),
+% ModeOfY = (InstOfY -> Inst),
+% categorize_unify_var_const_struct(ModeOfX, ModeOfY, LiveX, X, ConsId,
+% Det, UnifyContext, UnifyGoalInfo0, VarTypes, Unification0,
+% UnifyGoalExpr0, !ModeInfo),
+% ;
+ set_of_var.list_to_set([X], WaitingVars),
+ ModeError = mode_error_unify_var_functor(X, ConsId, [], InstOfX, []),
+ mode_info_error(WaitingVars, ModeError, !ModeInfo),
+ % If we get an error, set the inst to not_reached to suppress
+ % follow-on errors. But don't call categorize_unification, because
+ % that could cause an invalid call to `unify_proc.request_unify'
+ Inst = not_reached,
+ modecheck_set_var_inst(X, Inst, no, !ModeInfo),
+ % Return any old garbage.
+ Unification = construct(X, ConsId, [], [], construct_statically,
+ cell_is_shared, no_construct_sub_info),
+ ModeOfX = (InstOfX -> Inst),
+ ModeOfY = (InstOfY -> Inst),
+ Modes = ModeOfX - ModeOfY,
+ UnifyGoalExpr = unify(X, rhs_functor(ConsId, no, []), Modes,
+ Unification, UnifyContext)
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- pred modecheck_unify_functor(prog_var::in, mer_type::in, cons_id::in,
is_existential_construction::in, list(prog_var)::in, unification::in,
unify_context::in, hlds_goal_info::in, hlds_goal_expr::out,
@@ -584,11 +658,6 @@
mode_info_get_module_info(!.ModeInfo, ModuleInfo0),
mode_info_get_how_to_check(!.ModeInfo, HowToCheckGoal),
- % Fully module qualify all cons_ids (except for builtins such as
- % ints and characters).
-
- qualify_cons_id(ArgVars0, ConsId0, ConsId, InstConsId),
-
mode_info_get_instmap(!.ModeInfo, InstMap0),
instmap_lookup_var(InstMap0, X0, InstOfX0),
(
@@ -646,6 +715,7 @@
mode_info_get_instmap(!.ModeInfo, InstMap1),
instmap_lookup_vars(InstMap1, ArgVars0, InstArgs),
mode_info_var_list_is_live(!.ModeInfo, ArgVars0, LiveArgs),
+ qualify_cons_id(ArgVars0, ConsId0, ConsId, InstConsId),
InstOfY = bound(unique, inst_test_no_results,
[bound_functor(InstConsId, InstArgs)]),
(
Index: compiler/modecheck_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modecheck_util.m,v
retrieving revision 1.11
diff -u -b -r1.11 modecheck_util.m
--- compiler/modecheck_util.m 23 Apr 2012 03:34:48 -0000 1.11
+++ compiler/modecheck_util.m 7 Jun 2012 05:32:26 -0000
@@ -490,8 +490,8 @@
list(mer_inst)::in, int::in, inst_var_sub::in, inst_var_sub::out,
mode_info::in, mode_info::out) is det.
-modecheck_var_has_inst_list_no_exact_match_2([_ | _], [], _, !Subst,
- !ModeInfo) :-
+modecheck_var_has_inst_list_no_exact_match_2([_ | _], [], _,
+ !Subst, !ModeInfo) :-
unexpected($module, $pred, "length mismatch").
modecheck_var_has_inst_list_no_exact_match_2([], [_ | _], _,
!Subst, !ModeInfo) :-
@@ -874,7 +874,7 @@
construct_initialisation_call(Var, VarType, Inst, Context,
MaybeCallUnifyContext, InitVarGoal, !ModeInfo) :-
(
- type_to_ctor_and_args(VarType, TypeCtor, _TypeArgs),
+ type_to_ctor(VarType, TypeCtor),
PredName = special_pred_name(spec_pred_init, TypeCtor),
(
TypeCtor = type_ctor(qualified(ModuleName, _TypeName), _Arity)
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.191
diff -u -b -r1.191 module_qual.m
--- compiler/module_qual.m 5 Jun 2012 15:14:27 -0000 1.191
+++ compiler/module_qual.m 7 Jun 2012 05:32:26 -0000
@@ -1275,6 +1275,8 @@
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
; ConsId = tabling_info_const(_)
; ConsId = table_io_decl(_)
; ConsId = deep_profiling_proc_layout(_)
Index: compiler/options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.715
diff -u -b -r1.715 options.m
--- compiler/options.m 5 Apr 2012 05:57:42 -0000 1.715
+++ compiler/options.m 7 Jun 2012 05:32:26 -0000
@@ -647,6 +647,7 @@
; inline_vars_threshold
; intermod_inline_simple_threshold
; from_ground_term_threshold
+ ; enable_const_struct
; common_struct
; common_struct_preds
; common_goal
@@ -1550,6 +1551,7 @@
% Has no effect until
% --intermodule-optimization.
from_ground_term_threshold - int(5),
+ enable_const_struct - bool(yes),
common_struct - bool(no),
common_struct_preds - string(""),
common_goal - bool(yes),
@@ -2409,6 +2411,7 @@
long_option("from-ground-term-threshold",
from_ground_term_threshold).
long_option("inline-vars-threshold", inline_vars_threshold).
+long_option("const-struct", enable_const_struct).
long_option("common-struct", common_struct).
long_option("common-struct-preds", common_struct_preds).
long_option("common-goal", common_goal).
@@ -4994,6 +4997,8 @@
% "\tWrap a from_ground_term scope around the expanded,",
% "\tsuperhomogeneous form of a ground term that involves at least.",
% "\tthe given number of function symbols.",
+ "--no-const-struct",
+ "\tDisable the gathering of constant structures in a separate table.",
"--no-common-struct",
"\tDisable optimization of common term structures.",
% "--common-struct-preds <predids>",
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.379
diff -u -b -r1.379 polymorphism.m
--- compiler/polymorphism.m 5 Jun 2012 15:14:27 -0000 1.379
+++ compiler/polymorphism.m 7 Jun 2012 05:32:26 -0000
@@ -7,7 +7,7 @@
%-----------------------------------------------------------------------------%
%
% File: polymorphism.m.
-% Main author: fjh.
+% Main authors: fjh and zs.
%
% This module is a pass over the HLDS.
% It does a syntactic transformation to implement polymorphism, including
@@ -296,18 +296,6 @@
%
:- pred build_type_info_type(mer_type::in, mer_type::out) is det.
- % Succeed if the predicate is one of the predicates defined in
- % library/private_builtin.m to extract type_infos or typeclass_infos
- % from typeclass_infos.
- %
-:- pred is_typeclass_info_manipulator(module_info::in, pred_id::in,
- typeclass_info_manipulator::out) is semidet.
-
-:- type typeclass_info_manipulator
- ---> type_info_from_typeclass_info
- ; superclass_from_typeclass_info
- ; instance_constraint_from_typeclass_info.
-
% Look up the pred_id and proc_id for a type specific
% unification/comparison/index/initialise predicate.
%
@@ -356,11 +344,13 @@
rtti_varmaps::in, rtti_varmaps::out) is det.
% init_const_type_ctor_info_var(Type, TypeCtor,
- % TypeCtorInfoVar, TypeCtorInfoGoal, ModuleInfo, !VarSet, !VarTypes):
+ % TypeCtorInfoVar, TypeCtorConsId, TypeCtorInfoGoal,
+ % !VarSet, !VarTypes, !RttiVarMaps):
%
% Create the unification (returned as TypeCtorInfoGoal) that binds a
% new variable (returned as TypeCtorInfoVar) to the type_ctor_info
- % representing TypeCtor.
+ % representing TypeCtor. This will be the constant represented by
+ % TypeCtorConsId.
%
% This unification WILL NOT lead to the creation of a cell on the
% heap at runtime; it will cause TypeCtorInfoVar to refer to the
@@ -372,7 +362,7 @@
% TypeCtorInfoVar.
%
:- pred init_const_type_ctor_info_var(mer_type::in, type_ctor::in,
- prog_var::out, hlds_goal::out, module_info::in,
+ prog_var::out, cons_id::out, hlds_goal::out,
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
rtti_varmaps::in, rtti_varmaps::out) is det.
@@ -393,6 +383,7 @@
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
:- import_module hlds.from_ground_term_util.
+:- import_module hlds.const_struct.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_args.
:- import_module hlds.hlds_clauses.
@@ -417,8 +408,8 @@
:- import_module assoc_list.
:- import_module bool.
-:- import_module cord.
:- import_module int.
+:- import_module io.
:- import_module map.
:- import_module pair.
:- import_module require.
@@ -548,10 +539,24 @@
polymorphism_process_pred(PredId, !ModuleInfo),
fixup_pred_polymorphism(PredId, !ModuleInfo).
+:- mutable(selected_pred, bool, no, ground, [untrailed]).
+:- mutable(level, int, 0, ground, [untrailed]).
+
:- pred polymorphism_process_pred(pred_id::in,
module_info::in, module_info::out) is det.
polymorphism_process_pred(PredId, !ModuleInfo) :-
+ trace [compiletime(flag("debug_poly_caches"))] (
+ promise_pure (
+ % Replace 99999 with the id of the predicate you want to debug.
+ ( pred_id_to_int(PredId) = 15 ->
+ impure set_selected_pred(yes)
+ ;
+ true
+ )
+ )
+ ),
+
module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
% Run the polymorphism pass over the clauses_info, updating the headvars,
@@ -559,9 +564,12 @@
% poly_info.
pred_info_get_clauses_info(PredInfo0, ClausesInfo0),
- polymorphism_process_clause_info(PredInfo0, !.ModuleInfo,
+ polymorphism_process_clause_info(!.ModuleInfo, PredInfo0,
ClausesInfo0, ClausesInfo, Info, ExtraArgModes),
poly_info_get_module_info(Info, !:ModuleInfo),
+ poly_info_get_const_struct_db(Info, ConstStructDb),
+ module_info_set_const_struct_db(ConstStructDb, !ModuleInfo),
+
poly_info_get_typevarset(Info, TypeVarSet),
pred_info_set_typevarset(TypeVarSet, PredInfo0, PredInfo1),
pred_info_set_clauses_info(ClausesInfo, PredInfo1, PredInfo2),
@@ -576,13 +584,19 @@
ExtraArgModes), ProcIds, Procs0, Procs),
pred_info_set_procedures(Procs, PredInfo2, PredInfo),
+ trace [compiletime(flag("debug_poly_caches"))] (
+ promise_pure (
+ impure set_selected_pred(no)
+ )
+ ),
+
module_info_set_pred_info(PredId, PredInfo, !ModuleInfo).
-:- pred polymorphism_process_clause_info(pred_info::in, module_info::in,
+:- pred polymorphism_process_clause_info(module_info::in, pred_info::in,
clauses_info::in, clauses_info::out, poly_info::out,
poly_arg_vector(mer_mode)::out) is det.
-polymorphism_process_clause_info(PredInfo0, ModuleInfo0, !ClausesInfo, !:Info,
+polymorphism_process_clause_info(ModuleInfo0, PredInfo0, !ClausesInfo, !:Info,
ExtraArgModes) :-
init_poly_info(ModuleInfo0, PredInfo0, !.ClausesInfo, !:Info),
!.ClausesInfo = clauses_info(_VarSet, ExplicitVarTypes, _TVarNameMap,
@@ -624,7 +638,7 @@
Goal0 = !.Clause ^ clause_body,
% Process any polymorphic calls inside the goal.
- empty_maps(!Info),
+ empty_cache_maps(!Info),
poly_info_set_num_reuses(0, !Info),
polymorphism_process_goal(Goal0, Goal1, !Info),
@@ -834,7 +848,7 @@
check_marker(PredMarkers, marker_class_method)
->
% For class methods we record the type_info_locns even for the
- % existential constraints. It's easier to do it here than when we
+ % existential constraints. It is easier to do it here than when we
% are expanding class method bodies, and we know there won't be any
% references to the type_info after the instance method call so
% recording them now won't be a problem.
@@ -971,9 +985,9 @@
ExistQVarsForCall = [],
Goal0 = hlds_goal(_, GoalInfo),
Context = goal_info_get_context(GoalInfo),
- make_typeclass_info_vars(ActualExistConstraints,
- ExistQVarsForCall, Context, ExistTypeClassVars,
- ExtraTypeClassGoals, !Info),
+ make_typeclass_info_vars(ActualExistConstraints, ExistQVarsForCall,
+ Context, ExistTypeClassVarsMCAs, ExtraTypeClassGoals, !Info),
+ assoc_list.keys(ExistTypeClassVarsMCAs, ExistTypeClassVars),
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
list.foldl(rtti_reuse_typeclass_info_var, ExistTypeClassVars,
RttiVarMaps0, RttiVarMaps),
@@ -1005,11 +1019,11 @@
apply_subst_to_tvar_list(KindMap, PredToActualTypeSubst,
UnconstrainedTVars, ActualTypes),
- polymorphism_make_type_info_vars(ActualTypes, Context,
- TypeInfoVars, ExtraTypeInfoGoals, !Info),
- assign_var_list(TypeInfoHeadVars, TypeInfoVars,
- ExtraTypeInfoUnifyGoals),
- list.condense([[Goal0], ExtraTypeClassGoals, ExtraTypeClassUnifyGoals,
+ polymorphism_do_make_type_info_vars(ActualTypes, Context,
+ TypeInfoVarsMCAs, ExtraTypeInfoGoals, !Info),
+ assoc_list.keys(TypeInfoVarsMCAs, TypeInfoVars),
+ assign_var_list(TypeInfoHeadVars, TypeInfoVars, ExtraTypeInfoUnifyGoals),
+ list.condense([[Goal0 | ExtraTypeClassGoals], ExtraTypeClassUnifyGoals,
ExtraTypeInfoGoals, ExtraTypeInfoUnifyGoals], GoalList),
conj_list_to_goal(GoalList, GoalInfo, Goal).
@@ -1089,8 +1103,8 @@
( no_type_info_builtin(PredModule, PredName, PredArity) ->
Goal = Goal0
;
- polymorphism_process_foreign_proc(ModuleInfo, PredInfo, GoalExpr0,
- GoalInfo0, Goal, !Info)
+ polymorphism_process_foreign_proc(PredInfo, GoalExpr0, GoalInfo0,
+ Goal, !Info)
)
;
GoalExpr0 = unify(XVar, Y, Mode, Unification, UnifyContext),
@@ -1105,7 +1119,7 @@
polymorphism_process_plain_conj(Goals0, Goals, !Info)
;
ConjType = parallel_conj,
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("parconj", InitialSnapshot, !Info),
polymorphism_process_par_conj(Goals0, Goals, InitialSnapshot,
!Info)
% Unlike with disjunctions, we do not have to reset to
@@ -1114,35 +1128,35 @@
GoalExpr = conj(ConjType, Goals)
;
GoalExpr0 = disj(Goals0),
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("disj", InitialSnapshot, !Info),
polymorphism_process_disj(Goals0, Goals, InitialSnapshot, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after disj", InitialSnapshot, !Info),
GoalExpr = disj(Goals)
;
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("ite", InitialSnapshot, !Info),
polymorphism_process_goal(Cond0, Cond, !Info),
% If we allowed a type_info created inside Cond to be reused
% in Then, then we are adding an output variable to Cond.
% If Cond scope had no outputs to begin with, this would change
% its determinism.
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("before then", InitialSnapshot, !Info),
polymorphism_process_goal(Then0, Then, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("before else", InitialSnapshot, !Info),
polymorphism_process_goal(Else0, Else, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after ite", InitialSnapshot, !Info),
GoalExpr = if_then_else(Vars, Cond, Then, Else)
;
GoalExpr0 = negation(SubGoal0),
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("neg", InitialSnapshot, !Info),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after neg", InitialSnapshot, !Info),
GoalExpr = negation(SubGoal)
;
GoalExpr0 = switch(Var, CanFail, Cases0),
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("switch", InitialSnapshot, !Info),
polymorphism_process_cases(Cases0, Cases, InitialSnapshot, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after switch", InitialSnapshot, !Info),
GoalExpr = switch(Var, CanFail, Cases)
;
GoalExpr0 = scope(Reason0, SubGoal0),
@@ -1169,9 +1183,11 @@
% promise would have to cover. We cannot expect and do not want
% user level programmers making promises about variables added
% by the compiler.
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("promise_solns", InitialSnapshot,
+ !Info),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after promise_solns", InitialSnapshot,
+ !Info),
GoalExpr = scope(Reason0, SubGoal)
;
( Reason0 = promise_purity(_)
@@ -1193,9 +1209,10 @@
% However, using a type_info from before the scope in SubGoal
% is perfectly ok.
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("exists", InitialSnapshot, !Info),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after exists", InitialSnapshot,
+ !Info),
GoalExpr = scope(Reason0, SubGoal)
;
Reason0 = trace_goal(_, _, _, _, _),
@@ -1209,9 +1226,9 @@
% whether the deletion will happen or not, but doing so would
% require breaching the separation between compiler passes.
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("trace", InitialSnapshot, !Info),
polymorphism_process_goal(SubGoal0, SubGoal, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after trace", InitialSnapshot, !Info),
GoalExpr = scope(Reason0, SubGoal)
)
),
@@ -1221,11 +1238,11 @@
(
ShortHand0 = atomic_goal(GoalType, Outer, Inner, Vars,
MainGoal0, OrElseGoals0, OrElseInners),
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("atomic", InitialSnapshot, !Info),
polymorphism_process_goal(MainGoal0, MainGoal, !Info),
polymorphism_process_disj(OrElseGoals0, OrElseGoals,
InitialSnapshot, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after atomic", InitialSnapshot, !Info),
ShortHand = atomic_goal(GoalType, Outer, Inner, Vars,
MainGoal, OrElseGoals, OrElseInners)
;
@@ -1235,15 +1252,15 @@
% expressions; because those pieces of code will end up
% in different procedures. However, for try goals, this is true
% even for the first and second conjuncts.
- get_maps_snapshot(!.Info, InitialSnapshot),
+ get_cache_maps_snapshot("try", InitialSnapshot, !Info),
(
SubGoal0 = hlds_goal(SubGoalExpr0, SubGoalInfo),
SubGoalExpr0 = conj(plain_conj, Conjuncts0),
Conjuncts0 = [ConjunctA0, ConjunctB0]
->
- empty_maps(!Info),
+ empty_cache_maps(!Info),
polymorphism_process_goal(ConjunctA0, ConjunctA, !Info),
- empty_maps(!Info),
+ empty_cache_maps(!Info),
polymorphism_process_goal(ConjunctB0, ConjunctB, !Info),
Conjuncts = [ConjunctA, ConjunctB],
@@ -1252,7 +1269,7 @@
;
unexpected($module, $pred, "malformed try goal")
),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after try", InitialSnapshot, !Info),
ShortHand = try_goal(MaybeIO, ResultVar, SubGoal)
;
ShortHand0 = bi_implication(_, _),
@@ -1391,10 +1408,10 @@
% This is because, after lambda expansion, the code inside and outside
% the lambda goal will end up in different procedures.
- get_maps_snapshot(!.Info, InitialSnapshot),
- empty_maps(!Info),
+ get_cache_maps_snapshot("lambda", InitialSnapshot, !Info),
+ empty_cache_maps(!Info),
polymorphism_process_goal(LambdaGoal0, LambdaGoal1, !Info),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("after lambda", InitialSnapshot, !Info),
% Currently we don't allow lambda goals to be existentially typed.
ExistQVars = [],
@@ -1768,14 +1785,15 @@
Context = goal_info_get_context(GoalInfo),
(
IsConstruction = yes,
- % Assume it's a construction.
+ % Assume it is a construction.
lookup_hlds_constraint_list(ConstraintMap, unproven, GoalId,
NumExistentialConstraints, ActualExistentialConstraints),
make_typeclass_info_vars(ActualExistentialConstraints, [], Context,
- ExtraTypeClassVars, ExtraTypeClassGoals, !Info)
+ ExtraTypeClassVarsMCAs, ExtraTypeClassGoals, !Info),
+ assoc_list.keys(ExtraTypeClassVarsMCAs, ExtraTypeClassVars)
;
IsConstruction = no,
- % Assume it's a deconstruction.
+ % Assume it is a deconstruction.
lookup_hlds_constraint_list(ConstraintMap, assumed, GoalId,
NumExistentialConstraints, ActualExistentialConstraints),
make_existq_typeclass_info_vars(ActualExistentialConstraints,
@@ -1794,8 +1812,9 @@
% Create type_info variables for the _unconstrained_ existentially
% quantified type variables.
- polymorphism_make_type_info_vars(ActualExistentialTypes, Context,
- ExtraTypeInfoVars, ExtraTypeInfoGoals, !Info),
+ polymorphism_do_make_type_info_vars(ActualExistentialTypes, Context,
+ ExtraTypeInfoVarsMCAs, ExtraTypeInfoGoals, !Info),
+ assoc_list.keys(ExtraTypeInfoVarsMCAs, ExtraTypeInfoVars),
% The type_class_info variables go AFTER the type_info variables
% (for consistency with the order for argument passing,
@@ -1806,16 +1825,16 @@
%-----------------------------------------------------------------------------%
-:- pred polymorphism_process_foreign_proc(module_info::in, pred_info::in,
+:- pred polymorphism_process_foreign_proc(pred_info::in,
hlds_goal_expr::in(bound(call_foreign_proc(ground,ground,ground,ground,
ground,ground,ground))), hlds_goal_info::in, hlds_goal::out,
poly_info::in, poly_info::out) is det.
-polymorphism_process_foreign_proc(_ModuleInfo, PredInfo, Goal0, GoalInfo0, Goal,
- !Info) :-
+polymorphism_process_foreign_proc(PredInfo, GoalExpr0, GoalInfo0,
+ Goal, !Info) :-
% Insert the type_info vars into the argname map, so that the foreign_proc
% can refer to the type_info variable for type T as `TypeInfo_for_T'.
- Goal0 = call_foreign_proc(Attributes, PredId, ProcId,
+ GoalExpr0 = call_foreign_proc(Attributes, PredId, ProcId,
Args0, ProcExtraArgs, MaybeTraceRuntimeCond, Impl),
ArgVars0 = list.map(foreign_arg_var, Args0),
polymorphism_process_call(PredId, ArgVars0, GoalInfo0, GoalInfo,
@@ -1956,7 +1975,7 @@
polymorphism_process_plain_conj(Goals0, Goals, !Info).
:- pred polymorphism_process_par_conj(list(hlds_goal)::in,
- list(hlds_goal)::out, maps_snapshot::in, poly_info::in, poly_info::out)
+ list(hlds_goal)::out, cache_maps::in, poly_info::in, poly_info::out)
is det.
polymorphism_process_par_conj([], [], _, !Info).
@@ -1968,28 +1987,28 @@
% and (b) may drastically reduce the available parallelism, if the earlier
% conjunct produces the variable late but the later conjunct requires it
% early.
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("par conjunct", InitialSnapshot, !Info),
polymorphism_process_goal(Goal0, Goal, !Info),
polymorphism_process_par_conj(Goals0, Goals, InitialSnapshot, !Info).
:- pred polymorphism_process_disj(list(hlds_goal)::in, list(hlds_goal)::out,
- maps_snapshot::in, poly_info::in, poly_info::out) is det.
+ cache_maps::in, poly_info::in, poly_info::out) is det.
polymorphism_process_disj([], [], _, !Info).
polymorphism_process_disj([Goal0 | Goals0], [Goal | Goals], InitialSnapshot,
!Info) :-
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("disjunct", InitialSnapshot, !Info),
polymorphism_process_goal(Goal0, Goal, !Info),
polymorphism_process_disj(Goals0, Goals, InitialSnapshot, !Info).
:- pred polymorphism_process_cases(list(case)::in, list(case)::out,
- maps_snapshot::in, poly_info::in, poly_info::out) is det.
+ cache_maps::in, poly_info::in, poly_info::out) is det.
polymorphism_process_cases([], [], _, !Info).
polymorphism_process_cases([Case0 | Cases0], [Case | Cases], InitialSnapshot,
!Info) :-
Case0 = case(MainConsId, OtherConsIds, Goal0),
- set_maps_snapshot(InitialSnapshot, !Info),
+ set_cache_maps_snapshot("case", InitialSnapshot, !Info),
polymorphism_process_goal(Goal0, Goal, !Info),
Case = case(MainConsId, OtherConsIds, Goal),
polymorphism_process_cases(Cases0, Cases, InitialSnapshot, !Info).
@@ -2120,30 +2139,37 @@
),
Context = goal_info_get_context(GoalInfo0),
make_typeclass_info_vars(ActualUnivConstraints, ActualExistQVars,
- Context, ExtraUnivClassVars, ExtraUnivClassGoals, !Info),
+ Context, ExtraUnivClassVarsMCAs, ExtraUnivClassGoals,
+ !Info),
+ assoc_list.keys(ExtraUnivClassVarsMCAs, ExtraUnivClassVars),
% Make variables to hold any existentially quantified typeclass_infos
% in the call, insert them into the typeclass_info map.
list.length(ParentExistConstraints, NumExistConstraints),
lookup_hlds_constraint_list(ConstraintMap, assumed, GoalId,
NumExistConstraints, ActualExistConstraints),
- make_existq_typeclass_info_vars(
- ActualExistConstraints, ExtraExistClassVars,
- ExtraExistClassGoals, !Info),
+ make_existq_typeclass_info_vars(ActualExistConstraints,
+ ExtraExistClassVars, ExtraExistClassGoals, !Info),
% Make variables to hold typeinfos for unconstrained universal type
% vars.
apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualTypeSubst,
ParentUnconstrainedUnivTVars, ActualUnconstrainedUnivTypes),
- polymorphism_make_type_info_vars(ActualUnconstrainedUnivTypes,
- Context, ExtraUnivTypeInfoVars, ExtraUnivTypeInfoGoals, !Info),
+ polymorphism_do_make_type_info_vars(ActualUnconstrainedUnivTypes,
+ Context, ExtraUnivTypeInfoVarsMCAs,
+ ExtraUnivTypeInfoGoals, !Info),
+ assoc_list.keys(ExtraUnivTypeInfoVarsMCAs,
+ ExtraUnivTypeInfoVars),
% Make variables to hold typeinfos for unconstrained existential type
% vars.
apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualTypeSubst,
ParentUnconstrainedExistTVars, ActualUnconstrainedExistTypes),
- polymorphism_make_type_info_vars(ActualUnconstrainedExistTypes,
- Context, ExtraExistTypeInfoVars, ExtraExistTypeInfoGoals, !Info),
+ polymorphism_do_make_type_info_vars(ActualUnconstrainedExistTypes,
+ Context, ExtraExistTypeInfoVarsMCAs,
+ ExtraExistTypeInfoGoals, !Info),
+ assoc_list.keys(ExtraExistTypeInfoVarsMCAs,
+ ExtraExistTypeInfoVars),
% Add up the extra vars and goals.
ExtraGoals = ExtraUnivClassGoals ++ ExtraExistClassGoals
@@ -2220,8 +2246,9 @@
% Construct goals to make the required type_infos.
Ctxt = term.context_init,
- polymorphism_make_type_info_vars(ActualTypeInfoTypes, Ctxt,
- ExtraArgs, ExtraGoals, !Info),
+ polymorphism_do_make_type_info_vars(ActualTypeInfoTypes, Ctxt,
+ ExtraArgsConstArgs, ExtraGoals, !Info),
+ assoc_list.keys(ExtraArgsConstArgs, ExtraArgs),
CallArgs = ExtraArgs ++ CallArgs0,
NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
NonLocals1 = set_of_var.list_to_set(ExtraArgs),
@@ -2325,39 +2352,40 @@
%
:- pred make_typeclass_info_vars(list(prog_constraint)::in,
existq_tvars::in, prog_context::in,
- list(prog_var)::out, list(hlds_goal)::out,
+ assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
-make_typeclass_info_vars(Constraints, ExistQVars, Context, TypeClassInfoVars,
- ExtraGoals, !Info) :-
+make_typeclass_info_vars(Constraints, ExistQVars, Context,
+ TypeClassInfoVarsMCAs, ExtraGoals, !Info) :-
SeenInstances = [],
make_typeclass_info_vars_2(Constraints, SeenInstances, ExistQVars, Context,
- TypeClassInfoVars, cord.empty, ExtraGoalsCord, !Info),
- ExtraGoals = cord.list(ExtraGoalsCord).
+ TypeClassInfoVarsMCAs, ExtraGoals, !Info).
% Accumulator version of the above.
%
:- pred make_typeclass_info_vars_2(list(prog_constraint)::in,
list(prog_constraint)::in, existq_tvars::in, prog_context::in,
- list(prog_var)::out, cord(hlds_goal)::in, cord(hlds_goal)::out,
+ assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
make_typeclass_info_vars_2([], _Seen, _ExistQVars, _Context,
- [], !ExtraGoals, !Info).
+ [], [], !Info).
make_typeclass_info_vars_2([Constraint | Constraints], Seen, ExistQVars,
- Context, [TypeClassInfoVar | TypeClassInfoVars], !ExtraGoals, !Info) :-
+ Context, [TypeClassInfoVarMCA | TypeClassInfoVarsMCAs],
+ ExtraGoals, !Info) :-
make_typeclass_info_var(Constraint, [Constraint | Seen],
- ExistQVars, Context, TypeClassInfoVar, !ExtraGoals, !Info),
+ ExistQVars, Context, TypeClassInfoVarMCA, HeadExtraGoals, !Info),
make_typeclass_info_vars_2(Constraints, Seen, ExistQVars,
- Context, TypeClassInfoVars, !ExtraGoals, !Info).
+ Context, TypeClassInfoVarsMCAs, TailExtraGoals, !Info),
+ ExtraGoals = HeadExtraGoals ++ TailExtraGoals.
:- pred make_typeclass_info_var(prog_constraint::in,
list(prog_constraint)::in, existq_tvars::in, prog_context::in,
- prog_var::out, cord(hlds_goal)::in, cord(hlds_goal)::out,
+ pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
make_typeclass_info_var(Constraint, Seen, ExistQVars, Context,
- TypeClassInfoVar, !ExtraGoals, !Info) :-
+ TypeClassInfoVarMCA, Goals, !Info) :-
(
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
rtti_search_typeclass_info_var(RttiVarMaps0, Constraint,
@@ -2366,61 +2394,365 @@
% We already have a typeclass_info for this constraint, either from
% a parameter to the pred or from an existentially quantified goal
% that we have already processed.
- TypeClassInfoVar = OldTypeClassInfoVar
+ TypeClassInfoVar = OldTypeClassInfoVar,
+ TypeClassInfoVarMCA = TypeClassInfoVar - no,
+ Goals = []
;
- % We don't have the typeclass_info, we must either have a proof that
- % tells us how to make it, or it will be produced by an existentially
- % typed goal that we will process later on.
+ % We don't have the typeclass_info, so we must either have a proof
+ % that tells us how to make it, or ...
map.search(!.Info ^ poly_proof_map, Constraint, Proof)
->
make_typeclass_info_from_proof(Constraint, Seen, Proof, ExistQVars,
- Context, TypeClassInfoVar, !ExtraGoals, !Info)
+ Context, TypeClassInfoVarMCA, Goals, !Info)
;
+ % ... it will be produced by an existentially typed goal that
+ % we will process later on.
make_typeclass_info_head_var(do_record_type_info_locns, Constraint,
TypeClassInfoVar, !Info),
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
rtti_reuse_typeclass_info_var(TypeClassInfoVar,
RttiVarMaps0, RttiVarMaps),
- poly_info_set_rtti_varmaps(RttiVarMaps, !Info)
+ poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
+ TypeClassInfoVarMCA = TypeClassInfoVar - no,
+ Goals = []
).
:- pred make_typeclass_info_from_proof(prog_constraint::in,
list(prog_constraint)::in, constraint_proof::in, existq_tvars::in,
- prog_context::in, prog_var::out, cord(hlds_goal)::in, cord(hlds_goal)::out,
- poly_info::in, poly_info::out) is det.
+ prog_context::in, pair(prog_var, maybe(const_struct_arg))::out,
+ list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
make_typeclass_info_from_proof(Constraint, Seen, Proof,
- ExistQVars, Context, TypeClassInfoVar, !ExtraGoals, !Info) :-
+ ExistQVars, Context, TypeClassInfoVarMCA, Goals, !Info) :-
(
+ % XXX MR_Dictionary should have MR_Dictionaries for superclass
+ % We have to extract the typeclass_info from another one.
+ Proof = superclass(SubClassConstraint),
+ make_typeclass_info_from_subclass(Constraint, Seen, SubClassConstraint,
+ ExistQVars, Context, TypeClassInfoVarMCA, Goals, !Info)
+ ;
% We have to construct the typeclass_info using an instance
% declaration.
Proof = apply_instance(InstanceNum),
make_typeclass_info_from_instance(Constraint, Seen, InstanceNum,
- ExistQVars, Context, TypeClassInfoVar, !ExtraGoals, !Info)
+ ExistQVars, Context, TypeClassInfoVarMCA, Goals, !Info)
+ ).
+
+:- pred make_typeclass_info_from_subclass(prog_constraint::in,
+ list(prog_constraint)::in, prog_constraint::in, existq_tvars::in,
+ prog_context::in, pair(prog_var, maybe(const_struct_arg))::out,
+ list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
+
+make_typeclass_info_from_subclass(Constraint, Seen, SubClassConstraint,
+ ExistQVars, Context, TypeClassInfoVar - MaybeTCIConstArg, Goals,
+ !Info) :-
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ (
+ SelectedPred = no
+ ;
+ SelectedPred = yes,
+ IndentStr = string.duplicate_char(' ', Level * 4),
+ impure set_level(Level + 1),
+
+ io.write_string(IndentStr, !IO),
+ io.write_string("make_typeclass_info_from_subclass", !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("Constraint: ", !IO),
+ io.write(Constraint, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("Seen: ", !IO),
+ ( Seen = [Constraint] ->
+ io.write_string("[Constraint]\n", !IO)
+ ;
+ io.write(Seen, !IO),
+ io.nl(!IO)
+ ),
+ io.write_string(IndentStr, !IO),
+ io.write_string("SubClassConstraint: ", !IO),
+ io.write(SubClassConstraint, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("ExistQVars: ", !IO),
+ io.write(ExistQVars, !IO),
+ io.nl(!IO),
+ io.nl(!IO)
+ )
+ )
+ )
+ ),
+
+ % Work out where to extract the typeclass info from.
+ SubClassConstraint = constraint(SubClassName, SubClassTypes),
+ list.length(SubClassTypes, SubClassArity),
+ SubClassId = class_id(SubClassName, SubClassArity),
+
+ % Make the typeclass_info for the subclass.
+ make_typeclass_info_var(SubClassConstraint, Seen, ExistQVars, Context,
+ SubClassVarMCA, SubClassVarGoals, !Info),
+ SubClassVarMCA = SubClassVar - SubClassMCA,
+
+ % Look up the definition of the subclass.
+ poly_info_get_module_info(!.Info, ModuleInfo),
+ module_info_get_class_table(ModuleInfo, ClassTable),
+ map.lookup(ClassTable, SubClassId, SubClassDefn),
+
+ % Work out which superclass typeclass_info to take.
+ map.from_corresponding_lists(SubClassDefn ^ class_vars, SubClassTypes,
+ SubTypeSubst),
+ apply_subst_to_prog_constraint_list(SubTypeSubst,
+ SubClassDefn ^ class_supers, SuperClasses),
+ ( list.nth_member_search(SuperClasses, Constraint, SuperClassIndex0) ->
+ SuperClassIndex0 = SuperClassIndex
;
- % XXX MR_Dictionary should have MR_Dictionaries for superclass
- % We have to extract the typeclass_info from another one.
- Proof = superclass(SubClassConstraint),
- make_typeclass_info_from_subclass(Constraint, Seen, SubClassConstraint,
- ExistQVars, Context, TypeClassInfoVar, !ExtraGoals, !Info)
+ % We shouldn't have got this far if the constraints were not satisfied.
+ unexpected($module, $pred, "constraint not in constraint list")
+ ),
+
+ (
+ SubClassMCA = yes(SubClassConstArg),
+ (
+ SubClassConstArg = csa_constant(_, _),
+ unexpected($module, $pred, "typeclass infos need a cell")
+ ;
+ SubClassConstArg = csa_const_struct(SubClassConstNum),
+ poly_info_get_const_struct_db(!.Info, ConstStructDb),
+ lookup_const_struct_num(ConstStructDb, SubClassConstNum,
+ SubClassConstStruct),
+ SubClassConstStruct = const_struct(SubClassConsId, SubClassArgs,
+ _, _),
+ (
+ SubClassConsId = typeclass_info_cell_constructor,
+ SubClassArgs = [BTCIArg | OtherArgs],
+ BTCIArg = csa_constant(BTCIConsId, _),
+ BTCIConsId = base_typeclass_info_const(_, SubClassId,
+ SubInstanceNum, _),
+ module_info_get_instance_table(ModuleInfo, InstanceTable),
+ map.lookup(InstanceTable, SubClassId, SubInstanceDefns),
+ list.index1(SubInstanceDefns, SubInstanceNum, SubInstanceDefn),
+ num_extra_instance_args(SubInstanceDefn, NumExtra),
+ Index = NumExtra + SuperClassIndex,
+ list.det_index1(OtherArgs, Index, SelectedArg),
+ SelectedArg = csa_const_struct(SelectedConstNum)
+ ->
+ materialize_typeclass_info_var(Constraint, SelectedConstNum,
+ TypeClassInfoVar, Goals, !Info),
+ MaybeTCIConstArg = yes(SelectedArg)
+ ;
+ unexpected($module, $pred,
+ "unexpected typeclass info structure")
+ )
+ ),
+
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr, ResultStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ impure set_level(Level - 1),
+ (
+ SelectedPred = no
+ ;
+ SelectedPred = yes,
+ IndentStr = string.duplicate_char(' ', (Level-1) * 4),
+ io.write_string(IndentStr, !IO),
+ io.write_string("subclass constant result ", !IO),
+ io.write(TypeClassInfoVar - MaybeTCIConstArg, !IO),
+ io.nl(!IO),
+ io.nl(!IO)
+ )
+ )
+ )
+ )
+ ;
+ SubClassMCA = no,
+ new_typeclass_info_var(Constraint, typeclass_info_kind,
+ TypeClassInfoVar, _TypeClassInfoVarType, !Info),
+ get_poly_const(SuperClassIndex, IndexVar, IndexGoals, !Info),
+
+ % We extract the superclass typeclass_info by inserting a call
+ % to superclass_from_typeclass_info in private_builtin.
+ goal_util.generate_simple_call(mercury_private_builtin_module,
+ "superclass_from_typeclass_info",
+ pf_predicate, only_mode, detism_det, purity_pure,
+ [SubClassVar, IndexVar, TypeClassInfoVar], [],
+ instmap_delta_bind_no_var, ModuleInfo, term.context_init,
+ SuperClassGoal),
+ Goals = SubClassVarGoals ++ IndexGoals ++ [SuperClassGoal],
+ MaybeTCIConstArg = no,
+
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr, ResultStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ impure set_level(Level - 1),
+ (
+ SelectedPred = no
+ ;
+ SelectedPred = yes,
+ IndentStr = string.duplicate_char(' ', (Level-1) * 4),
+ io.write_string(IndentStr, !IO),
+ io.write_string("subclass computed result ", !IO),
+ io.write(TypeClassInfoVar - MaybeTCIConstArg, !IO),
+ io.nl(!IO),
+ io.nl(!IO)
+ )
+ )
+ )
+ )
).
:- pred make_typeclass_info_from_instance(prog_constraint::in,
list(prog_constraint)::in, int::in, existq_tvars::in, prog_context::in,
- prog_var::out, cord(hlds_goal)::in, cord(hlds_goal)::out,
+ pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
make_typeclass_info_from_instance(Constraint, Seen, InstanceNum, ExistQVars,
- Context, TypeClassInfoVar, !ExtraGoals, !Info) :-
+ Context, TypeClassInfoVarMCA, Goals, !Info) :-
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ (
+ SelectedPred = no
+ ;
+ SelectedPred = yes,
+ IndentStr = string.duplicate_char(' ', Level * 4),
+ impure set_level(Level + 1),
+
+ io.write_string(IndentStr, !IO),
+ io.write_string("make_typeclass_info_from_instance", !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("Constraint: ", !IO),
+ io.write(Constraint, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("Seen: ", !IO),
+ ( Seen = [Constraint] ->
+ io.write_string("[Constraint]\n", !IO)
+ ;
+ io.write(Seen, !IO),
+ io.nl(!IO)
+ ),
+ io.write_string(IndentStr, !IO),
+ io.write_string("InstanceNum: ", !IO),
+ io.write(InstanceNum, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("ExistQVars: ", !IO),
+ io.write(ExistQVars, !IO),
+ io.nl(!IO),
+ io.nl(!IO)
+ )
+ )
+ )
+ ),
+
+ poly_info_get_const_struct_db(!.Info, ConstStructDb0),
+ InstanceId = ciid(InstanceNum, Constraint, Seen),
+ (
+ ExistQVars = [],
+ search_for_constant_instance(ConstStructDb0, InstanceId,
+ InstanceIdConstNum)
+ ->
+ materialize_typeclass_info_var(Constraint, InstanceIdConstNum,
+ TypeClassInfoVar, Goals, !Info),
+ TypeClassInfoVarMCA =
+ TypeClassInfoVar - yes(csa_const_struct(InstanceIdConstNum)),
+
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr, ResultStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ impure set_level(Level - 1),
+ (
+ SelectedPred = no
+ ;
+ SelectedPred = yes,
+ IndentStr = string.duplicate_char(' ', (Level-1) * 4),
+ (
+ Goals = [],
+ ResultStr = "instance doubly cached result "
+ ;
+ Goals = [_ | _],
+ ResultStr = "instance cached result "
+ ),
+
+ io.write_string(IndentStr, !IO),
+ io.write_string(ResultStr, !IO),
+ io.write(TypeClassInfoVarMCA, !IO),
+ io.nl(!IO),
+ io.nl(!IO)
+ )
+ )
+ )
+ )
+ ;
+ do_make_typeclass_info_from_instance(InstanceId, ExistQVars,
+ Context, TypeClassInfoVarMCA, Goals, !Info),
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ impure set_level(Level - 1),
+ (
+ SelectedPred = no
+ ;
+ SelectedPred = yes,
+ IndentStr = string.duplicate_char(' ', (Level-1) * 4),
+ io.write_string(IndentStr, !IO),
+ io.write_string("instance computed result: ", !IO),
+ io.write(TypeClassInfoVarMCA, !IO),
+ io.nl(!IO),
+
+ io.write_string(IndentStr, !IO),
+ io.write_string("type_info_var_map ", !IO),
+ io.write(!.Info ^ poly_type_info_var_map, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("typeclass_info_map ", !IO),
+ io.write(!.Info ^ poly_typeclass_info_map, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("struct_var_map ", !IO),
+ io.write(!.Info ^ poly_const_struct_var_map, !IO),
+ io.nl(!IO),
+ io.nl(!IO)
+ )
+ )
+ )
+ )
+ ).
+
+:- pred do_make_typeclass_info_from_instance(const_instance_id::in,
+ existq_tvars::in, prog_context::in,
+ pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
+
+do_make_typeclass_info_from_instance(InstanceId, ExistQVars, Context,
+ TypeClassInfoVarMCA, Goals, !Info) :-
+ poly_info_get_module_info(!.Info, ModuleInfo),
+ module_info_get_instance_table(ModuleInfo, InstanceTable),
+ module_info_get_class_table(ModuleInfo, ClassTable),
+ poly_info_get_typevarset(!.Info, TypeVarSet),
+ poly_info_get_proofs(!.Info, Proofs0),
+
+ InstanceId = ciid(InstanceNum, Constraint, Seen),
Constraint = constraint(ClassName, ConstrainedTypes),
- TypeVarSet = !.Info ^ poly_typevarset,
- Proofs0 = !.Info ^ poly_proof_map,
- ModuleInfo = !.Info ^ poly_module_info,
list.length(ConstrainedTypes, ClassArity),
ClassId = class_id(ClassName, ClassArity),
- module_info_get_instance_table(ModuleInfo, InstanceTable),
map.lookup(InstanceTable, ClassId, InstanceList),
list.det_index1(InstanceList, InstanceNum, ProofInstanceDefn),
@@ -2435,10 +2767,11 @@
get_unconstrained_tvars(InstanceTvars, InstanceConstraints,
UnconstrainedTvars),
- % We can ignore the new typevarset because all the type variables in the
- % instance constraints and superclass proofs must appear in the arguments
- % of the instance, and all such variables are bound when we call
- % type_list_subsumes then apply the resulting bindings.
+ % We can ignore the new typevarset because all the type variables
+ % in the instance constraints and superclass proofs must appear
+ % in the arguments of the instance, and all such variables
+ % are bound when we call type_list_subsumes then apply
+ % the resulting bindings.
tvarset_merge_renaming(TypeVarSet, InstanceTVarset, _NewTVarset, Renaming),
apply_variable_renaming_to_type_list(Renaming, InstanceTypes,
RenamedInstanceTypes),
@@ -2466,286 +2799,275 @@
map.overlay(Proofs0, ActualInstanceProofs, Proofs),
+ get_var_maps_snapshot("make_typeclass_info_from_instance",
+ InitialVarMapsSnapshot, !Info),
+
% Make the type_infos for the types that are constrained by this.
% These are packaged in the typeclass_info.
- polymorphism_make_type_info_vars(ConstrainedTypes, Context,
- InstanceExtraTypeInfoVars, TypeInfoGoals, !Info),
+ polymorphism_do_make_type_info_vars(ConstrainedTypes, Context,
+ ArgTypeInfoVarsMCAs, TypeInfoGoals, !Info),
% Make the typeclass_infos for the constraints from the context of the
% instance decl.
make_typeclass_info_vars_2(ActualInstanceConstraints, Seen, ExistQVars,
- Context, InstanceExtraTypeClassInfoVars, !ExtraGoals, !Info),
-
- % Make the type_infos for the unconstrained type variables from the head
- % of the instance declaration.
- polymorphism_make_type_info_vars(ActualUnconstrainedTypes, Context,
- InstanceExtraTypeInfoUnconstrainedVars, UnconstrainedTypeInfoGoals,
- !Info),
+ Context, ArgTypeClassInfoVarsMCAs, InstanceConstraintGoals, !Info),
- make_typeclass_info(InstanceExtraTypeInfoUnconstrainedVars,
- InstanceExtraTypeInfoVars, InstanceExtraTypeClassInfoVars,
- ClassId, Constraint, InstanceNum, ConstrainedTypes,
- Proofs, ExistQVars, TypeClassInfoVar, MakeTypeClassInfoGoals, !Info),
-
- !:ExtraGoals = cord.from_list(TypeInfoGoals) ++ !.ExtraGoals ++
- MakeTypeClassInfoGoals ++ cord.from_list(UnconstrainedTypeInfoGoals).
-
-:- pred make_typeclass_info_from_subclass(prog_constraint::in,
- list(prog_constraint)::in, prog_constraint::in,
- existq_tvars::in, prog_context::in, prog_var::out,
- cord(hlds_goal)::in, cord(hlds_goal)::out,
- poly_info::in, poly_info::out) is det.
+ % Make the type_infos for the unconstrained type variables
+ % from the head of the instance declaration.
+ polymorphism_do_make_type_info_vars(ActualUnconstrainedTypes, Context,
+ ArgUnconstrainedTypeInfoVarsMCAs, UnconstrainedTypeInfoGoals, !Info),
-make_typeclass_info_from_subclass(Constraint, Seen, SubClassConstraint,
- ExistQVars, Context, TypeClassInfoVar, !ExtraGoals, !Info) :-
- % First create a variable to hold the new typeclass_info.
- new_typeclass_info_var(Constraint, typeclass_info_kind, TypeClassInfoVar,
- !Info),
+ % --------------------- %
- % Then work out where to extract it from.
- SubClassConstraint = constraint(SubClassName, SubClassTypes),
- list.length(SubClassTypes, SubClassArity),
- SubClassId = class_id(SubClassName, SubClassArity),
+ map.lookup(ClassTable, ClassId, ClassDefn),
- % Make the typeclass_info for the subclass.
- make_typeclass_info_var(SubClassConstraint, Seen, ExistQVars, Context,
- SubClassVar, !ExtraGoals, !Info),
+ get_arg_superclass_vars(ClassDefn, ConstrainedTypes, Proofs,
+ ExistQVars, ArgSuperClassVarsMCAs, SuperClassGoals, !Info),
- % Look up the definition of the subclass.
- poly_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_class_table(ModuleInfo, ClassTable),
- map.lookup(ClassTable, SubClassId, SubClassDefn),
+ PrevGoals = UnconstrainedTypeInfoGoals ++ TypeInfoGoals ++
+ InstanceConstraintGoals ++ SuperClassGoals,
+ % Lay out the argument variables as expected in the typeclass_info.
+ ArgVarsMCAs = ArgUnconstrainedTypeInfoVarsMCAs ++
+ ArgTypeClassInfoVarsMCAs ++
+ ArgSuperClassVarsMCAs ++ ArgTypeInfoVarsMCAs,
+ list.map(make_const_or_var_arg, ArgVarsMCAs, ArgCOVAs),
- % Work out which superclass typeclass_info to take.
- map.from_corresponding_lists(SubClassDefn ^ class_vars, SubClassTypes,
- SubTypeSubst),
- apply_subst_to_prog_constraint_list(SubTypeSubst,
- SubClassDefn ^ class_supers, SuperClasses),
- ( list.nth_member_search(SuperClasses, Constraint, SuperClassIndex0) ->
- SuperClassIndex0 = SuperClassIndex
+ Constraint = constraint(ConstraintClassName, ConstraintArgTypes),
+ poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap0),
+ (
+ map.search(TypeClassInfoMap0, ConstraintClassName, ClassNameMap0),
+ map.search(ClassNameMap0, ConstraintArgTypes, OldEntry0),
+ OldEntry0 = typeclass_info_map_entry(_BaseConsId, ArgsMap0),
+ map.search(ArgsMap0, ArgCOVAs, OldTypeClassInfoVarMCA0)
+ ->
+ TypeClassInfoVarMCA = OldTypeClassInfoVarMCA0,
+ % ZZZ
+ Goals = [],
+ set_var_maps_snapshot("make_typeclass_info",
+ InitialVarMapsSnapshot, !Info),
+ poly_info_get_num_reuses(!.Info, NumReuses),
+ poly_info_set_num_reuses(NumReuses + 2, !Info)
;
- % We shouldn't have got this far if the constraints were not satisfied.
- unexpected($module, $pred, "constraint not in constraint list")
+ BaseConsId = base_typeclass_info_cons_id(InstanceTable,
+ Constraint, InstanceNum, InstanceTypes),
+ materialize_base_typeclass_info_var(Constraint, BaseConsId, BaseVar,
+ BaseGoals, !Info),
+ construct_typeclass_info(Constraint, BaseVar, BaseConsId, ArgVarsMCAs,
+ InitialVarMapsSnapshot, TypeClassInfoVar, TypeClassInfoMCA,
+ BaseGoals ++ PrevGoals, Goals, !Info),
+ TypeClassInfoVarMCA = TypeClassInfoVar - TypeClassInfoMCA,
+
+ % We must start the search from scratch, since construct_typeclass_info
+ % may have reset all the cache maps.
+ poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap1),
+ ( map.search(TypeClassInfoMap1, ConstraintClassName, ClassNameMap1) ->
+ ( map.search(ClassNameMap1, ConstraintArgTypes, OldEntry1) ->
+ OldEntry1 = typeclass_info_map_entry(BaseConsId1, ArgsMap1),
+ expect(unify(BaseConsId1, BaseConsId), $module, $pred,
+ "BaseConsId1 != BaseConsId"),
+ map.det_insert(ArgCOVAs, TypeClassInfoVarMCA,
+ ArgsMap1, ArgsMap),
+ Entry = typeclass_info_map_entry(BaseConsId, ArgsMap),
+ map.det_update(ConstraintArgTypes, Entry,
+ ClassNameMap1, ClassNameMap),
+ map.det_update(ConstraintClassName, ClassNameMap,
+ TypeClassInfoMap1, TypeClassInfoMap)
+ ;
+ ArgsMap = map.singleton(ArgCOVAs, TypeClassInfoVarMCA),
+ Entry = typeclass_info_map_entry(BaseConsId, ArgsMap),
+ map.det_insert(ConstraintArgTypes, Entry,
+ ClassNameMap1, ClassNameMap),
+ map.det_update(ConstraintClassName, ClassNameMap,
+ TypeClassInfoMap1, TypeClassInfoMap)
+ )
+ ;
+ ArgsMap = map.singleton(ArgCOVAs, TypeClassInfoVarMCA),
+ Entry = typeclass_info_map_entry(BaseConsId, ArgsMap),
+ ClassNameMap = map.singleton(ConstraintArgTypes, Entry),
+ map.det_insert(ConstraintClassName, ClassNameMap,
+ TypeClassInfoMap1, TypeClassInfoMap)
+ ),
+ poly_info_set_typeclass_info_map(TypeClassInfoMap, !Info)
),
- get_poly_const(SuperClassIndex, IndexVar, IndexGoals, !Info),
-
- % We extract the superclass typeclass_info by inserting a call
- % to superclass_from_typeclass_info in private_builtin.
- goal_util.generate_simple_call(mercury_private_builtin_module,
- "superclass_from_typeclass_info", pf_predicate, only_mode, detism_det,
- purity_pure, [SubClassVar, IndexVar, TypeClassInfoVar], [],
- instmap_delta_bind_no_var, ModuleInfo, term.context_init,
- SuperClassGoal),
- !:ExtraGoals = !.ExtraGoals ++
- cord.from_list(IndexGoals ++ [SuperClassGoal]).
+ (
+ TypeClassInfoVarMCA = _ - yes(TypeClassInfoConstArg),
+ TypeClassInfoConstArg = csa_const_struct(TypeClassInfoConstArgNum)
+ ->
+ poly_info_get_const_struct_db(!.Info, ConstStructDb1),
+ insert_constant_instance(InstanceId, TypeClassInfoConstArgNum,
+ ConstStructDb1, ConstStructDb),
+ poly_info_set_const_struct_db(ConstStructDb, !Info)
+ ;
+ true
+ ).
-:- pred construct_base_typeclass_info(prog_constraint::in,
- int::in, list(mer_type)::in, prog_var::out, hlds_goal::out,
+:- pred construct_typeclass_info(prog_constraint::in,
+ prog_var::in, cons_id::in,
+ assoc_list(prog_var, maybe(const_struct_arg))::in, var_maps::in,
+ prog_var::out, maybe(const_struct_arg)::out,
+ list(hlds_goal)::in, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
-construct_base_typeclass_info(Constraint, InstanceNum, InstanceTypes,
- BaseVar, BaseGoal, !Info) :-
- new_typeclass_info_var(Constraint, base_typeclass_info_kind, BaseVar,
- !Info),
+construct_typeclass_info(Constraint, BaseVar, BaseConsId, ArgVarsMCAs,
+ InitialVarMapsSnapshot, TypeClassInfoVar, TypeClassInfoMCA,
+ PrevGoals, AllGoals, !Info) :-
+ % Build a unification to add the argvars to the base_typeclass_info.
+ ConsId = typeclass_info_cell_constructor,
- poly_info_get_module_info(!.Info, ModuleInfo),
- module_info_get_instance_table(ModuleInfo, InstanceTable),
- Constraint = constraint(ClassName, ConstraintArgTypes),
- ClassId = class_id(ClassName, list.length(ConstraintArgTypes)),
- map.lookup(InstanceTable, ClassId, InstanceList),
- list.det_index1(InstanceList, InstanceNum, InstanceDefn),
- InstanceModuleName = InstanceDefn ^ instance_module,
- make_instance_string(InstanceTypes, InstanceString),
- ConsId = base_typeclass_info_const(InstanceModuleName, ClassId,
- InstanceNum, InstanceString),
- BaseTypeClassInfoTerm = rhs_functor(ConsId, no, []),
+ poly_info_get_const_struct_db(!.Info, ConstStructDb0),
+ const_struct_db_get_enabled(ConstStructDb0, ConstStructEnabled),
+ (
+ ConstStructEnabled = yes,
+ all_are_const_struct_args(ArgVarsMCAs, VarConstArgs)
+ ->
+ poly_info_get_num_reuses(!.Info, NumReuses),
+ poly_info_set_num_reuses(NumReuses + 1, !Info),
+
+ set_var_maps_snapshot("construct_typeclass_info",
+ InitialVarMapsSnapshot, !Info),
+ new_typeclass_info_var(Constraint, typeclass_info_kind,
+ TypeClassInfoVar, TypeClassInfoVarType, !Info),
+
+ build_typeclass_info_type(Constraint, BaseConstArgType),
+ BaseConstArg = csa_constant(BaseConsId, BaseConstArgType),
+ StructArgs = [BaseConstArg | VarConstArgs],
+ list.map(get_inst_of_const_struct_arg(ConstStructDb0),
+ VarConstArgs, VarInsts),
+ list.length(ArgVarsMCAs, NumArgs),
+ InstConsId = cell_inst_cons_id(typeclass_info_cell, NumArgs),
+ StructInst = bound(shared, inst_test_results_fgtc,
+ [bound_functor(InstConsId, VarInsts)]),
+ ConstStruct = const_struct(ConsId, StructArgs,
+ TypeClassInfoVarType, StructInst),
+ lookup_insert_const_struct(ConstStruct, ConstNum,
+ ConstStructDb0, ConstStructDb),
+ poly_info_set_const_struct_db(ConstStructDb, !Info),
+ TypeClassInfoConstArg = csa_const_struct(ConstNum),
+ TypeClassInfoMCA = yes(TypeClassInfoConstArg),
% Create the construction unification to initialize the variable.
- BaseUnification = construct(BaseVar, ConsId, [], [],
- construct_dynamically, cell_is_shared, no_construct_sub_info),
- BaseUnifyMode = (free -> ground(shared, none)) -
+ ConstConsId = typeclass_info_const(ConstNum),
+ Unification = construct(TypeClassInfoVar, ConstConsId, [], [],
+ construct_statically, cell_is_shared, no_construct_sub_info),
+ UnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
- BaseUnifyContext = unify_context(umc_explicit, []),
% XXX The UnifyContext is wrong.
- BaseUnify = unify(BaseVar, BaseTypeClassInfoTerm, BaseUnifyMode,
- BaseUnification, BaseUnifyContext),
-
- % Create the unification goal.
- NonLocals = set_of_var.make_singleton(BaseVar),
- InstmapDelta = instmap_delta_bind_var(BaseVar),
- goal_info_init(NonLocals, InstmapDelta, detism_det, purity_pure,
- BaseGoalInfo),
- BaseGoal = hlds_goal(BaseUnify, BaseGoalInfo).
+ UnifyContext = unify_context(umc_explicit, []),
+ TypeClassInfoRHS = rhs_functor(ConstConsId, no, []),
+ GoalExpr = unify(TypeClassInfoVar, TypeClassInfoRHS, UnifyMode,
+ Unification, UnifyContext),
-:- pred construct_typeclass_info(prog_constraint::in,
- prog_var::in, list(prog_var)::in, prog_var::out, hlds_goal::out,
- poly_info::in, poly_info::out) is det.
+ % Create a goal_info for the unification.
+ goal_info_init(GoalInfo0),
+ NonLocals = set_of_var.make_singleton(TypeClassInfoVar),
+ goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo1),
+ % Note that we could perhaps be more accurate than `ground(shared)',
+ % but it shouldn't make any difference.
+ InstResults = inst_test_results(inst_result_is_ground,
+ inst_result_does_not_contain_any,
+ inst_result_contains_instnames_known(set.init),
+ inst_result_contains_types_known(set.init)),
+ TypeClassInfoInst = bound(shared, InstResults,
+ [bound_functor(ConsId, [])]),
+ TypeClassInfoVarInst = TypeClassInfoVar - TypeClassInfoInst,
+ InstMapDelta = instmap_delta_from_assoc_list([TypeClassInfoVarInst]),
+ goal_info_set_instmap_delta(InstMapDelta, GoalInfo1, GoalInfo2),
+ goal_info_set_determinism(detism_det, GoalInfo2, GoalInfo),
-construct_typeclass_info(Constraint, BaseVar, ArgVars, TypeClassInfoVar, Goal,
- !Info) :-
- % Build a unification to add the argvars to the base_typeclass_info.
- ConsId = typeclass_info_cell_constructor,
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+ % XXX reset varset and vartypes
+ AllGoals = [Goal]
+ ;
+ TypeClassInfoMCA = no,
+ new_typeclass_info_var(Constraint, typeclass_info_kind,
+ TypeClassInfoVar, _TypeClassInfoVarType, !Info),
+ assoc_list.keys(ArgVarsMCAs, ArgVars),
AllArgVars = [BaseVar | ArgVars],
- TypeClassInfoTerm = rhs_functor(ConsId, no, AllArgVars),
-
- new_typeclass_info_var(Constraint, typeclass_info_kind, TypeClassInfoVar,
- !Info),
% Create the construction unification to initialize the variable.
+ TypeClassInfoRHS = rhs_functor(ConsId, no, AllArgVars),
UniMode = (free - ground(shared, none) ->
ground(shared, none) - ground(shared, none)),
- list.length(AllArgVars, NumArgVars),
- list.duplicate(NumArgVars, UniMode, UniModes),
+ list.length(AllArgVars, NumArgs),
+ list.duplicate(NumArgs, UniMode, UniModes),
Unification = construct(TypeClassInfoVar, ConsId, AllArgVars, UniModes,
construct_dynamically, cell_is_unique, no_construct_sub_info),
UnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(umc_explicit, []),
% XXX The UnifyContext is wrong.
- GoalExpr = unify(TypeClassInfoVar, TypeClassInfoTerm, UnifyMode,
+ GoalExpr = unify(TypeClassInfoVar, TypeClassInfoRHS, UnifyMode,
Unification, UnifyContext),
% Create a goal_info for the unification.
goal_info_init(GoalInfo0),
set_of_var.list_to_set([TypeClassInfoVar | AllArgVars], NonLocals),
goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo1),
- list.duplicate(NumArgVars, ground(shared, none), ArgInsts),
+ list.duplicate(NumArgs, ground(shared, none), ArgInsts),
% Note that we could perhaps be more accurate than `ground(shared)',
% but it shouldn't make any difference.
- InstConsId = cell_inst_cons_id(typeclass_info_cell, NumArgVars),
+ InstConsId = cell_inst_cons_id(typeclass_info_cell, NumArgs),
InstResults = inst_test_results(inst_result_is_ground,
inst_result_does_not_contain_any,
inst_result_contains_instnames_known(set.init),
inst_result_contains_types_unknown),
+ % XXX that should be inst_result_contains_types_known(set.init),
TypeClassInfoInst = bound(unique, InstResults,
[bound_functor(InstConsId, ArgInsts)]),
- InstMapDelta =
- instmap_delta_from_assoc_list([TypeClassInfoVar - TypeClassInfoInst]),
+ TypeClassInfoVarInst = TypeClassInfoVar - TypeClassInfoInst,
+ InstMapDelta = instmap_delta_from_assoc_list([TypeClassInfoVarInst]),
goal_info_set_instmap_delta(InstMapDelta, GoalInfo1, GoalInfo2),
goal_info_set_determinism(detism_det, GoalInfo2, GoalInfo),
- Goal = hlds_goal(GoalExpr, GoalInfo).
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+ AllGoals = PrevGoals ++ [Goal]
+ ).
-:- pred make_typeclass_info(list(prog_var)::in, list(prog_var)::in,
- list(prog_var)::in, class_id::in, prog_constraint::in, int::in,
- list(mer_type)::in, constraint_proof_map::in, existq_tvars::in,
- prog_var::out, cord(hlds_goal)::out, poly_info::in, poly_info::out) is det.
-
-make_typeclass_info(ArgUnconstrainedTypeInfoVars, ArgTypeInfoVars,
- ArgTypeClassInfoVars, ClassId, Constraint, InstanceNum, InstanceTypes,
- SuperClassProofs, ExistQVars, TypeClassInfoVar, Goals, !Info) :-
- poly_info_get_module_info(!.Info, ModuleInfo),
+%---------------------------------------------------------------------------%
- module_info_get_class_table(ModuleInfo, ClassTable),
- map.lookup(ClassTable, ClassId, ClassDefn),
+:- pred get_arg_superclass_vars(hlds_class_defn::in, list(mer_type)::in,
+ constraint_proof_map::in, existq_tvars::in,
+ assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
- get_arg_superclass_vars(ClassDefn, InstanceTypes, SuperClassProofs,
- ExistQVars, ArgSuperClassVars, SuperClassGoals, !Info),
+get_arg_superclass_vars(ClassDefn, InstanceTypes, SuperClassProofs, ExistQVars,
+ SuperClassTypeClassInfoVarsMCAs, SuperClassGoals, !Info) :-
+ poly_info_get_proofs(!.Info, Proofs),
- % Lay out the argument variables as expected in the typeclass_info.
- ArgVars = ArgUnconstrainedTypeInfoVars ++ ArgTypeClassInfoVars ++
- ArgSuperClassVars ++ ArgTypeInfoVars,
-
- Constraint = constraint(ConstraintClassName, ConstraintArgTypes),
- poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap0),
- ( map.search(TypeClassInfoMap0, ConstraintClassName, ClassNameMap0) ->
- ( map.search(ClassNameMap0, ConstraintArgTypes, OldEntry) ->
- OldEntry = typeclass_info_map_entry(BaseVar, ArgsMap0),
- ( map.search(ArgsMap0, ArgVars, OldTypeClassInfoVar) ->
- TypeClassInfoVar = OldTypeClassInfoVar,
- Goals = SuperClassGoals,
- poly_info_get_num_reuses(!.Info, NumReuses),
- poly_info_set_num_reuses(NumReuses + 2, !Info)
- ;
- construct_typeclass_info(Constraint, BaseVar, ArgVars,
- TypeClassInfoVar, TypeClassInfoGoal, !Info),
- Goals = SuperClassGoals ++
- cord.singleton(TypeClassInfoGoal),
- poly_info_get_num_reuses(!.Info, NumReuses),
- poly_info_set_num_reuses(NumReuses + 1, !Info),
- map.det_insert(ArgVars, TypeClassInfoVar, ArgsMap0, ArgsMap),
- Entry = typeclass_info_map_entry(BaseVar, ArgsMap),
- map.det_update(ConstraintArgTypes, Entry,
- ClassNameMap0, ClassNameMap),
- map.det_update(ConstraintClassName, ClassNameMap,
- TypeClassInfoMap0, TypeClassInfoMap),
- poly_info_set_typeclass_info_map(TypeClassInfoMap, !Info)
- )
- ;
- construct_base_typeclass_info(Constraint,
- InstanceNum, InstanceTypes, BaseVar, BaseGoal, !Info),
- construct_typeclass_info(Constraint, BaseVar, ArgVars,
- TypeClassInfoVar, TypeClassInfoGoal, !Info),
- Goals = SuperClassGoals ++
- cord.from_list([BaseGoal, TypeClassInfoGoal]),
- ArgsMap = map.singleton(ArgVars, TypeClassInfoVar),
- Entry = typeclass_info_map_entry(BaseVar, ArgsMap),
- map.det_insert(ConstraintArgTypes, Entry,
- ClassNameMap0, ClassNameMap),
- map.det_update(ConstraintClassName, ClassNameMap,
- TypeClassInfoMap0, TypeClassInfoMap),
- poly_info_set_typeclass_info_map(TypeClassInfoMap, !Info)
- )
- ;
- construct_base_typeclass_info(Constraint,
- InstanceNum, InstanceTypes, BaseVar, BaseGoal, !Info),
- construct_typeclass_info(Constraint, BaseVar, ArgVars,
- TypeClassInfoVar, TypeClassInfoGoal, !Info),
- Goals = SuperClassGoals ++
- cord.from_list([BaseGoal, TypeClassInfoGoal]),
- ArgsMap = map.singleton(ArgVars, TypeClassInfoVar),
- Entry = typeclass_info_map_entry(BaseVar, ArgsMap),
- ClassNameMap = map.singleton(ConstraintArgTypes, Entry),
- map.det_insert(ConstraintClassName, ClassNameMap,
- TypeClassInfoMap0, TypeClassInfoMap),
- poly_info_set_typeclass_info_map(TypeClassInfoMap, !Info)
- ).
-
-%---------------------------------------------------------------------------%
-
-:- pred get_arg_superclass_vars(hlds_class_defn::in, list(mer_type)::in,
- constraint_proof_map::in, existq_tvars::in,
- list(prog_var)::out, cord(hlds_goal)::out,
- poly_info::in, poly_info::out) is det.
-
-get_arg_superclass_vars(ClassDefn, InstanceTypes, SuperClassProofs, ExistQVars,
- SuperClassTypeClassInfoVars, SuperClassGoals, !Info) :-
- poly_info_get_proofs(!.Info, Proofs),
-
- poly_info_get_typevarset(!.Info, TVarSet0),
- SuperClasses0 = ClassDefn ^ class_supers,
- ClassVars0 = ClassDefn ^ class_vars,
- ClassTVarSet = ClassDefn ^ class_tvarset,
- tvarset_merge_renaming(TVarSet0, ClassTVarSet, TVarSet1, Renaming),
- poly_info_set_typevarset(TVarSet1, !Info),
+ poly_info_get_typevarset(!.Info, TVarSet0),
+ SuperClasses0 = ClassDefn ^ class_supers,
+ ClassVars0 = ClassDefn ^ class_vars,
+ ClassTVarSet = ClassDefn ^ class_tvarset,
+ tvarset_merge_renaming(TVarSet0, ClassTVarSet, TVarSet1, Renaming),
+ poly_info_set_typevarset(TVarSet1, !Info),
apply_variable_renaming_to_tvar_list(Renaming, ClassVars0, ClassVars),
map.from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
apply_variable_renaming_to_prog_constraint_list(Renaming,
SuperClasses0, SuperClasses1),
- apply_rec_subst_to_prog_constraint_list(TypeSubst, SuperClasses1,
- SuperClasses),
+ apply_rec_subst_to_prog_constraint_list(TypeSubst,
+ SuperClasses1, SuperClasses),
poly_info_set_proofs(SuperClassProofs, !Info),
make_superclasses_from_proofs(SuperClasses, ExistQVars,
- SuperClassTypeClassInfoVars, cord.empty, SuperClassGoals, !Info),
+ SuperClassTypeClassInfoVarsMCAs, SuperClassGoals, !Info),
poly_info_set_proofs(Proofs, !Info).
:- pred make_superclasses_from_proofs(list(prog_constraint)::in,
- existq_tvars::in, list(prog_var)::out,
- cord(hlds_goal)::in, cord(hlds_goal)::out,
- poly_info::in, poly_info::out) is det.
+ existq_tvars::in, assoc_list(prog_var, maybe(const_struct_arg))::out,
+ list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
-make_superclasses_from_proofs([], _, [], !Goals, !Info).
+make_superclasses_from_proofs([], _, [], [], !Info).
make_superclasses_from_proofs([Constraint | Constraints], ExistQVars,
- [TypeClassInfoVar | TypeClassInfoVars], !Goals, !Info) :-
+ [TypeClassInfoVarMCA | TypeClassInfoVarsMCAs], Goals, !Info) :-
term.context_init(Context),
make_typeclass_info_var(Constraint, [], ExistQVars, Context,
- TypeClassInfoVar, !Goals, !Info),
+ TypeClassInfoVarMCA, HeadGoals, !Info),
make_superclasses_from_proofs(Constraints, ExistQVars,
- TypeClassInfoVars, !Goals, !Info).
+ TypeClassInfoVarsMCAs, TailGoals, !Info),
+ Goals = HeadGoals ++ TailGoals.
%-----------------------------------------------------------------------------%
@@ -2801,16 +3123,37 @@
%---------------------------------------------------------------------------%
-polymorphism_make_type_info_vars([], _, [], [], !Info).
-polymorphism_make_type_info_vars([Type | Types], Context,
- ExtraVars, ExtraGoals, !Info) :-
- polymorphism_make_type_info_var(Type, Context, Var, ExtraGoals1, !Info),
- polymorphism_make_type_info_vars(Types, Context, ExtraVars2, ExtraGoals2,
- !Info),
- ExtraVars = [Var | ExtraVars2],
- ExtraGoals = ExtraGoals1 ++ ExtraGoals2.
+polymorphism_make_type_info_vars(Types, Context, ExtraVars,
+ ExtraGoals, !Info) :-
+ polymorphism_do_make_type_info_vars(Types, Context, ExtraVarsMCAs,
+ ExtraGoals, !Info),
+ assoc_list.keys(ExtraVarsMCAs, ExtraVars).
+
+polymorphism_make_type_info_var(Type, Context, ExtraVar, ExtraGoals, !Info) :-
+ polymorphism_do_make_type_info_var(Type, Context, ExtraVarMCA,
+ ExtraGoals, !Info),
+ ExtraVarMCA = ExtraVar - _.
+
+:- pred polymorphism_do_make_type_info_vars(list(mer_type)::in,
+ term.context::in,
+ assoc_list(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
-polymorphism_make_type_info_var(Type, Context, Var, ExtraGoals, !Info) :-
+polymorphism_do_make_type_info_vars([], _, [], [], !Info).
+polymorphism_do_make_type_info_vars([Type | Types], Context,
+ VarsMCAs, Goals, !Info) :-
+ polymorphism_do_make_type_info_var(Type, Context, HeadVarMCA,
+ HeadGoals, !Info),
+ polymorphism_do_make_type_info_vars(Types, Context, TailVarsMCAs,
+ TailGoals, !Info),
+ VarsMCAs = [HeadVarMCA | TailVarsMCAs],
+ Goals = HeadGoals ++ TailGoals.
+
+:- pred polymorphism_do_make_type_info_var(mer_type::in, term.context::in,
+ pair(prog_var, maybe(const_struct_arg))::out, list(hlds_goal)::out,
+ poly_info::in, poly_info::out) is det.
+
+polymorphism_do_make_type_info_var(Type, Context, VarMCA, ExtraGoals, !Info) :-
% First handle statically known types (i.e. types which are not
% type variables).
( type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) ->
@@ -2826,7 +3169,7 @@
% we should not ignore the purity of higher order procs;
% it should get included in the RTTI.
polymorphism_make_type_info(Type, TypeCtor, TypeArgs, yes,
- Context, Var, ExtraGoals, !Info)
+ Context, VarMCA, ExtraGoals, !Info)
;
(
( Type = defined_type(_, _, _)
@@ -2842,76 +3185,49 @@
% transformation we perform is shown in the comment at the top
% of the module.
polymorphism_make_type_info(Type, TypeCtor, TypeArgs, no,
- Context, Var, ExtraGoals, !Info)
+ Context, VarMCA, ExtraGoals, !Info)
;
- % Now handle the cases of types which are not known statically
- % (i.e. type variables)
+ % Now handle the cases of types which are not known statically,
+ % i.e. type variables.
Type = type_variable(TypeVar, _),
get_type_info_locn(TypeVar, TypeInfoLocn, !Info),
- get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, !Info)
+ get_type_info_from_locn(TypeVar, TypeInfoLocn, Var, ExtraGoals,
+ !Info),
+ VarMCA = Var - no
)
).
-:- pred get_type_info_locn(tvar::in, type_info_locn::out, poly_info::in,
- poly_info::out) is det.
-
-get_type_info_locn(TypeVar, TypeInfoLocn, !Info) :-
- % If we have already allocated a location for this type_info, then all
- % we need to do is to extract the type_info variable from its location.
- (
- rtti_search_type_info_locn(!.Info ^ poly_rtti_varmaps, TypeVar,
- TypeInfoLocnPrime)
- ->
- TypeInfoLocn = TypeInfoLocnPrime
- ;
- % Otherwise, we need to create a new type_info variable, and set the
- % location for this type variable to be that type_info variable.
- %
- % This is wrong if the type variable is one of the existentially
- % quantified variables of a called predicate and the variable occurs
- % in an existential typeclass constraint. In that case the type_info
- % will be stored in the typeclass_info variable produced by the
- % predicate, not in a type_info variable. maybe_extract_type_info
- % will fix this up when the typeclass_info is created.
-
- get_tvar_kind(!.Info ^ poly_tvar_kinds, TypeVar, Kind),
- Type = type_variable(TypeVar, Kind),
- new_type_info_var(Type, type_info, Var, !Info),
- TypeInfoLocn = type_info(Var),
- poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
- rtti_det_insert_type_info_locn(TypeVar, TypeInfoLocn,
- RttiVarMaps0, RttiVarMaps),
- poly_info_set_rtti_varmaps(RttiVarMaps, !Info)
- ).
-
:- pred polymorphism_make_type_info(mer_type::in, type_ctor::in,
- list(mer_type)::in, bool::in, prog_context::in, prog_var::out,
+ list(mer_type)::in, bool::in, prog_context::in,
+ pair(prog_var, maybe(const_struct_arg))::out,
list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
polymorphism_make_type_info(Type, TypeCtor, TypeArgs, TypeCtorIsVarArity,
- Context, TypeInfoVar, ExtraGoals, !Info) :-
+ Context, TypeInfoVarMCA, ExtraGoals, !Info) :-
poly_info_get_type_info_var_map(!.Info, TypeInfoVarMap0),
(
map.search(TypeInfoVarMap0, TypeCtor, TypeCtorVarMap0),
- map.search(TypeCtorVarMap0, TypeArgs, OldTypeInfoVar)
+ map.search(TypeCtorVarMap0, TypeArgs, OldTypeInfoVarMCA)
->
poly_info_get_num_reuses(!.Info, NumReuses),
poly_info_set_num_reuses(NumReuses + 1, !Info),
- TypeInfoVar = OldTypeInfoVar,
+ TypeInfoVarMCA = OldTypeInfoVarMCA,
ExtraGoals = []
;
polymorphism_construct_type_info(Type, TypeCtor, TypeArgs,
- TypeCtorIsVarArity, Context, TypeInfoVar, ExtraGoals, !Info),
+ TypeCtorIsVarArity, Context, TypeInfoVar, TypeInfoConstArg,
+ ExtraGoals, !Info),
+ TypeInfoVarMCA = TypeInfoVar - TypeInfoConstArg,
% We have to get the type_info_var_map again since the call just above
% could have added relevant new entries to it.
poly_info_get_type_info_var_map(!.Info, TypeInfoVarMap1),
( map.search(TypeInfoVarMap1, TypeCtor, TypeCtorVarMap1) ->
- map.det_insert(TypeArgs, TypeInfoVar,
+ map.det_insert(TypeArgs, TypeInfoVarMCA,
TypeCtorVarMap1, TypeCtorVarMap),
map.det_update(TypeCtor, TypeCtorVarMap,
TypeInfoVarMap1, TypeInfoVarMap)
;
- TypeCtorVarMap = map.singleton(TypeArgs, TypeInfoVar),
+ TypeCtorVarMap = map.singleton(TypeArgs, TypeInfoVarMCA),
map.det_insert(TypeCtor, TypeCtorVarMap,
TypeInfoVarMap1, TypeInfoVarMap)
),
@@ -2919,52 +3235,50 @@
).
:- pred polymorphism_construct_type_info(mer_type::in, type_ctor::in,
- list(mer_type)::in, bool::in, prog_context::in, prog_var::out,
+ list(mer_type)::in, bool::in, prog_context::in,
+ prog_var::out, maybe(const_struct_arg)::out,
list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
polymorphism_construct_type_info(Type, TypeCtor, TypeArgs, TypeCtorIsVarArity,
- Context, Var, ExtraGoals, !Info) :-
+ Context, Var, MCA, ExtraGoals, !Info) :-
+ get_var_maps_snapshot("polymorphism_construct_type_info",
+ InitialVarMapsSnapshot, !Info),
+
% Create the typeinfo vars for the arguments.
- polymorphism_make_type_info_vars(TypeArgs, Context,
- ArgTypeInfoVars, ArgTypeInfoGoals, !Info),
+ polymorphism_do_make_type_info_vars(TypeArgs, Context,
+ ArgTypeInfoVarsMCAs, ArgTypeInfoGoals, !Info),
poly_info_get_varset(!.Info, VarSet0),
poly_info_get_var_types(!.Info, VarTypes0),
- poly_info_get_module_info(!.Info, ModuleInfo),
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
- poly_info_get_type_ctor_info_var_map(!.Info, TypeCtorInfoVarMap0),
- ( map.search(TypeCtorInfoVarMap0, TypeCtor, OldTypeCtorVar) ->
+ TypeCtorConsId = type_ctor_info_cons_id(TypeCtor),
+ TypeCtorConsIdConstArg = csa_constant(TypeCtorConsId, type_info_type),
+ poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap0),
+ ( map.search(ConstStructVarMap0, TypeCtorConsIdConstArg, OldTypeCtorVar) ->
poly_info_get_num_reuses(!.Info, NumReuses),
poly_info_set_num_reuses(NumReuses + 1, !Info),
TypeCtorVar = OldTypeCtorVar,
TypeCtorGoals = [],
- VarSet = VarSet0,
- VarTypes = VarTypes0,
- RttiVarMaps = RttiVarMaps0
- ;
- init_const_type_ctor_info_var(Type, TypeCtor, TypeCtorVar,
- TypeCtorGoal, ModuleInfo, VarSet0, VarSet, VarTypes0, VarTypes,
- RttiVarMaps0, RttiVarMaps),
+ VarSet1 = VarSet0,
+ VarTypes1 = VarTypes0,
+ RttiVarMaps1 = RttiVarMaps0
+ ;
+ init_const_type_ctor_info_var_from_cons_id(Type, TypeCtorConsId,
+ TypeCtorVar, TypeCtorGoal, VarSet0, VarSet1, VarTypes0, VarTypes1,
+ RttiVarMaps0, RttiVarMaps1),
TypeCtorGoals = [TypeCtorGoal],
- map.det_insert(TypeCtor, TypeCtorVar,
- TypeCtorInfoVarMap0, TypeCtorInfoVarMap),
- poly_info_set_type_ctor_info_var_map(TypeCtorInfoVarMap, !Info)
+ map.det_insert(TypeCtorConsIdConstArg, TypeCtorVar,
+ ConstStructVarMap0, ConstStructVarMap1),
+ poly_info_set_const_struct_var_map(ConstStructVarMap1, !Info)
),
- poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
- poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
+ poly_info_set_varset_and_types(VarSet1, VarTypes1, !Info),
+ poly_info_set_rtti_varmaps(RttiVarMaps1, !Info),
- maybe_init_second_cell(Type, TypeCtorVar, TypeCtorIsVarArity,
- ArgTypeInfoVars, Context, Var,
- ArgTypeInfoGoals, TypeCtorGoals, ExtraGoals, !Info).
-
- % maybe_init_second_cell(Type, TypeCtorVar, TypeCtorIsVarArity,
- % ArgTypeInfoVars, Context, Var,
- % ArgTypeInfoGoals, ExtraGoals0, ExtraGoals, !Info):
- %
- % Create a unification the constructs the second cell of a type_info
- % for Type if necessary. This cell will usually be of the form:
+ % The rest of this predicate create code that constructs the second cell
+ % of a type_info for Type if we need a second cell for Type. This cell
+ % will usually be of the form:
%
% TypeInfoVar = type_info(TypeCtorVar, ArgTypeInfoVars...)
%
@@ -2981,71 +3295,132 @@
%
% The returned Var will be bound to the type_info cell of Type if such
% a cell had to be allocated, and to the type_ctor_info of Type's only
- % type constructor if it didn't. The returned ExtraGoals is a
- % concatenation of ArgTypeInfoGoals, ExtraGoals0, and any goals needed
- % to construct Var.
- %
-:- pred maybe_init_second_cell(mer_type::in, prog_var::in,
- bool::in, list(prog_var)::in, prog_context::in, prog_var::out,
- list(hlds_goal)::in, list(hlds_goal)::in, list(hlds_goal)::out,
- poly_info::in, poly_info::out) is det.
+ % type constructor if it didn't.
-maybe_init_second_cell(Type, TypeCtorVar, TypeCtorIsVarArity, ArgTypeInfoVars,
- _Context, Var, ArgTypeInfoGoals, ExtraGoals0, ExtraGoals, !Info) :-
(
- TypeCtorIsVarArity = yes,
% Unfortunately, if the type's type constructor has variable arity,
% we cannot use a one-cell representation for that type.
+ TypeCtorIsVarArity = no,
+ ArgTypeInfoVarsMCAs = []
+ ->
+ % We do not need a second cell for a separate typeinfo; we will use
+ % the type_ctor_info as the type_info.
+
+ % Since this type_ctor_info is pretending to be a type_info,
+ % we need to adjust its type. We handle type_ctor_info_const cons_ids
+ % specially to make sure that this causes no problems.
+ TypeInfoType = type_info_type,
+ Var = TypeCtorVar,
+ TypeCtorConstArg = csa_constant(TypeCtorConsId, type_info_type),
+ MCA = yes(TypeCtorConstArg),
+ ExtraGoals = ArgTypeInfoGoals ++ TypeCtorGoals,
+ map.det_update(TypeCtorVar, TypeInfoType, VarTypes1, VarTypes),
+ poly_info_set_varset_and_types(VarSet1, VarTypes, !Info)
+ ;
+ % We do need a second cell for a separate typeinfo.
+ Cell = type_info_cell(TypeCtor),
+ ConsId = cell_cons_id(Cell),
+
+ poly_info_get_const_struct_db(!.Info, ConstStructDb0),
+ const_struct_db_get_enabled(ConstStructDb0, Enabled),
+ (
+ Enabled = yes,
+ all_are_const_struct_args(ArgTypeInfoVarsMCAs,
+ ArgTypeInfoConstArgs)
+ ->
+ TypeCtorConstArg = csa_constant(TypeCtorConsId, type_info_type),
+ TypeCtorInst = bound(shared, inst_test_results_fgtc,
+ [bound_functor(TypeCtorConsId, [])]),
+ list.map(get_inst_of_const_struct_arg(ConstStructDb0),
+ ArgTypeInfoConstArgs, ArgTypeInfoInsts),
+ (
+ TypeCtorIsVarArity = yes,
+ list.length(ArgTypeInfoVarsMCAs, ActualArity),
+ ArityConstArg = csa_constant(int_const(ActualArity), int_type),
+ ArityInst = bound(shared, inst_test_results_fgtc,
+ [bound_functor(int_const(ActualArity), [])]),
+ StructConstArgs =
+ [TypeCtorConstArg, ArityConstArg | ArgTypeInfoConstArgs],
+ StructArgInsts = [TypeCtorInst, ArityInst | ArgTypeInfoInsts]
+ ;
+ TypeCtorIsVarArity = no,
+ StructConstArgs = [TypeCtorConstArg | ArgTypeInfoConstArgs],
+ StructArgInsts = [TypeCtorInst | ArgTypeInfoInsts]
+ ),
+ StructType = type_info_type,
+ list.length(ArgTypeInfoConstArgs, NumArgs),
+ InstConsId = cell_inst_cons_id(Cell, NumArgs),
+ StructInst = bound(shared, inst_test_results_fgtc,
+ [bound_functor(InstConsId, StructArgInsts)]),
+
+ ConstStruct = const_struct(ConsId, StructConstArgs,
+ StructType, StructInst),
+ lookup_insert_const_struct(ConstStruct, ConstNum,
+ ConstStructDb0, ConstStructDb),
+ MCA = yes(csa_const_struct(ConstNum)),
+ poly_info_set_const_struct_db(ConstStructDb, !Info),
+
+ set_var_maps_snapshot("maybe_init_second_cell",
+ InitialVarMapsSnapshot, !Info),
+
+ new_type_info_var(Type, type_info, Var, !Info),
+ Unification = construct(Var, type_info_const(ConstNum),
+ [], [], construct_statically, cell_is_shared,
+ no_construct_sub_info),
+ UnifyMode = (free -> ground(shared, none)) -
+ (ground(shared, none) -> ground(shared, none)),
+ UnifyContext = unify_context(umc_explicit, []),
+ % XXX The UnifyContext is wrong.
+ TypeInfoRHS = rhs_functor(type_info_const(ConstNum), no, []),
+ Unify = unify(Var, TypeInfoRHS, UnifyMode, Unification,
+ UnifyContext),
+
+ % Create a goal_info for the unification.
+ NonLocals = set_of_var.make_singleton(Var),
+ % Note that we could be more accurate than `ground(shared)',
+ % but it shouldn't make any difference.
+ InstResults = inst_test_results(inst_result_is_ground,
+ inst_result_does_not_contain_any,
+ inst_result_contains_instnames_known(set.init),
+ inst_result_contains_types_known(set.init)),
+ VarInst = bound(shared, InstResults,
+ [bound_functor(InstConsId, [])]),
+ InstMapDelta = instmap_delta_from_assoc_list([Var - VarInst]),
+ goal_info_init(NonLocals, InstMapDelta, detism_det, purity_pure,
+ GoalInfo),
+ TypeInfoGoal = hlds_goal(Unify, GoalInfo),
+ ExtraGoals = [TypeInfoGoal]
+ ;
+ assoc_list.keys(ArgTypeInfoVarsMCAs, ArgTypeInfoVars),
+ (
+ TypeCtorIsVarArity = yes,
list.length(ArgTypeInfoVars, ActualArity),
get_poly_const(ActualArity, ArityVar, ArityGoals, !Info),
- poly_info_get_varset(!.Info, VarSet0),
- poly_info_get_var_types(!.Info, VarTypes0),
- poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
- init_type_info_var(Type, [TypeCtorVar, ArityVar | ArgTypeInfoVars],
- no, Var, TypeInfoGoal, VarSet0, VarSet, VarTypes0, VarTypes,
- RttiVarMaps0, RttiVarMaps),
- poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
- poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
- ExtraGoals = ExtraGoals0 ++ ArityGoals ++ ArgTypeInfoGoals
+ % The call get_poly_const may (and probably will) allocate
+ % a variable, so VarSet1, VarTypes1 and RttiVarMaps1 are
+ % all out of date.
+ poly_info_get_varset(!.Info, VarSet2),
+ poly_info_get_var_types(!.Info, VarTypes2),
+ poly_info_get_rtti_varmaps(!.Info, RttiVarMaps2),
+ init_type_info_var(Type,
+ [TypeCtorVar, ArityVar | ArgTypeInfoVars],
+ no, Var, TypeInfoGoal,
+ VarSet2, VarSet, VarTypes2, VarTypes,
+ RttiVarMaps2, RttiVarMaps),
+ ExtraGoals = TypeCtorGoals ++ ArityGoals ++ ArgTypeInfoGoals
++ [TypeInfoGoal]
;
TypeCtorIsVarArity = no,
- (
- ArgTypeInfoVars = [_ | _],
- poly_info_get_varset(!.Info, VarSet0),
- poly_info_get_var_types(!.Info, VarTypes0),
- poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
- init_type_info_var(Type, [TypeCtorVar | ArgTypeInfoVars], no, Var,
- TypeInfoGoal, VarSet0, VarSet, VarTypes0, VarTypes,
- RttiVarMaps0, RttiVarMaps),
- ExtraGoals = ExtraGoals0 ++ ArgTypeInfoGoals ++ [TypeInfoGoal],
+ init_type_info_var(Type, [TypeCtorVar | ArgTypeInfoVars],
+ no, Var, TypeInfoGoal,
+ VarSet1, VarSet, VarTypes1, VarTypes,
+ RttiVarMaps1, RttiVarMaps),
+ ExtraGoals = TypeCtorGoals ++ ArgTypeInfoGoals ++
+ [TypeInfoGoal]
+ ),
poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
- poly_info_set_rtti_varmaps(RttiVarMaps, !Info)
- ;
- ArgTypeInfoVars = [],
- % Since this type_ctor_info is pretending to be a type_info,
- % we need to adjust its type. Since type_ctor_info_const cons_ids
- % are handled specially, this should not cause problems.
- poly_info_get_varset(!.Info, VarSet0),
- poly_info_get_var_types(!.Info, VarTypes0),
- TypeInfoType = type_info_type,
- Var = TypeCtorVar,
- ExtraGoals = ArgTypeInfoGoals ++ ExtraGoals0,
- map.det_update(TypeCtorVar, TypeInfoType, VarTypes0, VarTypes),
- poly_info_set_varset_and_types(VarSet0, VarTypes, !Info)
-
- % The type_info to represent Type is just a type_ctor_info. We used
- % to simply change the type of TypeCtorVar from type_ctor_info to
- % type_info, but that would confuse size_prof.m. We cannot leave
- % its type as it is without extending type_util.type_unify to
- % consider type_ctor_info and type_info interchangeable.
- % We therefore create a new variable of type type_info,
- % and cast TypeCtorVar to it.
- %
- % new_type_info_var_raw(Type, type_info, Var, !VarSet, !VarTypes),
- % generate_unsafe_cast(TypeCtorVar, Var, Context, CastGoal),
- % list.append(ArgTypeInfoGoals, [CastGoal], ExtraGoals1),
- % list.append(ExtraGoals0, ExtraGoals1, ExtraGoals)
+ poly_info_set_rtti_varmaps(RttiVarMaps, !Info),
+ MCA = no
)
).
@@ -3126,7 +3501,17 @@
type_to_ctor_det(Type, TypeCtor),
Cell = type_info_cell(TypeCtor),
ConsId = cell_cons_id(Cell),
- TypeInfoTerm = rhs_functor(ConsId, no, ArgVars),
+ do_init_type_info_var(Type, Cell, ConsId, ArgVars, MaybePreferredVar,
+ TypeInfoVar, TypeInfoGoal, !VarSet, !VarTypes, !RttiVarMaps).
+
+:- pred do_init_type_info_var(mer_type::in, polymorphism_cell::in, cons_id::in,
+ list(prog_var)::in, maybe(prog_var)::in, prog_var::out, hlds_goal::out,
+ prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
+ rtti_varmaps::in, rtti_varmaps::out) is det.
+
+do_init_type_info_var(Type, Cell, ConsId, ArgVars, MaybePreferredVar,
+ TypeInfoVar, TypeInfoGoal, !VarSet, !VarTypes, !RttiVarMaps) :-
+ TypeInfoRHS = rhs_functor(ConsId, no, ArgVars),
% Introduce a new variable.
(
MaybePreferredVar = yes(TypeInfoVar)
@@ -3147,7 +3532,7 @@
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(umc_explicit, []),
% XXX The UnifyContext is wrong.
- Unify = unify(TypeInfoVar, TypeInfoTerm, UnifyMode, Unification,
+ Unify = unify(TypeInfoVar, TypeInfoRHS, UnifyMode, Unification,
UnifyContext),
% Create a goal_info for the unification.
@@ -3168,25 +3553,30 @@
TypeInfoGoal = hlds_goal(Unify, GoalInfo).
init_const_type_ctor_info_var(Type, TypeCtor, TypeCtorInfoVar,
- TypeCtorInfoGoal, ModuleInfo, !VarSet, !VarTypes, !RttiVarMaps) :-
- ModuleName = type_util.type_ctor_module(ModuleInfo, TypeCtor),
- TypeName = type_util.type_ctor_name(ModuleInfo, TypeCtor),
- TypeCtor = type_ctor(_, Arity),
- ConsId = type_ctor_info_const(ModuleName, TypeName, Arity),
- TypeInfoTerm = rhs_functor(ConsId, no, []),
+ ConsId, TypeCtorInfoGoal, !VarSet, !VarTypes, !RttiVarMaps) :-
+ ConsId = type_ctor_info_cons_id(TypeCtor),
+ init_const_type_ctor_info_var_from_cons_id(Type, ConsId,
+ TypeCtorInfoVar, TypeCtorInfoGoal, !VarSet, !VarTypes, !RttiVarMaps).
+:- pred init_const_type_ctor_info_var_from_cons_id(mer_type::in, cons_id::in,
+ prog_var::out, hlds_goal::out, prog_varset::in, prog_varset::out,
+ vartypes::in, vartypes::out, rtti_varmaps::in, rtti_varmaps::out) is det.
+
+init_const_type_ctor_info_var_from_cons_id(Type, ConsId,
+ TypeCtorInfoVar, TypeCtorInfoGoal, !VarSet, !VarTypes, !RttiVarMaps) :-
% Introduce a new variable.
new_type_info_var_raw(Type, type_ctor_info, TypeCtorInfoVar,
!VarSet, !VarTypes, !RttiVarMaps),
% Create the construction unification to initialize the variable.
+ TypeInfoRHS = rhs_functor(ConsId, no, []),
Unification = construct(TypeCtorInfoVar, ConsId, [], [],
construct_dynamically, cell_is_shared, no_construct_sub_info),
UnifyMode = (free -> ground(shared, none)) -
(ground(shared, none) -> ground(shared, none)),
UnifyContext = unify_context(umc_explicit, []),
% XXX The UnifyContext is wrong.
- Unify = unify(TypeCtorInfoVar, TypeInfoTerm, UnifyMode,
+ Unify = unify(TypeCtorInfoVar, TypeInfoRHS, UnifyMode,
Unification, UnifyContext),
% Create a goal_info for the unification.
@@ -3250,12 +3640,44 @@
%---------------------------------------------------------------------------%
+:- pred get_type_info_locn(tvar::in, type_info_locn::out, poly_info::in,
+ poly_info::out) is det.
+
+get_type_info_locn(TypeVar, TypeInfoLocn, !Info) :-
+ % If we have already allocated a location for this type_info, then all
+ % we need to do is to extract the type_info variable from its location.
+ (
+ rtti_search_type_info_locn(!.Info ^ poly_rtti_varmaps, TypeVar,
+ TypeInfoLocnPrime)
+ ->
+ TypeInfoLocn = TypeInfoLocnPrime
+ ;
+ % Otherwise, we need to create a new type_info variable, and set the
+ % location for this type variable to be that type_info variable.
+ %
+ % This is wrong if the type variable is one of the existentially
+ % quantified variables of a called predicate and the variable occurs
+ % in an existential typeclass constraint. In that case the type_info
+ % will be stored in the typeclass_info variable produced by the
+ % predicate, not in a type_info variable. maybe_extract_type_info
+ % will fix this up when the typeclass_info is created.
+
+ get_tvar_kind(!.Info ^ poly_tvar_kinds, TypeVar, Kind),
+ Type = type_variable(TypeVar, Kind),
+ new_type_info_var(Type, type_info, Var, !Info),
+ TypeInfoLocn = type_info(Var),
+ poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
+ rtti_det_insert_type_info_locn(TypeVar, TypeInfoLocn,
+ RttiVarMaps0, RttiVarMaps),
+ poly_info_set_rtti_varmaps(RttiVarMaps, !Info)
+ ).
+
% Generate code to get the value of a type variable.
%
-:- pred get_type_info(type_info_locn::in, tvar::in, list(hlds_goal)::out,
- prog_var::out, poly_info::in, poly_info::out) is det.
+:- pred get_type_info_from_locn(tvar::in, type_info_locn::in,
+ prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
-get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, !Info) :-
+get_type_info_from_locn(TypeVar, TypeInfoLocn, Var, ExtraGoals, !Info) :-
(
% If the typeinfo is available in a variable, just use it.
TypeInfoLocn = type_info(TypeInfoVar),
@@ -3376,7 +3798,7 @@
% Make a new variable to contain the dictionary for this typeclass
% constraint.
new_typeclass_info_var(Constraint, typeclass_info_kind,
- TypeClassInfoVar, !Info),
+ TypeClassInfoVar, _TypeClassInfoVarType, !Info),
(
RecordLocns = do_record_type_info_locns,
record_constraint_type_info_locns(Constraint, TypeClassInfoVar,
@@ -3429,9 +3851,9 @@
),
solutions(NewTVarAndIndex, NewClassTypeVars),
- % Make an entry in the TypeInfo locations map for each new type
- % variable. The type variable can be found at the previously calculated
- % offset with the new typeclass_info.
+ % Make an entry in the TypeInfo locations map for each new type variable.
+ % The type variable can be found at the previously calculated offset
+ % with the new typeclass_info.
MakeEntry =
(pred(IndexedTypeVar::in, R0::in, R::out) is det :-
IndexedTypeVar = TheTypeVar - Index,
@@ -3446,9 +3868,9 @@
; typeclass_info_kind.
:- pred new_typeclass_info_var(prog_constraint::in, tci_var_kind::in,
- prog_var::out, poly_info::in, poly_info::out) is det.
+ prog_var::out, mer_type::out, poly_info::in, poly_info::out) is det.
-new_typeclass_info_var(Constraint, VarKind, Var, !Info) :-
+new_typeclass_info_var(Constraint, VarKind, Var, VarType, !Info) :-
poly_info_get_varset(!.Info, VarSet0),
poly_info_get_var_types(!.Info, VarTypes0),
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
@@ -3466,8 +3888,8 @@
Name = "TypeClassInfo_for_" ++ ClassNameString
),
varset.name_var(Var, Name, VarSet1, VarSet),
- build_typeclass_info_type(Constraint, DictionaryType),
- map.set(Var, DictionaryType, VarTypes0, VarTypes),
+ build_typeclass_info_type(Constraint, VarType),
+ map.set(Var, VarType, VarTypes0, VarTypes),
rtti_det_insert_typeclass_info_var(Constraint, Var,
RttiVarMaps0, RttiVarMaps),
@@ -3499,49 +3921,20 @@
( type_has_variable_arity_ctor(Type, _, _) ->
% We cannot use a plain type_ctor_info because we need to
% record the arity.
- Kind = type_info
+ TypeInfoType = type_info_type
; type_to_ctor_and_args(Type, _Ctor, Args) ->
(
Args = [],
- Kind = type_ctor_info
+ TypeInfoType = type_ctor_info_type
;
Args = [_ | _],
- Kind = type_info
+ TypeInfoType = type_info_type
)
;
% The type is variable, which means we have a type_info for it.
% That type_info may actually be a type_ctor_info, but the code
% of the current predicate won't treat it as such.
- Kind = type_info
- ),
- build_type_info_type_2(Kind, TypeInfoType).
-
-:- pred build_type_info_type_2(type_info_kind::in, mer_type::out) is det.
-
-build_type_info_type_2(Kind, TypeInfoType) :-
- (
- Kind = type_info,
TypeInfoType = type_info_type
- ;
- Kind = type_ctor_info,
- TypeInfoType = type_ctor_info_type
- ).
-
-%---------------------------------------------------------------------------%
-
-is_typeclass_info_manipulator(ModuleInfo, PredId, TypeClassManipulator) :-
- module_info_pred_info(ModuleInfo, PredId, PredInfo),
- mercury_private_builtin_module = pred_info_module(PredInfo),
- PredName = pred_info_name(PredInfo),
- (
- PredName = "type_info_from_typeclass_info",
- TypeClassManipulator = type_info_from_typeclass_info
- ;
- PredName = "superclass_from_typeclass_info",
- TypeClassManipulator = superclass_from_typeclass_info
- ;
- PredName = "instance_constraint_from_typeclass_info",
- TypeClassManipulator = instance_constraint_from_typeclass_info
).
%---------------------------------------------------------------------------%
@@ -3693,24 +4086,141 @@
type_vars_list(CTypes, CVars).
%---------------------------------------------------------------------------%
+
+:- pred all_are_const_struct_args(
+ assoc_list(prog_var, maybe(const_struct_arg))::in,
+ list(const_struct_arg)::out) is semidet.
+
+all_are_const_struct_args([], []).
+all_are_const_struct_args([VarMCA | VarsMCAs], [ConstArg | ConstArgs]) :-
+ VarMCA = _Var - MCA,
+ MCA = yes(ConstArg),
+ all_are_const_struct_args(VarsMCAs, ConstArgs).
+
+:- pred get_inst_of_const_struct_arg(const_struct_db::in, const_struct_arg::in,
+ mer_inst::out)
+ is det.
+
+get_inst_of_const_struct_arg(ConstStructDb, ConstArg, Inst) :-
+ (
+ ConstArg = csa_constant(ConsId, _),
+ Inst = bound(shared, inst_test_results_fgtc,
+ [bound_functor(ConsId, [])])
+ ;
+ ConstArg = csa_const_struct(StructNum),
+ lookup_const_struct_num(ConstStructDb, StructNum, Struct),
+ Struct = const_struct(_, _, _, Inst)
+ ).
+
%---------------------------------------------------------------------------%
-:- type type_ctor_info_var_map ==
- map(type_ctor, prog_var).
+:- pred materialize_base_typeclass_info_var(prog_constraint::in, cons_id::in,
+ prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
+
+materialize_base_typeclass_info_var(Constraint, ConsId, Var, Goals, !Info) :-
+ poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap0),
+ build_typeclass_info_type(Constraint, ConstArgType),
+ ConstArg = csa_constant(ConsId, ConstArgType),
+ ( map.search(ConstStructVarMap0, ConstArg, OldVar) ->
+ poly_info_get_num_reuses(!.Info, NumReuses),
+ poly_info_set_num_reuses(NumReuses + 1, !Info),
+ Var = OldVar,
+ Goals = []
+ ;
+ new_typeclass_info_var(Constraint, base_typeclass_info_kind, Var,
+ _VarType, !Info),
+
+ % Create the construction unification to initialize the variable.
+ RHS = rhs_functor(ConsId, no, []),
+ Unification = construct(Var, ConsId, [], [],
+ construct_dynamically, cell_is_shared, no_construct_sub_info),
+ UnifyMode = (free -> ground(shared, none)) -
+ (ground(shared, none) -> ground(shared, none)),
+ UnifyContext = unify_context(umc_explicit, []),
+ % XXX The UnifyContext is wrong.
+ Unify = unify(Var, RHS, UnifyMode, Unification, UnifyContext),
+
+ % Create the unification goal.
+ NonLocals = set_of_var.make_singleton(Var),
+ InstmapDelta = instmap_delta_bind_var(Var),
+ goal_info_init(NonLocals, InstmapDelta, detism_det, purity_pure,
+ GoalInfo),
+ Goal = hlds_goal(Unify, GoalInfo),
+ Goals = [Goal]
+ ).
+
+:- pred materialize_typeclass_info_var(prog_constraint::in, int::in,
+ prog_var::out, list(hlds_goal)::out, poly_info::in, poly_info::out) is det.
+
+materialize_typeclass_info_var(Constraint, InstanceIdConstNum, Var, Goals,
+ !Info) :-
+ poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap0),
+ InstanceIdConstArg = csa_const_struct(InstanceIdConstNum),
+ ( map.search(ConstStructVarMap0, InstanceIdConstArg, OldVar) ->
+ poly_info_get_num_reuses(!.Info, NumReuses),
+ poly_info_set_num_reuses(NumReuses + 1, !Info),
+ Var = OldVar,
+ Goals = []
+ ;
+ new_typeclass_info_var(Constraint, typeclass_info_kind, Var, _VarType,
+ !Info),
+ map.det_insert(InstanceIdConstArg, Var,
+ ConstStructVarMap0, ConstStructVarMap),
+ poly_info_set_const_struct_var_map(ConstStructVarMap, !Info),
+
+ % Create the construction unification to initialize the variable.
+ ConsId = typeclass_info_const(InstanceIdConstNum),
+ RHS = rhs_functor(ConsId, no, []),
+ Unification = construct(Var, ConsId, [], [],
+ construct_dynamically, cell_is_shared, no_construct_sub_info),
+ UnifyMode = (free -> ground(shared, none)) -
+ (ground(shared, none) -> ground(shared, none)),
+ UnifyContext = unify_context(umc_explicit, []),
+ % XXX The UnifyContext is wrong.
+ GoalExpr = unify(Var, RHS, UnifyMode, Unification, UnifyContext),
+
+ % Create a goal_info for the unification.
+ NonLocals = set_of_var.make_singleton(Var),
+ InstmapDelta = instmap_delta_bind_var(Var),
+ goal_info_init(NonLocals, InstmapDelta, detism_det, purity_pure,
+ GoalInfo),
+ Goal = hlds_goal(GoalExpr, GoalInfo),
+ Goals = [Goal]
+ ).
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- type const_or_var_arg
+ ---> cova_const(const_struct_arg)
+ ; cova_var(prog_var).
+
+:- pred make_const_or_var_arg(pair(prog_var, maybe(const_struct_arg))::in,
+ const_or_var_arg::out) is det.
+
+make_const_or_var_arg(Var - MCA, ConstOrVarArg) :-
+ (
+ MCA = no,
+ ConstOrVarArg = cova_var(Var)
+ ;
+ MCA = yes(ConstArg),
+ ConstOrVarArg = cova_const(ConstArg)
+ ).
:- type type_info_var_map ==
- map(type_ctor, map(list(mer_type), prog_var)).
+ map(type_ctor,
+ map(list(mer_type), pair(prog_var, maybe(const_struct_arg)))).
:- type typeclass_info_map_entry
---> typeclass_info_map_entry(
- % The variable that holds the base_typeclass_info for the
- % constraint.
- prog_var,
+ % The cons_id representing the base_typeclass_info.
+ cons_id,
% Maps the arguments of the typeclass_info_cell_constructor
% after the base_typeclass_info to the variable that holds the
% typeclass_info for that cell.
- map(list(prog_var), prog_var)
+ map(list(const_or_var_arg),
+ pair(prog_var, maybe(const_struct_arg)))
).
:- type typeclass_info_map ==
@@ -3718,6 +4228,11 @@
:- type int_const_map == map(int, prog_var).
+ % If the value that can be a constant structure argument is currently
+ % available in a variable, give the id of that variable.
+ %
+:- type const_struct_var_map == map(const_struct_arg, prog_var).
+
:- type poly_info
---> poly_info(
% The first two fields are from the proc_info.
@@ -3745,18 +4260,30 @@
poly_constraint_map :: constraint_map,
% The next four maps hold information about what
- % type_ctor_infos, type_infos, base_typeclass_infos and
- % typeclass_infos are guaranteed to be available (i.e. created
- % by previous code on all execution paths) at the current point
- % in the code, so they can be reused. The fifth field counts
- % the number of times that one of these variables has in fact
- % been reused.
- poly_type_ctor_info_var_map :: type_ctor_info_var_map,
+ % type_ctor_infos, type_infos, base_typeclass_infos,
+ % typeclass_infos and ints are guaranteed to be available
+ % (i.e. created by previous code on all execution paths)
+ % at the current point in the code, so they can be reused.
+ % The fifth field counts the number of times that one of these
+ % variables has in fact been reused.
+ %
+ % The type_infos and typeclass_infos are in the first two maps.
+ % The type_ctor_infos and base_typeclass_infos are in the
+ % fourth map. The integers are in the third map.
+ % The fourth map also caches typeclass_infos for instance ids.
poly_type_info_var_map :: type_info_var_map,
poly_typeclass_info_map :: typeclass_info_map,
poly_int_const_map :: int_const_map,
+ poly_const_struct_var_map :: const_struct_var_map,
poly_num_reuses :: int,
+ poly_snapshot_num :: int,
+
+ % The database of constant structures of the module.
+ % If a type_info or typeclass_info we construct is a constant
+ % term, we allocate it in this database.
+ poly_const_struct_db :: const_struct_db,
+
poly_pred_info :: pred_info,
poly_module_info :: module_info
).
@@ -3777,14 +4304,17 @@
pred_info_get_constraint_proofs(PredInfo, Proofs),
pred_info_get_constraint_map(PredInfo, ConstraintMap),
rtti_varmaps_init(RttiVarMaps),
- map.init(TypeCtorInfoVarMap),
map.init(TypeInfoVarMap),
map.init(TypeClassInfoMap),
map.init(IntConstMap),
+ map.init(ConstStructVarMap),
NumReuses = 0,
+ SnapshotNum = 0,
+ module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarKinds,
- RttiVarMaps, Proofs, ConstraintMap, TypeCtorInfoVarMap, TypeInfoVarMap,
- TypeClassInfoMap, IntConstMap, NumReuses, PredInfo, ModuleInfo).
+ RttiVarMaps, Proofs, ConstraintMap,
+ TypeInfoVarMap, TypeClassInfoMap, IntConstMap, ConstStructVarMap,
+ NumReuses, SnapshotNum, ConstStructDb, PredInfo, ModuleInfo).
% Create_poly_info creates a poly_info for an existing procedure.
% (See also init_poly_info.)
@@ -3797,20 +4327,25 @@
proc_info_get_varset(ProcInfo, VarSet),
proc_info_get_vartypes(ProcInfo, VarTypes),
proc_info_get_rtti_varmaps(ProcInfo, RttiVarMaps),
- map.init(TypeCtorInfoVarMap),
map.init(TypeInfoVarMap),
map.init(TypeClassInfoMap),
map.init(IntConstMap),
+ map.init(ConstStructVarMap),
NumReuses = 0,
+ SnapshotNum = 0,
+ module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarKinds,
- RttiVarMaps, Proofs, ConstraintMap, TypeCtorInfoVarMap, TypeInfoVarMap,
- TypeClassInfoMap, IntConstMap, NumReuses, PredInfo, ModuleInfo).
+ RttiVarMaps, Proofs, ConstraintMap, TypeInfoVarMap,
+ TypeClassInfoMap, IntConstMap, ConstStructVarMap,
+ NumReuses, SnapshotNum, ConstStructDb, PredInfo, ModuleInfo).
-poly_info_extract(Info, !PredInfo, !ProcInfo, ModuleInfo) :-
+poly_info_extract(Info, !PredInfo, !ProcInfo, !:ModuleInfo) :-
Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarKinds,
RttiVarMaps, _Proofs, _ConstraintMap,
- _TypeCtorInfoVarMap, _TypeInfoVarMap, _TypeClassInfoMap, _IntConstMap,
- _NumReuses, _OldPredInfo, ModuleInfo),
+ _TypeInfoVarMap, _TypeClassInfoMap, _IntConstMap, _ConstStructVarMap,
+ _NumReuses, _SnapshotNum, ConstStructDb, _OldPredInfo, !:ModuleInfo),
+
+ module_info_set_const_struct_db(ConstStructDb, !ModuleInfo),
% Set the new values of the fields in proc_info and pred_info.
proc_info_set_varset(VarSet, !ProcInfo),
@@ -3829,14 +4364,16 @@
:- pred poly_info_get_proofs(poly_info::in, constraint_proof_map::out) is det.
:- pred poly_info_get_constraint_map(poly_info::in, constraint_map::out)
is det.
-:- pred poly_info_get_type_ctor_info_var_map(poly_info::in,
- type_ctor_info_var_map::out) is det.
:- pred poly_info_get_type_info_var_map(poly_info::in,
type_info_var_map::out) is det.
:- pred poly_info_get_typeclass_info_map(poly_info::in,
typeclass_info_map::out) is det.
:- pred poly_info_get_int_const_map(poly_info::in, int_const_map::out) is det.
:- pred poly_info_get_num_reuses(poly_info::in, int::out) is det.
+:- pred poly_info_get_const_struct_db(poly_info::in, const_struct_db::out)
+ is det.
+:- pred poly_info_get_const_struct_var_map(poly_info::in,
+ const_struct_var_map::out) is det.
:- pred poly_info_get_pred_info(poly_info::in, pred_info::out) is det.
:- pred poly_info_get_module_info(poly_info::in, module_info::out) is det.
@@ -3847,12 +4384,13 @@
poly_info_get_rtti_varmaps(PolyInfo, PolyInfo ^ poly_rtti_varmaps).
poly_info_get_proofs(PolyInfo, PolyInfo ^ poly_proof_map).
poly_info_get_constraint_map(PolyInfo, PolyInfo ^ poly_constraint_map).
-poly_info_get_type_ctor_info_var_map(PolyInfo,
- PolyInfo ^ poly_type_ctor_info_var_map).
poly_info_get_type_info_var_map(PolyInfo, PolyInfo ^ poly_type_info_var_map).
poly_info_get_typeclass_info_map(PolyInfo, PolyInfo ^ poly_typeclass_info_map).
poly_info_get_int_const_map(PolyInfo, PolyInfo ^ poly_int_const_map).
poly_info_get_num_reuses(PolyInfo, PolyInfo ^ poly_num_reuses).
+poly_info_get_const_struct_db(PolyInfo, PolyInfo ^ poly_const_struct_db).
+poly_info_get_const_struct_var_map(PolyInfo,
+ PolyInfo ^ poly_const_struct_var_map).
poly_info_get_pred_info(PolyInfo, PolyInfo ^ poly_pred_info).
poly_info_get_module_info(PolyInfo, PolyInfo ^ poly_module_info).
@@ -3868,8 +4406,6 @@
poly_info::in, poly_info::out) is det.
:- pred poly_info_set_proofs(constraint_proof_map::in,
poly_info::in, poly_info::out) is det.
-:- pred poly_info_set_type_ctor_info_var_map(type_ctor_info_var_map::in,
- poly_info::in, poly_info::out) is det.
:- pred poly_info_set_type_info_var_map(type_info_var_map::in,
poly_info::in, poly_info::out) is det.
:- pred poly_info_set_typeclass_info_map(typeclass_info_map::in,
@@ -3878,6 +4414,10 @@
poly_info::in, poly_info::out) is det.
:- pred poly_info_set_num_reuses(int::in,
poly_info::in, poly_info::out) is det.
+:- pred poly_info_set_const_struct_db(const_struct_db::in,
+ poly_info::in, poly_info::out) is det.
+:- pred poly_info_set_const_struct_var_map(const_struct_var_map::in,
+ poly_info::in, poly_info::out) is det.
poly_info_set_varset(VarSet, !PI) :-
!PI ^ poly_varset := VarSet.
@@ -3892,8 +4432,6 @@
!PI ^ poly_rtti_varmaps := RttiVarMaps.
poly_info_set_proofs(Proofs, !PI) :-
!PI ^ poly_proof_map := Proofs.
-poly_info_set_type_ctor_info_var_map(TypeCtorInfoVarMap, !PI) :-
- !PI ^ poly_type_ctor_info_var_map := TypeCtorInfoVarMap.
poly_info_set_type_info_var_map(TypeInfoVarMap, !PI) :-
!PI ^ poly_type_info_var_map := TypeInfoVarMap.
poly_info_set_typeclass_info_map(TypeClassInfoMap, !PI) :-
@@ -3902,35 +4440,198 @@
!PI ^ poly_int_const_map := IntConstMap.
poly_info_set_num_reuses(NumReuses, !PI) :-
!PI ^ poly_num_reuses := NumReuses.
+poly_info_set_const_struct_db(ConstStructDb, !PI) :-
+ !PI ^ poly_const_struct_db := ConstStructDb.
+poly_info_set_const_struct_var_map(ConstStructVarMap, !PI) :-
+ !PI ^ poly_const_struct_var_map := ConstStructVarMap.
-:- type maps_snapshot
- ---> maps_snapshot(poly_info).
- % We could remember only the fields of the poly_info that we
- % actually need in the snapshot, but that would require more memory
- % allocation.
+%---------------------------------------------------------------------------%
-:- pred get_maps_snapshot(poly_info::in, maps_snapshot::out) is det.
-:- pred set_maps_snapshot(maps_snapshot::in, poly_info::in, poly_info::out)
- is det.
-:- pred empty_maps(poly_info::in, poly_info::out) is det.
+:- type cache_maps
+ ---> cache_maps(
+ cm_snapshot_num :: int,
+ cm_type_info_var_map :: type_info_var_map,
+ cm_typeclass_info_map :: typeclass_info_map,
+ cm_int_const_map :: int_const_map,
+ cm_const_struct_var_map :: const_struct_var_map
+ ).
+
+:- pred get_cache_maps_snapshot(string::in, cache_maps::out,
+ poly_info::in, poly_info::out) is det.
+:- pred set_cache_maps_snapshot(string::in, cache_maps::in,
+ poly_info::in, poly_info::out) is det.
+:- pred empty_cache_maps(poly_info::in, poly_info::out) is det.
-get_maps_snapshot(Info, maps_snapshot(Info)).
+get_cache_maps_snapshot(Name, CacheMaps, !Info) :-
+ SnapshotNum = !.Info ^ poly_snapshot_num,
+ TypeInfoVarMap = !.Info ^ poly_type_info_var_map,
+ TypeClassInfoMap = !.Info ^ poly_typeclass_info_map,
+ IntConstMap = !.Info ^ poly_int_const_map,
+ ConstStructVarMap = !.Info ^ poly_const_struct_var_map,
+ CacheMaps = cache_maps(SnapshotNum, TypeInfoVarMap, TypeClassInfoMap,
+ IntConstMap, ConstStructVarMap),
+ !Info ^ poly_snapshot_num := SnapshotNum + 1,
+
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ (
+ SelectedPred = yes,
+ Name \= ""
+ ->
+ IndentStr = string.duplicate_char(' ', Level * 4),
+ io.write_string(IndentStr, !IO),
+ io.format("get_cache_maps_snapshot %d %s\n",
+ [i(SnapshotNum), s(Name)], !IO),
+ io.write_string(IndentStr, !IO),
+ NumVars = varset.num_allocated(!.Info ^ poly_varset),
+ io.format("num_allocated vars: %d\n\n", [i(NumVars)], !IO)
+ ;
+ true
+ )
+ )
+ )
+ ).
-set_maps_snapshot(maps_snapshot(SnapshotInfo), !Info) :-
- TypeCtorInfoVarMap = SnapshotInfo ^ poly_type_ctor_info_var_map,
- TypeInfoVarMap = SnapshotInfo ^ poly_type_info_var_map,
- TypeClassInfoMap = SnapshotInfo ^ poly_typeclass_info_map,
- IntConstMap = SnapshotInfo ^ poly_int_const_map,
- !Info ^ poly_type_ctor_info_var_map := TypeCtorInfoVarMap,
+set_cache_maps_snapshot(Name, CacheMaps, !Info) :-
+ CacheMaps = cache_maps(SnapshotNum, TypeInfoVarMap, TypeClassInfoMap,
+ IntConstMap, ConstStructVarMap),
!Info ^ poly_type_info_var_map := TypeInfoVarMap,
!Info ^ poly_typeclass_info_map := TypeClassInfoMap,
- !Info ^ poly_int_const_map := IntConstMap.
+ !Info ^ poly_int_const_map := IntConstMap,
+ !Info ^ poly_const_struct_var_map := ConstStructVarMap,
-empty_maps(!Info) :-
- !Info ^ poly_type_ctor_info_var_map := map.init,
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ (
+ SelectedPred = yes,
+ Name \= ""
+ ->
+ IndentStr = string.duplicate_char(' ', Level * 4),
+ io.write_string(IndentStr, !IO),
+ io.format("set_cache_maps_snapshot %d %s\n",
+ [i(SnapshotNum), s(Name)], !IO),
+ io.write_string(IndentStr, !IO),
+ NumVars = varset.num_allocated(!.Info ^ poly_varset),
+ io.format("num_allocated vars: %d\n\n", [i(NumVars)], !IO),
+
+ io.write_string(IndentStr, !IO),
+ io.write_string("type_info_var_map ", !IO),
+ io.write(CacheMaps ^ cm_type_info_var_map, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("typeclass_info_map ", !IO),
+ io.write(CacheMaps ^ cm_typeclass_info_map, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("struct_var_map ", !IO),
+ io.write(CacheMaps ^ cm_const_struct_var_map, !IO),
+ io.nl(!IO),
+ io.nl(!IO)
+ ;
+ true
+ )
+ )
+ )
+ ).
+
+empty_cache_maps(!Info) :-
!Info ^ poly_type_info_var_map := map.init,
!Info ^ poly_typeclass_info_map := map.init,
- !Info ^ poly_int_const_map := map.init.
+ !Info ^ poly_int_const_map := map.init,
+ !Info ^ poly_const_struct_var_map := map.init.
+
+%---------------------------------------------------------------------------%
+
+:- type var_maps
+ ---> var_maps(
+ vm_snapshot_num :: int,
+ vm_varset :: prog_varset,
+ vm_vartypes :: vartypes,
+ vm_rtti_varmaps :: rtti_varmaps,
+ vm_cache_maps :: cache_maps
+ ).
+
+:- pred get_var_maps_snapshot(string::in, var_maps::out,
+ poly_info::in, poly_info::out) is det.
+
+get_var_maps_snapshot(Name, VarMaps, !Info) :-
+ SnapshotNum = !.Info ^ poly_snapshot_num,
+ VarSet = !.Info ^ poly_varset,
+ VarTypes = !.Info ^ poly_vartypes,
+ RttiVarMaps = !.Info ^ poly_rtti_varmaps,
+
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ (
+ SelectedPred = no
+ ;
+ SelectedPred = yes,
+ IndentStr = string.duplicate_char(' ', Level * 4),
+ io.write_string(IndentStr, !IO),
+ io.format("get_var_maps_snapshot %d %s\n",
+ [i(SnapshotNum), s(Name)], !IO),
+ io.write_string(IndentStr, !IO),
+ NumVars = varset.num_allocated(VarSet),
+ io.format("num_allocated vars: %d\n\n", [i(NumVars)], !IO)
+ )
+ )
+ )
+ ),
+
+ get_cache_maps_snapshot("", CacheMaps, !Info),
+ VarMaps = var_maps(SnapshotNum, VarSet, VarTypes, RttiVarMaps, CacheMaps).
+
+:- pred set_var_maps_snapshot(string::in, var_maps::in,
+ poly_info::in, poly_info::out) is det.
+
+set_var_maps_snapshot(Name, VarMaps, !Info) :-
+ VarMaps = var_maps(SnapshotNum, VarSet, VarTypes, RttiVarMaps, CacheMaps),
+
+ trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
+ some [SelectedPred, Level, IndentStr] (
+ promise_pure (
+ semipure get_selected_pred(SelectedPred),
+ semipure get_level(Level),
+ (
+ SelectedPred = no
+ ;
+ SelectedPred = yes,
+ IndentStr = string.duplicate_char(' ', Level * 4),
+ io.write_string(IndentStr, !IO),
+ io.format("set_var_maps_snapshot %d %s\n",
+ [i(SnapshotNum), s(Name)], !IO),
+
+ io.write_string(IndentStr, !IO),
+ io.write_string("type_info_var_map ", !IO),
+ io.write(CacheMaps ^ cm_type_info_var_map, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("typeclass_info_map ", !IO),
+ io.write(CacheMaps ^ cm_typeclass_info_map, !IO),
+ io.nl(!IO),
+ io.write_string(IndentStr, !IO),
+ io.write_string("struct_var_map ", !IO),
+ io.write(CacheMaps ^ cm_const_struct_var_map, !IO),
+ io.nl(!IO),
+ io.nl(!IO)
+ )
+ )
+ )
+ ),
+
+ !Info ^ poly_varset := VarSet,
+ !Info ^ poly_vartypes := VarTypes,
+ !Info ^ poly_rtti_varmaps := RttiVarMaps,
+ set_cache_maps_snapshot("", CacheMaps, !Info).
%---------------------------------------------------------------------------%
:- end_module check_hlds.polymorphism.
Index: compiler/post_term_analysis.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_term_analysis.m,v
retrieving revision 1.24
diff -u -b -r1.24 post_term_analysis.m
--- compiler/post_term_analysis.m 16 Jun 2011 06:42:15 -0000 1.24
+++ compiler/post_term_analysis.m 7 Jun 2012 05:32:26 -0000
@@ -243,7 +243,6 @@
fixed(SpecialPredStr ++ " predicate"),
words("for the type "), fixed(TypeCtorString),
words("cannot be proven to terminate.")],
- % ZZZ
report_warning(Globals, Context, 0, Pieces, !IO).
%----------------------------------------------------------------------------%
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.157
diff -u -b -r1.157 post_typecheck.m
--- compiler/post_typecheck.m 16 Apr 2012 08:13:19 -0000 1.157
+++ compiler/post_typecheck.m 7 Jun 2012 05:32:26 -0000
@@ -1230,7 +1230,7 @@
cons_id::in, mer_type::in, list(mer_type)::in) is semidet.
find_matching_constructor(ModuleInfo, TVarSet, ConsId, Type, ArgTypes) :-
- type_to_ctor_and_args(Type, TypeCtor, _),
+ type_to_ctor(Type, TypeCtor),
module_info_get_cons_table(ModuleInfo, ConsTable),
search_cons_table_of_type_ctor(ConsTable, TypeCtor, ConsId, ConsDefn),
Index: compiler/proc_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/proc_gen.m,v
retrieving revision 1.53
diff -u -b -r1.53 proc_gen.m
--- compiler/proc_gen.m 17 Jan 2012 15:49:44 -0000 1.53
+++ compiler/proc_gen.m 7 Jun 2012 05:32:26 -0000
@@ -51,8 +51,8 @@
% Translate a HLDS procedure to LLDS, threading through the data structure
% that records information about layout structures.
%
-:- pred generate_proc_code(pred_info::in, proc_info::in,
- pred_id::in, proc_id::in, module_info::in,
+:- pred generate_proc_code(module_info::in, const_struct_map::in,
+ pred_id::in, pred_info::in, proc_id::in, proc_info::in,
global_data::in, global_data::out, c_procedure::out) is det.
% Return the message that identifies the procedure to pass to
@@ -95,6 +95,7 @@
:- import_module ll_backend.middle_rec.
:- import_module ll_backend.stack_layout.
:- import_module ll_backend.trace_gen.
+:- import_module ll_backend.unify_gen.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.program_representation.
:- import_module parse_tree.prog_data.
@@ -125,34 +126,50 @@
globals.lookup_bool_option(Globals, parallel_code_gen, ParallelCodeGen),
globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
globals.lookup_bool_option(Globals, detailed_statistics, Statistics),
+
+ (
+ VeryVerbose = yes,
+ io.write_string("% Generating constant structures\n", !IO),
+ generate_const_structs(!.ModuleInfo, ConstStructMap, !GlobalData),
+ maybe_report_stats(Statistics, !IO)
+ ;
+ VeryVerbose = no,
+ generate_const_structs(!.ModuleInfo, ConstStructMap, !GlobalData)
+ ),
+
(
ParallelCodeGen = yes,
% Can't do parallel code generation if I/O is required.
VeryVerbose = no,
Statistics = no
->
- generate_code_parallel(!.ModuleInfo, PredIds, !GlobalData,
- Procedures)
+ generate_code_parallel(!.ModuleInfo, ConstStructMap, PredIds,
+ !GlobalData, Procedures)
;
- generate_code_sequential(!.ModuleInfo, PredIds, !GlobalData,
- Procedures, !IO)
+ generate_code_sequential(!.ModuleInfo, VeryVerbose, Statistics,
+ ConstStructMap, PredIds, !GlobalData, Procedures, !IO)
).
-:- pred generate_code_sequential(module_info::in, list(pred_id)::in,
- global_data::in, global_data::out, list(c_procedure)::out, io::di, io::uo)
- is det.
-
-generate_code_sequential(ModuleInfo0, PredIds, !GlobalData, Procedures, !IO) :-
- list.map_foldl2(generate_maybe_pred_code(ModuleInfo0),
+:- pred generate_code_sequential(module_info::in, bool::in, bool::in,
+ const_struct_map::in, list(pred_id)::in, global_data::in, global_data::out,
+ list(c_procedure)::out, io::di, io::uo) is det.
+
+generate_code_sequential(ModuleInfo, VeryVerbose, Statistics, ConstStructMap,
+ PredIds, !GlobalData, Procedures, !IO) :-
+ list.map_foldl2(
+ generate_maybe_pred_code(ModuleInfo, VeryVerbose, Statistics,
+ ConstStructMap),
PredIds, PredProcedures, !GlobalData, !IO),
list.condense(PredProcedures, Procedures).
%-----------------------------------------------------------------------------%
-:- pred generate_code_parallel(module_info::in, list(pred_id)::in,
- global_data::in, global_data::out, list(c_procedure)::out) is det.
+:- pred generate_code_parallel(module_info::in, const_struct_map::in,
+ list(pred_id)::in, global_data::in, global_data::out,
+ list(c_procedure)::out) is det.
-generate_code_parallel(ModuleInfo0, PredIds, !GlobalData, Procedures) :-
+generate_code_parallel(ModuleInfo, ConstStructMap, PredIds, !GlobalData,
+ Procedures) :-
% Split up the list of predicates into pieces for processing in parallel.
% Splitting the list in the middle does not work well as the load will be
% unbalanced. Splitting the list in any other way (as we do) does mean
@@ -169,14 +186,14 @@
GlobalData0 = !.GlobalData,
(
list.condense(ListsOfPredIdsA, PredIdsA),
- list.map_foldl(generate_pred_code_par(ModuleInfo0),
+ list.map_foldl(generate_pred_code_par(ModuleInfo, ConstStructMap),
PredIdsA, PredProceduresA, GlobalData0, GlobalDataA),
list.condense(PredProceduresA, ProceduresA)
% XXX the following should be a parallel conjunction
,
list.condense(ListsOfPredIdsB, PredIdsB),
bump_type_num_counter(type_num_skip, GlobalData0, GlobalData1),
- list.map_foldl(generate_pred_code_par(ModuleInfo0),
+ list.map_foldl(generate_pred_code_par(ModuleInfo, ConstStructMap),
PredIdsB, PredProceduresB0, GlobalData1, GlobalDataB),
list.condense(PredProceduresB0, ProceduresB0)
),
@@ -208,15 +225,16 @@
%-----------------------------------------------------------------------------%
-:- pred generate_maybe_pred_code(module_info::in,
- pred_id::in, list(c_procedure)::out,
+:- pred generate_maybe_pred_code(module_info::in, bool::in, bool::in,
+ const_struct_map::in, pred_id::in, list(c_procedure)::out,
global_data::in, global_data::out, io::di, io::uo) is det.
+generate_maybe_pred_code(ModuleInfo, VeryVerbose, Statistics, ConstStructMap,
+ PredId, Predicates, !GlobalData, !IO) :-
% Note that some of the logic of generate_maybe_pred_code is duplicated
% by mercury_compile.backend_pass_by_preds, so modifications here may
% also need to be repeated there.
- %
-generate_maybe_pred_code(ModuleInfo, PredId, Predicates, !GlobalData, !IO) :-
+
module_info_get_preds(ModuleInfo, PredInfos),
map.lookup(PredInfos, PredId, PredInfo),
ProcIds = pred_info_non_imported_procids(PredInfo),
@@ -225,60 +243,61 @@
Predicates = []
;
ProcIds = [_ | _],
- module_info_get_globals(ModuleInfo, Globals),
- globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
(
VeryVerbose = yes,
io.write_string("% Generating code for ", !IO),
write_pred_id(ModuleInfo, PredId, !IO),
io.write_string("\n", !IO),
- globals.lookup_bool_option(Globals, detailed_statistics,
- Statistics),
+ generate_pred_code(ModuleInfo, ConstStructMap, PredId, PredInfo,
+ ProcIds, Predicates, !GlobalData),
maybe_report_stats(Statistics, !IO)
;
- VeryVerbose = no
- ),
- generate_pred_code(ModuleInfo, PredId, PredInfo, ProcIds, Predicates,
- !GlobalData)
+ VeryVerbose = no,
+ generate_pred_code(ModuleInfo, ConstStructMap, PredId, PredInfo,
+ ProcIds, Predicates, !GlobalData)
+ )
).
-:- pred generate_pred_code_par(module_info::in, pred_id::in,
- list(c_procedure)::out, global_data::in, global_data::out) is det.
+:- pred generate_pred_code_par(module_info::in, const_struct_map::in,
+ pred_id::in, list(c_procedure)::out,
+ global_data::in, global_data::out) is det.
-generate_pred_code_par(ModuleInfo, PredId, Predicates, !GlobalData) :-
+generate_pred_code_par(ModuleInfo, ConstStructMap, PredId, CProcs,
+ !GlobalData) :-
module_info_get_preds(ModuleInfo, PredInfos),
map.lookup(PredInfos, PredId, PredInfo),
ProcIds = pred_info_non_imported_procids(PredInfo),
- generate_pred_code(ModuleInfo, PredId, PredInfo, ProcIds, Predicates,
- !GlobalData).
+ generate_pred_code(ModuleInfo, ConstStructMap, PredId, PredInfo,
+ ProcIds, CProcs, !GlobalData).
% Translate a HLDS predicate to LLDS.
%
-:- pred generate_pred_code(module_info::in,
+:- pred generate_pred_code(module_info::in, const_struct_map::in,
pred_id::in, pred_info::in, list(proc_id)::in, list(c_procedure)::out,
global_data::in, global_data::out) is det.
-generate_pred_code(ModuleInfo, PredId, PredInfo, ProcIds, Code, !GlobalData) :-
- generate_proc_list_code(ProcIds, PredId, PredInfo, ModuleInfo,
- !GlobalData, [], Code).
+generate_pred_code(ModuleInfo, ConstStructMap, PredId, PredInfo, ProcIds,
+ Code, !GlobalData) :-
+ generate_proc_list_code(ModuleInfo, ConstStructMap, PredId, PredInfo,
+ ProcIds, !GlobalData, [], Code).
% Translate all the procedures of a HLDS predicate to LLDS.
%
-:- pred generate_proc_list_code(list(proc_id)::in, pred_id::in, pred_info::in,
- module_info::in, global_data::in, global_data::out,
+:- pred generate_proc_list_code(module_info::in, const_struct_map::in,
+ pred_id::in, pred_info::in, list(proc_id)::in,
+ global_data::in, global_data::out,
list(c_procedure)::in, list(c_procedure)::out) is det.
-generate_proc_list_code([], _PredId, _PredInfo, _ModuleInfo,
- !GlobalData, !Procs).
-generate_proc_list_code([ProcId | ProcIds], PredId, PredInfo, ModuleInfo0,
- !GlobalData, !Procs) :-
+generate_proc_list_code(_, _, _, _, [], !GlobalData, !Procs).
+generate_proc_list_code(ModuleInfo, ConstStructMap, PredId, PredInfo,
+ [ProcId | ProcIds], !GlobalData, !Procs) :-
pred_info_get_procedures(PredInfo, ProcInfos),
map.lookup(ProcInfos, ProcId, ProcInfo),
- generate_proc_code(PredInfo, ProcInfo, PredId, ProcId, ModuleInfo0,
- !GlobalData, Proc),
+ generate_proc_code(ModuleInfo, ConstStructMap, PredId, PredInfo,
+ ProcId, ProcInfo, !GlobalData, Proc),
!:Procs = [Proc | !.Procs],
- generate_proc_list_code(ProcIds, PredId, PredInfo, ModuleInfo0,
- !GlobalData, !Procs).
+ generate_proc_list_code(ModuleInfo, ConstStructMap, PredId, PredInfo,
+ ProcIds, !GlobalData, !Procs).
%---------------------------------------------------------------------------%
@@ -299,8 +318,8 @@
%---------------------------------------------------------------------------%
-generate_proc_code(PredInfo, ProcInfo0, PredId, ProcId, ModuleInfo0,
- !GlobalData, CProc) :-
+generate_proc_code(ModuleInfo0, ConstStructMap, PredId, PredInfo,
+ ProcId, ProcInfo0, !GlobalData, CProc) :-
% The modified module_info and proc_info are both discarded
% on return from generate_proc_code.
maybe_set_trace_level(PredInfo, ModuleInfo0, ModuleInfo),
@@ -354,7 +373,7 @@
TSRevStringTable0, TSStringTableSize0),
code_info_init(SaveSuccip, Globals, PredId, ProcId, PredInfo,
- ProcInfo, FollowVars, ModuleInfo, StaticCellInfo0,
+ ProcInfo, FollowVars, ModuleInfo, StaticCellInfo0, ConstStructMap,
OutsideResumePoint, TraceSlotInfo, MaybeContainingGoalMap,
TSRevStringTable0, TSStringTableSize0, CodeInfo0),
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.240
diff -u -b -r1.240 prog_data.m
--- compiler/prog_data.m 23 Apr 2012 03:34:48 -0000 1.240
+++ compiler/prog_data.m 7 Jun 2012 05:32:26 -0000
@@ -1584,6 +1584,9 @@
; type_info_cell_constructor(type_ctor)
; typeclass_info_cell_constructor
+ ; type_info_const(int)
+ ; typeclass_info_const(int)
+
; tabling_info_const(shrouded_pred_proc_id)
% The address of the static structure that holds information
% about the table that implements memoization, loop checking
@@ -1611,6 +1614,8 @@
%
:- pred equivalent_cons_ids(cons_id::in, cons_id::in) is semidet.
+:- pred cons_id_is_const_struct(cons_id::in, int::out) is semidet.
+
:- implementation.
cons_id_dummy_type_ctor = type_ctor(unqualified(""), -1).
@@ -1650,6 +1655,32 @@
ConsIdA = ConsIdB
).
+cons_id_is_const_struct(ConsId, ConstNum) :-
+ require_complete_switch [ConsId]
+ (
+ ConsId = type_info_const(ConstNum)
+ ;
+ ConsId = typeclass_info_const(ConstNum)
+ ;
+ ( ConsId = cons(_, _, _)
+ ; ConsId = tuple_cons(_)
+ ; 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(_)
+ ),
+ fail
+ ).
+
%-----------------------------------------------------------------------------%
%
% Types.
Index: compiler/prog_rep.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.77
diff -u -b -r1.77 prog_rep.m
--- compiler/prog_rep.m 13 Feb 2012 00:11:46 -0000 1.77
+++ compiler/prog_rep.m 7 Jun 2012 05:32:26 -0000
@@ -674,6 +674,8 @@
cons_id_rep(type_info_cell_constructor(_)) = "$type_info_cell_constructor".
cons_id_rep(typeclass_info_cell_constructor) =
"$typeclass_info_cell_constructor".
+cons_id_rep(type_info_const(_)) = "$type_info_const".
+cons_id_rep(typeclass_info_const(_)) = "$typeclass_info_const".
cons_id_rep(tabling_info_const(_)) = "$tabling_info_const".
cons_id_rep(table_io_decl(_)) = "$table_io_decl".
cons_id_rep(deep_profiling_proc_layout(_)) = "$deep_profiling_proc_layout".
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.59
diff -u -b -r1.59 prog_type.m
--- compiler/prog_type.m 12 Apr 2012 04:56:17 -0000 1.59
+++ compiler/prog_type.m 7 Jun 2012 05:32:26 -0000
@@ -9,7 +9,7 @@
% File: prog_type.m.
% Main author: fjh.
%
-% Utility predicates dealing with type in the parse tree. The predicates for
+% Utility predicates dealing with types in the parse tree. The predicates for
% doing type substitutions are in prog_type_subst.m, while utility predicates
% for dealing with types in the HLDS are in type_util.m.
%
@@ -35,7 +35,7 @@
% Simple tests for certain properties of types. These tests work modulo any
% kind annotations, so in the early stages of the compiler (i.e., before type
% checking) these should be used rather than direct tests. Once we reach
-% type checking all kind annotations should have been removed, so it would
+% type checking, all kind annotations should have been removed, so it would
% be preferable to switch on the top functor rather than use these predicates
% in an if-then-else expression, since switches will give better error
% detection.
@@ -49,8 +49,7 @@
%
:- pred type_is_nonvar(mer_type::in) is semidet.
- % Succeeds iff the given type is a higher-order predicate or function
- % type.
+ % Succeeds iff the given type is a higher-order predicate or function type.
%
:- pred type_is_higher_order(mer_type::in) is semidet.
@@ -553,7 +552,8 @@
TypeCtor = TypeCtorPrime,
Args = ArgsPrime
;
- unexpected($module, $pred, "type_to_ctor_and_args failed: " ++ string(Type))
+ unexpected($module, $pred,
+ "type_to_ctor_and_args failed: " ++ string(Type))
).
type_to_ctor(Type, TypeCtor) :-
@@ -813,7 +813,7 @@
type_ctor(qualified(unqualified("bitmap"), "bitmap"), 0)).
is_introduced_type_info_type(Type) :-
- type_to_ctor_and_args(Type, TypeCtor, _),
+ type_to_ctor(Type, TypeCtor),
is_introduced_type_info_type_ctor(TypeCtor).
is_introduced_type_info_type_ctor(TypeCtor) :-
@@ -891,8 +891,6 @@
%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
% 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
@@ -952,6 +950,8 @@
; ConsId0 = impl_defined_const(_)
; ConsId0 = type_ctor_info_const(_, _, _)
; ConsId0 = base_typeclass_info_const(_, _, _, _)
+ ; ConsId0 = type_info_const(_)
+ ; ConsId0 = typeclass_info_const(_)
; ConsId0 = table_io_decl(_)
; ConsId0 = tabling_info_const(_)
; ConsId0 = deep_profiling_proc_layout(_)
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.116
diff -u -b -r1.116 prog_util.m
--- compiler/prog_util.m 23 Apr 2012 03:34:49 -0000 1.116
+++ compiler/prog_util.m 7 Jun 2012 05:32:26 -0000
@@ -625,6 +625,8 @@
; ConsId = base_typeclass_info_const(_, _, _, _)
; ConsId = type_info_cell_constructor(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
; ConsId = tabling_info_const(_)
; ConsId = deep_profiling_proc_layout(_)
; ConsId = table_io_decl(_)
@@ -644,6 +646,8 @@
cons_id_maybe_arity(base_typeclass_info_const(_, _, _, _)) = no.
cons_id_maybe_arity(type_info_cell_constructor(_)) = no.
cons_id_maybe_arity(typeclass_info_cell_constructor) = no.
+cons_id_maybe_arity(type_info_const(_)) = no.
+cons_id_maybe_arity(typeclass_info_const(_)) = no.
cons_id_maybe_arity(tabling_info_const(_)) = no.
cons_id_maybe_arity(deep_profiling_proc_layout(_)) = no.
cons_id_maybe_arity(table_io_decl(_)) = no.
Index: compiler/rbmm.execution_path.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rbmm.execution_path.m,v
retrieving revision 1.17
diff -u -b -r1.17 rbmm.execution_path.m
--- compiler/rbmm.execution_path.m 13 Feb 2012 00:11:47 -0000 1.17
+++ compiler/rbmm.execution_path.m 7 Jun 2012 05:32:26 -0000
@@ -244,6 +244,8 @@
; MainConsId = base_typeclass_info_const(_, _, _, _)
; MainConsId = type_info_cell_constructor(_)
; MainConsId = typeclass_info_cell_constructor
+ ; MainConsId = type_info_const(_)
+ ; MainConsId = typeclass_info_const(_)
; MainConsId = tabling_info_const(_)
; MainConsId = table_io_decl(_)
; MainConsId = deep_profiling_proc_layout(_)
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.106
diff -u -b -r1.106 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 12 Dec 2011 16:15:14 -0000 1.106
+++ compiler/rtti_to_mlds.m 7 Jun 2012 05:32:26 -0000
@@ -1641,12 +1641,16 @@
% the function label allocated for the wrapper func does not overlap
% with any function labels used when generating code for the wrapped
% procedure.
+ %
+ % The empty const struct map is a lie, but a white lie; the RTTI
+ % data cannot contain any type_info_const or typeclass_info_const
+ % cons_ids.
PredId = RttiProcId ^ rpl_pred_id,
ProcId = RttiProcId ^ rpl_proc_id,
module_info_proc_info(ModuleInfo, PredId, ProcId, ProcInfo),
- !:Info = ml_gen_info_init(ModuleInfo, PredId, ProcId, ProcInfo,
- !.GlobalData),
+ !:Info = ml_gen_info_init(ModuleInfo, map.init, PredId, ProcId,
+ ProcInfo, !.GlobalData),
ml_gen_info_bump_counters(!Info),
% Now we can safely go ahead and generate the wrapper function.
Index: compiler/size_prof.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/size_prof.m,v
retrieving revision 1.73
diff -u -b -r1.73 size_prof.m
--- compiler/size_prof.m 13 Feb 2012 00:11:48 -0000 1.73
+++ compiler/size_prof.m 7 Jun 2012 05:32:26 -0000
@@ -614,14 +614,9 @@
size_prof_process_construct(LHS, RHS, UniMode, UnifyContext, Var, ConsId,
Args, ArgModes, How, Unique, GoalInfo, GoalExpr, !Info) :-
map.lookup(!.Info ^ spi_vartypes, Var, VarType),
- ( type_to_ctor_and_args(VarType, VarTypeCtorPrime, _VarTypeArgs) ->
- VarTypeCtor = VarTypeCtorPrime
- ;
- unexpected($module, $pred, "constructing term of variable type")
- ),
- ModuleInfo = !.Info ^ spi_module_info,
- VarTypeCtorModule = type_ctor_module(ModuleInfo, VarTypeCtor),
- VarTypeCtorName = type_ctor_name(ModuleInfo, VarTypeCtor),
+ type_to_ctor_det(VarType, VarTypeCtor),
+ type_ctor_module_name_arity(VarTypeCtor,
+ VarTypeCtorModule, VarTypeCtorName, _),
(
ctor_is_type_info_related(VarTypeCtorModule, VarTypeCtorName)
->
@@ -679,14 +674,9 @@
size_prof_process_deconstruct(Var, ConsId, Args, ArgModes, Goal0, GoalExpr,
!Info) :-
map.lookup(!.Info ^ spi_vartypes, Var, VarType),
- ( type_to_ctor_and_args(VarType, VarTypeCtorPrime, _VarTypeArgs) ->
- VarTypeCtor = VarTypeCtorPrime
- ;
- unexpected($module, $pred, "deconstructing term of variable type")
- ),
- ModuleInfo = !.Info ^ spi_module_info,
- VarTypeCtorModule = type_ctor_module(ModuleInfo, VarTypeCtor),
- VarTypeCtorName = type_ctor_name(ModuleInfo, VarTypeCtor),
+ type_to_ctor_det(VarType, VarTypeCtor),
+ type_ctor_module_name_arity(VarTypeCtor, VarTypeCtorModule,
+ VarTypeCtorName, _),
(
ctor_is_type_info_related(VarTypeCtorModule, VarTypeCtorName)
->
@@ -994,8 +984,7 @@
VarTypes0 = !.Info ^ spi_vartypes,
RttiVarMaps0 = !.Info ^ spi_rtti_varmaps,
polymorphism.init_const_type_ctor_info_var(Type, TypeCtor,
- TypeCtorVar, TypeCtorGoal, !.Info ^ spi_module_info,
- VarSet0, VarSet, VarTypes0, VarTypes,
+ TypeCtorVar, _, TypeCtorGoal, VarSet0, VarSet, VarTypes0, VarTypes,
RttiVarMaps0, RttiVarMaps),
TypeCtorGoals = [TypeCtorGoal],
!Info ^ spi_varset := VarSet,
Index: compiler/stack_layout.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stack_layout.m,v
retrieving revision 1.168
diff -u -b -r1.168 stack_layout.m
--- compiler/stack_layout.m 5 Jun 2012 18:19:31 -0000 1.168
+++ compiler/stack_layout.m 7 Jun 2012 05:32:26 -0000
@@ -70,7 +70,7 @@
closure_layout_info::in, proc_label::in, module_name::in,
string::in, int::in, pred_origin::in, string::in,
static_cell_info::in, static_cell_info::out,
- assoc_list(rval, llds_type)::out, closure_proc_id_data::out) is det.
+ list(typed_rval)::out, closure_proc_id_data::out) is det.
:- pred convert_table_arg_info(table_arg_infos::in, int::out,
rval::out, rval::out, static_cell_info::in, static_cell_info::out) is det.
@@ -314,8 +314,7 @@
Rval = const(llconst_data_addr(TypesDataAddr, no)),
map.det_insert(EventNumber, Rval, !EventArgTypeInfoMap).
-:- pred build_event_arg_type_info(event_attribute::in,
- pair(rval, llds_type)::out,
+:- pred build_event_arg_type_info(event_attribute::in, typed_rval::out,
static_cell_info::in, static_cell_info::out) is det.
build_event_arg_type_info(Attr, TypeRvalAndType, !StaticCellInfo) :-
@@ -324,7 +323,7 @@
NumUnivQTvars = -1,
ll_pseudo_type_info.construct_typed_llds_pseudo_type_info(Type,
NumUnivQTvars, ExistQTvars, !StaticCellInfo, TypeRval, TypeRvalType),
- TypeRvalAndType = TypeRval - TypeRvalType.
+ TypeRvalAndType = typed_rval(TypeRval, TypeRvalType).
%---------------------------------------------------------------------------%
@@ -1081,11 +1080,10 @@
),
LvalLocns = set.make_singleton_set(LvalLocn).
-:- pred construct_table_arg_pti_rval(
- table_arg_info::in, pair(rval, llds_type)::out,
+:- pred construct_table_arg_pti_rval(table_arg_info::in, typed_rval::out,
static_cell_info::in, static_cell_info::out) is det.
-construct_table_arg_pti_rval(ClosureArg, ArgRval - ArgRvalType,
+construct_table_arg_pti_rval(ClosureArg, typed_rval(ArgRval, ArgRvalType),
!StaticCellInfo) :-
ClosureArg = table_arg_info(_, _, _, Type),
ExistQTvars = [],
@@ -1609,28 +1607,28 @@
:- pred construct_user_data_array(stack_layout_params::in, var_num_map::in,
list(maybe(user_attribute))::in,
- assoc_list(rval, llds_type)::out, list(maybe(int))::out,
+ list(typed_rval)::out, list(maybe(int))::out,
static_cell_info::in, static_cell_info::out) is det.
construct_user_data_array(_, _, [], [], [], !Info).
construct_user_data_array(Params, VarNumMap, [MaybeAttr | MaybeAttrs],
- [LocnRvalAndType | LocnRvalAndTypes], [MaybeVarNum | MaybeVarNums],
+ [LocnTypedRval | LocnTypedRvals], [MaybeVarNum | MaybeVarNums],
!StaticCellInfo) :-
(
MaybeAttr = yes(Attr),
Attr = user_attribute(Locn, Var),
represent_locn_or_const_as_int_rval(Params, Locn, LocnRval,
LocnRvalType, !StaticCellInfo),
- LocnRvalAndType = LocnRval - LocnRvalType,
+ LocnTypedRval = typed_rval(LocnRval, LocnRvalType),
convert_var_to_int(VarNumMap, Var, VarNum),
MaybeVarNum = yes(VarNum)
;
MaybeAttr = no,
- LocnRvalAndType = const(llconst_int(0)) - lt_unsigned,
+ LocnTypedRval = typed_rval(const(llconst_int(0)), lt_unsigned),
MaybeVarNum = no
),
construct_user_data_array(Params, VarNumMap, MaybeAttrs,
- LocnRvalAndTypes, MaybeVarNums, !StaticCellInfo).
+ LocnTypedRvals, MaybeVarNums, !StaticCellInfo).
%---------------------------------------------------------------------------%
@@ -1717,7 +1715,7 @@
%
:- pred construct_type_param_locn_vector(
assoc_list(tvar, set(layout_locn))::in,
- int::in, assoc_list(rval, llds_type)::out) is det.
+ int::in, list(typed_rval)::out) is det.
construct_type_param_locn_vector([], _, []).
construct_type_param_locn_vector([TVar - Locns | TVarLocns], CurSlot,
@@ -1732,12 +1730,12 @@
),
represent_locn_as_int_rval(Locn, Rval),
construct_type_param_locn_vector(TVarLocns, NextSlot, VectorTail),
- Vector = [Rval - lt_unsigned | VectorTail]
+ Vector = [typed_rval(Rval, lt_unsigned) | VectorTail]
; TVarNum > CurSlot ->
construct_type_param_locn_vector([TVar - Locns | TVarLocns], NextSlot,
VectorTail),
% This slot will never be referred to.
- Vector = [const(llconst_int(0)) - lt_unsigned | VectorTail]
+ Vector = [typed_rval(const(llconst_int(0)), lt_unsigned) | VectorTail]
;
unexpected($module, $pred, "unsorted tvars")
).
@@ -1981,14 +1979,14 @@
).
:- pred construct_tvar_rvals(map(tvar, set(layout_locn))::in,
- assoc_list(rval, llds_type)::out) is det.
+ list(typed_rval)::out) is det.
construct_tvar_rvals(TVarLocnMap, Vector) :-
map.to_assoc_list(TVarLocnMap, TVarLocns),
construct_type_param_locn_vector(TVarLocns, 1, TypeParamLocs),
list.length(TypeParamLocs, TypeParamsLength),
LengthRval = const(llconst_int(TypeParamsLength)),
- Vector = [LengthRval - lt_unsigned | TypeParamLocs].
+ Vector = [typed_rval(LengthRval, lt_unsigned) | TypeParamLocs].
%---------------------------------------------------------------------------%
%
@@ -1998,7 +1996,7 @@
construct_closure_layout(CallerProcLabel, SeqNo,
ClosureLayoutInfo, ClosureProcLabel, ModuleName,
FileName, LineNumber, Origin, GoalPath, !StaticCellInfo,
- RvalsTypes, Data) :-
+ TypedRvals, Data) :-
% The representation we build here should be kept in sync
% with runtime/mercury_ho_call.h, which contains macros to access
% the data structures we build here.
@@ -2007,31 +2005,30 @@
DataId = layout_id(ClosureId),
Data = closure_proc_id_data(CallerProcLabel, SeqNo, ClosureProcLabel,
ModuleName, FileName, LineNumber, Origin, GoalPath),
- ProcIdRvalType = const(llconst_data_addr(DataId, no)) - lt_data_ptr,
+ ProcIdRval = const(llconst_data_addr(DataId, no)),
+ ProcIdTypedRval = typed_rval(ProcIdRval, lt_data_ptr),
ClosureLayoutInfo = closure_layout_info(ClosureArgs, TVarLocnMap),
construct_closure_arg_rvals(ClosureArgs,
- ClosureArgRvalsTypes, !StaticCellInfo),
+ ClosureArgTypedRvals, !StaticCellInfo),
construct_tvar_vector(TVarLocnMap, TVarVectorRval, !StaticCellInfo),
- RvalsTypes = [ProcIdRvalType, TVarVectorRval - lt_data_ptr |
- ClosureArgRvalsTypes].
+ TVarVectorTypedRval = typed_rval(TVarVectorRval, lt_data_ptr),
+ TypedRvals = [ProcIdTypedRval, TVarVectorTypedRval | ClosureArgTypedRvals].
:- pred construct_closure_arg_rvals(list(closure_arg_info)::in,
- assoc_list(rval, llds_type)::out,
- static_cell_info::in, static_cell_info::out) is det.
+ list(typed_rval)::out, static_cell_info::in, static_cell_info::out) is det.
-construct_closure_arg_rvals(ClosureArgs, ClosureArgRvalsTypes,
+construct_closure_arg_rvals(ClosureArgs, ClosureArgTypedRvals,
!StaticCellInfo) :-
- list.map_foldl(construct_closure_arg_rval, ClosureArgs, ArgRvalsTypes,
+ list.map_foldl(construct_closure_arg_rval, ClosureArgs, ArgTypedRvals,
!StaticCellInfo),
- list.length(ArgRvalsTypes, Length),
- ClosureArgRvalsTypes =
- [const(llconst_int(Length)) - lt_integer | ArgRvalsTypes].
+ list.length(ArgTypedRvals, Length),
+ LengthTypedRval = typed_rval(const(llconst_int(Length)), lt_integer),
+ ClosureArgTypedRvals = [LengthTypedRval| ArgTypedRvals].
:- pred construct_closure_arg_rval(closure_arg_info::in,
- pair(rval, llds_type)::out,
- static_cell_info::in, static_cell_info::out) is det.
+ typed_rval::out, static_cell_info::in, static_cell_info::out) is det.
-construct_closure_arg_rval(ClosureArg, ArgRval - ArgRvalType,
+construct_closure_arg_rval(ClosureArg, typed_rval(ArgRval, ArgRvalType),
!StaticCellInfo) :-
ClosureArg = closure_arg_info(Type, _Inst),
% For a stack layout, we can treat all type variables as universally
@@ -2153,7 +2150,7 @@
UnboxedFloats = Params ^ slp_unboxed_floats,
ArgWidth = full_word,
LLDSType = rval_type_as_arg(UnboxedFloats, ArgWidth, LvalOrConst),
- add_scalar_static_cell([LvalOrConst - LLDSType], DataId,
+ add_scalar_static_cell([typed_rval(LvalOrConst, LLDSType)], DataId,
!StaticCellInfo),
Rval = const(llconst_data_addr(DataId, no)),
Type = lt_data_ptr
Index: compiler/stack_opt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.56
diff -u -b -r1.56 stack_opt.m
--- compiler/stack_opt.m 12 Oct 2011 00:38:19 -0000 1.56
+++ compiler/stack_opt.m 7 Jun 2012 05:32:26 -0000
@@ -425,7 +425,7 @@
->
FreeOfCost = no
;
- type_to_ctor_and_args(Type, TypeCtor, _),
+ type_to_ctor(Type, TypeCtor),
ModuleInfo = IntParams ^ ip_module_info,
module_info_get_type_table(ModuleInfo, TypeTable),
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.81
diff -u -b -r1.81 stratify.m
--- compiler/stratify.m 13 Feb 2012 00:11:49 -0000 1.81
+++ compiler/stratify.m 7 Jun 2012 05:32:26 -0000
@@ -89,9 +89,9 @@
!Specs).
% The following code was used for the second pass of this module but
- % as that pass is disabled so is this code. The higher order code
+ % as that pass is disabled, so is this code. The higher order code
% is disabled because it is currently unable to detect cases where a
- % higher order proc is hidden in some complex data structure
+ % higher order proc is hidden in some complex data structure.
%
% gen_conservative_graph(!ModuleInfo, DepGraph0, DepGraph, HOInfo),
% digraph.atsort(DepGraph, HOSCCs1),
@@ -128,7 +128,7 @@
ModuleInfo, !Specs) :-
(
set.intersect(SCCs, StratifiedPreds, Intersection),
- set.empty(Intersection)
+ set.is_empty(Intersection)
->
Warn = Warn0
;
@@ -306,7 +306,7 @@
Warn = yes,
map.search(HOInfo, PredProcId, HigherOrderInfo)
->
- HigherOrderInfo = ho_info(HOCalls, _),
+ HigherOrderInfo = strat_ho_info(HOCalls, _),
set.intersect(HOCalls, WholeScc, HOLoops),
( set.empty(HOLoops) ->
HighOrderLoops = no
@@ -468,16 +468,18 @@
% This structure is used to hold the higher order characteristics of a
% procedure.
-:- type higher_order_info
- ---> ho_info(
- set(pred_proc_id), % Possible higher order addresses that
- % can reach the procedure.
- ho_in_out % Possible paths the address can take
- % in and out of the procedure.
+:- type strat_ho_info
+ ---> strat_ho_info(
+ % Possible higher order addresses that can reach the procedure.
+ set(pred_proc_id),
+
+ % Possible paths the address can take in and out
+ % of the procedure.
+ ho_in_out
).
% A map from all non imported procedures to there higher order info.
-:- type ho_map == map(pred_proc_id, higher_order_info).
+:- type ho_map == map(pred_proc_id, strat_ho_info).
% A map from all non imported procs to all the procedures they can call.
:- type call_map == map(pred_proc_id, set(pred_proc_id)).
@@ -554,8 +556,8 @@
merge_calls([C | Cs], P, CallsHO, DoingFirstOrder, !HOInfo, !Changed) :-
( map.search(!.HOInfo, C, CInfo) ->
map.lookup(!.HOInfo, P, PInfo),
- CInfo = ho_info(CHaveAT0, CHOInOut),
- PInfo = ho_info(PHaveAT0, PHOInOut),
+ CInfo = strat_ho_info(CHaveAT0, CHOInOut),
+ PInfo = strat_ho_info(PHaveAT0, PHOInOut),
% First merge the first order info, if we need to.
( CHOInOut = ho_none ->
true
@@ -594,8 +596,8 @@
% XXX What is a good message for this?
unexpected($module, $pred, "ho_none")
),
- NewCInfo = ho_info(CHaveAT, CHOInOut),
- NewPInfo = ho_info(PHaveAT, PHOInOut),
+ NewCInfo = strat_ho_info(CHaveAT, CHOInOut),
+ NewPInfo = strat_ho_info(PHaveAT, PHOInOut),
map.det_update(C, NewCInfo, !HOInfo),
map.det_update(P, NewPInfo, !HOInfo)
),
@@ -605,7 +607,7 @@
set.member(P, CallsHO)
->
map.lookup(!.HOInfo, P, PHOInfo),
- PHOInfo = ho_info(PossibleCalls, _),
+ PHOInfo = strat_ho_info(PossibleCalls, _),
set.to_sorted_list(PossibleCalls, PossibleCallsL),
merge_calls(PossibleCallsL, P, CallsHO, no, !HOInfo, !Changed)
;
@@ -620,14 +622,14 @@
% list of procedures and higher order call info, this predicate rebuilds
% the given call graph with new arcs for every possible higher order call.
%
-:- pred add_new_arcs(assoc_list(pred_proc_id, higher_order_info)::in,
+:- pred add_new_arcs(assoc_list(pred_proc_id, strat_ho_info)::in,
set(pred_proc_id)::in, dependency_graph::in, dependency_graph::out) is det.
add_new_arcs([], _, !DepGraph).
add_new_arcs([Caller - CallerInfo | Cs], CallsHO, !DepGraph) :-
% Only add arcs for callers who call higher order procs.
( set.member(Caller, CallsHO) ->
- CallerInfo = ho_info(PossibleCallees0, _),
+ CallerInfo = strat_ho_info(PossibleCallees0, _),
set.to_sorted_list(PossibleCallees0, PossibleCallees),
digraph.lookup_key(!.DepGraph, Caller, CallerKey),
add_new_arcs2(PossibleCallees, CallerKey, !DepGraph)
@@ -693,7 +695,7 @@
stratify_analyze_proc_body(Goal, Calls, HaveAT, CallsHigherOrder),
map.det_insert(PredProcId, Calls, !ProcCalls),
higherorder_in_out(ArgTypes, ArgModes, ModuleInfo, HOInOut),
- map.det_insert(PredProcId, ho_info(HaveAT, HOInOut), !HOInfo),
+ map.det_insert(PredProcId, strat_ho_info(HaveAT, HOInOut), !HOInfo),
(
CallsHigherOrder = calls_higher_order,
set.insert(PredProcId, !CallsHO)
Index: compiler/switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_gen.m,v
retrieving revision 1.121
diff -u -b -r1.121 switch_gen.m
--- compiler/switch_gen.m 9 Aug 2011 05:34:35 -0000 1.121
+++ compiler/switch_gen.m 7 Jun 2012 05:32:26 -0000
@@ -456,23 +456,25 @@
ConsTag = reserved_address_tag(_),
IsReservedAddr = yes
;
- ( ConsTag = no_tag
- ; ConsTag = base_typeclass_info_tag(_, _, _)
- ; ConsTag = deep_profiling_proc_layout_tag(_, _)
+ ( ConsTag = int_tag(_)
; ConsTag = float_tag(_)
+ ; ConsTag = string_tag(_)
; ConsTag = foreign_tag(_, _)
- ; ConsTag = int_tag(_)
; ConsTag = closure_tag(_, _, _)
- ; ConsTag = shared_local_tag(_, _)
- ; ConsTag = shared_remote_tag(_, _)
- ; ConsTag = shared_with_reserved_addresses_tag(_, _)
- ; ConsTag = single_functor_tag
- ; ConsTag = string_tag(_)
- ; ConsTag = table_io_decl_tag(_, _)
- ; ConsTag = tabling_info_tag(_, _)
; ConsTag = type_ctor_info_tag(_, _, _)
+ ; ConsTag = base_typeclass_info_tag(_, _, _)
+ ; ConsTag = type_info_const_tag(_)
+ ; ConsTag = typeclass_info_const_tag(_)
+ ; ConsTag = tabling_info_tag(_, _)
+ ; ConsTag = deep_profiling_proc_layout_tag(_, _)
+ ; ConsTag = table_io_decl_tag(_, _)
+ ; ConsTag = single_functor_tag
; ConsTag = unshared_tag(_)
; ConsTag = direct_arg_tag(_)
+ ; ConsTag = shared_remote_tag(_, _)
+ ; ConsTag = shared_local_tag(_, _)
+ ; ConsTag = no_tag
+ ; ConsTag = shared_with_reserved_addresses_tag(_, _)
),
IsReservedAddr = no
).
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.60
diff -u -b -r1.60 switch_util.m
--- compiler/switch_util.m 9 Aug 2011 05:34:35 -0000 1.60
+++ compiler/switch_util.m 7 Jun 2012 05:32:26 -0000
@@ -575,6 +575,8 @@
; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
@@ -1159,6 +1161,8 @@
; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
@@ -1260,6 +1264,8 @@
; Tag = closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
+ ; Tag = type_info_const_tag(_)
+ ; Tag = typeclass_info_const_tag(_)
; Tag = tabling_info_tag(_, _)
; Tag = deep_profiling_proc_layout_tag(_, _)
; Tag = table_io_decl_tag(_, _)
Index: compiler/term_constr_build.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_constr_build.m,v
retrieving revision 1.34
diff -u -b -r1.34 term_constr_build.m
--- compiler/term_constr_build.m 13 Feb 2012 00:11:49 -0000 1.34
+++ compiler/term_constr_build.m 7 Jun 2012 05:32:26 -0000
@@ -705,7 +705,7 @@
SizeVarMap = !.Info ^ tti_size_var_map,
map.lookup(TypeMap, SwitchProgVar, SwitchVarType),
SwitchSizeVar = prog_var_to_size_var(SizeVarMap, SwitchProgVar),
- type_to_ctor_and_args_det(SwitchVarType, TypeCtor, _),
+ type_to_ctor_det(SwitchVarType, TypeCtor),
ModuleInfo = !.Info ^ tti_module_info,
Norm = !.Info ^ tti_norm,
Zeros = !.Info ^ tti_zeros,
@@ -866,9 +866,9 @@
unexpected($module, $pred, "complicated_unify")
).
- % Used for deconstruction and construction unifications. e.g. for a
- % unification of the form: X = f(U, V, W), if the norm counts the
- % first and second arguments then the constraint returned is |X| -
+ % Used for deconstruction and construction unifications, i.e. for
+ % unifications of the form: X = f(U, V, W). If the norm counts the
+ % first and second arguments, then the constraint returned is |X| -
% |U| - |V| = |f|. (|X| is the size_var corresponding to X).
%
:- pred build_abstract_decon_or_con_unify(prog_var::in, cons_id::in,
@@ -879,9 +879,14 @@
!Info) :-
VarTypes = !.Info ^ tti_vartypes,
map.lookup(VarTypes, Var, Type),
- ( type_is_higher_order(Type) ->
+ (
% The only valid higher-order unifications are assignments.
% For the purposes of the IR analysis, we can ignore them.
+ % We can also ignore unifications that build constant terms.
+ ( type_is_higher_order(Type)
+ ; cons_id_is_const_struct(ConsId, _)
+ )
+ ->
Constraints = []
;
% We need to strip out any typeinfo related variables before
Index: compiler/term_traversal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/term_traversal.m,v
retrieving revision 1.67
diff -u -b -r1.67 term_traversal.m
--- compiler/term_traversal.m 13 Feb 2012 00:11:49 -0000 1.67
+++ compiler/term_traversal.m 7 Jun 2012 05:32:26 -0000
@@ -526,7 +526,8 @@
params_get_var_types(Params, VarTypes),
map.lookup(VarTypes, OutVar, Type),
\+ type_is_higher_order(Type),
- type_to_ctor_and_args_det(Type, TypeCtor, _),
+ \+ cons_id_is_const_struct(ConsId, _),
+ type_to_ctor_det(Type, TypeCtor),
filter_args_and_modes(VarTypes, Args0, Args1, Modes0, Modes1),
functor_norm(ModuleInfo, FunctorInfo, TypeCtor, ConsId, Gamma,
Args1, Args, Modes1, Modes),
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.109
diff -u -b -r1.109 type_ctor_info.m
--- compiler/type_ctor_info.m 5 Jul 2011 03:34:34 -0000 1.109
+++ compiler/type_ctor_info.m 7 Jun 2012 05:32:26 -0000
@@ -707,6 +707,8 @@
; ConsTag = closure_tag(_, _, _)
; ConsTag = type_ctor_info_tag(_, _, _)
; ConsTag = base_typeclass_info_tag(_, _, _)
+ ; ConsTag = type_info_const_tag(_)
+ ; ConsTag = typeclass_info_const_tag(_)
; ConsTag = tabling_info_tag(_, _)
; ConsTag = deep_profiling_proc_layout_tag(_, _)
; ConsTag = table_io_decl_tag(_, _)
@@ -887,6 +889,8 @@
; ConsTag = closure_tag(_, _, _)
; ConsTag = type_ctor_info_tag(_, _, _)
; ConsTag = base_typeclass_info_tag(_, _, _)
+ ; ConsTag = type_info_const_tag(_)
+ ; ConsTag = typeclass_info_const_tag(_)
; ConsTag = tabling_info_tag(_, _)
; ConsTag = deep_profiling_proc_layout_tag(_, _)
; ConsTag = table_io_decl_tag(_, _)
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.215
diff -u -b -r1.215 type_util.m
--- compiler/type_util.m 18 Apr 2012 02:25:00 -0000 1.215
+++ compiler/type_util.m 7 Jun 2012 05:32:26 -0000
@@ -34,9 +34,11 @@
% Given a type_ctor, look up its module/name/arity.
%
-:- func type_ctor_module(module_info, type_ctor) = module_name.
-:- func type_ctor_name(module_info, type_ctor) = string.
-:- func type_ctor_arity(module_info, type_ctor) = arity.
+:- func type_ctor_module(type_ctor) = module_name.
+:- func type_ctor_name(type_ctor) = string.
+:- func type_ctor_arity(type_ctor) = arity.
+:- pred type_ctor_module_name_arity(type_ctor::in,
+ module_name::out, string::out, arity::out) is det.
% Succeed iff type is an "atomic" type - one which can be unified
% using a simple_test rather than a complicated_unify.
@@ -380,13 +382,20 @@
%-----------------------------------------------------------------------------%
-type_ctor_module(_ModuleInfo, type_ctor(TypeSymName, _Arity)) = ModuleName :-
+type_ctor_module(type_ctor(TypeSymName, _Arity)) = ModuleName :-
sym_name_get_module_name_default(TypeSymName, unqualified(""), ModuleName).
-type_ctor_name(_ModuleInfo, type_ctor(TypeSymName, _Arity)) =
+type_ctor_name(type_ctor(TypeSymName, _Arity)) =
unqualify_name(TypeSymName).
-type_ctor_arity(_ModuleInfo, type_ctor(_Name, Arity)) = Arity.
+type_ctor_arity(type_ctor(_TypeSymName, Arity)) = Arity.
+
+type_ctor_module_name_arity(type_ctor(TypeSymName, Arity), ModuleName, Name,
+ Arity) :-
+ sym_name_get_module_name_default_name(TypeSymName, unqualified(""),
+ ModuleName, Name).
+
+%-----------------------------------------------------------------------------%
type_is_atomic(ModuleInfo, Type) :-
type_to_ctor(Type, TypeCtor),
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.211
diff -u -b -r1.211 unify_gen.m
--- compiler/unify_gen.m 13 Feb 2012 00:11:50 -0000 1.211
+++ compiler/unify_gen.m 7 Jun 2012 05:32:26 -0000
@@ -24,7 +24,9 @@
:- import_module hlds.code_model.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_module.
:- import_module ll_backend.code_info.
+:- import_module ll_backend.global_data.
:- import_module ll_backend.llds.
:- import_module parse_tree.prog_data.
@@ -51,6 +53,9 @@
:- pred generate_ground_term(prog_var::in, hlds_goal::in,
code_info::in, code_info::out) is det.
+:- pred generate_const_structs(module_info::in, const_struct_map::out,
+ global_data::in, global_data::out) is det.
+
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
@@ -63,9 +68,9 @@
:- import_module backend_libs.type_class_info.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
+:- import_module hlds.const_struct.
:- import_module hlds.hlds_code_util.
:- import_module hlds.hlds_llds.
-:- import_module hlds.hlds_module.
:- import_module hlds.hlds_out.
:- import_module hlds.hlds_out.hlds_out_goal.
:- import_module hlds.hlds_out.hlds_out_util.
@@ -205,7 +210,7 @@
).
:- pred get_cons_arg_widths(module_info::in, cons_id::in,
- list(prog_var)::in, list(arg_width)::out) is det.
+ list(T)::in, list(arg_width)::out) is det.
get_cons_arg_widths(ModuleInfo, ConsId, Args, AllArgWidths) :-
(
@@ -421,6 +426,13 @@
ConsTag = base_typeclass_info_tag(_, _, _),
unexpected($module, $pred, "Attempted base_typeclass_info unification")
;
+ ConsTag = type_info_const_tag(_),
+ unexpected($module, $pred, "Attempted type_info_const_tag unification")
+ ;
+ ConsTag = typeclass_info_const_tag(_),
+ unexpected($module, $pred,
+ "Attempted typeclass_info_const_tag unification")
+ ;
ConsTag = tabling_info_tag(_, _),
unexpected($module, $pred, "Attempted tabling_info unification")
;
@@ -605,7 +617,7 @@
;
ConsTag = type_ctor_info_tag(ModuleName, TypeName, TypeArity),
expect(unify(Args, []), $module, $pred,
- "generate_construction_2: type_ctor_info constant has args"),
+ "type_ctor_info constant has args"),
RttiTypeCtor = rtti_type_ctor(ModuleName, TypeName, TypeArity),
DataId = rtti_data_id(ctor_rtti_id(RttiTypeCtor,
type_ctor_type_ctor_info)),
@@ -614,16 +626,23 @@
;
ConsTag = base_typeclass_info_tag(ModuleName, ClassId, Instance),
expect(unify(Args, []), $module, $pred,
- "generate_construction_2: base_typeclass_info constant has args"),
+ "base_typeclass_info constant has args"),
TCName = generate_class_name(ClassId),
DataId = rtti_data_id(tc_rtti_id(TCName,
type_class_base_typeclass_info(ModuleName, Instance))),
assign_const_to_var(Var, const(llconst_data_addr(DataId, no)), !CI),
Code = empty
;
+ ( ConsTag = type_info_const_tag(ConstNum)
+ ; ConsTag = typeclass_info_const_tag(ConstNum)
+ ),
+ get_const_struct_map(!.CI, ConstStructMap),
+ map.lookup(ConstStructMap, ConstNum, typed_rval(Rval, _Type)),
+ assign_expr_to_var(Var, Rval, Code, !CI)
+ ;
ConsTag = tabling_info_tag(PredId, ProcId),
expect(unify(Args, []), $module, $pred,
- "generate_construction_2: tabling_info constant has args"),
+ "tabling_info constant has args"),
get_module_info(!.CI, ModuleInfo),
ProcLabel = make_proc_label(ModuleInfo, PredId, ProcId),
DataId = proc_tabling_data_id(ProcLabel, tabling_info),
@@ -632,7 +651,7 @@
;
ConsTag = deep_profiling_proc_layout_tag(PredId, ProcId),
expect(unify(Args, []), $module, $pred,
- "generate_construction_2: deep_profiling_proc_static has args"),
+ "deep_profiling_proc_static has args"),
get_module_info(!.CI, ModuleInfo),
RttiProcLabel = make_rtti_proc_label(ModuleInfo, PredId, ProcId),
Origin = RttiProcLabel ^ rpl_pred_info_origin,
@@ -648,7 +667,7 @@
;
ConsTag = table_io_decl_tag(PredId, ProcId),
expect(unify(Args, []), $module, $pred,
- "generate_construction_2: table_io_decl has args"),
+ "table_io_decl has args"),
PredProcId = proc(PredId, ProcId),
DataId = layout_slot_id(table_io_decl_id, PredProcId),
assign_const_to_var(Var, const(llconst_data_addr(DataId, no)), !CI),
@@ -656,7 +675,7 @@
;
ConsTag = reserved_address_tag(RA),
expect(unify(Args, []), $module, $pred,
- "generate_construction_2: reserved_address constant has args"),
+ "reserved_address constant has args"),
assign_const_to_var(Var, generate_reserved_address(RA), !CI),
Code = empty
;
@@ -669,9 +688,9 @@
;
ConsTag = closure_tag(PredId, ProcId, EvalMethod),
expect(unify(TakeAddr, []), $module, $pred,
- "generate_construction_2: closure_tag has take_addr"),
+ "closure_tag has take_addr"),
expect(unify(MaybeSize, no), $module, $pred,
- "generate_construction_2: closure_tag has size"),
+ "closure_tag has size"),
generate_closure(PredId, ProcId, EvalMethod, Var, Args, GoalInfo,
Code, !CI)
).
@@ -846,12 +865,12 @@
stack_layout.construct_closure_layout(CallerProcLabel,
SeqNo, ClosureInfo, ProcLabel, ModuleName, FileName, LineNumber,
PredOrigin, GoalIdStr, StaticCellInfo0, StaticCellInfo,
- ClosureLayoutRvalsTypes, Data),
+ ClosureLayoutTypedRvals, Data),
set_static_cell_info(StaticCellInfo, !CI),
add_closure_layout(Data, !CI),
% For now, closures always have zero size, and the size slot
% is never looked at.
- add_scalar_static_cell(ClosureLayoutRvalsTypes, ClosureDataAddr, !CI),
+ add_scalar_static_cell(ClosureLayoutTypedRvals, ClosureDataAddr, !CI),
ClosureLayoutRval = const(llconst_data_addr(ClosureDataAddr, no)),
proc_info_arg_info(ProcInfo, ArgInfo),
VarTypes = get_var_types(!.CI),
@@ -1260,6 +1279,12 @@
),
Code = empty
;
+ Tag = type_info_const_tag(_),
+ unexpected($module, $pred, "type_info_const_tag")
+ ;
+ Tag = typeclass_info_const_tag(_),
+ unexpected($module, $pred, "typeclass_info_const_tag")
+ ;
Tag = table_io_decl_tag(_, _),
unexpected($module, $pred, "table_io_decl_tag")
;
@@ -1304,7 +1329,8 @@
;
Tag = unshared_tag(Ptag),
Rval = var(Var),
- make_fields_and_argvars(Args, ArgWidths, Rval, -1, Ptag, Fields, ArgVars),
+ make_fields_and_argvars(Args, ArgWidths, Rval, -1, Ptag,
+ Fields, ArgVars),
var_types(!.CI, Args, ArgTypes),
generate_unify_args(Fields, ArgVars, Modes, ArgTypes, Code, !CI)
;
@@ -1323,7 +1349,8 @@
;
Tag = shared_remote_tag(Ptag, _Sectag1),
Rval = var(Var),
- make_fields_and_argvars(Args, ArgWidths, Rval, 0, Ptag, Fields, ArgVars),
+ make_fields_and_argvars(Args, ArgWidths, Rval, 0, Ptag,
+ Fields, ArgVars),
var_types(!.CI, Args, ArgTypes),
generate_unify_args(Fields, ArgVars, Modes, ArgTypes, Code, !CI)
;
@@ -1623,8 +1650,231 @@
%---------------------------------------------------------------------------%
-:- type active_ground_term == pair(rval, llds_type).
-:- type active_ground_term_map == map(prog_var, active_ground_term).
+generate_const_structs(ModuleInfo, ConstStructMap, !GlobalData) :-
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, unboxed_float, UB),
+ (
+ UB = yes,
+ UnboxedFloats = have_unboxed_floats
+ ;
+ UB = no,
+ UnboxedFloats = do_not_have_unboxed_floats
+ ),
+ module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
+ const_struct_db_get_structs(ConstStructDb, ConstStructs),
+ global_data_get_static_cell_info(!.GlobalData, StaticCellInfo0),
+ list.foldl2(generate_const_struct(ModuleInfo, UnboxedFloats), ConstStructs,
+ map.init, ConstStructMap, StaticCellInfo0, StaticCellInfo),
+ global_data_set_static_cell_info(StaticCellInfo, !GlobalData).
+
+:- pred generate_const_struct(module_info::in, have_unboxed_floats::in,
+ pair(int, const_struct)::in,
+ const_struct_map::in, const_struct_map::out,
+ static_cell_info::in, static_cell_info::out) is det.
+
+generate_const_struct(ModuleInfo, UnboxedFloats, ConstNum - ConstStruct,
+ !ConstStructMap, !StaticCellInfo) :-
+ ConstStruct = const_struct(ConsId, ConstArgs, _, _),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
+ get_cons_arg_widths(ModuleInfo, ConsId, ConstArgs, ConsArgWidths),
+ generate_const_struct_rval(ModuleInfo, UnboxedFloats, !.ConstStructMap,
+ ConsId, ConsTag, ConstArgs, ConsArgWidths, Rval, !StaticCellInfo),
+ map.det_insert(ConstNum, Rval, !ConstStructMap).
+
+:- pred generate_const_struct_rval(module_info::in, have_unboxed_floats::in,
+ const_struct_map::in, cons_id::in, cons_tag::in,
+ list(const_struct_arg)::in, list(arg_width)::in, typed_rval::out,
+ static_cell_info::in, static_cell_info::out) is det.
+
+generate_const_struct_rval(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConsId, ConsTag, ConstArgs, ConsArgWidths, TypedRval,
+ !StaticCellInfo) :-
+ (
+ ConsTag = shared_with_reserved_addresses_tag(_, ActualConsTag),
+ generate_const_struct_rval(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConsId, ActualConsTag, ConstArgs, ConsArgWidths,
+ TypedRval, !StaticCellInfo)
+ ;
+ ConsTag = no_tag,
+ generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConstArgs, ArgTypedRvals),
+ (
+ ArgTypedRvals = [ArgTypedRval],
+ TypedRval = ArgTypedRval
+ ;
+ ( ArgTypedRvals = []
+ ; ArgTypedRvals = [_, _ | _]
+ ),
+ unexpected($module, $pred, "no_tag arity != 1")
+ )
+ ;
+ ConsTag = direct_arg_tag(Ptag),
+ generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConstArgs, ArgTypedRvals),
+ (
+ ArgTypedRvals = [ArgTypedRval],
+ ArgTypedRval = typed_rval(ArgRval, _RvalType),
+ Rval = mkword(Ptag, ArgRval),
+ TypedRval = typed_rval(Rval, lt_data_ptr)
+ ;
+ ( ArgTypedRvals = []
+ ; ArgTypedRvals = [_, _ | _]
+ ),
+ unexpected($module, $pred, "direct_arg_tag: arity != 1")
+ )
+ ;
+ (
+ ConsTag = single_functor_tag,
+ Ptag = 0
+ ;
+ ConsTag = unshared_tag(Ptag)
+ ),
+ generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConstArgs, ArgTypedRvals),
+ pack_ground_term_args(ConsArgWidths, ArgTypedRvals, PackArgTypedRvals),
+ add_scalar_static_cell(PackArgTypedRvals, DataAddr, !StaticCellInfo),
+ MaybeOffset = no,
+ CellPtrConst = const(llconst_data_addr(DataAddr, MaybeOffset)),
+ Rval = mkword(Ptag, CellPtrConst),
+ TypedRval = typed_rval(Rval, lt_data_ptr)
+ ;
+ ConsTag = shared_remote_tag(Ptag, Stag),
+ generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConstArgs, ArgTypedRvals),
+ pack_ground_term_args(ConsArgWidths, ArgTypedRvals, PackArgTypedRvals),
+ StagTypedRval = typed_rval(const(llconst_int(Stag)), lt_integer),
+ AllTypedRvals = [StagTypedRval | PackArgTypedRvals],
+ add_scalar_static_cell(AllTypedRvals, DataAddr, !StaticCellInfo),
+ MaybeOffset = no,
+ CellPtrConst = const(llconst_data_addr(DataAddr, MaybeOffset)),
+ Rval = mkword(Ptag, CellPtrConst),
+ TypedRval = typed_rval(Rval, lt_data_ptr)
+ ;
+ ( ConsTag = string_tag(_)
+ ; ConsTag = int_tag(_)
+ ; ConsTag = foreign_tag(_, _)
+ ; ConsTag = float_tag(_)
+ ; ConsTag = shared_local_tag(_, _)
+ ; ConsTag = reserved_address_tag(_)
+ ; ConsTag = closure_tag(_, _, _)
+ ; ConsTag = type_ctor_info_tag(_, _, _)
+ ; ConsTag = base_typeclass_info_tag(_, _, _)
+ ; ConsTag = type_info_const_tag(_)
+ ; ConsTag = typeclass_info_const_tag(_)
+ ; ConsTag = tabling_info_tag(_, _)
+ ; ConsTag = table_io_decl_tag(_, _)
+ ; ConsTag = deep_profiling_proc_layout_tag(_, _)
+ ),
+ unexpected($module, $pred, "unexpected tag")
+ ).
+
+:- pred generate_const_struct_args(module_info::in, have_unboxed_floats::in,
+ const_struct_map::in, list(const_struct_arg)::in, list(typed_rval)::out)
+ is det.
+
+generate_const_struct_args(_, _, _, [], []).
+generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
+ [ConstArg | ConstArgs], [TypedRval | TypedRvals]) :-
+ generate_const_struct_arg(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConstArg, TypedRval),
+ generate_const_struct_args(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConstArgs, TypedRvals).
+
+:- pred generate_const_struct_arg(module_info::in, have_unboxed_floats::in,
+ const_struct_map::in, const_struct_arg::in, typed_rval::out) is det.
+
+generate_const_struct_arg(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConstArg, TypedRval) :-
+ (
+ ConstArg = csa_const_struct(ConstNum),
+ map.lookup(ConstStructMap, ConstNum, TypedRval)
+ ;
+ ConstArg = csa_constant(ConsId, _),
+ ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
+ generate_const_struct_arg_tag(ModuleInfo, UnboxedFloats,
+ ConstStructMap, ConsTag, TypedRval)
+ ).
+
+:- pred generate_const_struct_arg_tag(module_info::in, have_unboxed_floats::in,
+ const_struct_map::in, cons_tag::in, typed_rval::out) is det.
+
+generate_const_struct_arg_tag(ModuleInfo, UnboxedFloats, ConstStructMap,
+ ConsTag, TypedRval) :-
+ (
+ (
+ ConsTag = string_tag(String),
+ Const = llconst_string(String),
+ Type = lt_string
+ ;
+ ConsTag = int_tag(Int),
+ Const = llconst_int(Int),
+ Type = lt_integer
+ ;
+ ConsTag = foreign_tag(Lang, Val),
+ expect(unify(Lang, lang_c), $module, $pred,
+ "foreign_tag for language other than C"),
+ Const = llconst_foreign(Val, lt_integer),
+ Type = lt_integer
+ ;
+ ConsTag = float_tag(Float),
+ Const = llconst_float(Float),
+ (
+ UnboxedFloats = have_unboxed_floats,
+ Type = lt_float
+ ;
+ UnboxedFloats = do_not_have_unboxed_floats,
+ Type = lt_data_ptr
+ )
+ ),
+ TypedRval = typed_rval(const(Const), Type)
+ ;
+ ConsTag = shared_local_tag(Ptag, Stag),
+ Rval = mkword(Ptag, unop(mkbody, const(llconst_int(Stag)))),
+ TypedRval = typed_rval(Rval, lt_data_ptr)
+ ;
+ ConsTag = reserved_address_tag(RA),
+ Rval = generate_reserved_address(RA),
+ rval_type(Rval, Type),
+ TypedRval = typed_rval(Rval, Type)
+ ;
+ ConsTag = shared_with_reserved_addresses_tag(_, ActualConsTag),
+ generate_const_struct_arg_tag(ModuleInfo, UnboxedFloats,
+ ConstStructMap, ActualConsTag, TypedRval)
+ ;
+ ConsTag = type_ctor_info_tag(ModuleName, TypeName, TypeArity),
+ RttiTypeCtor = rtti_type_ctor(ModuleName, TypeName, TypeArity),
+ DataId = rtti_data_id(ctor_rtti_id(RttiTypeCtor,
+ type_ctor_type_ctor_info)),
+ Rval = const(llconst_data_addr(DataId, no)),
+ Type = lt_data_ptr,
+ TypedRval = typed_rval(Rval, Type)
+ ;
+ ConsTag = base_typeclass_info_tag(ModuleName, ClassId, Instance),
+ TCName = generate_class_name(ClassId),
+ DataId = rtti_data_id(tc_rtti_id(TCName,
+ type_class_base_typeclass_info(ModuleName, Instance))),
+ Rval = const(llconst_data_addr(DataId, no)),
+ Type = lt_data_ptr,
+ TypedRval = typed_rval(Rval, Type)
+ ;
+ ( ConsTag = no_tag
+ ; ConsTag = direct_arg_tag(_)
+ ; ConsTag = single_functor_tag
+ ; ConsTag = unshared_tag(_)
+ ; ConsTag = shared_remote_tag(_, _)
+ ; ConsTag = type_info_const_tag(_)
+ ; ConsTag = typeclass_info_const_tag(_)
+ ; ConsTag = closure_tag(_, _, _)
+ ; ConsTag = tabling_info_tag(_, _)
+ ; ConsTag = table_io_decl_tag(_, _)
+ ; ConsTag = deep_profiling_proc_layout_tag(_, _)
+ ),
+ unexpected($module, $pred, "unexpected tag")
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- type active_ground_term_map == map(prog_var, typed_rval).
generate_ground_term(TermVar, Goal, !CI) :-
Goal = hlds_goal(GoalExpr, GoalInfo),
@@ -1650,7 +1900,7 @@
( ActivePairs = [TermVar - GroundTerm] ->
add_forward_live_vars(NonLocals, !CI),
set_static_cell_info(StaticCellInfo, !CI),
- GroundTerm = Rval - _,
+ GroundTerm = typed_rval(Rval, _),
assign_const_to_var(TermVar, Rval, !CI)
;
unexpected($module, $pred, "no active pairs")
@@ -1734,18 +1984,18 @@
Type = lt_data_ptr
)
),
- ActiveGroundTerm = const(Const) - Type,
+ ActiveGroundTerm = typed_rval(const(Const), Type),
map.det_insert(Var, ActiveGroundTerm, !ActiveMap)
;
ConsTag = shared_local_tag(Ptag, Stag),
Rval = mkword(Ptag, unop(mkbody, const(llconst_int(Stag)))),
- ActiveGroundTerm = Rval - lt_data_ptr,
+ ActiveGroundTerm = typed_rval(Rval, lt_data_ptr),
map.det_insert(Var, ActiveGroundTerm, !ActiveMap)
;
ConsTag = reserved_address_tag(RA),
Rval = generate_reserved_address(RA),
rval_type(Rval, RvalType),
- ActiveGroundTerm = Rval - RvalType,
+ ActiveGroundTerm = typed_rval(Rval, RvalType),
map.det_insert(Var, ActiveGroundTerm, !ActiveMap)
;
ConsTag = shared_with_reserved_addresses_tag(_, ActualConsTag),
@@ -1771,22 +2021,22 @@
;
ConsTag = unshared_tag(Ptag)
),
- generate_ground_term_args(Args, ConsArgWidths, ArgRvalsTypes,
+ generate_ground_term_args(Args, ConsArgWidths, ArgTypedRvals,
!ActiveMap),
- pack_ground_term_args(ConsArgWidths, ArgRvalsTypes, PackArgRvalsTypes),
- add_scalar_static_cell(PackArgRvalsTypes, DataAddr, !StaticCellInfo),
+ pack_ground_term_args(ConsArgWidths, ArgTypedRvals, PackArgTypedRvals),
+ add_scalar_static_cell(PackArgTypedRvals, DataAddr, !StaticCellInfo),
MaybeOffset = no,
CellPtrConst = const(llconst_data_addr(DataAddr, MaybeOffset)),
Rval = mkword(Ptag, CellPtrConst),
- ActiveGroundTerm = Rval - lt_data_ptr,
+ ActiveGroundTerm = typed_rval(Rval, lt_data_ptr),
map.det_insert(Var, ActiveGroundTerm, !ActiveMap)
;
ConsTag = direct_arg_tag(Ptag),
(
Args = [Arg],
- map.det_remove(Arg, ArgRval - _RvalType, !ActiveMap),
+ map.det_remove(Arg, typed_rval(ArgRval, _RvalType), !ActiveMap),
Rval = mkword(Ptag, ArgRval),
- ActiveGroundTerm = Rval - lt_data_ptr,
+ ActiveGroundTerm = typed_rval(Rval, lt_data_ptr),
map.det_insert(Var, ActiveGroundTerm, !ActiveMap)
;
( Args = []
@@ -1796,21 +2046,23 @@
)
;
ConsTag = shared_remote_tag(Ptag, Stag),
- generate_ground_term_args(Args, ConsArgWidths, ArgRvalsTypes,
+ generate_ground_term_args(Args, ConsArgWidths, ArgTypedRvals,
!ActiveMap),
- pack_ground_term_args(ConsArgWidths, ArgRvalsTypes, PackArgRvalsTypes),
- StagRvalType = const(llconst_int(Stag)) - lt_integer,
- AllRvalsTypes = [StagRvalType | PackArgRvalsTypes],
- add_scalar_static_cell(AllRvalsTypes, DataAddr, !StaticCellInfo),
+ pack_ground_term_args(ConsArgWidths, ArgTypedRvals, PackArgTypedRvals),
+ StagTypedRval = typed_rval(const(llconst_int(Stag)), lt_integer),
+ AllTypedRvals = [StagTypedRval | PackArgTypedRvals],
+ add_scalar_static_cell(AllTypedRvals, DataAddr, !StaticCellInfo),
MaybeOffset = no,
CellPtrConst = const(llconst_data_addr(DataAddr, MaybeOffset)),
Rval = mkword(Ptag, CellPtrConst),
- ActiveGroundTerm = Rval - lt_data_ptr,
+ ActiveGroundTerm = typed_rval(Rval, lt_data_ptr),
map.det_insert(Var, ActiveGroundTerm, !ActiveMap)
;
( ConsTag = closure_tag(_, _, _)
; ConsTag = type_ctor_info_tag(_, _, _)
; ConsTag = base_typeclass_info_tag(_, _, _)
+ ; ConsTag = type_info_const_tag(_)
+ ; ConsTag = typeclass_info_const_tag(_)
; ConsTag = tabling_info_tag(_, _)
; ConsTag = table_io_decl_tag(_, _)
; ConsTag = deep_profiling_proc_layout_tag(_, _)
@@ -1819,35 +2071,35 @@
).
:- pred generate_ground_term_args(list(prog_var)::in, list(arg_width)::in,
- assoc_list(rval, llds_type)::out,
+ list(typed_rval)::out,
active_ground_term_map::in, active_ground_term_map::out) is det.
-generate_ground_term_args(Vars, ConsArgWidths, RvalsTypes, !ActiveMap) :-
+generate_ground_term_args(Vars, ConsArgWidths, TypedRvals, !ActiveMap) :-
list.map_corresponding_foldl(generate_ground_term_arg, Vars, ConsArgWidths,
- RvalsTypes, !ActiveMap).
+ TypedRvals, !ActiveMap).
:- pred generate_ground_term_arg(prog_var::in, arg_width::in,
- pair(rval, llds_type)::out,
+ typed_rval::out,
active_ground_term_map::in, active_ground_term_map::out) is det.
-generate_ground_term_arg(Var, ConsArgWidth, RvalType, !ActiveMap) :-
- map.det_remove(Var, RvalType0, !ActiveMap),
+generate_ground_term_arg(Var, ConsArgWidth, TypedRval, !ActiveMap) :-
+ map.det_remove(Var, TypedRval0, !ActiveMap),
% Though a standalone float might have needed to boxed, it may be stored in
% unboxed form as a constructor argument.
(
ConsArgWidth = double_word,
- RvalType0 = Rval - lt_data_ptr
+ TypedRval0 = typed_rval(Rval, lt_data_ptr)
->
- RvalType = Rval - lt_float
+ TypedRval = typed_rval(Rval, lt_float)
;
- RvalType = RvalType0
+ TypedRval = TypedRval0
).
:- pred pack_ground_term_args(list(arg_width)::in,
- assoc_list(rval, llds_type)::in, assoc_list(rval, llds_type)::out) is det.
+ list(typed_rval)::in, list(typed_rval)::out) is det.
-pack_ground_term_args(Widths, !RvalsTypes) :-
- pack_args(shift_combine_rval_type, Widths, !RvalsTypes, unit, _, unit, _).
+pack_ground_term_args(Widths, !TypedRvals) :-
+ pack_args(shift_combine_rval_type, Widths, !TypedRvals, unit, _, unit, _).
%-----------------------------------------------------------------------------%
@@ -1913,15 +2165,15 @@
)
).
-:- pred shift_combine_rval_type(pair(rval, llds_type)::in, int::in,
- maybe(pair(rval, llds_type))::in, pair(rval, llds_type)::out,
+:- pred shift_combine_rval_type(typed_rval::in, int::in,
+ maybe(typed_rval)::in, typed_rval::out,
unit::in, unit::out, unit::in, unit::out) is det.
shift_combine_rval_type(ArgA, Shift, MaybeArgB, FinalArg, !Acc1, !Acc2) :-
- ArgA = RvalA - TypeA,
+ ArgA = typed_rval(RvalA, TypeA),
ShiftRvalA = maybe_left_shift_rval(RvalA, Shift),
(
- MaybeArgB = yes(RvalB - TypeB),
+ MaybeArgB = yes(typed_rval(RvalB, TypeB)),
( TypeA = TypeB ->
FinalRval = binop(bitwise_or, ShiftRvalA, RvalB)
;
@@ -1931,7 +2183,7 @@
MaybeArgB = no,
FinalRval = ShiftRvalA
),
- FinalArg = FinalRval - TypeA.
+ FinalArg = typed_rval(FinalRval, TypeA).
:- func maybe_left_shift_rval(rval, int) = rval.
@@ -2001,15 +2253,11 @@
:- pred var_type_msg(mer_type::in, string::out) is det.
var_type_msg(Type, Msg) :-
- ( type_to_ctor_and_args(Type, TypeCtor, _) ->
+ type_to_ctor_det(Type, TypeCtor),
TypeCtor = type_ctor(TypeSym, TypeArity),
TypeSymStr = sym_name_to_string(TypeSym),
string.int_to_string(TypeArity, TypeArityStr),
- string.append_list([TypeSymStr, "/", TypeArityStr], Msg)
- ;
- unexpected($module, $pred,
- "type is still a type variable in var_type_msg")
- ).
+ string.append_list([TypeSymStr, "/", TypeArityStr], Msg).
%---------------------------------------------------------------------------%
:- end_module unify_gen.
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.173
diff -u -b -r1.173 unused_args.m
--- compiler/unused_args.m 13 Feb 2012 00:11:50 -0000 1.173
+++ compiler/unused_args.m 7 Jun 2012 05:32:26 -0000
@@ -1119,7 +1119,7 @@
:- pred make_new_pred_info(module_info::in, list(int)::in, import_status::in,
pred_proc_id::in, pred_info::in, pred_info::out) is det.
-make_new_pred_info(ModuleInfo, UnusedArgs, Status, proc(PredId, ProcId),
+make_new_pred_info(_ModuleInfo, UnusedArgs, Status, proc(PredId, ProcId),
!PredInfo) :-
PredModule = pred_info_module(!.PredInfo),
Name0 = pred_info_name(!.PredInfo),
@@ -1135,9 +1135,8 @@
% Fix up special pred names.
OrigOrigin = origin_special_pred(_SpecialId - TypeCtor)
->
- TypeModule = type_ctor_module(ModuleInfo, TypeCtor),
- TypeName = type_ctor_name(ModuleInfo, TypeCtor),
- TypeArity = type_ctor_arity(ModuleInfo, TypeCtor),
+ type_ctor_module_name_arity(TypeCtor, TypeModule, TypeName,
+ TypeArity),
string.int_to_string(TypeArity, TypeArityStr),
TypeModuleString = sym_name_to_string_sep(TypeModule, "__"),
string.append_list([Name0, "_", TypeModuleString, "__", TypeName,
Index: compiler/unused_imports.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_imports.m,v
retrieving revision 1.31
diff -u -b -r1.31 unused_imports.m
--- compiler/unused_imports.m 23 Apr 2012 03:34:49 -0000 1.31
+++ compiler/unused_imports.m 7 Jun 2012 05:32:26 -0000
@@ -492,6 +492,8 @@
; ConsId = string_const(_)
; ConsId = impl_defined_const(_)
; ConsId = typeclass_info_cell_constructor
+ ; ConsId = type_info_const(_)
+ ; ConsId = typeclass_info_const(_)
; ConsId = tabling_info_const(_)
; ConsId = table_io_decl(_)
; ConsId = deep_profiling_proc_layout(_)
Index: compiler/var_locn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/var_locn.m,v
retrieving revision 1.82
diff -u -b -r1.82 var_locn.m
--- compiler/var_locn.m 17 Jan 2012 15:49:44 -0000 1.82
+++ compiler/var_locn.m 7 Jun 2012 05:32:26 -0000
@@ -869,9 +869,9 @@
% and they are all constants.
(
StaticGroundCells = have_static_ground_cells,
- cell_is_constant(VarStateMap, ExprnOpts, CellArgs, RvalsTypes)
+ cell_is_constant(VarStateMap, ExprnOpts, CellArgs, TypedRvals)
->
- add_scalar_static_cell(RvalsTypes, DataAddr, !StaticCellInfo),
+ add_scalar_static_cell(TypedRvals, DataAddr, !StaticCellInfo),
CellPtrConst = const(llconst_data_addr(DataAddr, MaybeOffset)),
CellPtrRval = mkword(Ptag, CellPtrConst),
var_locn_assign_const_to_var(ExprnOpts, Var, CellPtrRval, !VLI),
@@ -2249,11 +2249,11 @@
%----------------------------------------------------------------------------%
:- pred cell_is_constant(var_state_map::in, exprn_opts::in,
- list(cell_arg)::in, assoc_list(rval, llds_type)::out) is semidet.
+ list(cell_arg)::in, list(typed_rval)::out) is semidet.
cell_is_constant(_VarStateMap, _ExprnOpts, [], []).
cell_is_constant(VarStateMap, ExprnOpts, [CellArg | CellArgs],
- [Rval - LldsType | RvalsTypes]) :-
+ [typed_rval(Rval, LldsType) | TypedRvals]) :-
require_complete_switch [CellArg]
(
CellArg = cell_arg_full_word(Rval0, complete),
@@ -2270,7 +2270,7 @@
),
expr_is_constant(VarStateMap, ExprnOpts, Rval0, Rval),
LldsType = rval_type_as_arg(get_unboxed_floats(ExprnOpts), ArgWidth, Rval),
- cell_is_constant(VarStateMap, ExprnOpts, CellArgs, RvalsTypes).
+ cell_is_constant(VarStateMap, ExprnOpts, CellArgs, TypedRvals).
% expr_is_constant(VarStateMap, ExprnOpts, Rval0, Rval):
% Check if Rval0 is a constant rval, after substituting the values of the
Index: compiler/xml_documentation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/xml_documentation.m,v
retrieving revision 1.32
diff -u -b -r1.32 xml_documentation.m
--- compiler/xml_documentation.m 23 Apr 2012 03:34:49 -0000 1.32
+++ compiler/xml_documentation.m 7 Jun 2012 05:32:26 -0000
@@ -663,6 +663,8 @@
cons_id(type_info_cell_constructor(_)) = nyi("type_info_cell_constructor").
cons_id(typeclass_info_cell_constructor) =
nyi("typeclass_info_cell_constructor").
+cons_id(type_info_const(_)) = nyi("type_info_const").
+cons_id(typeclass_info_const(_)) = nyi("typeclass_info_const").
cons_id(tabling_info_const(_)) = nyi("tabling_info_const").
cons_id(table_io_decl(_)) = nyi("table_io_decl").
cons_id(deep_profiling_proc_layout(_)) = nyi("deep_profiling_proc_layout").
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.155
diff -u -b -r1.155 compiler_design.html
--- compiler/notes/compiler_design.html 16 Apr 2012 08:13:22 -0000 1.155
+++ compiler/notes/compiler_design.html 7 Jun 2012 05:32:26 -0000
@@ -540,6 +540,8 @@
<li>
hlds_rtti.m defines the part of the HLDS concerning RTTI.
<li>
+const_struct.m defines the part of the HLDS concerning constant structures.
+<li>
hlds_pred.m defines the part of the HLDS concerning predicates and procedures;
<li>
pred_table.m defines the tables that index predicates and functions
@@ -1903,6 +1905,6 @@
<hr>
<!-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -->
-Last update was $Date: 2012/04/16 08:13:22 $ by $Author: zs $@cs.mu.oz.au. <br>
+Last update was $Date: 2012-04-16 08:13:22 $ by $Author: zs $@cs.mu.oz.au. <br>
</body>
</html>
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.651
diff -u -b -r1.651 user_guide.texi
--- doc/user_guide.texi 5 Jun 2012 18:19:31 -0000 1.651
+++ doc/user_guide.texi 7 Jun 2012 05:32:26 -0000
@@ -7286,6 +7286,7 @@
S - information about structure sharing,
T - type and typeclass information,
U - unify and compare predicates,
+X - constant structures,
Z - information about globals structs representing call and answer tables.
@sp 1
cvs diff: Diffing extras
cvs diff: Diffing extras/base64
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/fixed
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_allegro
cvs diff: Diffing extras/graphics/mercury_allegro/examples
cvs diff: Diffing extras/graphics/mercury_allegro/samples
cvs diff: Diffing extras/graphics/mercury_allegro/samples/demo
cvs diff: Diffing extras/graphics/mercury_allegro/samples/mandel
cvs diff: Diffing extras/graphics/mercury_allegro/samples/pendulum2
cvs diff: Diffing extras/graphics/mercury_allegro/samples/speed
cvs diff: Diffing extras/graphics/mercury_cairo
cvs diff: Diffing extras/graphics/mercury_cairo/samples
cvs diff: Diffing extras/graphics/mercury_cairo/samples/data
cvs diff: Diffing extras/graphics/mercury_cairo/tutorial
cvs diff: Diffing extras/graphics/mercury_glfw
cvs diff: Diffing extras/graphics/mercury_glfw/samples
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/log4m
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/monte
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/mopenssl
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/net
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/posix/samples
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
Index: library/erlang_rtti_implementation.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/erlang_rtti_implementation.m,v
retrieving revision 1.32
diff -u -b -r1.32 erlang_rtti_implementation.m
--- library/erlang_rtti_implementation.m 16 Sep 2011 08:17:34 -0000 1.32
+++ library/erlang_rtti_implementation.m 7 Jun 2012 05:32:26 -0000
@@ -33,7 +33,6 @@
:- func get_type_info(T::unused) = (type_info::out) is det.
- %
% Check if two values are equal.
% Note this is not structural equality because a type
% can have user-defined equality.
cvs diff: Diffing m4
cvs diff: Diffing mdbcomp
Index: mdbcomp/prim_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/mdbcomp/prim_data.m,v
retrieving revision 1.39
diff -u -b -r1.39 prim_data.m
--- mdbcomp/prim_data.m 27 Mar 2012 23:29:14 -0000 1.39
+++ mdbcomp/prim_data.m 7 Jun 2012 05:32:26 -0000
@@ -204,6 +204,14 @@
:- pred sym_name_get_module_name_default(sym_name::in, module_name::in,
module_name::out) is det.
+ % sym_name_get_module_name_default_name(SymName,
+ % DefaultModName, ModName, Name):
+ % Return the ModName sym_name_get_module_name_default would,
+ % and the Name unqualify_name would.
+ %
+:- pred sym_name_get_module_name_default_name(sym_name::in, module_name::in,
+ module_name::out, string::out) is det.
+
% match_sym_name(PartialSymName, CompleteSymName):
%
% Succeeds iff there is some sequence of module qualifiers
@@ -446,6 +454,15 @@
SymName = qualified(ModuleName, _)
).
+sym_name_get_module_name_default_name(SymName, DefaultModuleName, ModuleName,
+ Name) :-
+ (
+ SymName = unqualified(Name),
+ ModuleName = DefaultModuleName
+ ;
+ SymName = qualified(ModuleName, Name)
+ ).
+
% match_sym_name(PartialSymName, CompleteSymName):
%
% Succeeds iff there is some sequence of module qualifiers
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/appengine
cvs diff: Diffing samples/appengine/war
cvs diff: Diffing samples/appengine/war/WEB-INF
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/standalone_c
cvs diff: Diffing samples/concurrency
cvs diff: Diffing samples/concurrency/dining_philosophers
cvs diff: Diffing samples/concurrency/midimon
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/java_interface
cvs diff: Diffing samples/java_interface/java_calls_mercury
cvs diff: Diffing samples/java_interface/mercury_calls_java
cvs diff: Diffing samples/lazy_list
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/solver_types
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing ssdb
cvs diff: Diffing tests
cvs diff: Diffing tests/analysis
cvs diff: Diffing tests/analysis/ctgc
cvs diff: Diffing tests/analysis/excp
cvs diff: Diffing tests/analysis/ext
cvs diff: Diffing tests/analysis/sharing
cvs diff: Diffing tests/analysis/table
cvs diff: Diffing tests/analysis/trail
cvs diff: Diffing tests/analysis/unused_args
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/feedback
cvs diff: Diffing tests/feedback/mandelbrot
cvs diff: Diffing tests/feedback/mmc
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
Index: tests/invalid/any_passed_as_ground.err_exp2
===================================================================
RCS file: tests/invalid/any_passed_as_ground.err_exp2
diff -N tests/invalid/any_passed_as_ground.err_exp2
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/any_passed_as_ground.err_exp2 7 Jun 2012 05:32:26 -0000
@@ -0,0 +1,13 @@
+any_passed_as_ground.m:036: In clause for `main(di, uo)':
+any_passed_as_ground.m:036: in call to predicate `list.member'/2:
+any_passed_as_ground.m:036: mode error: arguments `TypeInfo_12, V_10, Xs'
+any_passed_as_ground.m:036: have the following insts:
+any_passed_as_ground.m:036: bound(private_builtin.type_info(bound(<type_ctor_info
+any_passed_as_ground.m:036: for pair.pair/2>), bound(<type_ctor_info for
+any_passed_as_ground.m:036: .int/0>), bound(<type_ctor_info for
+any_passed_as_ground.m:036: any_passed_as_ground.st/0>))),
+any_passed_as_ground.m:036: free,
+any_passed_as_ground.m:036: any
+any_passed_as_ground.m:036: which does not match any of the modes for
+any_passed_as_ground.m:036: predicate `list.member'/2.
+For more information, recompile with `-E'.
Index: tests/invalid/ho_default_func_1.err_exp2
===================================================================
RCS file: tests/invalid/ho_default_func_1.err_exp2
diff -N tests/invalid/ho_default_func_1.err_exp2
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ho_default_func_1.err_exp2 7 Jun 2012 05:32:26 -0000
@@ -0,0 +1,24 @@
+ho_default_func_1.m:029: In clause for `baz(in, out)':
+ho_default_func_1.m:029: mode error in conjunction. The next 2 error messages
+ho_default_func_1.m:029: indicate possible causes of this error.
+ho_default_func_1.m:029: In clause for `baz(in, out)':
+ho_default_func_1.m:029: in call to function `univ.univ'/1:
+ho_default_func_1.m:029: mode error: arguments `TypeInfo_9, V_7, V_6' have
+ho_default_func_1.m:029: the following insts:
+ho_default_func_1.m:029: bound(private_builtin.type_info(bound(<type_ctor_info
+ho_default_func_1.m:029: for .func/0>), bound(2), bound(<type_ctor_info for
+ho_default_func_1.m:029: .int/0>), bound(<type_ctor_info for .int/0>))),
+ho_default_func_1.m:029: /* unique */(func((free >> ground)) = (ground >>
+ho_default_func_1.m:029: ground) is det),
+ho_default_func_1.m:029: free
+ho_default_func_1.m:029: which does not match any of the modes for function
+ho_default_func_1.m:029: `univ.univ'/1.
+ho_default_func_1.m:029: In clause for `baz(in, out)':
+ho_default_func_1.m:029: in call to predicate `univ.univ_to_type'/2:
+ho_default_func_1.m:029: mode error: arguments `TypeInfo_for_T, V_6, Y0' have
+ho_default_func_1.m:029: the following insts:
+ho_default_func_1.m:029: ground,
+ho_default_func_1.m:029: free,
+ho_default_func_1.m:029: free
+ho_default_func_1.m:029: which does not match any of the modes for predicate
+ho_default_func_1.m:029: `univ.univ_to_type'/2.
Index: tests/invalid/ho_default_func_3.err_exp2
===================================================================
RCS file: tests/invalid/ho_default_func_3.err_exp2
diff -N tests/invalid/ho_default_func_3.err_exp2
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/ho_default_func_3.err_exp2 7 Jun 2012 05:32:26 -0000
@@ -0,0 +1,24 @@
+ho_default_func_3.m:029: In clause for `baz(in, out)':
+ho_default_func_3.m:029: mode error in conjunction. The next 2 error messages
+ho_default_func_3.m:029: indicate possible causes of this error.
+ho_default_func_3.m:029: In clause for `baz(in, out)':
+ho_default_func_3.m:029: in call to function `univ.univ'/1:
+ho_default_func_3.m:029: mode error: arguments `TypeInfo_9, V_7, V_6' have
+ho_default_func_3.m:029: the following insts:
+ho_default_func_3.m:029: bound(private_builtin.type_info(bound(<type_ctor_info
+ho_default_func_3.m:029: for .func/0>), bound(2), bound(<type_ctor_info for
+ho_default_func_3.m:029: .int/0>), bound(<type_ctor_info for .int/0>))),
+ho_default_func_3.m:029: /* unique */(func((unique >> clobbered)) = (free
+ho_default_func_3.m:029: >> unique) is det),
+ho_default_func_3.m:029: free
+ho_default_func_3.m:029: which does not match any of the modes for function
+ho_default_func_3.m:029: `univ.univ'/1.
+ho_default_func_3.m:029: In clause for `baz(in, out)':
+ho_default_func_3.m:029: in call to predicate `univ.univ_to_type'/2:
+ho_default_func_3.m:029: mode error: arguments `TypeInfo_for_T, V_6, Y0' have
+ho_default_func_3.m:029: the following insts:
+ho_default_func_3.m:029: ground,
+ho_default_func_3.m:029: free,
+ho_default_func_3.m:029: free
+ho_default_func_3.m:029: which does not match any of the modes for predicate
+ho_default_func_3.m:029: `univ.univ_to_type'/2.
Index: tests/invalid/try_detism.err_exp2
===================================================================
RCS file: tests/invalid/try_detism.err_exp2
diff -N tests/invalid/try_detism.err_exp2
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/try_detism.err_exp2 7 Jun 2012 05:32:26 -0000
@@ -0,0 +1,24 @@
+try_detism.m:008: In `p'(out, di, uo):
+try_detism.m:008: error: determinism declaration not satisfied.
+try_detism.m:008: Declared `cc_multi', inferred `cc_nondet'.
+try_detism.m:015: In argument 1 of call to predicate `try_detism.q'/3:
+try_detism.m:015: unification with `X' can fail.
+try_detism.m:019: Error: call to predicate `exception.magic_exception_result'/1
+try_detism.m:019: with determinism `cc_multi' occurs in a context which
+try_detism.m:019: requires all solutions.
+try_detism.m:015: Unification of X and V_18 can fail.
+try_detism.m:019: In clause for `p(out, di, uo)':
+try_detism.m:019: in call to predicate `exception.try_io'/4:
+try_detism.m:019: mode error: arguments
+try_detism.m:019: `TypeInfo_22, TryLambda, TryResult, STATE_VARIABLE_IO_10, TryIOOutput'
+try_detism.m:019: have the following insts:
+try_detism.m:019: bound(private_builtin.type_info(bound(<type_ctor_info for
+try_detism.m:019: .tuple/0>), bound(0))),
+try_detism.m:019: /* unique */(pred((free >> ground), (unique >>
+try_detism.m:019: clobbered), (free >> unique)) is semidet),
+try_detism.m:019: free,
+try_detism.m:019: unique,
+try_detism.m:019: free
+try_detism.m:019: which does not match any of the modes for predicate
+try_detism.m:019: `exception.try_io'/4.
+For more information, recompile with `-E'.
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