[m-dev.] for review: typeclasses in .opt files
Simon Taylor
stayl at cs.mu.OZ.AU
Thu Dec 2 12:07:01 AEDT 1999
Estimated hours taken: 15
Implement handling of typeclasses for inter-module optimization.
compiler/hlds_data.m:
compiler/*.m:
Add fields to type hlds_class_defn for use by intermod.m
- the import_status of the `:- typeclass' declaration.
- the original class interface from the `:- typeclass' declaration.
compiler/intermod.m:
Write all local typeclasses, instances, types, insts and modes to
the `.opt' file, instead of trying to work out which are needed.
The old code to do this missed some types, insts and modes
(test case tests/valid/intermod_test.m).
compiler/polymorphism.m:
Expand class method bodies for imported predicates so that
method lookups for those classes can be optimized.
compiler/hlds_pred.m:
compiler/check_typeclass.m:
compiler/higher_order.m:
compiler/hlds_out.m:
Add a marker `class_instance_method', used to identify predicates
introduced by check_typeclass.m to call the methods for each instance.
Don't export `check_typeclass__introduced_pred_name_prefix/0' -
higher_order.m now checks for a `class_instance_method' marker
instead.
compiler/dead_proc_elim.m:
Analyse all instance declarations, not just those defined in
the current module, so that declarations for imported instance
methods are not removed before method lookups have been specialized.
tests/valid/Mmakefile:
tests/valid/intermod_test.m:
tests/valid/intermod_test2.m:
Check that nested types and modes are written to the `.opt' file.
tests/valid/intermod_typeclass.m:
tests/valid/intermod_typeclass2.m:
Check that local typeclass and instance declarations are written
to the `.opt' file.
Index: compiler/base_typeclass_info.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/base_typeclass_info.m,v
retrieving revision 1.12
diff -u -u -r1.12 base_typeclass_info.m
--- base_typeclass_info.m 1999/04/30 06:19:09 1.12
+++ base_typeclass_info.m 1999/11/25 01:55:54
@@ -159,7 +159,8 @@
SuperClassRvals) :-
module_info_classes(ModuleInfo, ClassTable),
map__lookup(ClassTable, ClassId, ClassDefn),
- ClassDefn = hlds_class_defn(SuperClassConstraints, ClassVars, _, _, _),
+ ClassDefn = hlds_class_defn(_, SuperClassConstraints, ClassVars,
+ _, _, _, _),
map__from_corresponding_lists(ClassVars, InstanceTypes, VarToType),
GetRval = lambda([Constraint::in, Rval::out] is det,
(
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/check_typeclass.m,v
retrieving revision 1.28
diff -u -u -r1.28 check_typeclass.m
--- check_typeclass.m 1999/10/07 02:34:07 1.28
+++ check_typeclass.m 1999/12/01 02:57:47
@@ -55,10 +55,6 @@
io__state, io__state).
:- mode check_typeclass__check_instance_decls(in, out, out, di, uo) is det.
- % The prefix added to the class method name for the predicate
- % used to call a class method for a specific instance.
-:- func check_typeclass__introduced_pred_name_prefix = string.
-
:- implementation.
:- import_module map, list, std_util, hlds_pred, hlds_data, prog_data, require.
@@ -111,8 +107,8 @@
ClassId - InstanceDefns, ModuleInfo0, ModuleInfo) :-
map__lookup(ClassTable, ClassId, ClassDefn),
- ClassDefn = hlds_class_defn(SuperClasses, ClassVars, ClassInterface,
- ClassVarSet, _TermContext),
+ ClassDefn = hlds_class_defn(_, SuperClasses, ClassVars, _,
+ ClassInterface, ClassVarSet, _TermContext),
solutions(
lambda([PredId::out] is nondet,
(
@@ -483,7 +479,7 @@
Info0 = instance_method_info(ModuleInfo0, PredName, PredArity,
ExistQVars0, ArgTypes0, ClassContext0, ArgModes, Errors,
- ArgTypeVars0, Status, PredOrFunc),
+ ArgTypeVars0, Status0, PredOrFunc),
% Rename the instance variables apart from the class variables
varset__merge_subst(ArgTypeVars0, InstanceVarSet, ArgTypeVars1,
@@ -523,7 +519,8 @@
Cond = true,
map__init(Proofs),
- init_markers(Markers),
+ init_markers(Markers0),
+ add_marker(Markers0, class_instance_method, Markers),
module_info_globals(ModuleInfo0, Globals),
globals__lookup_string_option(Globals, aditi_user, User),
@@ -539,6 +536,12 @@
ClausesInfo0 = clauses_info(VarSet, VarTypes, VarTypes, HeadVars,
DummyClause, TI_VarMap, TCI_VarMap),
+ ( status_is_imported(Status0, yes) ->
+ Status = opt_imported
+ ;
+ Status = Status0
+ ),
+
pred_info_init(ModuleName, PredName, PredArity, ArgTypeVars,
ExistQVars, ArgTypes, Cond, Context, ClausesInfo0, Status,
Markers, none, PredOrFunc, ClassContext, Proofs, User,
@@ -636,6 +639,10 @@
PredArityString],
PredNameString),
PredName = unqualified(PredNameString).
+
+ % The prefix added to the class method name for the predicate
+ % used to call a class method for a specific instance.
+:- func check_typeclass__introduced_pred_name_prefix = string.
check_typeclass__introduced_pred_name_prefix = "Introduced_pred_for_".
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.51
diff -u -u -r1.51 dead_proc_elim.m
--- dead_proc_elim.m 1999/11/11 23:04:05 1.51
+++ dead_proc_elim.m 1999/11/29 05:06:39
@@ -117,8 +117,9 @@
module_info_base_gen_infos(ModuleInfo, BaseGenInfos),
dead_proc_elim__initialize_base_gen_infos(BaseGenInfos,
Queue2, Queue3, Needed2, Needed3),
+ module_info_classes(ModuleInfo, Classes),
module_info_instances(ModuleInfo, Instances),
- dead_proc_elim__initialize_class_methods(Instances,
+ dead_proc_elim__initialize_class_methods(Classes, Instances,
Queue3, Queue, Needed3, Needed).
% Add all normally exported procedures within the listed predicates
@@ -206,41 +207,32 @@
dead_proc_elim__initialize_base_gen_infos(BaseGenInfos,
Queue1, Queue, Needed1, Needed).
-:- pred dead_proc_elim__initialize_class_methods(instance_table,
+:- pred dead_proc_elim__initialize_class_methods(class_table, instance_table,
entity_queue, entity_queue, needed_map, needed_map).
-:- mode dead_proc_elim__initialize_class_methods(in, in, out, in, out) is det.
+:- mode dead_proc_elim__initialize_class_methods(in, in,
+ in, out, in, out) is det.
-dead_proc_elim__initialize_class_methods(Instances, Queue0, Queue,
+dead_proc_elim__initialize_class_methods(Classes, Instances, Queue0, Queue,
Needed0, Needed) :-
map__values(Instances, InstanceDefns0),
list__condense(InstanceDefns0, InstanceDefns),
- list__foldl2(get_instance_pred_procs, InstanceDefns, Queue0, Queue,
- Needed0, Needed).
+ list__foldl2(get_instance_pred_procs, InstanceDefns, Queue0, Queue1,
+ Needed0, Needed1),
+ map__values(Classes, ClassDefns),
+ list__foldl2(get_class_pred_procs, ClassDefns, Queue1, Queue,
+ Needed1, Needed).
:- pred get_instance_pred_procs(hlds_instance_defn, entity_queue, entity_queue,
needed_map, needed_map).
:- mode get_instance_pred_procs(in, in, out, in, out) is det.
get_instance_pred_procs(Instance, Queue0, Queue, Needed0, Needed) :-
- Instance = hlds_instance_defn(ImportStatus, _, _, _, _,
- PredProcIds, _, _),
- (
- % We only need the instance declarations which were
- % made in this module.
- status_defined_in_this_module(ImportStatus, yes)
- ->
- get_instance_pred_procs2(PredProcIds, Queue0, Queue,
- Needed0, Needed)
- ;
- Queue = Queue0,
- Needed = Needed0
- ).
-
-:- pred get_instance_pred_procs2(maybe(list(hlds_class_proc)),
- entity_queue, entity_queue, needed_map, needed_map).
-:- mode get_instance_pred_procs2(in, in, out, in, out) is det.
+ Instance = hlds_instance_defn(_, _, _, _, _, PredProcIds, _, _),
-get_instance_pred_procs2(PredProcIds, Queue0, Queue, Needed0, Needed) :-
+ %
+ % We need to keep the instance methods for all instances
+ % for optimization of method lookups.
+ %
(
% This should never happen
PredProcIds = no,
@@ -248,17 +240,34 @@
Needed = Needed0
;
PredProcIds = yes(Ids),
- AddHldsClassProc = lambda(
- [PredProc::in, Q0::in, Q::out, N0::in, N::out] is det,
- (
- PredProc = hlds_class_proc(PredId, ProcId),
- queue__put(Q0, proc(PredId, ProcId), Q),
- map__set(N0, proc(PredId, ProcId), no, N)
- )),
- list__foldl2(AddHldsClassProc, Ids, Queue0, Queue,
+ get_class_interface_pred_procs(Ids, Queue0, Queue,
Needed0, Needed)
).
+:- pred get_class_pred_procs(hlds_class_defn, entity_queue, entity_queue,
+ needed_map, needed_map).
+:- mode get_class_pred_procs(in, in, out, in, out) is det.
+
+get_class_pred_procs(Class, Queue0, Queue, Needed0, Needed) :-
+ Class = hlds_class_defn(_, _, _, _, Methods, _, _),
+ get_class_interface_pred_procs(Methods,
+ Queue0, Queue, Needed0, Needed).
+
+:- pred get_class_interface_pred_procs(list(hlds_class_proc),
+ entity_queue, entity_queue, needed_map, needed_map).
+:- mode get_class_interface_pred_procs(in, in, out, in, out) is det.
+
+get_class_interface_pred_procs(Ids, Queue0, Queue, Needed0, Needed) :-
+ AddHldsClassProc = lambda(
+ [PredProc::in, Q0::in, Q::out, N0::in, N::out] is det,
+ (
+ PredProc = hlds_class_proc(PredId, ProcId),
+ queue__put(Q0, proc(PredId, ProcId), Q),
+ map__set(N0, proc(PredId, ProcId), no, N)
+ )),
+ list__foldl2(AddHldsClassProc, Ids, Queue0, Queue,
+ Needed0, Needed).
+
%-----------------------------------------------------------------------------%
:- pred dead_proc_elim__examine(entity_queue, examined_set, module_info,
@@ -671,8 +680,14 @@
module_info_get_pragma_exported_procs(ModuleInfo0, PragmaExports),
dead_proc_elim__initialize_pragma_exports(PragmaExports,
Queue0, _, Needed0, Needed1),
+ %
+ % The goals for the class method procs need to be
+ % examined because they contain calls to the actual method
+ % implementations.
+ %
module_info_instances(ModuleInfo0, Instances),
- dead_proc_elim__initialize_class_methods(Instances,
+ module_info_classes(ModuleInfo0, Classes),
+ dead_proc_elim__initialize_class_methods(Classes, Instances,
Queue0, _, Needed1, Needed),
map__keys(Needed, Entities),
queue__init(Queue1),
Index: compiler/higher_order.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/higher_order.m,v
retrieving revision 1.59
diff -u -u -r1.59 higher_order.m
--- higher_order.m 1999/11/11 23:11:48 1.59
+++ higher_order.m 1999/11/26 02:31:52
@@ -39,7 +39,7 @@
:- import_module code_util, globals, make_hlds, mode_util, goal_util.
:- import_module type_util, options, prog_data, prog_out, quantification.
:- import_module mercury_to_mercury, inlining, polymorphism, prog_util.
-:- import_module special_pred, passes_aux, check_typeclass.
+:- import_module special_pred, passes_aux.
:- import_module assoc_list, bool, char, int, list, map, require, set.
:- import_module std_util, string, varset, term.
@@ -1245,15 +1245,13 @@
% Without this, user-specified specialized
% versions of class methods won't be called.
UserTypeSpec = yes,
+ pred_info_get_markers(CalledPredInfo,
+ Markers),
(
- pred_info_get_markers(CalledPredInfo,
- Markers),
check_marker(Markers, class_method)
;
- pred_info_name(CalledPredInfo,
- CalledPredName),
- string__prefix(CalledPredName,
- check_typeclass__introduced_pred_name_prefix)
+ check_marker(Markers,
+ class_instance_method)
)
;
HigherOrder = yes,
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_data.m,v
retrieving revision 1.41
diff -u -u -r1.41 hlds_data.m
--- hlds_data.m 1999/11/12 09:08:15 1.41
+++ hlds_data.m 1999/11/25 01:26:33
@@ -729,8 +729,15 @@
% Information about a single `typeclass' declaration
:- type hlds_class_defn
---> hlds_class_defn(
+ import_status,
list(class_constraint), % SuperClasses
list(tvar), % ClassVars
+ class_interface, % The interface from the
+ % original declaration,
+ % used by intermod.m to
+ % write out the interface
+ % for a local typeclass to
+ % the `.opt' file.
hlds_class_interface, % Methods
tvarset, % VarNames
prog_context % Location of declaration
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_out.m,v
retrieving revision 1.232
diff -u -u -r1.232 hlds_out.m
--- hlds_out.m 1999/11/22 05:49:34 1.232
+++ hlds_out.m 1999/12/01 04:55:14
@@ -323,8 +323,8 @@
{ error("special_pred_get_type failed!") }
)
;
- { string__prefix(Name,
- check_typeclass__introduced_pred_name_prefix) }
+ { pred_info_get_markers(PredInfo, Markers) },
+ { check_marker(Markers, class_instance_method) }
->
io__write_string("type class method implementation")
;
@@ -819,6 +819,7 @@
hlds_out__marker_name(dnf, "dnf").
hlds_out__marker_name(obsolete, "obsolete").
hlds_out__marker_name(class_method, "class_method").
+hlds_out__marker_name(class_instance_method, "class_instance_method").
hlds_out__marker_name((impure), "impure").
hlds_out__marker_name((semipure), "semipure").
hlds_out__marker_name(promised_pure, "promise_pure").
@@ -2536,8 +2537,8 @@
hlds_out__write_class_id(ClassId),
io__write_string(":\n"),
- { ClassDefn = hlds_class_defn(Constraints, Vars, Interface, VarSet,
- Context) },
+ { ClassDefn = hlds_class_defn(_, Constraints, Vars, _, Interface,
+ VarSet, Context) },
{ term__context_file(Context, FileName) },
{ term__context_line(Context, LineNumber) },
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_pred.m,v
retrieving revision 1.67
diff -u -u -r1.67 hlds_pred.m
--- hlds_pred.m 1999/11/11 23:11:52 1.67
+++ hlds_pred.m 1999/11/26 02:16:31
@@ -351,6 +351,11 @@
; class_method % Requests that this predicate be transformed
% into the appropriate call to a class method
+ ; class_instance_method
+ % This predicate was automatically
+ % generated for the implementation of
+ % a class method for an instance.
+
; (impure) % Requests that no transformation that would
% be inappropriate for impure code be
% performed on calls to this predicate. This
Index: compiler/intermod.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/intermod.m,v
retrieving revision 1.75
diff -u -u -r1.75 intermod.m
--- intermod.m 1999/11/14 02:27:20 1.75
+++ intermod.m 1999/12/02 00:22:44
@@ -88,7 +88,7 @@
:- import_module code_util, globals, goal_util, term, varset.
:- import_module hlds_data, hlds_goal, hlds_pred, hlds_out, inlining, llds.
:- import_module mercury_to_mercury, mode_util, modules.
-:- import_module options, passes_aux, prog_out, prog_util.
+:- import_module options, passes_aux, prog_data, prog_io, prog_out, prog_util.
:- import_module special_pred, typecheck, type_util, instmap, (inst).
%-----------------------------------------------------------------------------%
@@ -126,21 +126,11 @@
{ intermod__gather_preds(PredIds, yes, Threshold,
HigherOrderSizeLimit, Deforestation,
IntermodInfo0, IntermodInfo1) },
- { intermod__gather_abstract_exported_types(IntermodInfo1,
- IntermodInfo2) },
- { intermod_info_get_pred_decls(PredDeclsSet,
- IntermodInfo2, IntermodInfo3) },
- { intermod_info_get_module_info(ModuleInfo1,
- IntermodInfo3, IntermodInfo4) },
- { module_info_insts(ModuleInfo1, Insts) },
- { inst_table_get_user_insts(Insts, UserInsts) },
- { user_inst_table_get_inst_defns(UserInsts, InstDefns) },
- { module_info_modes(ModuleInfo1, Modes) },
- { mode_table_get_mode_defns(Modes, ModeDefns) },
- { set__to_sorted_list(PredDeclsSet, PredDecls) },
- { intermod__gather_modes(ModuleInfo1, ModeDefns, InstDefns,
- PredDecls, IntermodInfo4, IntermodInfo) },
+ { intermod__gather_instances(IntermodInfo1,
+ IntermodInfo) },
intermod__write_intermod_info(IntermodInfo),
+ { intermod_info_get_module_info(ModuleInfo1,
+ IntermodInfo, _) },
io__told,
globals__io_lookup_bool_option(intermod_unused_args,
UnusedArgs),
@@ -158,9 +148,11 @@
set(module_name), % modules to import
set(pred_id), % preds to output clauses for
set(pred_id), % preds to output decls for
- set(type_id), % local types to export
- set(mode_id), % local modes to export
- set(inst_id), % local insts to export
+ list(pair(class_id, hlds_instance_defn)),
+ % instances declarations
+ % to write
+ unit,
+ unit,
module_info,
bool, % do the c_header_codes for
% the module need writing, yes if there
@@ -175,13 +167,11 @@
set__init(Modules),
set__init(Procs),
set__init(ProcDecls),
- set__init(Types),
- set__init(Insts),
- set__init(Modes),
map__init(VarTypes),
varset__init(TVarSet),
- IntermodInfo = info(Modules, Procs, ProcDecls, Types, Modes,
- Insts, ModuleInfo, no, VarTypes, TVarSet).
+ Instances = [],
+ IntermodInfo = info(Modules, Procs, ProcDecls, Instances, unit,
+ unit, ModuleInfo, no, VarTypes, TVarSet).
%-----------------------------------------------------------------------------%
% Predicates to gather stuff to output to .opt file.
@@ -229,14 +219,6 @@
),
{ set__insert(Preds0, PredId, Preds) },
intermod_info_set_preds(Preds),
- ( { CollectTypes = yes } ->
- { module_info_types(ModuleInfo, TypeTable) },
- { map__values(VarTypes, Types) },
- intermod__gather_types(ModuleInfo,
- TypeTable, Types)
- ;
- []
- ),
intermod_info_set_module_info(ModuleInfo)
;
% Remove any items added for the clauses
@@ -260,7 +242,7 @@
%
% note: we can't include exported_to_submodules predicates in
% the `.opt' file, for reasons explained in the comments for
- % intermod_info_add_proc
+ % intermod__add_proc
%
pred_info_is_exported(PredInfo),
(
@@ -277,6 +259,14 @@
% size thresholds.
pred_info_arity(PredInfo, Arity),
+ % Predicates with `class_method' markers contain
+ % class_method_call goals which can't be written
+ % to `.opt' files (they can't be read back in).
+ % They will be recreated in the importing module.
+ pred_info_get_markers(PredInfo, Markers),
+ \+ check_marker(Markers, class_method),
+ \+ check_marker(Markers, class_instance_method),
+
% Don't export builtins since they will be
% recreated in the importing module anyway.
\+ code_util__compiler_generated(PredInfo),
@@ -395,72 +385,6 @@
),
goal_contains_one_branched_goal(Goals, FoundBranch).
- % Add all local types used in a type to the intermod info.
- % It may be sufficient (and much more efficient! to just export
- % the definitions of all local types).
-:- pred intermod__gather_types(module_info::in, type_table::in, list(type)::in,
- intermod_info::in, intermod_info::out) is det.
-
-intermod__gather_types(_ModuleInfo, _TypeTable, []) --> [].
-intermod__gather_types(ModuleInfo, TypeTable, [TypeToCheck | TypesToCheck]) -->
- (
- { type_to_type_id(TypeToCheck, TypeId, ArgTypes) },
- { map__search(TypeTable, TypeId, TypeDefn) }
- ->
- { hlds_data__get_type_defn_status(TypeDefn, Status) },
- ( { status_is_imported(Status, yes) } ->
- { type_util__type_id_module(ModuleInfo,
- TypeId, Module) },
- intermod_info_get_modules(Modules0),
- { set__insert(Modules0, Module, Modules) },
- intermod_info_set_modules(Modules)
- ; { Status = local ; Status = abstract_exported } ->
- intermod_info_get_types(TypesToExport0),
- { set__insert(TypesToExport0, TypeId,
- TypesToExport) },
- intermod_info_set_types(TypesToExport)
- ;
- []
- ),
- intermod__gather_types(ModuleInfo, TypeTable, ArgTypes)
- ;
- []
- ),
- intermod__gather_types(ModuleInfo, TypeTable, TypesToCheck).
-
- % All equivalence types that only have a :- type foo. in the
- % interface section need to be exported in full. All other
- % types of type will be exported by intermod__gather_types.
-:- pred intermod__gather_abstract_exported_types(intermod_info::in,
- intermod_info::out) is det.
-
-intermod__gather_abstract_exported_types -->
- intermod_info_get_module_info(ModuleInfo),
- { module_info_types(ModuleInfo, Types) },
- { map__to_assoc_list(Types, TypeList) },
- { AddAbstractEquivType =
- lambda([TypeAndDefn::in, Info0::in, Info::out] is det, (
- TypeAndDefn = TypeId - TypeDefn,
- hlds_data__get_type_defn_status(TypeDefn, Status),
- hlds_data__get_type_defn_body(TypeDefn, Body),
- (
- Body = eqv_type(EqvType),
- Status = abstract_exported
- ->
- intermod__gather_types(ModuleInfo, Types,
- [EqvType], Info0, Info1),
- intermod_info_get_types(TypesToExport0,
- Info1, Info2),
- set__insert(TypesToExport0, TypeId,
- TypesToExport),
- intermod_info_set_types(TypesToExport,
- Info2, Info)
- ;
- Info = Info0
- )
- )) },
- list__foldl(AddAbstractEquivType, TypeList).
-
% Go over the goal of an exported proc looking for proc decls, types,
% insts and modes that we need to write to the optfile.
:- pred intermod__traverse_goal(hlds_goal::in, hlds_goal::out, bool::out,
@@ -503,7 +427,7 @@
%
% Ensure that the called predicate will be exported.
%
- intermod_info_add_proc(PredId, DoWrite).
+ intermod__add_proc(PredId, DoWrite).
intermod__traverse_goal(generic_call(A,B,C,D) - Info,
generic_call(A,B,C,D) - Info, yes) --> [].
@@ -570,7 +494,7 @@
).
%
- % intermod_info_add_proc/4 tries to do what ever is necessary to
+ % intermod__add_proc/4 tries to do what ever is necessary to
% ensure that the specified predicate will be exported,
% so that it can be called from clauses in the `.opt' file.
% If it can't, then it returns DoWrite = no, which will
@@ -582,10 +506,10 @@
% module, we need to include an `:- import_module' declaration
% to import that module in the `.opt' file.
%
-:- pred intermod_info_add_proc(pred_id::in, bool::out,
+:- pred intermod__add_proc(pred_id::in, bool::out,
intermod_info::in, intermod_info::out) is det.
-intermod_info_add_proc(PredId, DoWrite) -->
+intermod__add_proc(PredId, DoWrite) -->
intermod_info_get_module_info(ModuleInfo),
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
{ pred_info_import_status(PredInfo, Status) },
@@ -665,6 +589,26 @@
{ DoWrite = no }
;
%
+ % If a pred whose code we're going to put in the .opt file
+ % calls a predicate which is exported, then we don't
+ % need to do anything special.
+ %
+ { Status = exported }
+ ->
+ { DoWrite = yes }
+ ;
+ %
+ % Declarations for class methods will be recreated
+ % from the class declaration in the `.opt' file.
+ % Declarations for local classes are always written
+ % to the `.opt' file.
+ %
+ { pred_info_get_markers(PredInfo, Markers) },
+ { check_marker(Markers, class_method) }
+ ->
+ { DoWrite = yes }
+ ;
+ %
% If a pred whose code we're going to put in the `.opt' file
% calls a predicate which is local to that module, then
% we need to put the declaration for the called predicate
@@ -707,16 +651,7 @@
intermod_info_set_modules(Modules)
)
;
- %
- % if a pred whose code we're going to put in the .opt file
- % calls a predicate which is exported, then we don't
- % need to do anything special
- %
- { Status = exported }
- ->
- { DoWrite = yes }
- ;
- { error("intermod_info_add_proc: unexpected status") }
+ { error("intermod__add_proc: unexpected status") }
).
% Resolve overloading and module qualify everything in a unify_rhs.
@@ -738,15 +673,7 @@
{ DoWrite = no },
{ Goal = Goal0 }
;
- intermod__traverse_goal(Goal0, Goal, DoWrite),
- intermod_info_get_module_info(ModuleInfo),
- { module_info_modes(ModuleInfo, ModeTable) },
- { mode_table_get_mode_defns(ModeTable, ModeDefns) },
- { module_info_insts(ModuleInfo, Insts) },
- { inst_table_get_user_insts(Insts, UserInsts) },
- { user_inst_table_get_inst_defns(UserInsts, UserInstDefns) },
- intermod__gather_proc_modes(ModuleInfo, ModeDefns,
- UserInstDefns, Modes)
+ intermod__traverse_goal(Goal0, Goal, DoWrite)
).
% Fully module-qualify the right-hand-side of a unification.
@@ -789,7 +716,7 @@
% Make sure that the called function will be exported.
%
{ Functor = cons(QualifiedFuncName, Arity) },
- intermod_info_add_proc(PredId, DoWrite)
+ intermod__add_proc(PredId, DoWrite)
;
%
% Is this a higher-order predicate or higher-order function
@@ -820,7 +747,7 @@
{ get_pred_id_and_proc_id(PredName, PredOrFunc,
TVarSet, ArgTypes, ModuleInfo,
PredId, _ProcId) },
- intermod_info_add_proc(PredId, DoWrite),
+ intermod__add_proc(PredId, DoWrite),
%
% Fully module-qualify it.
%
@@ -855,110 +782,147 @@
).
%-----------------------------------------------------------------------------%
- % Gather all the user defined modes and insts used by all the
- % local predicates we are exporting.
-:- pred intermod__gather_modes(module_info::in, mode_defns::in,
- user_inst_defns::in, list(pred_id)::in,
- intermod_info::in, intermod_info::out) is det.
-intermod__gather_modes(_, _, _, []) --> [].
-intermod__gather_modes(ModuleInfo, Modes, Insts, [PredId | PredIds]) -->
- { module_info_pred_info(ModuleInfo, PredId, PredInfo) },
- { pred_info_procids(PredInfo, ProcIds) },
- { pred_info_procedures(PredInfo, Procs) },
- intermod__gather_pred_modes(ModuleInfo, Modes, Insts, Procs, ProcIds),
- intermod__gather_modes(ModuleInfo, Modes, Insts, PredIds).
+:- pred intermod__gather_instances(intermod_info::in,
+ intermod_info::out) is det.
-:- pred intermod__gather_pred_modes(module_info::in, mode_defns::in,
- user_inst_defns::in, proc_table::in, list(proc_id)::in,
- intermod_info::in, intermod_info::out) is det.
+intermod__gather_instances -->
+ intermod_info_get_module_info(ModuleInfo),
+ { module_info_instances(ModuleInfo, Instances) },
+ map__foldl(intermod__gather_instances_2(ModuleInfo), Instances).
-intermod__gather_pred_modes(_, _, _, _, []) --> [].
-intermod__gather_pred_modes(ModuleInfo, Modes, Insts, Procs, [ProcId | ProcIds])
- -->
- { map__lookup(Procs, ProcId, ProcInfo) },
- { proc_info_declared_argmodes(ProcInfo, ArgModes) },
- intermod__gather_proc_modes(ModuleInfo, Modes, Insts, ArgModes),
- intermod__gather_pred_modes(ModuleInfo, Modes, Insts, Procs, ProcIds).
-
- % Get the modes from pred and func declarations.
-:- pred intermod__gather_proc_modes(module_info::in, mode_defns::in,
- user_inst_defns::in, list(mode)::in,
+:- pred intermod__gather_instances_2(module_info::in, class_id::in,
+ list(hlds_instance_defn)::in,
intermod_info::in, intermod_info::out) is det.
+
+intermod__gather_instances_2(ModuleInfo, ClassId, InstanceDefns) -->
+ list__foldl(intermod__gather_instances_3(ModuleInfo, ClassId),
+ InstanceDefns).
+
+:- pred intermod__gather_instances_3(module_info::in, class_id::in,
+ hlds_instance_defn::in, intermod_info::in, intermod_info::out) is det.
+
+intermod__gather_instances_3(ModuleInfo, ClassId, InstanceDefn) -->
+ { InstanceDefn = hlds_instance_defn(Status, B, C, D, Interface0,
+ MaybePredProcIds, F, G) },
+ (
+ %
+ % The bodies are always stripped from instance declarations
+ % before writing them to `int' files, so the full instance
+ % declaration should be written even for exported instances.
+ %
+ { status_defined_in_this_module(Status, yes) },
-intermod__gather_proc_modes(_, _, _, []) --> [].
-intermod__gather_proc_modes(ModuleInfo, ModeTable,
- UserInstTable, [Mode | Modes]) -->
- { mode_get_insts(ModuleInfo, Mode, Inst1, Inst2) },
- intermod__gather_insts(UserInstTable, [Inst1, Inst2]),
- ( { Mode = user_defined_mode(Name, Args) } ->
- intermod__gather_insts(UserInstTable, Args),
- { list__length(Args, Arity) },
- { ModeId = Name - Arity },
- { map__lookup(ModeTable, ModeId, ModeDefn) },
- { ModeDefn = hlds_mode_defn(_,_,_,_,_, Status) },
- ( { Status = local } ->
- intermod_info_get_modes(ModesToExport0),
- { set__insert(ModesToExport0, ModeId,
- ModesToExport) },
- intermod_info_set_modes(ModesToExport)
- ; { Status = imported(_) } ->
+ %
+ % See the comments on intermod__add_proc.
+ %
+ { Status \= exported_to_submodules }
+ ->
+ =(IntermodInfo0),
+ (
+ { Interface0 = concrete(Methods0) },
+ { MaybePredProcIds = yes(PredProcIds) ->
+ assoc_list__from_corresponding_lists(
+ PredProcIds, Methods0,
+ MethodAL0)
+ ;
+ error(
+ "intermod__gather_instances_3: method pred_proc_ids not filled in")
+ },
+ { list__map(
+ intermod__qualify_instance_method(ModuleInfo),
+ MethodAL0, MethodAL) },
+ { assoc_list__keys(MethodAL, PredIds) },
+ { assoc_list__values(MethodAL, Methods) },
+ list__map_foldl(intermod__add_proc,
+ PredIds, DoWriteMethodsList),
+ { bool__and_list(DoWriteMethodsList, DoWriteMethods) },
(
- { Name = qualified(Module, _) },
- intermod_info_get_modules(Modules0),
- { set__insert(Modules0, Module, Modules) },
- intermod_info_set_modules(Modules)
+ { DoWriteMethods = yes },
+ { Interface = concrete(Methods) }
;
- { Name = unqualified(_) }
+ { DoWriteMethods = no },
+
+ %
+ % Write an abstract instance declaration
+ % if any of the methods cannot be written
+ % to the `.opt' file for any reason.
+ %
+ { Interface = abstract },
+
+ %
+ % Don't write declarations for any of the
+ % methods if one can't be written.
+ %
+ dcg_set(IntermodInfo0)
)
;
+ { Interface0 = abstract },
+ { Interface = Interface0 }
+ ),
+ (
+ %
+ % Don't write an abstract instance declaration
+ % if the declaration is already in the `.int' file.
+ %
+ {
+ Interface = abstract
+ =>
+ status_is_exported(Status, no)
+ }
+ ->
+ { InstanceDefnToWrite = hlds_instance_defn(Status,
+ B, C, D, Interface, MaybePredProcIds,
+ F, G) },
+ intermod_info_get_instances(Instances0),
+ intermod_info_set_instances(
+ [ClassId - InstanceDefnToWrite | Instances0])
+ ;
[]
)
;
[]
- ),
- intermod__gather_proc_modes(ModuleInfo, ModeTable,
- UserInstTable, Modes).
-
-:- pred intermod__gather_insts(user_inst_defns::in, list((inst))::in,
- intermod_info::in, intermod_info::out) is det.
-
-intermod__gather_insts(_, []) --> [].
-intermod__gather_insts(UserInstTable, [Inst | Insts]) -->
- intermod__add_inst(UserInstTable, Inst),
- intermod__gather_insts(UserInstTable, Insts).
-
-:- pred intermod__add_inst(user_inst_defns::in, (inst)::in,
- intermod_info::in, intermod_info::out) is det.
+ ).
-intermod__add_inst(UserInstTable, Inst) -->
+ % Resolve overloading of instance methods before writing them
+ % to the `.opt' file.
+:- pred intermod__qualify_instance_method(module_info::in,
+ pair(hlds_class_proc, instance_method)::in,
+ pair(pred_id, instance_method)::out) is det.
+
+intermod__qualify_instance_method(ModuleInfo, ClassProcId - InstanceMethod0,
+ PredId - InstanceMethod) :-
+ ClassProcId = hlds_class_proc(MethodCallPredId, _),
+ module_info_pred_info(ModuleInfo, MethodCallPredId,
+ MethodCallPredInfo),
+ pred_info_arg_types(MethodCallPredInfo, MethodCallTVarSet, _,
+ MethodCallArgTypes),
(
- { Inst = defined_inst(InstName) },
- { InstName = user_inst(Name, InstArgs) }
- ->
- intermod__gather_insts(UserInstTable, InstArgs),
- { list__length(InstArgs, Arity) },
- { InstId = Name - Arity },
- { map__lookup(UserInstTable, InstId, InstDefn) },
- { InstDefn = hlds_inst_defn(_,_,_,_,_, Status) },
- ( { Status = local } ->
- intermod_info_get_insts(InstsToExport0),
- { set__insert(InstsToExport0, InstId,
- InstsToExport) },
- intermod_info_set_insts(InstsToExport)
- ; { Status = imported(_) } ->
- ( { Name = qualified(Module, _) } ->
- intermod_info_get_modules(Modules0),
- { set__insert(Modules0, Module, Modules) },
- intermod_info_set_modules(Modules)
- ;
- { error("unqualified imported inst") }
- )
+ InstanceMethod0 = func_instance(MethodName,
+ InstanceMethodName0, MethodArity, MethodContext),
+ module_info_get_predicate_table(ModuleInfo, PredicateTable),
+ (
+ predicate_table_search_func_sym_arity(PredicateTable,
+ InstanceMethodName0, MethodArity, PredIds),
+ typecheck__find_matching_pred_id(PredIds, ModuleInfo,
+ MethodCallTVarSet, MethodCallArgTypes,
+ PredId0, InstanceMethodName)
+ ->
+ PredId = PredId0,
+ InstanceMethod = func_instance(MethodName,
+ InstanceMethodName, MethodArity, MethodContext)
;
- []
+ error(
+ "intermod__qualify_instance_method: undefined function")
)
;
- []
+ InstanceMethod0 = pred_instance(MethodName,
+ InstanceMethodName0, MethodArity, MethodContext),
+ typecheck__resolve_pred_overloading(ModuleInfo,
+ MethodCallArgTypes, MethodCallTVarSet,
+ InstanceMethodName0, InstanceMethodName, PredId),
+ InstanceMethod = pred_instance(MethodName,
+ InstanceMethodName, MethodArity, MethodContext)
).
%-----------------------------------------------------------------------------%
@@ -967,25 +931,66 @@
:- pred intermod__write_intermod_info(intermod_info::in,
io__state::di, io__state::uo) is det.
-intermod__write_intermod_info(IntermodInfo) -->
- { IntermodInfo = info(Modules0, Preds0, PredDecls0, Types0,
- Modes0, Insts0, ModuleInfo, WriteHeader, _, _) },
- { set__to_sorted_list(Modules0, Modules) },
- { set__to_sorted_list(Preds0, Preds) },
- { set__to_sorted_list(PredDecls0, PredDecls) },
- { set__to_sorted_list(Types0, Types) },
- { set__to_sorted_list(Modes0, Modes) },
- { set__to_sorted_list(Insts0, Insts) },
- { module_info_name(ModuleInfo, ModName) },
+intermod__write_intermod_info(IntermodInfo0) -->
+ { intermod_info_get_module_info(ModuleInfo,
+ IntermodInfo0, IntermodInfo1) },
+ { module_info_name(ModuleInfo, ModuleName) },
io__write_string(":- module "),
- mercury_output_bracketed_sym_name(ModName),
+ mercury_output_bracketed_sym_name(ModuleName),
io__write_string(".\n"),
+
+ { intermod_info_get_preds(Preds, IntermodInfo1, IntermodInfo2) },
+ { intermod_info_get_pred_decls(PredDecls,
+ IntermodInfo2, IntermodInfo3) },
+ { intermod_info_get_instances(Instances,
+ IntermodInfo3, IntermodInfo) },
+ (
+ %
+ % If none of these item types need writing, nothing
+ % else needs to be written.
+ %
+ { set__empty(Preds) },
+ { set__empty(PredDecls) },
+ { Instances = [] },
+ { module_info_types(ModuleInfo, Types) },
+ \+ {
+ map__member(Types, _, TypeDefn),
+ hlds_data__get_type_defn_status(TypeDefn, Status),
+ Status = abstract_exported
+ }
+ ->
+ []
+ ;
+ intermod__write_intermod_info_2(IntermodInfo)
+ ).
+
+:- pred intermod__write_intermod_info_2(intermod_info::in, io__state::di,
+ io__state::uo) is det.
+
+intermod__write_intermod_info_2(IntermodInfo) -->
+ { IntermodInfo = info(_, Preds0, PredDecls0, Instances, _, _,
+ ModuleInfo, WriteHeader, _, _) },
+ { set__to_sorted_list(Preds0, Preds) },
+ { set__to_sorted_list(PredDecls0, PredDecls) },
+
+
+ { module_info_get_imported_module_specifiers(ModuleInfo, Modules0) },
+ { set__to_sorted_list(Modules0, Modules) },
( { Modules \= [] } ->
+ % XXX this could be reduced to the set that is
+ % actually needed by the items being written.
io__write_string(":- use_module "),
intermod__write_modules(Modules)
;
[]
),
+
+ intermod__write_types(ModuleInfo),
+ intermod__write_insts(ModuleInfo),
+ intermod__write_modes(ModuleInfo),
+ intermod__write_classes(ModuleInfo),
+ intermod__write_instances(Instances),
+
% Disable verbose dumping of clauses.
globals__io_lookup_string_option(dump_hlds_options, VerboseDump),
globals__io_set_option(dump_hlds_options, string("")),
@@ -995,15 +1000,6 @@
;
[]
),
- { module_info_types(ModuleInfo, TypeTable) },
- intermod__write_types(ModuleInfo, TypeTable, Types),
- { module_info_modes(ModuleInfo, ModeTable) },
- { mode_table_get_mode_defns(ModeTable, ModeDefns) },
- intermod__write_modes(ModuleInfo, ModeDefns, Modes),
- { module_info_insts(ModuleInfo, InstTable) },
- { inst_table_get_user_insts(InstTable, UserInstTable) },
- { user_inst_table_get_inst_defns(UserInstTable, InstDefns) },
- intermod__write_insts(ModuleInfo, InstDefns, Insts),
intermod__write_pred_decls(ModuleInfo, PredDecls),
intermod__write_preds(ModuleInfo, Preds),
globals__io_set_option(dump_hlds_options, string(VerboseDump)).
@@ -1031,77 +1027,164 @@
intermod__write_c_header(Headers),
mercury_output_pragma_c_header(Header).
-:- pred intermod__write_types(module_info::in, type_table::in,
- list(type_id)::in, io__state::di, io__state::uo) is det.
+:- pred intermod__write_types(module_info::in,
+ io__state::di, io__state::uo) is det.
-intermod__write_types(_, _, []) --> [].
-intermod__write_types(ModuleInfo, TypeTable, [TypeId | TypeIds]) -->
+intermod__write_types(ModuleInfo) -->
+ { module_info_name(ModuleInfo, ModuleName) },
+ { module_info_types(ModuleInfo, Types) },
+ map__foldl(intermod__write_type(ModuleName), Types).
+
+:- pred intermod__write_type(module_name::in, type_id::in,
+ hlds_type_defn::in, io__state::di, io__state::uo) is det.
+
+intermod__write_type(ModuleName, TypeId, TypeDefn) -->
+ { hlds_data__get_type_defn_status(TypeDefn, ImportStatus) },
{ TypeId = Name - _Arity },
- { map__lookup(TypeTable, TypeId, TypeDefn) },
- { hlds_data__get_type_defn_tvarset(TypeDefn, VarSet) },
- { hlds_data__get_type_defn_tparams(TypeDefn, Args) },
- { hlds_data__get_type_defn_body(TypeDefn, Body) },
- { hlds_data__get_type_defn_context(TypeDefn, Context) },
- (
- { Body = du_type(Ctors, _, _, MaybeEqualityPred) },
- mercury_output_type_defn(VarSet,
- du_type(Name, Args, Ctors, MaybeEqualityPred),
+ (
+ { Name = qualified(ModuleName, _) },
+ { ImportStatus = local
+ ; ImportStatus = abstract_exported
+ }
+ ->
+ { hlds_data__get_type_defn_tvarset(TypeDefn, VarSet) },
+ { hlds_data__get_type_defn_tparams(TypeDefn, Args) },
+ { hlds_data__get_type_defn_body(TypeDefn, Body) },
+ { hlds_data__get_type_defn_context(TypeDefn, Context) },
+ (
+ { Body = du_type(Ctors, _, _, MaybeEqualityPred) },
+ mercury_output_type_defn(VarSet,
+ du_type(Name, Args, Ctors,
+ MaybeEqualityPred),
Context)
- ;
- { Body = uu_type(_) },
- { error("uu types not implemented") }
- ;
- { Body = eqv_type(EqvType) },
- mercury_output_type_defn(VarSet,
+ ;
+ { Body = uu_type(_) },
+ { error("uu types not implemented") }
+ ;
+ { Body = eqv_type(EqvType) },
+ mercury_output_type_defn(VarSet,
eqv_type(Name, Args, EqvType), Context)
+ ;
+ { Body = abstract_type },
+ mercury_output_type_defn(VarSet,
+ abstract_type(Name, Args), Context)
+ )
;
- { Body = abstract_type },
- mercury_output_type_defn(VarSet, abstract_type(Name, Args),
- Context)
- ),
- intermod__write_types(ModuleInfo, TypeTable, TypeIds).
+ []
+ ).
-:- pred intermod__write_modes(module_info::in, mode_defns::in,
- list(mode_id)::in, io__state::di, io__state::uo) is det.
+:- pred intermod__write_modes(module_info::in,
+ io__state::di, io__state::uo) is det.
+
+intermod__write_modes(ModuleInfo) -->
+ { module_info_name(ModuleInfo, ModuleName) },
+ { module_info_modes(ModuleInfo, Modes) },
+ { mode_table_get_mode_defns(Modes, ModeDefns) },
+ map__foldl(intermod__write_mode(ModuleName), ModeDefns).
-intermod__write_modes(_, _, []) --> [].
-intermod__write_modes(ModuleInfo, ModeTable, [ModeId | Modes]) -->
+:- pred intermod__write_mode(module_name::in, mode_id::in, hlds_mode_defn::in,
+ io__state::di, io__state::uo) is det.
+
+intermod__write_mode(ModuleName, ModeId, ModeDefn) -->
{ ModeId = SymName - _Arity },
- { map__lookup(ModeTable, ModeId, ModeDefn) },
{ ModeDefn = hlds_mode_defn(Varset, Args, eqv_mode(Mode),
- _, Context, _) },
- mercury_output_mode_defn(
+ _, Context, ImportStatus) },
+ (
+ { SymName = qualified(ModuleName, _) },
+ { ImportStatus = local }
+ ->
+ mercury_output_mode_defn(
Varset,
eqv_mode(SymName, Args, Mode),
Context
- ),
- intermod__write_modes(ModuleInfo, ModeTable, Modes).
+ )
+ ;
+ []
+ ).
+
+:- pred intermod__write_insts(module_info::in,
+ io__state::di, io__state::uo) is det.
-:- pred intermod__write_insts(module_info::in, user_inst_defns::in,
- list(inst_id)::in, io__state::di, io__state::uo) is det.
+intermod__write_insts(ModuleInfo) -->
+ { module_info_name(ModuleInfo, ModuleName) },
+ { module_info_insts(ModuleInfo, Insts) },
+ { inst_table_get_user_insts(Insts, UserInsts) },
+ { user_inst_table_get_inst_defns(UserInsts, InstDefns) },
+ map__foldl(intermod__write_inst(ModuleName), InstDefns).
-intermod__write_insts(_, _, []) --> [].
-intermod__write_insts(ModuleInfo, UserInstTable, [Inst | Insts]) -->
- { Inst = SymName - _Arity },
- { map__lookup(UserInstTable, Inst, InstDefn) },
- { InstDefn = hlds_inst_defn(Varset, Args, Body, _, Context, _) },
- (
- { Body = eqv_inst(Inst2) },
- mercury_output_inst_defn(
- Varset,
- eqv_inst(SymName, Args, Inst2),
- Context
+:- pred intermod__write_inst(module_name::in, inst_id::in, hlds_inst_defn::in,
+ io__state::di, io__state::uo) is det.
+
+intermod__write_inst(ModuleName, InstId, InstDefn) -->
+ { InstId = SymName - _Arity },
+ { InstDefn = hlds_inst_defn(Varset, Args, Body, _,
+ Context, ImportStatus) },
+ (
+ { SymName = qualified(ModuleName, _) },
+ { ImportStatus = local }
+ ->
+ (
+ { Body = eqv_inst(Inst2) },
+ mercury_output_inst_defn(
+ Varset,
+ eqv_inst(SymName, Args, Inst2),
+ Context
+ )
+ ;
+ { Body = abstract_inst },
+ mercury_output_inst_defn(
+ Varset,
+ abstract_inst(SymName, Args),
+ Context
+ )
)
;
- { Body = abstract_inst },
- mercury_output_inst_defn(
- Varset,
- abstract_inst(SymName, Args),
- Context
- )
- ),
- intermod__write_insts(ModuleInfo, UserInstTable, Insts).
+ []
+ ).
+:- pred intermod__write_classes(module_info::in,
+ io__state::di, io__state::uo) is det.
+
+intermod__write_classes(ModuleInfo) -->
+ { module_info_name(ModuleInfo, ModuleName) },
+ { module_info_classes(ModuleInfo, Classes) },
+ map__foldl(intermod__write_class(ModuleName), Classes).
+
+:- pred intermod__write_class(module_name::in, class_id::in,
+ hlds_class_defn::in, io__state::di, io__state::uo) is det.
+
+intermod__write_class(ModuleName, ClassId, ClassDefn) -->
+ { ClassDefn = hlds_class_defn(ImportStatus, Constraints,
+ TVars, Interface, _HLDSClassInterface,
+ TVarSet, Context) },
+ { ClassId = class_id(QualifiedClassName, _) },
+ (
+ { QualifiedClassName = qualified(ModuleName, _) },
+ { ImportStatus = local }
+ ->
+ { Item = typeclass(Constraints, QualifiedClassName, TVars,
+ Interface, TVarSet) },
+ mercury_output_item(Item, Context)
+ ;
+ []
+ ).
+
+:- pred intermod__write_instances(assoc_list(class_id, hlds_instance_defn)::in,
+ io__state::di, io__state::uo) is det.
+
+intermod__write_instances(Instances) -->
+ list__foldl(intermod__write_instance, Instances).
+
+:- pred intermod__write_instance(pair(class_id, hlds_instance_defn)::in,
+ io__state::di, io__state::uo) is det.
+
+intermod__write_instance(ClassId - InstanceDefn) -->
+ { InstanceDefn = hlds_instance_defn(_, Context, Constraints,
+ Types, Body, _, TVarSet, _) },
+ { ClassId = class_id(ClassName, _) },
+ { Item = instance(Constraints, ClassName, Types, Body, TVarSet) },
+ mercury_output_item(Item, Context).
+
% We need to write all the declarations for local predicates so
% the procedure labels for the C code are calculated correctly.
:- pred intermod__write_pred_decls(module_info::in, list(pred_id)::in,
@@ -1376,6 +1459,7 @@
intermod__should_output_marker((semipure), no).
% There is no pragma required for generated class methods.
intermod__should_output_marker(class_method, no).
+intermod__should_output_marker(class_instance_method, no).
% The warning for calls to local obsolete predicates should appear
% once in the defining module, not in importing modules.
intermod__should_output_marker(obsolete, no).
@@ -1502,13 +1586,14 @@
:- pred intermod_info_get_preds(set(pred_id)::out,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_get_pred_decls(set(pred_id)::out,
- intermod_info::in, intermod_info::out) is det.
-:- pred intermod_info_get_types(set(type_id)::out,
- intermod_info::in, intermod_info::out) is det.
-:- pred intermod_info_get_modes(set(mode_id)::out,
intermod_info::in, intermod_info::out) is det.
-:- pred intermod_info_get_insts(set(inst_id)::out,
+:- pred intermod_info_get_instances(
+ assoc_list(class_id, hlds_instance_defn)::out,
intermod_info::in, intermod_info::out) is det.
+%:- pred intermod_info_get_modes(set(mode_id)::out,
+% intermod_info::in, intermod_info::out) is det.
+%:- pred intermod_info_get_insts(set(inst_id)::out,
+% intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_get_module_info(module_info::out,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_get_write_c_header(bool::out,
@@ -1522,9 +1607,10 @@
intermod_info_get_preds(Procs) --> =(info(_,Procs,_,_,_,_,_,_,_,_)).
intermod_info_get_pred_decls(ProcDecls) -->
=(info(_,_,ProcDecls,_,_,_,_,_,_,_)).
-intermod_info_get_types(Types) --> =(info(_,_,_,Types,_,_,_,_,_,_)).
-intermod_info_get_modes(Modes) --> =(info(_,_,_,_,Modes,_,_,_,_,_)).
-intermod_info_get_insts(Insts) --> =(info(_,_,_,_,_,Insts,_,_,_,_)).
+intermod_info_get_instances(Instances) -->
+ =(info(_,_,_,Instances,_,_,_,_,_,_)).
+%intermod_info_get_modes(Modes) --> =(info(_,_,_,_,Modes,_,_,_,_,_)).
+%intermod_info_get_insts(Insts) --> =(info(_,_,_,_,_,Insts,_,_,_,_)).
intermod_info_get_module_info(Module) --> =(info(_,_,_,_,_,_,Module,_,_,_)).
intermod_info_get_write_c_header(Write) --> =(info(_,_,_,_,_,_,_,Write,_,_)).
intermod_info_get_var_types(VarTypes) --> =(info(_,_,_,_,_,_,_,_,VarTypes,_)).
@@ -1536,12 +1622,13 @@
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_pred_decls(set(pred_id)::in,
intermod_info::in, intermod_info::out) is det.
-:- pred intermod_info_set_types(set(type_id)::in,
+:- pred intermod_info_set_instances(
+ assoc_list(class_id, hlds_instance_defn)::in,
intermod_info::in, intermod_info::out) is det.
-:- pred intermod_info_set_modes(set(mode_id)::in,
- intermod_info::in, intermod_info::out) is det.
-:- pred intermod_info_set_insts(set(inst_id)::in,
- intermod_info::in, intermod_info::out) is det.
+%:- pred intermod_info_set_modes(set(mode_id)::in,
+% intermod_info::in, intermod_info::out) is det.
+%:- pred intermod_info_set_insts(set(inst_id)::in,
+% intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_module_info(module_info::in,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_write_header(intermod_info::in,
@@ -1559,15 +1646,15 @@
intermod_info_set_pred_decls(ProcDecls, info(A,B,_,D,E,F,G,H,I,J),
info(A,B, ProcDecls, D,E,F,G,H,I,J)).
-
-intermod_info_set_types(Types, info(A,B,C,_,E,F,G,H,I,J),
- info(A,B,C, Types, E,F,G,H,I,J)).
-intermod_info_set_modes(Modes, info(A,B,C,D,_,F,G,H,I,J),
- info(A,B,C,D, Modes, F,G,H,I,J)).
+intermod_info_set_instances(Instances, info(A,B,C,_,E,F,G,H,I,J),
+ info(A,B,C, Instances, E,F,G,H,I,J)).
-intermod_info_set_insts(Insts, info(A,B,C,D,E,_,G,H,I,J),
- info(A,B,C,D,E, Insts, G,H,I,J)).
+%intermod_info_set_modes(Modes, info(A,B,C,D,_,F,G,H,I,J),
+% info(A,B,C,D, Modes, F,G,H,I,J)).
+%
+%intermod_info_set_insts(Insts, info(A,B,C,D,E,_,G,H,I,J),
+% info(A,B,C,D,E, Insts, G,H,I,J)).
intermod_info_set_module_info(ModuleInfo, info(A,B,C,D,E,F,_,H,I,J),
info(A,B,C,D,E,F, ModuleInfo, H,I,J)).
@@ -1601,57 +1688,168 @@
globals__lookup_int_option(Globals, higher_order_size_limit,
HigherOrderSizeLimit),
intermod__gather_preds(PredIds, yes, Threshold, HigherOrderSizeLimit,
- Deforestation, Info0, Info1),
- intermod__gather_abstract_exported_types(Info1, Info),
+ Deforestation, Info0, Info),
do_adjust_pred_import_status(Info, Module0, Module),
maybe_write_string(VVerbose, " done\n", IO2, IO).
:- pred do_adjust_pred_import_status(intermod_info::in,
module_info::in, module_info::out) is det.
-do_adjust_pred_import_status(Info, Module0, Module) :-
+do_adjust_pred_import_status(Info, ModuleInfo0, ModuleInfo) :-
intermod_info_get_pred_decls(PredDecls0, Info, _),
- intermod_info_get_types(TypeIds0, Info, _),
set__to_sorted_list(PredDecls0, PredDecls),
- set__to_sorted_list(TypeIds0, TypeIds),
- module_info_types(Module0, Types0),
- set_list_of_types_exported(TypeIds, Types0, Types),
- module_info_set_types(Module0, Types, Module1),
- special_pred_list(SpecPredIdList),
- module_info_get_special_pred_map(Module1, SpecPredMap),
- module_info_preds(Module1, Preds0),
- fixup_special_preds(TypeIds, SpecPredIdList,
- SpecPredMap, Preds0, Preds1),
- set_list_of_preds_exported(PredDecls, Preds1, Preds2),
- module_info_set_preds(Module1, Preds2, Module).
-
-:- pred set_list_of_types_exported(list(type_id)::in, type_table::in,
- type_table::out) is det.
-
-set_list_of_types_exported([], Types, Types).
-set_list_of_types_exported([TypeId | TypeIds], Types0, Types) :-
- map__lookup(Types0, TypeId, TypeDefn0),
- hlds_data__set_type_defn_status(TypeDefn0, exported, TypeDefn),
- map__det_update(Types0, TypeId, TypeDefn, Types1),
- set_list_of_types_exported(TypeIds, Types1, Types).
-
-:- pred fixup_special_preds(list(type_id)::in, list(special_pred_id)::in,
- special_pred_map::in, pred_table::in, pred_table::out) is det.
-
-fixup_special_preds([], _, _, Preds, Preds).
-fixup_special_preds([TypeId | TypeIds], SpecialPredList,
- SpecMap, Preds0, Preds) :-
- list__map(lambda([SpecPredId::in, PredId::out] is det, (
- map__lookup(SpecMap, SpecPredId - TypeId, PredId)
- )), SpecialPredList, NewPredIds),
- set_list_of_preds_exported(NewPredIds, Preds0, Preds1),
- fixup_special_preds(TypeIds, SpecialPredList, SpecMap, Preds1, Preds).
+ set_list_of_preds_exported(PredDecls, ModuleInfo0, ModuleInfo1),
+ adjust_type_status(ModuleInfo1, ModuleInfo2),
+ adjust_class_status(ModuleInfo2, ModuleInfo3),
+ adjust_instance_status(ModuleInfo3, ModuleInfo).
+
+:- pred adjust_type_status(module_info::in, module_info::out) is det.
+
+adjust_type_status(ModuleInfo0, ModuleInfo) :-
+ module_info_types(ModuleInfo0, Types0),
+ map__to_assoc_list(Types0, TypesAL0),
+ list__map_foldl(adjust_type_status_2, TypesAL0, TypesAL,
+ ModuleInfo0, ModuleInfo1),
+ map__from_assoc_list(TypesAL, Types),
+ module_info_set_types(ModuleInfo1, Types, ModuleInfo).
+
+:- pred adjust_type_status_2(pair(type_id, hlds_type_defn)::in,
+ pair(type_id, hlds_type_defn)::out,
+ module_info::in, module_info::out) is det.
+
+adjust_type_status_2(TypeId - TypeDefn0, TypeId - TypeDefn,
+ ModuleInfo0, ModuleInfo) :-
+ hlds_data__get_type_defn_status(TypeDefn0, Status),
+ (
+ module_info_name(ModuleInfo0, ModuleName),
+ TypeId = qualified(ModuleName, _) - _,
+ ( Status = local
+ ; Status = abstract_exported
+ )
+ ->
+ hlds_data__set_type_defn_status(TypeDefn0, exported, TypeDefn),
+ fixup_special_preds(TypeId, ModuleInfo0, ModuleInfo)
+ ;
+ ModuleInfo = ModuleInfo0,
+ TypeDefn = TypeDefn0
+ ).
+
+:- pred fixup_special_preds((type_id)::in,
+ module_info::in, module_info::out) is det.
+
+fixup_special_preds(TypeId, ModuleInfo0, ModuleInfo) :-
+ special_pred_list(SpecialPredList),
+ module_info_get_special_pred_map(ModuleInfo0, SpecPredMap),
+ list__map((pred(SpecPredId::in, PredId::out) is det :-
+ map__lookup(SpecPredMap, SpecPredId - TypeId, PredId)
+ ), SpecialPredList, PredIds),
+ set_list_of_preds_exported(PredIds, ModuleInfo0, ModuleInfo).
+
+:- pred adjust_class_status(module_info::in, module_info::out) is det.
+
+adjust_class_status(ModuleInfo0, ModuleInfo) :-
+ module_info_name(ModuleInfo0, ModuleName),
+ module_info_classes(ModuleInfo0, Classes0),
+ map__to_assoc_list(Classes0, ClassAL0),
+ list__map_foldl(adjust_class_status_2(ModuleName), ClassAL0, ClassAL,
+ ModuleInfo0, ModuleInfo1),
+ map__from_assoc_list(ClassAL, Classes),
+ module_info_set_classes(ModuleInfo1, Classes, ModuleInfo).
+
+:- pred adjust_class_status_2(module_name::in,
+ pair(class_id, hlds_class_defn)::in,
+ pair(class_id, hlds_class_defn)::out,
+ module_info::in, module_info::out) is det.
+
+adjust_class_status_2(ModuleName, ClassId - ClassDefn0, ClassId - ClassDefn,
+ ModuleInfo0, ModuleInfo) :-
+ (
+ ClassId = class_id(qualified(ModuleName, _), _),
+ ClassDefn0 = hlds_class_defn(Status0, Constraints, TVars,
+ Interface, HLDSClassInterface,
+ TVarSet, Context),
+ Status0 \= exported
+ ->
+ ClassDefn = hlds_class_defn(exported, Constraints, TVars,
+ Interface, HLDSClassInterface,
+ TVarSet, Context),
+ class_procs_to_pred_ids(HLDSClassInterface, PredIds),
+ set_list_of_preds_exported(PredIds, ModuleInfo0, ModuleInfo)
+ ;
+ ClassDefn = ClassDefn0,
+ ModuleInfo = ModuleInfo0
+ ).
+
+:- pred class_procs_to_pred_ids(list(hlds_class_proc)::in,
+ list(pred_id)::out) is det.
+
+class_procs_to_pred_ids(ClassProcs, PredIds) :-
+ list__map(
+ (pred(ClassProc::in, PredId::out) is det :-
+ ClassProc = hlds_class_proc(PredId, _)
+ ),
+ ClassProcs, PredIds0),
+ list__sort_and_remove_dups(PredIds0, PredIds).
+
+:- pred adjust_instance_status(module_info::in, module_info::out) is det.
+
+adjust_instance_status(ModuleInfo0, ModuleInfo) :-
+ module_info_instances(ModuleInfo0, Instances0),
+ map__to_assoc_list(Instances0, InstanceAL0),
+ list__map_foldl(adjust_instance_status_2, InstanceAL0, InstanceAL,
+ ModuleInfo0, ModuleInfo1),
+ map__from_assoc_list(InstanceAL, Instances),
+ module_info_set_instances(ModuleInfo1, Instances, ModuleInfo).
+
+:- pred adjust_instance_status_2(pair(class_id, list(hlds_instance_defn))::in,
+ pair(class_id, list(hlds_instance_defn))::out,
+ module_info::in, module_info::out) is det.
+
+adjust_instance_status_2(ClassId - InstanceList0, ClassId - InstanceList,
+ ModuleInfo0, ModuleInfo) :-
+ list__map_foldl(adjust_instance_status_3, InstanceList0, InstanceList,
+ ModuleInfo0, ModuleInfo).
+
+:- pred adjust_instance_status_3(hlds_instance_defn::in,
+ hlds_instance_defn::out, module_info::in, module_info::out) is det.
+
+adjust_instance_status_3(Instance0, Instance, ModuleInfo0, ModuleInfo) :-
+ Instance0 = hlds_instance_defn(Status0, Context, Constraints, Types,
+ Body, HLDSClassInterface, TVarSet, ConstraintProofs),
+ (
+ ( Status0 = local
+ ; Status0 = abstract_exported
+ )
+ ->
+ Instance = hlds_instance_defn(exported, Context, Constraints,
+ Types, Body, HLDSClassInterface, TVarSet,
+ ConstraintProofs),
+ ( HLDSClassInterface = yes(ClassInterface) ->
+ class_procs_to_pred_ids(ClassInterface, PredIds),
+ set_list_of_preds_exported(PredIds,
+ ModuleInfo0, ModuleInfo)
+ ;
+ error(
+ "intermod__adjust_instance_status: undefined instance body")
+ )
+ ;
+ ModuleInfo = ModuleInfo0,
+ Instance = Instance0
+ ).
+
+:- pred set_list_of_preds_exported(list(pred_id)::in, module_info::in,
+ module_info::out) is det.
+
+set_list_of_preds_exported(PredIds, ModuleInfo0, ModuleInfo) :-
+ module_info_preds(ModuleInfo0, Preds0),
+ set_list_of_preds_exported_2(PredIds, Preds0, Preds),
+ module_info_set_preds(ModuleInfo0, Preds, ModuleInfo).
-:- pred set_list_of_preds_exported(list(pred_id)::in, pred_table::in,
+:- pred set_list_of_preds_exported_2(list(pred_id)::in, pred_table::in,
pred_table::out) is det.
-set_list_of_preds_exported([], Preds, Preds).
-set_list_of_preds_exported([PredId | PredIds], Preds0, Preds) :-
+set_list_of_preds_exported_2([], Preds, Preds).
+set_list_of_preds_exported_2([PredId | PredIds], Preds0, Preds) :-
map__lookup(Preds0, PredId, PredInfo0),
( pred_info_import_status(PredInfo0, local) ->
(
@@ -1667,7 +1865,7 @@
;
Preds1 = Preds0
),
- set_list_of_preds_exported(PredIds, Preds1, Preds).
+ set_list_of_preds_exported_2(PredIds, Preds1, Preds).
%-----------------------------------------------------------------------------%
% Read in and process the optimization interfaces.
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.318
diff -u -u -r1.318 make_hlds.m
--- make_hlds.m 1999/11/22 05:49:37 1.318
+++ make_hlds.m 1999/12/01 05:21:38
@@ -2138,7 +2138,7 @@
(
{ map__search(Classes0, ClassId, OldValue) }
->
- { OldValue = hlds_class_defn(_, _, _, _, OldContext) },
+ { OldValue = hlds_class_defn(_, _, _, _, _, _, OldContext) },
multiple_def_error(Name, ClassArity, "typeclass",
Context, OldContext),
io__set_exit_status(1),
@@ -2162,8 +2162,9 @@
%
{ list__sort(PredProcIds1, PredProcIds) },
- { Value = hlds_class_defn(Constraints, Vars, PredProcIds,
- VarSet, Context) },
+ { Status = item_status(ImportStatus, _) },
+ { Value = hlds_class_defn(ImportStatus, Constraints,
+ Vars, Interface, PredProcIds, VarSet, Context) },
{ map__det_insert(Classes0, ClassId, Value, Classes) },
{ module_info_set_classes(Module1, Classes, Module2) },
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.176
diff -u -u -r1.176 polymorphism.m
--- polymorphism.m 1999/10/26 01:01:06 1.176
+++ polymorphism.m 1999/11/28 05:49:59
@@ -309,6 +309,7 @@
:- import_module hlds_goal, hlds_module, hlds_pred, hlds_data.
:- import_module prog_data, special_pred.
+:- import_module globals, options.
:- import_module io, list, term, map.
@@ -2173,8 +2174,8 @@
% Look up the definition of the subclass
module_info_classes(ModuleInfo, ClassTable),
map__lookup(ClassTable, SubClassId, SubClassDefn),
- SubClassDefn = hlds_class_defn(SuperClasses0,
- SubClassVars, _, _, _),
+ SubClassDefn = hlds_class_defn(_, SuperClasses0,
+ SubClassVars, _, _, _, _),
% Work out which superclass typeclass_info to
% take
@@ -2373,8 +2374,8 @@
poly_info_get_proofs(Info0, Proofs),
poly_info_get_typevarset(Info0, TVarSet0),
- ClassDefn = hlds_class_defn(SuperClasses0, ClassVars0,
- _, ClassTVarSet, _),
+ ClassDefn = hlds_class_defn(_, SuperClasses0, ClassVars0,
+ _, _, ClassTVarSet, _),
varset__merge_subst(TVarSet0, ClassTVarSet, TVarSet1, Subst),
poly_info_set_typevarset(TVarSet1, Info0, Info1),
@@ -2984,7 +2985,7 @@
ClassId = class_id(ClassName0, ClassArity),
module_info_classes(ModuleInfo, ClassTable),
map__lookup(ClassTable, ClassId, ClassDefn),
- ClassDefn = hlds_class_defn(SuperClasses, _, _, _, _),
+ ClassDefn = hlds_class_defn(_, SuperClasses, _, _, _, _, _),
list__length(SuperClasses, NumSuperClasses),
unqualify_name(ClassName0, ClassName),
@@ -3129,10 +3130,14 @@
%---------------------------------------------------------------------------%
- % Expand the bodies of all class methods for typeclasses which
- % were defined in this module. The expansion involves inserting a
- % class_method_call with the appropriate arguments, which is
- % responsible for extracting the appropriate part of the dictionary.
+ % Expand the bodies of all class methods.
+ % Class methods for imported classes are only expanded if
+ % we are performing type specialization, so that method lookups
+ % for imported classes can be optimized.
+ %
+ % The expansion involves inserting a class_method_call with the
+ % appropriate arguments, which is responsible for extracting the
+ % appropriate part of the dictionary.
:- pred polymorphism__expand_class_method_bodies(module_info, module_info).
:- mode polymorphism__expand_class_method_bodies(in, out) is det.
@@ -3141,20 +3146,29 @@
module_info_name(ModuleInfo0, ModuleName),
map__keys(Classes, ClassIds0),
- % Don't expand classes from other modules
- FromThisModule = lambda([ClassId::in] is semidet,
- (
- ClassId = class_id(qualified(ModuleName, _), _)
- )),
- list__filter(FromThisModule, ClassIds0, ClassIds),
-
+ module_info_globals(ModuleInfo0, Globals),
+ globals__lookup_bool_option(Globals, user_guided_type_specialization,
+ TypeSpec),
+ (
+ TypeSpec = no,
+
+ % Don't expand classes from other modules
+ FromThisModule = lambda([ClassId::in] is semidet,
+ (
+ ClassId = class_id(qualified(ModuleName, _), _)
+ )),
+ list__filter(FromThisModule, ClassIds0, ClassIds)
+ ;
+ TypeSpec = yes,
+ ClassIds = ClassIds0
+ ),
map__apply_to_list(ClassIds, Classes, ClassDefns),
list__foldl(expand_bodies, ClassDefns, ModuleInfo0, ModuleInfo).
:- pred expand_bodies(hlds_class_defn, module_info, module_info).
:- mode expand_bodies(in, in, out) is det.
-expand_bodies(hlds_class_defn(_, _, Interface, _, _),
+expand_bodies(hlds_class_defn(_, _, _, _, Interface, _, _),
ModuleInfo0, ModuleInfo) :-
list__foldl2(expand_one_body, Interface, 1, _, ModuleInfo0, ModuleInfo).
@@ -3226,7 +3240,14 @@
proc_info_set_goal(ProcInfo0, BodyGoal, ProcInfo),
map__det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
- pred_info_set_procedures(PredInfo0, ProcTable, PredInfo),
+ pred_info_set_procedures(PredInfo0, ProcTable, PredInfo1),
+
+ ( pred_info_is_imported(PredInfo1) ->
+ pred_info_set_import_status(PredInfo1, opt_imported, PredInfo)
+ ;
+ PredInfo = PredInfo1
+ ),
+
map__det_update(PredTable0, PredId, PredInfo, PredTable),
module_info_set_preds(ModuleInfo0, PredTable, ModuleInfo),
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/valid/Mmakefile,v
retrieving revision 1.49
diff -u -u -r1.49 Mmakefile
--- Mmakefile 1999/11/19 13:22:25 1.49
+++ Mmakefile 1999/12/01 04:33:40
@@ -66,6 +66,7 @@
intermod_nested_uniq.m \
intermod_quote.m \
intermod_test.m \
+ intermod_typeclass.m \
ite_to_disj.m \
lambda_inference.m\
lambda_instmap_bug.m \
@@ -194,6 +195,7 @@
MCFLAGS-intermod_quote2 = --intermodule-optimization
MCFLAGS-intermod_test = --intermodule-optimization
MCFLAGS-intermod_test2 = --intermodule-optimization
+MCFLAGS-intermod_typeclass = --intermodule-optimization
+MCFLAGS-intermod_typeclass2 = --intermodule-optimization
MCFLAGS-ite_to_disj = --aditi
MCFLAGS-livevals_seq = -O5 --opt-space
MCFLAGS-middle_rec_labels = --middle-rec --no-follow-vars
Index: tests/valid/intermod_test.m
===================================================================
RCS file: /home/staff/zs/imp/tests/valid/intermod_test.m,v
retrieving revision 1.2
diff -u -u -r1.2 intermod_test.m
--- intermod_test.m 1997/11/21 00:38:54 1.2
+++ intermod_test.m 1999/12/01 01:56:37
@@ -4,7 +4,7 @@
:- import_module int.
-:- pred p(int::out) is det.
+:- pred p(int::out) is semidet.
:- type t
---> f(int)
@@ -14,11 +14,13 @@
:- import_module intermod_test2.
+:- pragma inline(p/1).
p(X) :-
Y = f(1),
Y = f(_),
Lambda = lambda([Z::int_mode] is det, Z = 2),
- local(Lambda, X).
+ local(Lambda, X),
+ intermod_test2__baz(X).
:- mode int_mode :: out.
Index: tests/valid/intermod_test2.m
===================================================================
RCS file: /home/staff/zs/imp/tests/valid/intermod_test2.m,v
retrieving revision 1.3
diff -u -u -r1.3 intermod_test2.m
--- intermod_test2.m 1998/02/04 12:10:42 1.3
+++ intermod_test2.m 1999/12/01 01:55:19
@@ -11,16 +11,25 @@
:- type t
---> f(int)
- ; g.
+ ; g(int1).
-:- mode int_mode :: in.
+% Check that local types used only in other type declarations are put
+% in the `.opt' file.
+:- type int1 ---> int1(int).
+:- mode int_mode :: int_mode1.
+:- mode int_mode1 :: in.
baz(X) :- T = f(1), bar(T, X).
:- pred bar(t::in, int::int_mode) is semidet.
-bar(T, 2) :- T = f(1).
+bar(T, 2) :-
+ Pred = (pred(T1::in, Int::int_mode) is semidet :-
+ T1 = f(1),
+ Int = 2
+ ),
+ Pred(T, 2).
% One version of the compiler incorrectly wrote this declaration to
% the .opt file as `:- pragma inline((intermod_test2:plusone)/2).'
Index: tests/valid/intermod_typeclass.m
===================================================================
RCS file: intermod_typeclass.m
diff -N intermod_typeclass.m
--- /dev/null Thu Dec 2 11:59:44 1999
+++ intermod_typeclass.m Wed Dec 1 16:38:50 1999
@@ -0,0 +1,36 @@
+% Test handling of typeclasses with intermodule optimization.
+:- module intermod_typeclass.
+:- interface.
+
+:- import_module int.
+
+:- pred p(int::out) is semidet.
+
+:- type t
+ ---> f(int)
+ ; g.
+
+:- implementation.
+
+:- import_module intermod_typeclass2.
+
+:- pragma inline(p/1).
+p(X) :-
+ Y = f(1),
+ Y = f(_),
+ Lambda = lambda([Z::int_mode] is det, Z = 2),
+ local(Lambda, X),
+ intermod_typeclass2__baz(X).
+
+:- mode int_mode :: out.
+
+:- pred local(pred(int), int).
+:- mode local(pred(int_mode) is det, out) is det.
+
+local(Pred, Int) :- call(Pred, Int).
+
+:- pred local_2(pred(int), int).
+:- mode local_2(pred(int_mode) is det, out) is det.
+
+local_2(Pred, plusone(Int)) :- call(Pred, Int).
+
Index: tests/valid/intermod_typeclass2.m
===================================================================
RCS file: intermod_typeclass2.m
diff -N intermod_typeclass2.m
--- /dev/null Thu Dec 2 11:59:44 1999
+++ intermod_typeclass2.m Wed Dec 1 16:38:50 1999
@@ -0,0 +1,53 @@
+
+:- module intermod_typeclass2.
+
+:- interface.
+
+:- import_module int.
+:- pred baz(int::in) is semidet.
+
+:- func plusone(int :: in) = (int :: out) is det.
+
+:- implementation.
+
+:- type t
+ ---> f(int)
+ ; g(int1).
+
+% Check that local types used only in other type declarations are put
+% in the `.opt' file.
+:- type int1 ---> int1(int).
+
+:- mode int_mode :: int_mode1.
+:- mode int_mode1 :: in.
+
+baz(X) :- T = f(1), bar(T, X), method(X).
+
+:- pred bar(t::in, int::int_mode) is semidet.
+
+bar(T, 2) :-
+ Pred = (pred(T1::in, Int::int_mode) is semidet :-
+ T1 = f(1),
+ Int = 2
+ ),
+ Pred(T, 2).
+
+% One version of the compiler incorrectly wrote this declaration to
+% the .opt file as `:- pragma inline((intermod_test2:plusone)/2).'
+% -- bromage 20 Nov 1997
+:- pragma inline(plusone/1).
+
+plusone(Int0) = Int :- Int is Int0 + 1.
+
+:- typeclass class(T) where [
+ pred method(T::in) is semidet
+ ].
+
+:- instance class(int) where [
+ pred(method/1) is int_method
+ ].
+
+:- pred int_method(int::in) is semidet.
+
+int_method(1).
+
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list