[m-rev.] diff: moving cons_id to prog_data.m (part 2 of 2)
Zoltan Somogyi
zs at cs.mu.OZ.AU
Mon Jun 14 14:19:34 AEST 2004
Index: mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.157
diff -u -b -r1.157 mode_util.m
--- mode_util.m 7 Jun 2004 09:06:56 -0000 1.157
+++ mode_util.m 12 Jun 2004 14:07:22 -0000
@@ -14,12 +14,10 @@
:- interface.
-:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- import_module hlds__hlds_module.
:- import_module hlds__hlds_pred.
:- import_module hlds__instmap.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module bool, list.
@@ -28,41 +26,29 @@
% the final instantiatedness for a given mode, aborting
% if the mode is undefined.
%
-:- pred mode_get_insts(module_info, mode, inst, inst).
-:- mode mode_get_insts(in, in, out, out) is det.
+:- pred mode_get_insts(module_info::in, (mode)::in, (inst)::out, (inst)::out)
+ is det.
% a version of mode_get_insts which fails if the mode is undefined
-:- pred mode_get_insts_semidet(module_info, mode, inst, inst).
-:- mode mode_get_insts_semidet(in, in, out, out) is semidet.
-
- % inst_substitute_arg_list(Inst0, Params, Args, Inst) is true
- % iff Inst is the inst that results from substituting all
- % occurrences of Params in Inst0 with the corresponding
- % value in Args.
-:- pred inst_substitute_arg_list(inst, list(inst_var), list(inst), inst).
-:- mode inst_substitute_arg_list(in, in, in, out) is det.
+:- pred mode_get_insts_semidet(module_info::in, (mode)::in,
+ (inst)::out, (inst)::out) is semidet.
% a mode is considered input if the initial inst is bound
-:- pred mode_is_input(module_info, mode).
-:- mode mode_is_input(in, in) is semidet.
+:- pred mode_is_input(module_info::in, (mode)::in) is semidet.
% a mode is considered fully input if the initial inst is ground
-:- pred mode_is_fully_input(module_info, mode).
-:- mode mode_is_fully_input(in, in) is semidet.
+:- pred mode_is_fully_input(module_info::in, (mode)::in) is semidet.
% a mode is considered output if the initial inst is free
% and the final inst is bound
-:- pred mode_is_output(module_info, mode).
-:- mode mode_is_output(in, in) is semidet.
+:- pred mode_is_output(module_info::in, (mode)::in) is semidet.
% a mode is considered fully output if the initial inst is free and
% the final inst is ground
-:- pred mode_is_fully_output(module_info, mode).
-:- mode mode_is_fully_output(in, in) is semidet.
+:- pred mode_is_fully_output(module_info::in, (mode)::in) is semidet.
% a mode is considered unused if both initial and final insts are free
-:- pred mode_is_unused(module_info, mode).
-:- mode mode_is_unused(in, in) is semidet.
+:- pred mode_is_unused(module_info::in, (mode)::in) is semidet.
% mode_to_arg_mode converts a mode (and corresponding type) to
% an arg_mode. A mode is a high-level notion, the normal
@@ -73,49 +59,25 @@
% the mode, because the argument passing convention can depend
% on the type's representation.
%
-:- pred mode_to_arg_mode(module_info, mode, type, arg_mode).
-:- mode mode_to_arg_mode(in, in, in, out) is det.
+:- pred mode_to_arg_mode(module_info::in, (mode)::in, (type)::in,
+ arg_mode::out) is det.
-:- pred modes_to_arg_modes(module_info, list(mode), list(type),
- list(arg_mode)).
-:- mode modes_to_arg_modes(in, in, in, out) is det.
-
- % Given an expanded inst and a cons_id and its arity, return the
- % insts of the arguments of the top level functor, failing if the
- % inst could not be bound to the functor.
-:- pred get_arg_insts(inst, cons_id, arity, list(inst)).
-:- mode get_arg_insts(in, in, in, out) is semidet.
+:- pred modes_to_arg_modes(module_info::in, list(mode)::in, list(type)::in,
+ list(arg_mode)::out) is det.
- % Given a list of bound_insts, get the corresponding list of cons_ids
- %
-:- pred functors_to_cons_ids(list(bound_inst), list(cons_id)).
-:- mode functors_to_cons_ids(in, out) is det.
-
-:- pred mode_id_to_int(mode_id, int).
-:- mode mode_id_to_int(in, out) is det.
+:- pred mode_list_get_initial_insts(list(mode)::in, module_info::in,
+ list(inst)::out) is det.
-:- pred mode_list_get_initial_insts(list(mode), module_info, list(inst)).
-:- mode mode_list_get_initial_insts(in, in, out) is det.
+:- pred mode_list_get_final_insts(list(mode)::in, module_info::in,
+ list(inst)::out) is det.
-:- pred mode_list_get_final_insts(list(mode), module_info, list(inst)).
-:- mode mode_list_get_final_insts(in, in, out) is det.
-
-:- pred mode_util__modes_to_uni_modes(list(mode), list(mode), module_info,
- list(uni_mode)).
-:- mode mode_util__modes_to_uni_modes(in, in, in, out) is det.
-
- % inst_lists_to_mode_list(InitialInsts, FinalInsts, Modes):
- % Given two lists of corresponding initial and final
- % insts, return a list of modes which maps from the
- % initial insts to the final insts.
-:- pred inst_lists_to_mode_list(list(inst), list(inst), list(mode)).
-:- mode inst_lists_to_mode_list(in, in, out) is det.
+:- pred mode_util__modes_to_uni_modes(list(mode)::in, list(mode)::in,
+ module_info::in, list(uni_mode)::out) is det.
% Given a user-defined or compiler-defined inst name,
% lookup the corresponding inst in the inst table.
%
-:- pred inst_lookup(module_info, inst_name, inst).
-:- mode inst_lookup(in, in, out) is det.
+:- pred inst_lookup(module_info::in, inst_name::in, (inst)::out) is det.
% Use the instmap deltas for all the atomic sub-goals to recompute
% the instmap deltas for all the non-atomic sub-goals of a goal.
@@ -132,117 +94,59 @@
vartypes::in, inst_varset::in, instmap::in, module_info::in,
module_info::out) is det.
-
% Given corresponding lists of types and modes, produce a new
% list of modes which includes the information provided by the
% corresponding types.
%
-:- pred propagate_types_into_mode_list(list(type), module_info, list(mode),
- list(mode)).
-:- mode propagate_types_into_mode_list(in, in, in, out) is det.
+:- pred propagate_types_into_mode_list(list(type)::in, module_info::in,
+ list(mode)::in, list(mode)::out) is det.
% Given corresponding lists of types and insts and a substitution
% for the type variables in the type, produce a new list of insts
% which includes the information provided by the corresponding types.
%
-:- pred propagate_types_into_inst_list(list(type), tsubst, module_info,
- list(inst), list(inst)).
-:- mode propagate_types_into_inst_list(in, in, in, in, out) is det.
+:- pred propagate_types_into_inst_list(list(type)::in, tsubst::in,
+ module_info::in, list(inst)::in, list(inst)::out) is det.
% Convert a list of constructors to a list of bound_insts where the
% arguments are `ground'.
% Note that the list(bound_inst) is not sorted and may contain
% duplicates.
-:- pred constructors_to_bound_insts(list(constructor), uniqueness, module_info,
- list(bound_inst)).
-:- mode constructors_to_bound_insts(in, in, in, out) is det.
+:- pred constructors_to_bound_insts(list(constructor)::in, uniqueness::in,
+ module_info::in, list(bound_inst)::out) is det.
% Convert a list of constructors to a list of bound_insts where the
% arguments are `any'.
% Note that the list(bound_inst) is not sorted and may contain
% duplicates.
-:- pred constructors_to_bound_any_insts(list(constructor), uniqueness,
- module_info, list(bound_inst)).
-:- mode constructors_to_bound_any_insts(in, in, in, out) is det.
+:- pred constructors_to_bound_any_insts(list(constructor)::in, uniqueness::in,
+ module_info::in, list(bound_inst)::out) is det.
% Given the mode of a predicate,
% work out which arguments are live (might be used again
% by the caller of that predicate) and which are dead.
-:- pred get_arg_lives(list(mode), module_info, list(is_live)).
-:- mode get_arg_lives(in, in, out) is det.
-
- % Predicates to make error messages more readable by stripping
- % "builtin:" module qualifiers from modes.
-
-:- pred strip_builtin_qualifier_from_cons_id(cons_id, cons_id).
-:- mode strip_builtin_qualifier_from_cons_id(in, out) is det.
-
-:- pred strip_builtin_qualifiers_from_mode_list(list(mode), list(mode)).
-:- mode strip_builtin_qualifiers_from_mode_list(in, out) is det.
-
-:- pred strip_builtin_qualifiers_from_inst_list(list(inst), list(inst)).
-:- mode strip_builtin_qualifiers_from_inst_list(in, out) is det.
-
-:- pred strip_builtin_qualifiers_from_inst((inst), (inst)).
-:- mode strip_builtin_qualifiers_from_inst(in, out) is det.
+:- pred get_arg_lives(list(mode)::in, module_info::in, list(is_live)::out)
+ is det.
% Given the switched on variable and the instmaps before the switch
% and after a branch make sure that any information added by the
% functor test gets added to the instmap for the case.
-:- pred fixup_switch_var(prog_var, instmap, instmap, hlds_goal, hlds_goal).
-:- mode fixup_switch_var(in, in, in, in, out) is det.
+:- pred fixup_switch_var(prog_var::in, instmap::in, instmap::in,
+ hlds_goal::in, hlds_goal::out) is det.
%-----------------------------------------------------------------------------%
-:- pred normalise_insts(list(inst), list(type), module_info, list(inst)).
-:- mode normalise_insts(in, in, in, out) is det.
+:- pred normalise_insts(list(inst)::in, list(type)::in, module_info::in,
+ list(inst)::out) is det.
-:- pred normalise_inst(inst, (type), module_info, inst).
-:- mode normalise_inst(in, in, in, out) is det.
+:- pred normalise_inst((inst)::in, (type)::in, module_info::in, (inst)::out)
+ is det.
%-----------------------------------------------------------------------------%
% Partition a list of arguments into inputs and others.
-:- pred partition_args(module_info, list(mode), list(T), list(T), list(T)).
-:- mode partition_args(in, in, in, out, out) is det.
-
-%-----------------------------------------------------------------------------%
-
-:- pred inst_list_apply_substitution(list(inst), inst_var_sub, list(inst)).
-:- mode inst_list_apply_substitution(in, in, out) is det.
-
-:- pred mode_list_apply_substitution(list(mode), inst_var_sub, list(mode)).
-:- mode mode_list_apply_substitution(in, in, out) is det.
-
-%-----------------------------------------------------------------------------%
-
-:- pred rename_apart_inst_vars(inst_varset, inst_varset, list(mode),
- list(mode)).
-:- mode rename_apart_inst_vars(in, in, in, out) is det.
-
-%-----------------------------------------------------------------------------%
-
- % Construct a mode corresponding to the standard `in',
- % `out', `uo' or `unused' mode.
-:- pred in_mode((mode)::out) is det.
-:- func in_mode = (mode).
-:- pred out_mode((mode)::out) is det.
-:- func out_mode = (mode).
-:- pred uo_mode((mode)::out) is det.
-:- func uo_mode = (mode).
-:- pred unused_mode((mode)::out) is det.
-:- func unused_mode = (mode).
-
-:- func ground_inst = (inst).
-:- func free_inst = (inst).
-
- % Construct the modes used for `aditi__state' arguments.
- % XXX These should be unique, but are not yet because that
- % would require alias tracking.
-:- func aditi_mui_mode = (mode).
-:- func aditi_ui_mode = (mode).
-:- func aditi_di_mode = (mode).
-:- func aditi_uo_mode = (mode).
+:- pred partition_args(module_info::in, list(mode)::in, list(T)::in,
+ list(T)::out, list(T)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -253,7 +157,9 @@
:- import_module check_hlds__inst_util.
:- import_module check_hlds__mode_info.
:- import_module check_hlds__type_util.
+:- import_module hlds__hlds_data.
:- import_module parse_tree__prog_io.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_util.
:- import_module require, int, string, map, set, term, std_util.
@@ -271,52 +177,6 @@
mode_get_insts(ModuleInfo, Mode, Inst, _),
mode_list_get_initial_insts(Modes, ModuleInfo, Insts).
-inst_lists_to_mode_list([], [_|_], _) :-
- error("inst_lists_to_mode_list: length mis-match").
-inst_lists_to_mode_list([_|_], [], _) :-
- error("inst_lists_to_mode_list: length mis-match").
-inst_lists_to_mode_list([], [], []).
-inst_lists_to_mode_list([Initial|Initials], [Final|Finals], [Mode|Modes]) :-
- insts_to_mode(Initial, Final, Mode),
- inst_lists_to_mode_list(Initials, Finals, Modes).
-
-:- pred insts_to_mode(inst, inst, mode).
-:- mode insts_to_mode(in, in, out) is det.
-
-insts_to_mode(Initial, Final, Mode) :-
- %
- % Use some abbreviations.
- % This is just to make error messages and inferred modes
- % more readable.
- %
- ( Initial = free, Final = ground(shared, none) ->
- make_std_mode("out", [], Mode)
- ; Initial = free, Final = ground(unique, none) ->
- make_std_mode("uo", [], Mode)
- ; Initial = free, Final = ground(mostly_unique, none) ->
- make_std_mode("muo", [], Mode)
- ; Initial = ground(shared, none), Final = ground(shared, none) ->
- make_std_mode("in", [], Mode)
- ; Initial = ground(unique, none), Final = ground(clobbered, none) ->
- make_std_mode("di", [], Mode)
- ; Initial = ground(mostly_unique, none),
- Final = ground(mostly_clobbered, none) ->
- make_std_mode("mdi", [], Mode)
- ; Initial = ground(unique, none), Final = ground(unique, none) ->
- make_std_mode("ui", [], Mode)
- ; Initial = ground(mostly_unique, none),
- Final = ground(mostly_unique, none) ->
- make_std_mode("mdi", [], Mode)
- ; Initial = free ->
- make_std_mode("out", [Final], Mode)
- ; Final = ground(clobbered, none) ->
- make_std_mode("di", [Initial], Mode)
- ; Initial = Final ->
- make_std_mode("in", [Initial], Mode)
- ;
- Mode = (Initial -> Final)
- ).
-
%-----------------------------------------------------------------------------%
% A mode is considered an input mode if the top-level
@@ -372,8 +232,8 @@
mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode) :-
mode_to_arg_mode_2(ModuleInfo, Mode, Type, [], ArgMode).
-:- pred mode_to_arg_mode_2(module_info, mode, type, list(type_ctor), arg_mode).
-:- mode mode_to_arg_mode_2(in, in, in, in, out) is det.
+:- pred mode_to_arg_mode_2(module_info::in, (mode)::in, (type)::in,
+ list(type_ctor)::in, arg_mode::out) is det.
mode_to_arg_mode_2(ModuleInfo, Mode, Type, ContainingTypes, ArgMode) :-
%
@@ -408,8 +268,9 @@
base_mode_to_arg_mode(ModuleInfo, Mode, ArgMode)
).
-:- pred base_mode_to_arg_mode(module_info, mode, arg_mode).
-:- mode base_mode_to_arg_mode(in, in, out) is det.
+:- pred base_mode_to_arg_mode(module_info::in, (mode)::in, arg_mode::out)
+ is det.
+
base_mode_to_arg_mode(ModuleInfo, Mode, ArgMode) :-
mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst),
( inst_is_bound(ModuleInfo, InitialInst) ->
@@ -427,8 +288,8 @@
% argument would be, assuming that the functor is
% the one given by the specified ConsId, whose arity is 1.
%
-:- pred get_single_arg_inst(inst, module_info, cons_id, inst).
-:- mode get_single_arg_inst(in, in, in, out) is det.
+:- pred get_single_arg_inst((inst)::in, module_info::in, cons_id::in,
+ (inst)::out) is det.
get_single_arg_inst(defined_inst(InstName), ModuleInfo, ConsId, ArgInst) :-
inst_lookup(ModuleInfo, InstName, Inst),
@@ -453,14 +314,11 @@
ArgInst) :-
get_single_arg_inst(Inst, ModuleInfo, ConsId, ArgInst).
-
-:- pred get_single_arg_inst_2(list(bound_inst), cons_id, inst).
-:- mode get_single_arg_inst_2(in, in, out) is semidet.
+:- pred get_single_arg_inst_2(list(bound_inst)::in, cons_id::in, (inst)::out)
+ is semidet.
get_single_arg_inst_2([BoundInst | BoundInsts], ConsId, ArgInst) :-
- (
- BoundInst = functor(ConsId, [ArgInst0])
- ->
+ ( BoundInst = functor(ConsId, [ArgInst0]) ->
ArgInst = ArgInst0
;
get_single_arg_inst_2(BoundInsts, ConsId, ArgInst)
@@ -484,53 +342,14 @@
%-----------------------------------------------------------------------------%
-functors_to_cons_ids([], []).
-functors_to_cons_ids([Functor | Functors], [ConsId | ConsIds]) :-
- Functor = functor(ConsId, _ArgInsts),
- functors_to_cons_ids(Functors, ConsIds).
-
-%-----------------------------------------------------------------------------%
-
-get_arg_insts(not_reached, _ConsId, Arity, ArgInsts) :-
- list__duplicate(Arity, not_reached, ArgInsts).
-get_arg_insts(ground(Uniq, _PredInst), _ConsId, Arity, ArgInsts) :-
- list__duplicate(Arity, ground(Uniq, none), ArgInsts).
-get_arg_insts(bound(_Uniq, List), ConsId, Arity, ArgInsts) :-
- ( get_arg_insts_2(List, ConsId, ArgInsts0) ->
- ArgInsts = ArgInsts0
- ;
- % the code is unreachable
- list__duplicate(Arity, not_reached, ArgInsts)
- ).
-get_arg_insts(free, _ConsId, Arity, ArgInsts) :-
- list__duplicate(Arity, free, ArgInsts).
-get_arg_insts(free(_Type), _ConsId, Arity, ArgInsts) :-
- list__duplicate(Arity, free, ArgInsts).
-get_arg_insts(any(Uniq), _ConsId, Arity, ArgInsts) :-
- list__duplicate(Arity, any(Uniq), ArgInsts).
-
-:- pred get_arg_insts_2(list(bound_inst), cons_id, list(inst)).
-:- mode get_arg_insts_2(in, in, out) is semidet.
-
-get_arg_insts_2([BoundInst | BoundInsts], ConsId, ArgInsts) :-
- (
- BoundInst = functor(ConsId, ArgInsts0)
- ->
- ArgInsts = ArgInsts0
- ;
- get_arg_insts_2(BoundInsts, ConsId, ArgInsts)
- ).
-
-%-----------------------------------------------------------------------------%
-
inst_lookup(ModuleInfo, InstName, Inst) :-
inst_lookup_2(InstName, ModuleInfo, Inst).
-:- pred inst_lookup_2(inst_name, module_info, inst).
-:- mode inst_lookup_2(in, in, out) is det.
+:- pred inst_lookup_2(inst_name::in, module_info::in, (inst)::out) is det.
inst_lookup_2(InstName, ModuleInfo, Inst) :-
- ( InstName = unify_inst(_, _, _, _),
+ (
+ InstName = unify_inst(_, _, _, _),
module_info_insts(ModuleInfo, InstTable),
inst_table_get_unify_insts(InstTable, UnifyInstTable),
map__lookup(UnifyInstTable, InstName, MaybeInst),
@@ -539,7 +358,8 @@
;
Inst = defined_inst(InstName)
)
- ; InstName = merge_inst(A, B),
+ ;
+ InstName = merge_inst(A, B),
module_info_insts(ModuleInfo, InstTable),
inst_table_get_merge_insts(InstTable, MergeInstTable),
map__lookup(MergeInstTable, A - B, MaybeInst),
@@ -548,7 +368,8 @@
;
Inst = defined_inst(InstName)
)
- ; InstName = ground_inst(_, _, _, _),
+ ;
+ InstName = ground_inst(_, _, _, _),
module_info_insts(ModuleInfo, InstTable),
inst_table_get_ground_insts(InstTable, GroundInstTable),
map__lookup(GroundInstTable, InstName, MaybeInst),
@@ -557,7 +378,8 @@
;
Inst = defined_inst(InstName)
)
- ; InstName = any_inst(_, _, _, _),
+ ;
+ InstName = any_inst(_, _, _, _),
module_info_insts(ModuleInfo, InstTable),
inst_table_get_any_insts(InstTable, AnyInstTable),
map__lookup(AnyInstTable, InstName, MaybeInst),
@@ -566,7 +388,8 @@
;
Inst = defined_inst(InstName)
)
- ; InstName = shared_inst(SharedInstName),
+ ;
+ InstName = shared_inst(SharedInstName),
module_info_insts(ModuleInfo, InstTable),
inst_table_get_shared_insts(InstTable, SharedInstTable),
map__lookup(SharedInstTable, SharedInstName, MaybeInst),
@@ -575,7 +398,8 @@
;
Inst = defined_inst(InstName)
)
- ; InstName = mostly_uniq_inst(NondetLiveInstName),
+ ;
+ InstName = mostly_uniq_inst(NondetLiveInstName),
module_info_insts(ModuleInfo, InstTable),
inst_table_get_mostly_uniq_insts(InstTable,
NondetLiveInstTable),
@@ -585,7 +409,8 @@
;
Inst = defined_inst(InstName)
)
- ; InstName = user_inst(Name, Args),
+ ;
+ InstName = user_inst(Name, Args),
module_info_insts(ModuleInfo, InstTable),
inst_table_get_user_insts(InstTable, UserInstTable),
user_inst_table_get_inst_defns(UserInstTable, InstDefns),
@@ -597,11 +422,13 @@
;
Inst = abstract_inst(Name, Args)
)
- ; InstName = typed_ground(Uniq, Type),
+ ;
+ InstName = typed_ground(Uniq, Type),
map__init(Subst),
propagate_type_into_inst(Type, Subst, ModuleInfo,
ground(Uniq, none), Inst)
- ; InstName = typed_inst(Type, TypedInstName),
+ ;
+ InstName = typed_inst(Type, TypedInstName),
inst_lookup_2(TypedInstName, ModuleInfo, Inst0),
map__init(Subst),
propagate_type_into_inst(Type, Subst, ModuleInfo, Inst0, Inst)
@@ -636,8 +463,8 @@
% Given a type and a mode, produce a new mode which includes
% the information provided by the type.
-:- pred propagate_type_into_mode(type, module_info, mode, mode).
-:- mode propagate_type_into_mode(in, in, in, out) is det.
+:- pred propagate_type_into_mode((type)::in, module_info::in,
+ (mode)::in, (mode)::out) is det.
propagate_type_into_mode(Type, ModuleInfo, Mode0, Mode) :-
mode_get_insts(ModuleInfo, Mode0, InitialInst0, FinalInst0),
@@ -672,27 +499,25 @@
% Also, usually many of the imported procedures will not be called,
% so for the insts in imported mode declarations N is often zero.
-:- pred propagate_type_into_inst(type, tsubst, module_info, inst, inst).
-:- mode propagate_type_into_inst(in, in, in, in, out) is det.
+:- pred propagate_type_into_inst((type)::in, tsubst::in, module_info::in,
+ (inst)::in, (inst)::out) is det.
-:- pred propagate_type_into_inst_lazily(type, tsubst, module_info, inst, inst).
-:- mode propagate_type_into_inst_lazily(in, in, in, in, out) is det.
+:- pred propagate_type_into_inst_lazily((type)::in, tsubst::in,
+ module_info::in, (inst)::in, (inst)::out) is det.
-/*********
- % XXX We ought to expand things eagerly here, using the commented
- % out code below. However, that causes efficiency problems,
- % so for the moment it is disabled.
-propagate_type_into_inst(Type, Subst, ModuleInfo, Inst0, Inst) :-
- apply_type_subst(Type0, Subst, Type),
- (
- type_constructors(Type, ModuleInfo, Constructors)
- ->
- propagate_ctor_info(Inst0, Type, Constructors, ModuleInfo,
- Inst)
- ;
- Inst = Inst0
- ).
-*********/
+% % XXX We ought to expand things eagerly here, using the commented
+% % out code below. However, that causes efficiency problems,
+% % so for the moment it is disabled.
+% propagate_type_into_inst(Type, Subst, ModuleInfo, Inst0, Inst) :-
+% apply_type_subst(Type0, Subst, Type),
+% (
+% type_constructors(Type, ModuleInfo, Constructors)
+% ->
+% propagate_ctor_info(Inst0, Type, Constructors, ModuleInfo,
+% Inst)
+% ;
+% Inst = Inst0
+% ).
propagate_type_into_inst(Type, Subst, ModuleInfo, Inst0, Inst) :-
propagate_ctor_info_lazily(Inst0, Type, Subst, ModuleInfo, Inst).
@@ -702,8 +527,8 @@
%-----------------------------------------------------------------------------%
-:- pred propagate_ctor_info(inst, type, list(constructor), module_info, inst).
-:- mode propagate_ctor_info(in, in, in, in, out) is det.
+:- pred propagate_ctor_info((inst)::in, (type)::in, list(constructor)::in,
+ module_info::in, (inst)::out) is det.
propagate_ctor_info(any(Uniq), _Type, _, _, any(Uniq)). % XXX loses type info!
@@ -762,8 +587,8 @@
inst_lookup(ModuleInfo, InstName, Inst0),
propagate_ctor_info(Inst0, Type, Ctors, ModuleInfo, Inst).
-:- pred propagate_ctor_info_lazily(inst, type, tsubst, module_info, inst).
-:- mode propagate_ctor_info_lazily(in, in, in, in, out) is det.
+:- pred propagate_ctor_info_lazily((inst)::in, (type)::in, tsubst::in,
+ module_info::in, (inst)::out) is det.
propagate_ctor_info_lazily(any(Uniq), _Type, _, _, any(Uniq)).
% XXX loses type info!
@@ -795,9 +620,8 @@
% XXX The information added by this is not yet used,
% so it's disabled since it unnecessarily complicates
% the insts.
- /*********
- Inst = defined_inst(typed_ground(Uniq, Type))
- *********/
+ %
+ % Inst = defined_inst(typed_ground(Uniq, Type))
Inst = ground(Uniq, none)
).
@@ -849,8 +673,8 @@
% This applies recursively to the arguments and return
% value too.
%
-:- pred default_higher_order_func_inst(list(type), module_info, pred_inst_info).
-:- mode default_higher_order_func_inst(in, in, out) is det.
+:- pred default_higher_order_func_inst(list(type)::in, module_info::in,
+ pred_inst_info::out) is det.
default_higher_order_func_inst(PredArgTypes, ModuleInfo, PredInstInfo) :-
In = (ground(shared, none) -> ground(shared, none)),
@@ -872,9 +696,8 @@
constructors_to_bound_insts_2(Constructors, Uniq, ModuleInfo,
any(Uniq), BoundInsts).
-:- pred constructors_to_bound_insts_2(list(constructor), uniqueness,
- module_info, inst, list(bound_inst)).
-:- mode constructors_to_bound_insts_2(in, in, in, in, out) is det.
+:- pred constructors_to_bound_insts_2(list(constructor)::in, uniqueness::in,
+ module_info::in, (inst)::in, list(bound_inst)::out) is det.
constructors_to_bound_insts_2([], _, _, _, []).
constructors_to_bound_insts_2([Ctor | Ctors], Uniq, ModuleInfo, ArgInst,
@@ -886,16 +709,15 @@
constructors_to_bound_insts_2(Ctors, Uniq, ModuleInfo, ArgInst,
BoundInsts).
-:- pred ctor_arg_list_to_inst_list(list(constructor_arg), (inst), list(inst)).
-:- mode ctor_arg_list_to_inst_list(in, in, out) is det.
+:- pred ctor_arg_list_to_inst_list(list(constructor_arg)::in, (inst)::in,
+ list(inst)::out) is det.
ctor_arg_list_to_inst_list([], _, []).
ctor_arg_list_to_inst_list([_Name - _Type | Args], Inst, [Inst | Insts]) :-
ctor_arg_list_to_inst_list(Args, Inst, Insts).
-:- pred propagate_ctor_info_2(list(bound_inst), (type), module_info,
- list(bound_inst)).
-:- mode propagate_ctor_info_2(in, in, in, out) is det.
+:- pred propagate_ctor_info_2(list(bound_inst)::in, (type)::in,
+ module_info::in, list(bound_inst)::out) is det.
propagate_ctor_info_2(BoundInsts0, Type, ModuleInfo, BoundInsts) :-
(
@@ -941,9 +763,9 @@
BoundInsts = BoundInsts0
).
-:- pred propagate_ctor_info_3(list(bound_inst), module_name, list(constructor),
- tsubst, module_info, list(bound_inst)).
-:- mode propagate_ctor_info_3(in, in, in, in, in, out) is det.
+:- pred propagate_ctor_info_3(list(bound_inst)::in, module_name::in,
+ list(constructor)::in, tsubst::in, module_info::in,
+ list(bound_inst)::out) is det.
propagate_ctor_info_3([], _, _, _, _, []).
propagate_ctor_info_3([BoundInst0 | BoundInsts0], TypeModule, Constructors,
@@ -980,8 +802,7 @@
propagate_ctor_info_3(BoundInsts0, TypeModule,
Constructors, Subst, ModuleInfo, BoundInsts).
-:- pred apply_type_subst(type, tsubst, type).
-:- mode apply_type_subst(in, in, out) is det.
+:- pred apply_type_subst((type)::in, tsubst::in, (type)::out) is det.
apply_type_subst(Type0, Subst, Type) :-
% optimize common case
@@ -993,9 +814,8 @@
%-----------------------------------------------------------------------------%
-:- pred inst_lookup_subst_args(hlds_inst_body, list(inst_var), sym_name,
- list(inst), inst).
-:- mode inst_lookup_subst_args(in, in, in, in, out) is det.
+:- pred inst_lookup_subst_args(hlds_inst_body::in, list(inst_var)::in,
+ sym_name::in, list(inst)::in, (inst)::out) is det.
inst_lookup_subst_args(eqv_inst(Inst0), Params, _Name, Args, Inst) :-
inst_substitute_arg_list(Inst0, Params, Args, Inst).
@@ -1028,247 +848,6 @@
error("mode_get_insts_semidet failed")
).
-
- % mode_substitute_arg_list(Mode0, Params, Args, Mode) is true
- % iff Mode is the mode that results from substituting all
- % occurrences of Params in Mode0 with the corresponding
- % value in Args.
-
-:- pred mode_substitute_arg_list(mode, list(inst_var), list(inst), mode).
-:- mode mode_substitute_arg_list(in, in, in, out) is det.
-
-mode_substitute_arg_list(Mode0, Params, Args, Mode) :-
- ( Params = [] ->
- Mode = Mode0 % optimize common case
- ;
- map__from_corresponding_lists(Params, Args, Subst),
- mode_apply_substitution(Mode0, Subst, Mode)
- ).
-
-inst_substitute_arg_list(Inst0, Params, Args, Inst) :-
- ( Params = [] ->
- Inst = Inst0 % optimize common case
- ;
- map__from_corresponding_lists(Params, Args, Subst),
- inst_apply_substitution(Inst0, Subst, Inst)
- ).
-
- % mode_apply_substitution(Mode0, Subst, Mode) is true iff
- % Mode is the mode that results from apply Subst to Mode0.
-
-:- pred mode_apply_substitution(mode, inst_var_sub, mode).
-:- mode mode_apply_substitution(in, in, out) is det.
-
-mode_apply_substitution((I0 -> F0), Subst, (I -> F)) :-
- inst_apply_substitution(I0, Subst, I),
- inst_apply_substitution(F0, Subst, F).
-mode_apply_substitution(user_defined_mode(Name, Args0), Subst,
- user_defined_mode(Name, Args)) :-
- inst_list_apply_substitution_2(Args0, Subst, Args).
-
- % inst_list_apply_substitution(Insts0, Subst, Insts) is true
- % iff Inst is the inst that results from applying Subst to Insts0.
-
-inst_list_apply_substitution(Insts0, Subst, Insts) :-
- ( map__is_empty(Subst) ->
- Insts = Insts0
- ;
- inst_list_apply_substitution_2(Insts0, Subst, Insts)
- ).
-
-:- pred inst_list_apply_substitution_2(list(inst), inst_var_sub, list(inst)).
-:- mode inst_list_apply_substitution_2(in, in, out) is det.
-
-inst_list_apply_substitution_2([], _, []).
-inst_list_apply_substitution_2([A0 | As0], Subst, [A | As]) :-
- inst_apply_substitution(A0, Subst, A),
- inst_list_apply_substitution_2(As0, Subst, As).
-
- % inst_substitute_arg(Inst0, Subst, Inst) is true
- % iff Inst is the inst that results from substituting all
- % occurrences of Param in Inst0 with Arg.
-
-:- pred inst_apply_substitution(inst, inst_var_sub, inst).
-:- mode inst_apply_substitution(in, in, out) is det.
-
-inst_apply_substitution(any(Uniq), _, any(Uniq)).
-inst_apply_substitution(free, _, free).
-inst_apply_substitution(free(T), _, free(T)).
-inst_apply_substitution(ground(Uniq, GroundInstInfo0), Subst, Inst) :-
- ground_inst_info_apply_substitution(GroundInstInfo0, Subst, Uniq, Inst).
-inst_apply_substitution(bound(Uniq, Alts0), Subst, bound(Uniq, Alts)) :-
- alt_list_apply_substitution(Alts0, Subst, Alts).
-inst_apply_substitution(not_reached, _, not_reached).
-inst_apply_substitution(inst_var(Var), Subst, Result) :-
- (
- map__search(Subst, Var, Replacement)
- ->
- Result = Replacement
- ;
- Result = inst_var(Var)
- ).
-inst_apply_substitution(constrained_inst_vars(Vars, Inst0), Subst, Result) :-
- ( set__singleton_set(Vars, Var0) ->
- Var = Var0
- ;
- error("inst_apply_substitution: multiple inst_vars found")
- ),
- (
- map__search(Subst, Var, Replacement)
- ->
- Result = Replacement
- % XXX Should probably have a sanity check here that
- % Replacement =< Inst0
- ;
- inst_apply_substitution(Inst0, Subst, Result0),
- Result = constrained_inst_vars(Vars, Result0)
- ).
-inst_apply_substitution(defined_inst(InstName0), Subst,
- defined_inst(InstName)) :-
- ( inst_name_apply_substitution(InstName0, Subst, InstName1) ->
- InstName = InstName1
- ;
- InstName = InstName0
- ).
-inst_apply_substitution(abstract_inst(Name, Args0), Subst,
- abstract_inst(Name, Args)) :-
- inst_list_apply_substitution_2(Args0, Subst, Args).
-
- % This predicate fails if the inst_name is not one of user_inst,
- % typed_inst or typed_ground. The other types of inst_names are just
- % used as keys in the inst_table so it does not make sense to apply
- % substitutions to them.
-:- pred inst_name_apply_substitution(inst_name, inst_var_sub, inst_name).
-:- mode inst_name_apply_substitution(in, in, out) is semidet.
-
-inst_name_apply_substitution(user_inst(Name, Args0), Subst,
- user_inst(Name, Args)) :-
- inst_list_apply_substitution_2(Args0, Subst, Args).
-inst_name_apply_substitution(typed_inst(T, Inst0), Subst,
- typed_inst(T, Inst)) :-
- inst_name_apply_substitution(Inst0, Subst, Inst).
-inst_name_apply_substitution(typed_ground(Uniq, T), _, typed_ground(Uniq, T)).
-
-:- pred alt_list_apply_substitution(list(bound_inst), inst_var_sub,
- list(bound_inst)).
-:- mode alt_list_apply_substitution(in, in, out) is det.
-
-alt_list_apply_substitution([], _, []).
-alt_list_apply_substitution([Alt0|Alts0], Subst, [Alt|Alts]) :-
- Alt0 = functor(Name, Args0),
- inst_list_apply_substitution_2(Args0, Subst, Args),
- Alt = functor(Name, Args),
- alt_list_apply_substitution(Alts0, Subst, Alts).
-
-:- pred ground_inst_info_apply_substitution(ground_inst_info, inst_var_sub,
- uniqueness, inst).
-:- mode ground_inst_info_apply_substitution(in, in, in, out) is det.
-
-ground_inst_info_apply_substitution(none, _, Uniq, ground(Uniq, none)).
-ground_inst_info_apply_substitution(GII0, Subst, Uniq, ground(Uniq, GII)) :-
- GII0 = higher_order(pred_inst_info(PredOrFunc, Modes0, Det)),
- mode_list_apply_substitution(Modes0, Subst, Modes),
- GII = higher_order(pred_inst_info(PredOrFunc, Modes, Det)).
-
- % mode_list_apply_substitution(Modes0, Subst, Modes) is true
- % iff Mode is the mode that results from applying Subst to Modes0.
-
-mode_list_apply_substitution(Modes0, Subst, Modes) :-
- ( map__is_empty(Subst) ->
- Modes = Modes0
- ;
- mode_list_apply_substitution_2(Modes0, Subst, Modes)
- ).
-
-:- pred mode_list_apply_substitution_2(list(mode), inst_var_sub, list(mode)).
-:- mode mode_list_apply_substitution_2(in, in, out) is det.
-
-mode_list_apply_substitution_2([], _, []).
-mode_list_apply_substitution_2([A0 | As0], Subst, [A | As]) :-
- mode_apply_substitution(A0, Subst, A),
- mode_list_apply_substitution_2(As0, Subst, As).
-
-%-----------------------------------------------------------------------------%
-
-rename_apart_inst_vars(VarSet, NewVarSet, Modes0, Modes) :-
- varset__merge_subst(VarSet, NewVarSet, _, Sub),
- list__map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes).
-
-:- pred rename_apart_inst_vars_in_mode(substitution(inst_var_type), mode, mode).
-:- mode rename_apart_inst_vars_in_mode(in, in, out) is det.
-
-rename_apart_inst_vars_in_mode(Sub, I0 -> F0, I -> F) :-
- rename_apart_inst_vars_in_inst(Sub, I0, I),
- rename_apart_inst_vars_in_inst(Sub, F0, F).
-rename_apart_inst_vars_in_mode(Sub, user_defined_mode(Name, Insts0),
- user_defined_mode(Name, Insts)) :-
- list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts).
-
-:- pred rename_apart_inst_vars_in_inst(substitution(inst_var_type), inst, inst).
-:- mode rename_apart_inst_vars_in_inst(in, in, out) is det.
-
-rename_apart_inst_vars_in_inst(_, any(U), any(U)).
-rename_apart_inst_vars_in_inst(_, free, free).
-rename_apart_inst_vars_in_inst(_, free(T), free(T)).
-rename_apart_inst_vars_in_inst(Sub, bound(U, BIs0), bound(U, BIs)) :-
- list__map((pred(functor(C, Is0)::in, functor(C, Is)::out) is det :-
- list__map(rename_apart_inst_vars_in_inst(Sub), Is0, Is)),
- BIs0, BIs).
-rename_apart_inst_vars_in_inst(Sub, ground(U, GI0), ground(U, GI)) :-
- (
- GI0 = higher_order(pred_inst_info(PoF, Modes0, Det)),
- list__map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes),
- GI = higher_order(pred_inst_info(PoF, Modes, Det))
- ;
- GI0 = none,
- GI = none
- ).
-rename_apart_inst_vars_in_inst(_, not_reached, not_reached).
-rename_apart_inst_vars_in_inst(Sub, inst_var(Var0), inst_var(Var)) :-
- ( map__search(Sub, Var0, term__variable(Var1)) ->
- Var = Var1
- ;
- Var = Var0
- ).
-rename_apart_inst_vars_in_inst(Sub, constrained_inst_vars(Vars0, Inst0),
- constrained_inst_vars(Vars, Inst)) :-
- rename_apart_inst_vars_in_inst(Sub, Inst0, Inst),
- Vars = set__map(func(Var0) =
- ( map__search(Sub, Var0, term__variable(Var)) ->
- Var
- ;
- Var0
- ), Vars0).
-rename_apart_inst_vars_in_inst(Sub, defined_inst(Name0), defined_inst(Name)) :-
- ( rename_apart_inst_vars_in_inst_name(Sub, Name0, Name1) ->
- Name = Name1
- ;
- Name = Name0
- ).
-rename_apart_inst_vars_in_inst(Sub, abstract_inst(Sym, Insts0),
- abstract_inst(Sym, Insts)) :-
- list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts).
-
-:- pred rename_apart_inst_vars_in_inst_name(substitution(inst_var_type),
- inst_name, inst_name).
-:- mode rename_apart_inst_vars_in_inst_name(in, in, out) is semidet.
-
-rename_apart_inst_vars_in_inst_name(Sub, user_inst(Sym, Insts0),
- user_inst(Sym, Insts)) :-
- list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts).
-rename_apart_inst_vars_in_inst_name(Sub, typed_inst(Type, Name0),
- typed_inst(Type, Name)) :-
- rename_apart_inst_vars_in_inst_name(Sub, Name0, Name).
-rename_apart_inst_vars_in_inst_name(_, typed_ground(U, T), typed_ground(U, T)).
-
-
-%-----------------------------------------------------------------------------%
-
- % In case we later decided to change the representation
- % of mode_ids.
-
-mode_id_to_int(_ - X, X).
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -1720,132 +1299,6 @@
get_arg_lives(Modes, ModuleInfo, IsLives).
%-----------------------------------------------------------------------------%
-
- %
- % Predicates to make error messages more readable by stripping
- % "builtin:" module qualifiers from modes and insts.
- % The interesting part is strip_builtin_qualifier_from_sym_name;
- % the rest is basically just recursive traversals.
- %
-
-strip_builtin_qualifiers_from_mode_list(Modes0, Modes) :-
- list__map(strip_builtin_qualifiers_from_mode, Modes0, Modes).
-
-:- pred strip_builtin_qualifiers_from_mode((mode)::in, (mode)::out) is det.
-
-strip_builtin_qualifiers_from_mode((Initial0 -> Final0), (Initial -> Final)) :-
- strip_builtin_qualifiers_from_inst(Initial0, Initial),
- strip_builtin_qualifiers_from_inst(Final0, Final).
-
-strip_builtin_qualifiers_from_mode(user_defined_mode(SymName0, Insts0),
- user_defined_mode(SymName, Insts)) :-
- strip_builtin_qualifiers_from_inst_list(Insts0, Insts),
- strip_builtin_qualifier_from_sym_name(SymName0, SymName).
-
-strip_builtin_qualifier_from_cons_id(ConsId0, ConsId) :-
- ( ConsId0 = cons(Name0, Arity) ->
- strip_builtin_qualifier_from_sym_name(Name0, Name),
- ConsId = cons(Name, Arity)
- ;
- ConsId = ConsId0
- ).
-
-:- pred strip_builtin_qualifier_from_sym_name(sym_name::in, sym_name::out)
- is det.
-
-strip_builtin_qualifier_from_sym_name(SymName0, SymName) :-
- (
- SymName0 = qualified(Module, Name),
- mercury_public_builtin_module(Module)
- ->
- SymName = unqualified(Name)
- ;
- SymName = SymName0
- ).
-
-strip_builtin_qualifiers_from_inst_list(Insts0, Insts) :-
- list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts).
-
-strip_builtin_qualifiers_from_inst(inst_var(V), inst_var(V)).
-strip_builtin_qualifiers_from_inst(constrained_inst_vars(Vars, Inst0),
- constrained_inst_vars(Vars, Inst)) :-
- strip_builtin_qualifiers_from_inst(Inst0, Inst).
-strip_builtin_qualifiers_from_inst(not_reached, not_reached).
-strip_builtin_qualifiers_from_inst(free, free).
-strip_builtin_qualifiers_from_inst(free(Type), free(Type)).
-strip_builtin_qualifiers_from_inst(any(Uniq), any(Uniq)).
-strip_builtin_qualifiers_from_inst(ground(Uniq, GII0), ground(Uniq, GII)) :-
- strip_builtin_qualifiers_from_ground_inst_info(GII0, GII).
-strip_builtin_qualifiers_from_inst(bound(Uniq, BoundInsts0),
- bound(Uniq, BoundInsts)) :-
- strip_builtin_qualifiers_from_bound_inst_list(BoundInsts0, BoundInsts).
-strip_builtin_qualifiers_from_inst(defined_inst(Name0), defined_inst(Name)) :-
- strip_builtin_qualifiers_from_inst_name(Name0, Name).
-strip_builtin_qualifiers_from_inst(abstract_inst(Name0, Args0),
- abstract_inst(Name, Args)) :-
- strip_builtin_qualifier_from_sym_name(Name0, Name),
- strip_builtin_qualifiers_from_inst_list(Args0, Args).
-
-:- pred strip_builtin_qualifiers_from_bound_inst_list(list(bound_inst)::in,
- list(bound_inst)::out) is det.
-
-strip_builtin_qualifiers_from_bound_inst_list(Insts0, Insts) :-
- list__map(strip_builtin_qualifiers_from_bound_inst, Insts0, Insts).
-
-:- pred strip_builtin_qualifiers_from_bound_inst(bound_inst::in,
- bound_inst::out) is det.
-strip_builtin_qualifiers_from_bound_inst(BoundInst0, BoundInst) :-
- BoundInst0 = functor(ConsId0, Insts0),
- strip_builtin_qualifier_from_cons_id(ConsId0, ConsId),
- BoundInst = functor(ConsId, Insts),
- list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts).
-
-:- pred strip_builtin_qualifiers_from_inst_name(inst_name::in, inst_name::out)
- is det.
-
-strip_builtin_qualifiers_from_inst_name(user_inst(SymName0, Insts0),
- user_inst(SymName, Insts)) :-
- strip_builtin_qualifier_from_sym_name(SymName0, SymName),
- strip_builtin_qualifiers_from_inst_list(Insts0, Insts).
-strip_builtin_qualifiers_from_inst_name(merge_inst(InstA0, InstB0),
- merge_inst(InstA, InstB)) :-
- strip_builtin_qualifiers_from_inst(InstA0, InstA),
- strip_builtin_qualifiers_from_inst(InstB0, InstB).
-strip_builtin_qualifiers_from_inst_name(unify_inst(Live, InstA0, InstB0, Real),
- unify_inst(Live, InstA, InstB, Real)) :-
- strip_builtin_qualifiers_from_inst(InstA0, InstA),
- strip_builtin_qualifiers_from_inst(InstB0, InstB).
-strip_builtin_qualifiers_from_inst_name(
- ground_inst(InstName0, Live, Uniq, Real),
- ground_inst(InstName, Live, Uniq, Real)) :-
- strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
-strip_builtin_qualifiers_from_inst_name(
- any_inst(InstName0, Live, Uniq, Real),
- any_inst(InstName, Live, Uniq, Real)) :-
- strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
-strip_builtin_qualifiers_from_inst_name(shared_inst(InstName0),
- shared_inst(InstName)) :-
- strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
-strip_builtin_qualifiers_from_inst_name(mostly_uniq_inst(InstName0),
- mostly_uniq_inst(InstName)) :-
- strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
-strip_builtin_qualifiers_from_inst_name(typed_ground(Uniq, Type),
- typed_ground(Uniq, Type)).
-strip_builtin_qualifiers_from_inst_name(typed_inst(Type, InstName0),
- typed_inst(Type, InstName)) :-
- strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
-
-:- pred strip_builtin_qualifiers_from_ground_inst_info(ground_inst_info::in,
- ground_inst_info::out) is det.
-
-strip_builtin_qualifiers_from_ground_inst_info(none, none).
-strip_builtin_qualifiers_from_ground_inst_info(higher_order(Pred0),
- higher_order(Pred)) :-
- Pred0 = pred_inst_info(PorF, Modes0, Det),
- Pred = pred_inst_info(PorF, Modes, Det),
- strip_builtin_qualifiers_from_mode_list(Modes0, Modes).
-
-%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
normalise_insts([], [], _, []).
@@ -1915,36 +1368,6 @@
goal_info_set_instmap_delta(GoalInfo0, InstMapDelta, GoalInfo)
),
Goal = GoalExpr - GoalInfo.
-
-%-----------------------------------------------------------------------------%
-
-in_mode(in_mode).
-out_mode(out_mode).
-uo_mode(uo_mode).
-unused_mode(unused_mode).
-
-in_mode = make_std_mode("in", []).
-out_mode = make_std_mode("out", []).
-uo_mode = make_std_mode("uo", []).
-unused_mode = make_std_mode("unused", []).
-
-aditi_mui_mode = Mode :- in_mode(Mode).
-aditi_ui_mode = Mode :- in_mode(Mode).
-aditi_di_mode = Mode :- in_mode(Mode).
-aditi_uo_mode = Mode :- out_mode(Mode).
-
-ground_inst = ground(shared, none).
-free_inst = free.
-
-:- pred make_std_mode(string, list(inst), mode).
-:- mode make_std_mode(in, in, out) is det.
-make_std_mode(Name, Args, make_std_mode(Name, Args)).
-
-:- func make_std_mode(string, list(inst)) = (mode).
-make_std_mode(Name, Args) = Mode :-
- mercury_public_builtin_module(MercuryBuiltin),
- QualifiedName = qualified(MercuryBuiltin, Name),
- Mode = user_defined_mode(QualifiedName, Args).
%-----------------------------------------------------------------------------%
Index: modecheck_call.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_call.m,v
retrieving revision 1.49
diff -u -b -r1.49 modecheck_call.m
--- modecheck_call.m 31 Mar 2004 08:52:23 -0000 1.49
+++ modecheck_call.m 12 Jun 2004 14:23:52 -0000
@@ -88,8 +88,8 @@
:- import_module check_hlds__unify_proc.
:- import_module hlds__hlds_data.
:- import_module hlds__instmap.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_mode.
:- import_module int, map, bool, set, require, term, varset.
Index: modecheck_unify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.67
diff -u -b -r1.67 modecheck_unify.m
--- modecheck_unify.m 31 Mar 2004 08:52:23 -0000 1.67
+++ modecheck_unify.m 12 Jun 2004 14:24:13 -0000
@@ -61,8 +61,9 @@
:- import_module hlds__instmap.
:- import_module hlds__make_hlds.
:- import_module hlds__quantification.
-:- import_module parse_tree__inst.
:- import_module parse_tree__module_qual.
+:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
:- import_module bool, list, map, std_util, int, set, require.
@@ -160,13 +161,15 @@
% check if variable has a higher-order type
type_is_higher_order(TypeOfX, Purity, _, EvalMethod,
PredArgTypes),
- ConsId0 = pred_const(PredId, ProcId, _)
+ ConsId0 = pred_const(ShroudedPredProcId, _)
->
%
% convert the pred term to a lambda expression
%
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, ArgVars0, PredArgTypes,
UnifyContext, GoalInfo0, Context,
@@ -1029,9 +1032,11 @@
% converted back to a predicate constant, but
% that doesn't matter since the code will be
% pruned away later by simplify.m.
- ConsId = pred_const(PredId, ProcId, EvalMethod),
+ ConsId = pred_const(ShroudedPredProcId, EvalMethod),
instmap__is_reachable(InstMap)
->
+ proc(PredId, ProcId) =
+ unshroud_pred_proc_id(ShroudedPredProcId),
(
RHS0 = lambda_goal(_, _, EvalMethod, _,
_, _, _, _, Goal),
Index: modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.278
diff -u -b -r1.278 modes.m
--- modes.m 7 Jun 2004 09:06:57 -0000 1.278
+++ modes.m 12 Jun 2004 14:25:00 -0000
@@ -41,84 +41,81 @@
% set the final insts to `not_reached'. What this means is that we don't
% yet have any information about what the final insts will be. We then keep
% iterating mode inference passes until we reach a fixpoint.
-
-/*************************************
-To mode-analyse a procedure:
- 1. Initialize the insts of the head variables.
- 2. Mode-analyse the goal.
- 3. a. If we're doing mode-checking:
- Check that the final insts of the head variables
- matches that specified in the mode declaration
- b. If we're doing mode-inference:
- Normalise the final insts of the head variables,
- record the newly inferred normalised final insts
- in the proc_info, and check whether they changed
- (so that we know when we've reached the fixpoint).
-
-To mode-analyse a goal:
-If goal is
- (a) a disjunction
- Mode-analyse the sub-goals;
- check that the final insts of all the non-local
- variables are the same for all the sub-goals.
- (b) a conjunction
- Attempt to schedule each sub-goal. If a sub-goal can
- be scheduled, then schedule it, otherwise delay it.
- Continue with the remaining sub-goals until there are
- no goals left. Every time a variable gets bound,
- see whether we should wake up a delayed goal,
- and if so, wake it up next time we get back to
- the conjunction. If there are still delayed goals
- hanging around at the end of the conjunction,
- report a mode error.
- (c) a negation
- Mode-check the sub-goal.
- Check that the sub-goal does not further instantiate
- any non-local variables. (Actually, rather than
- doing this check after we mode-analyse the subgoal,
- we instead "lock" the non-local variables, and
- disallow binding of locked variables.)
- (d) a unification
- Check that the unification doesn't attempt to unify
- two free variables (or in general two free sub-terms)
- unless one of them is dead. Split unifications
- up if necessary to avoid complicated sub-unifications.
- We also figure out at this point whether or not each
- unification can fail.
- (e) a predicate call
- Check that there is a mode declaration for the
- predicate which matches the current instantiation of
- the arguments. (Also handle calls to implied modes.)
- If the called predicate is one for which we must infer
- the modes, then create a new mode for the called predicate
- whose initial insts are the result of normalising
- the current inst of the arguments.
- (f) an if-then-else
- Attempt to schedule the condition. If successful,
- then check that it doesn't further instantiate any
- non-local variables, mode-check the `then' part
- and the `else' part, and then check that the final
- insts match. (Perhaps also think about expanding
- if-then-elses so that they can be run backwards,
- if the condition can't be scheduled?)
-
-To attempt to schedule a goal, first mode-check the goal. If mode-checking
-succeeds, then scheduling succeeds. If mode-checking would report
-an error due to the binding of a local variable, then scheduling
-fails. (If mode-checking would report an error due to the binding of
-a *local* variable, we could report the error right away --
-but this idea has not yet been implemented.)
-
-Note that the notion of liveness used here is different to that
-used in liveness.m and the code generator. Here, we consider
-a variable live if its value will be used later on in the computation.
-
-******************************************/
-
+%
+% To mode-analyse a procedure:
+% 1. Initialize the insts of the head variables.
+% 2. Mode-analyse the goal.
+% 3. a. If we're doing mode-checking:
+% Check that the final insts of the head variables
+% matches that specified in the mode declaration
+% b. If we're doing mode-inference:
+% Normalise the final insts of the head variables,
+% record the newly inferred normalised final insts
+% in the proc_info, and check whether they changed
+% (so that we know when we've reached the fixpoint).
+%
+% To mode-analyse a goal:
+% If goal is
+% (a) a disjunction
+% Mode-analyse the sub-goals;
+% check that the final insts of all the non-local
+% variables are the same for all the sub-goals.
+% (b) a conjunction
+% Attempt to schedule each sub-goal. If a sub-goal can
+% be scheduled, then schedule it, otherwise delay it.
+% Continue with the remaining sub-goals until there are
+% no goals left. Every time a variable gets bound,
+% see whether we should wake up a delayed goal,
+% and if so, wake it up next time we get back to
+% the conjunction. If there are still delayed goals
+% hanging around at the end of the conjunction,
+% report a mode error.
+% (c) a negation
+% Mode-check the sub-goal.
+% Check that the sub-goal does not further instantiate
+% any non-local variables. (Actually, rather than
+% doing this check after we mode-analyse the subgoal,
+% we instead "lock" the non-local variables, and
+% disallow binding of locked variables.)
+% (d) a unification
+% Check that the unification doesn't attempt to unify
+% two free variables (or in general two free sub-terms)
+% unless one of them is dead. Split unifications
+% up if necessary to avoid complicated sub-unifications.
+% We also figure out at this point whether or not each
+% unification can fail.
+% (e) a predicate call
+% Check that there is a mode declaration for the
+% predicate which matches the current instantiation of
+% the arguments. (Also handle calls to implied modes.)
+% If the called predicate is one for which we must infer
+% the modes, then create a new mode for the called predicate
+% whose initial insts are the result of normalising
+% the current inst of the arguments.
+% (f) an if-then-else
+% Attempt to schedule the condition. If successful,
+% then check that it doesn't further instantiate any
+% non-local variables, mode-check the `then' part
+% and the `else' part, and then check that the final
+% insts match. (Perhaps also think about expanding
+% if-then-elses so that they can be run backwards,
+% if the condition can't be scheduled?)
+%
+% To attempt to schedule a goal, first mode-check the goal. If mode-checking
+% succeeds, then scheduling succeeds. If mode-checking would report
+% an error due to the binding of a local variable, then scheduling
+% fails. (If mode-checking would report an error due to the binding of
+% a *local* variable, we could report the error right away --
+% but this idea has not yet been implemented.)
+%
+% Note that the notion of liveness used here is different to that
+% used in liveness.m and the code generator. Here, we consider
+% a variable live if its value will be used later on in the computation.
+%
% XXX we ought to allow unification of free with free even when both
% *variables* are live, if one of the particular *sub-nodes* is
% dead (causes problems handling e.g. `list__same_length').
-
+%
% XXX we ought to break unifications into "micro-unifications", because
% some code can't be scheduled without splitting up unifications.
% For example, `p(X) :- X = f(A, B), B is A + 1.', where
@@ -135,7 +132,6 @@
:- import_module hlds__hlds_module.
:- import_module hlds__hlds_pred.
:- import_module hlds__instmap.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module bool, list, io, std_util.
@@ -191,7 +187,6 @@
% The following predicates are used by unique_modes.m.
:- import_module check_hlds__mode_info.
-:- import_module hlds__hlds_data.
% Modecheck a unification.
@@ -358,6 +353,7 @@
:- import_module libs__options.
:- import_module parse_tree__mercury_to_mercury.
:- import_module parse_tree__module_qual.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
:- import_module int, set, term, varset.
Index: module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.91
diff -u -b -r1.91 module_qual.m
--- module_qual.m 9 Jun 2004 07:56:14 -0000 1.91
+++ module_qual.m 12 Jun 2004 11:30:27 -0000
@@ -114,12 +114,8 @@
:- implementation.
:- import_module check_hlds__type_util.
-:- import_module hlds__hlds_data. % for cons_id.
-:- import_module hlds__hlds_out.
-:- import_module hlds__instmap.
:- import_module libs__globals.
:- import_module libs__options.
-:- import_module parse_tree__inst.
:- import_module parse_tree__mercury_to_mercury.
:- import_module parse_tree__modules.
:- import_module parse_tree__prog_io.
Index: modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.302
diff -u -b -r1.302 modules.m
--- modules.m 9 Jun 2004 07:56:14 -0000 1.302
+++ modules.m 12 Jun 2004 16:53:58 -0000
@@ -41,7 +41,6 @@
:- interface.
-:- import_module backend_libs__foreign.
:- import_module libs__globals.
:- import_module libs__timestamp.
:- import_module parse_tree__prog_data.
@@ -765,10 +764,8 @@
:- implementation.
-:- import_module backend_libs__c_util.
:- import_module backend_libs__foreign.
:- import_module backend_libs__name_mangle.
-:- import_module hlds__passes_aux.
:- import_module libs__handle_options.
:- import_module libs__options.
:- import_module make. % XXX undesirable dependency
Index: optimize.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/optimize.m,v
retrieving revision 1.42
diff -u -b -r1.42 optimize.m
--- optimize.m 23 May 2004 23:14:33 -0000 1.42
+++ optimize.m 12 Jun 2004 10:05:08 -0000
@@ -48,6 +48,7 @@
:- import_module ll_backend__reassign.
:- import_module ll_backend__use_local_vars.
:- import_module ll_backend__wrap_blocks.
+:- import_module parse_tree__prog_out.
:- import_module bool, int, string.
:- import_module map, set, std_util, require, counter.
Index: options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.426
diff -u -b -r1.426 options.m
Index: options_file.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options_file.m,v
retrieving revision 1.21
diff -u -b -r1.21 options_file.m
Index: par_conj_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/par_conj_gen.m,v
retrieving revision 1.16
diff -u -b -r1.16 par_conj_gen.m
--- par_conj_gen.m 10 Apr 2004 10:33:01 -0000 1.16
+++ par_conj_gen.m 12 Jun 2004 10:05:08 -0000
@@ -123,7 +123,6 @@
:- import_module ll_backend__code_info.
:- import_module ll_backend__code_util.
:- import_module ll_backend__continuation_info.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module bool, int, list, set, map, std_util, require.
Index: parse_tree.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/parse_tree.m,v
retrieving revision 1.6
diff -u -b -r1.6 parse_tree.m
--- parse_tree.m 23 Mar 2004 10:52:10 -0000 1.6
+++ parse_tree.m 12 Jun 2004 13:00:11 -0000
@@ -15,14 +15,11 @@
:- interface.
:- import_module libs.
-:- import_module hlds. % XXX for hlds_data__cons_id
:- import_module backend_libs. % XXX for `foreign'
:- import_module recompilation.
% The parse tree data type itself.
:- include_module prog_data.
-:- include_module (inst).
- % XXX inst uses hlds_data__cons_id
% The parser.
:- include_module prog_io.
@@ -37,6 +34,7 @@
:- include_module prog_out.
% Utility routines.
+:- include_module prog_mode.
:- include_module prog_util.
:- include_module error_util.
@@ -53,12 +51,10 @@
% :- include_module intermod.
% :- include_module trans_opt.
-% :- implementation.
+%-----------------------------------------------------------------------------%
% XXX lots of stuff uses hlds_data__type_id and type_util.m.
% XXX modules.m uses llds_out for the init names.
-
-%-----------------------------------------------------------------------------%
:- implementation.
Index: passes_aux.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/passes_aux.m,v
retrieving revision 1.61
diff -u -b -r1.61 passes_aux.m
--- passes_aux.m 14 May 2004 08:40:26 -0000 1.61
+++ passes_aux.m 12 Jun 2004 15:07:39 -0000
@@ -132,13 +132,6 @@
:- pred write_proc_progress_message(string::in, pred_id::in, proc_id::in,
module_info::in, io::di, io::uo) is det.
-:- pred maybe_report_stats(bool::in, io::di, io::uo) is det.
-:- pred maybe_write_string(bool::in, string::in, io::di, io::uo) is det.
-:- pred maybe_flush_output(bool::in, io::di, io::uo) is det.
-
-:- pred report_error(string::in, io::di, io::uo) is det.
-:- pred report_error(io__output_stream::in, string::in, io::di, io::uo) is det.
-
:- pred maybe_report_sizes(module_info::in, io::di, io::uo) is det.
% Prints the id of the given procedure via report_pred_name_mode,
@@ -247,7 +240,9 @@
:- import_module libs__options.
:- import_module libs__process_util.
:- import_module parse_tree__mercury_to_mercury.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_util.
:- import_module int, string, map, require, varset.
@@ -410,26 +405,6 @@
;
[]
).
-
-maybe_report_stats(yes) --> io__report_stats.
-maybe_report_stats(no) --> [].
-
-maybe_write_string(yes, String) --> io__write_string(String).
-maybe_write_string(no, _) --> [].
-
-maybe_flush_output(yes) --> io__flush_output.
-maybe_flush_output(no) --> [].
-
-report_error(ErrorMessage) -->
- io__write_string("Error: "),
- io__write_string(ErrorMessage),
- io__write_string("\n"),
- io__set_exit_status(1).
-
-report_error(Stream, ErrorMessage) -->
- io__set_output_stream(Stream, OldStream),
- report_error(ErrorMessage),
- io__set_output_stream(OldStream, _).
:- pred passes_aux__handle_errors(int::in, int::in,
module_info::in, module_info::out, io::di, io::uo) is det.
Index: pd_cost.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_cost.m,v
retrieving revision 1.19
diff -u -b -r1.19 pd_cost.m
Index: pd_debug.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_debug.m,v
retrieving revision 1.9
diff -u -b -r1.9 pd_debug.m
Index: pd_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_info.m,v
retrieving revision 1.12
diff -u -b -r1.12 pd_info.m
--- pd_info.m 24 Oct 2003 06:17:45 -0000 1.12
+++ pd_info.m 12 Jun 2004 10:05:09 -0000
@@ -13,7 +13,6 @@
:- interface.
-:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- import_module hlds__hlds_module.
:- import_module hlds__hlds_pred.
@@ -168,6 +167,7 @@
:- import_module check_hlds__det_util.
:- import_module check_hlds__inst_match.
+:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- import_module hlds__hlds_pred.
:- import_module libs__globals.
Index: pd_term.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_term.m,v
retrieving revision 1.7
diff -u -b -r1.7 pd_term.m
--- pd_term.m 5 Nov 2003 03:17:42 -0000 1.7
+++ pd_term.m 12 Jun 2004 10:05:09 -0000
@@ -93,7 +93,6 @@
:- import_module check_hlds__mode_util.
:- import_module hlds__hlds_pred.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module transform_hlds__pd_util.
Index: pd_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_util.m,v
retrieving revision 1.31
diff -u -b -r1.31 pd_util.m
--- pd_util.m 28 Nov 2003 02:23:07 -0000 1.31
+++ pd_util.m 12 Jun 2004 10:05:09 -0000
@@ -18,7 +18,6 @@
:- import_module hlds__hlds_goal.
:- import_module hlds__hlds_module.
:- import_module hlds__hlds_pred.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module transform_hlds__pd_info.
@@ -152,7 +151,6 @@
:- import_module hlds__instmap.
:- import_module hlds__quantification.
:- import_module libs__options.
-:- import_module parse_tree__inst.
:- import_module transform_hlds__constraint.
:- import_module transform_hlds__pd_cost.
:- import_module transform_hlds__pd_debug.
Index: polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.252
diff -u -b -r1.252 polymorphism.m
--- polymorphism.m 7 Jun 2004 09:07:02 -0000 1.252
+++ polymorphism.m 12 Jun 2004 14:25:17 -0000
@@ -354,8 +354,8 @@
:- import_module hlds__quantification.
:- import_module libs__globals.
:- import_module libs__options.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_io.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
@@ -1260,13 +1260,15 @@
% check if variable has a higher-order type
type_is_higher_order(TypeOfX, Purity, _PredOrFunc,
EvalMethod, CalleeArgTypes),
- ConsId0 = pred_const(PredId, ProcId, _)
+ ConsId0 = pred_const(ShroudedPredProcId, _)
->
%
% convert the higher-order pred term to a lambda goal
%
poly_info_get_varset(!.Info, VarSet0),
goal_info_get_context(GoalInfo0, Context),
+ proc(PredId, ProcId) =
+ unshroud_pred_proc_id(ShroudedPredProcId),
convert_pred_to_lambda_goal(Purity, EvalMethod,
X0, PredId, ProcId, ArgVars0, CalleeArgTypes,
UnifyContext, GoalInfo0, Context, ModuleInfo0,
Index: post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.63
diff -u -b -r1.63 post_typecheck.m
--- post_typecheck.m 5 Apr 2004 05:07:42 -0000 1.63
+++ post_typecheck.m 12 Jun 2004 14:25:49 -0000
@@ -31,7 +31,6 @@
:- module check_hlds__post_typecheck.
:- interface.
-:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- import_module hlds__hlds_module.
:- import_module hlds__hlds_pred.
@@ -101,8 +100,8 @@
---> aditi_update_of_derived_relation(prog_context,
aditi_builtin, simple_call_id).
-:- pred report_aditi_builtin_error(aditi_builtin_error, io__state, io__state).
-:- mode report_aditi_builtin_error(in, di, uo) is det.
+:- pred report_aditi_builtin_error(aditi_builtin_error::in, io::di, io::uo)
+ is det.
% Work out whether a var-functor unification is actually a function
% call. If so, replace the unification goal with a call.
@@ -125,13 +124,14 @@
:- import_module check_hlds__typecheck.
:- import_module hlds__assertion.
:- import_module hlds__goal_util.
+:- import_module hlds__hlds_data.
:- import_module hlds__hlds_out.
:- import_module hlds__special_pred.
:- import_module libs__globals.
:- import_module libs__options.
:- import_module parse_tree__error_util.
-:- import_module parse_tree__inst.
:- import_module parse_tree__mercury_to_mercury.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
@@ -645,7 +645,7 @@
prog_out__write_context(Context),
io__write_string(" error: the modified "),
{ CallId = PredOrFunc - _ },
- hlds_out__write_pred_or_func(PredOrFunc),
+ write_pred_or_func(PredOrFunc),
io__write_string(" is not a base relation.\n").
%-----------------------------------------------------------------------------%
@@ -1234,7 +1234,9 @@
PredOrFunc, TVarSet, AllArgTypes, ModuleInfo, PredId)
->
get_proc_id(ModuleInfo, PredId, ProcId),
- ConsId = pred_const(PredId, ProcId, EvalMethod),
+ ShroudedPredProcId =
+ shroud_pred_proc_id(proc(PredId, ProcId)),
+ ConsId = pred_const(ShroudedPredProcId, EvalMethod),
Goal = unify(X0, functor(ConsId, no, ArgVars0), Mode0,
Unification0, UnifyContext) - GoalInfo0
;
Index: proc_label.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/proc_label.m,v
retrieving revision 1.6
diff -u -b -r1.6 proc_label.m
Index: process_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/process_util.m,v
retrieving revision 1.11
diff -u -b -r1.11 process_util.m
Index: prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.109
diff -u -b -r1.109 prog_data.m
--- prog_data.m 9 Jun 2004 07:56:15 -0000 1.109
+++ prog_data.m 12 Jun 2004 17:48:33 -0000
@@ -18,13 +18,8 @@
:- interface.
-% This module should NOT import hlds*.m, either directly or indirectly.
-% Any types which are needed in both the parse tree and in the HLDS
-% should be defined here, rather than in hlds*.m.
-
:- import_module libs__globals.
:- import_module libs__options.
-:- import_module parse_tree__inst.
:- import_module recompilation.
:- import_module bool, list, assoc_list, map, set, varset, term, std_util.
@@ -726,6 +721,16 @@
; share
; automatic.
+:- type foreign_import_module_info == list(foreign_import_module).
+ % in reverse order
+
+:- type foreign_import_module
+ ---> foreign_import_module(
+ foreign_language,
+ module_name,
+ prog_context
+ ).
+
%-----------------------------------------------------------------------------%
%
% Stuff for type classes
@@ -758,6 +763,8 @@
).
:- type class_name == sym_name.
+:- type class_id
+ ---> class_id(class_name, arity).
:- type class_interface
---> abstract
@@ -1015,6 +1022,89 @@
:- type prog_context == term__context.
+%-----------------------------------------------------------------------------%
+%
+% Cons ids
+%
+
+ % The representation of cons_ids below is a compromise. The cons_id
+ % type must be defined here, in a submodule of parse_tree.m, because
+ % it is a component of insts. However, after the program has been read
+ % in, the cons_ids cons, int_const, string_const and float_const,
+ % which can appear in user programs, may also be augmented by the other
+ % cons_ids, which can only be generated by the compiler.
+ %
+ % The problem is that some of these compiler generated cons_ids
+ % refer to procedures, and the natural method of identifying
+ % procedures requires the types pred_id and proc_id, defined
+ % in hlds_pred.m, which we don't want to import here.
+ %
+ % We could try to avoid this problem using two different types
+ % for cons_ids, one defined here for use in the parse tree and one
+ % defined in hlds_data.m for use in the HLDS. We could distinguish
+ % the two by having the HLDS cons_id have a definition such as
+ % hlds_cons_id ---> parse_cons_id(parse_cons_id) ; ...
+ % or, alternatively, by making cons_id parametric in the type of
+ % constants, and substitute different constant types (since all the
+ % cons_ids that refer to HLDS concepts are constants).
+ %
+ % Using two different types requires a translation from one to the
+ % other. While the runtime cost would be acceptable, the cost in code
+ % complexity isn't, since the translation isn't confined to
+ % make_hlds.m. (I found this out the hard way.) This is especially so
+ % if we want to use in each case only the tightest possible type.
+ % For example, while construct goals can involve all cons_ids,
+ % deconstruct goals and switches can currently involve only the
+ % cons_ids that can appear in parse trees.
+ %
+ % The solution we have chosen is to exploit the fact that pred_ids
+ % and proc_ids are integers. Those types are private to hlds_pred.m,
+ % but hlds_pred.m also contains functions for translating them to and
+ % from the shrouded versions defined below. The next three types are
+ % designed to be used in only two ways: for translation to their HLDS
+ % equivalents by the unshroud functions in hlds_pred.m, and for
+ % printing for diagnostics.
+
+:- type shrouded_pred_id ---> shrouded_pred_id(int).
+:- type shrouded_proc_id ---> shrouded_proc_id(int).
+:- type shrouded_pred_proc_id ---> shrouded_pred_proc_id(int, int).
+
+:- type cons_id
+ ---> cons(sym_name, arity) % name, arity
+ % Tuples have cons_id `cons(unqualified("{}"), Arity)'.
+
+ ; int_const(int)
+ ; string_const(string)
+ ; float_const(float)
+ ; pred_const(shrouded_pred_proc_id, lambda_eval_method)
+ % Note that a pred_const represents a closure,
+ % not just a code address.
+ ; type_ctor_info_const(module_name, string, int)
+ % module name, type name, type arity
+ ; base_typeclass_info_const(module_name, class_id, int, string)
+ % module name of instance declaration
+ % (not filled in so that link errors result
+ % from overlapping instances),
+ % class name and arity,
+ % class instance, a string encoding the type
+ % names and arities of the arguments to the
+ % instance declaration
+ ; type_info_cell_constructor(type_ctor)
+ ; typeclass_info_cell_constructor
+ ; tabling_pointer_const(shrouded_pred_proc_id)
+ % The address of the static variable
+ % that points to the table that implements
+ % memoization, loop checking or the minimal
+ % model semantics for the given procedure.
+ ; deep_profiling_proc_layout(shrouded_pred_proc_id)
+ % The Proc_Layout structure of a procedure. Its proc_static
+ % field is used by deep profiling, as documented in the deep
+ % profiling paper.
+ ; table_io_decl(shrouded_pred_proc_id).
+ % The address of a structure that describes
+ % the layout of the answer block used by
+ % I/O tabling for declarative debugging.
+
% Describe how a lambda expression is to be evaluated.
%
% `normal' is the top-down Mercury execution algorithm.
@@ -1156,13 +1246,88 @@
% type terms (see above), we need a separate data structure for inst
% terms.
- % The `inst' data type itself is defined in the module `inst.m'.
+:- type (inst)
+ ---> any(uniqueness)
+ ; free
+ ; free(type)
+ ; bound(uniqueness, list(bound_inst))
+ % The list(bound_inst) must be sorted
+ ; ground(uniqueness, ground_inst_info)
+ % The ground_inst_info holds extra information
+ % about the ground inst.
+ ; not_reached
+ ; inst_var(inst_var)
+ % constrained_inst_vars is a set of inst
+ % variables that are constrained to have the
+ % same uniqueness as and to match_final the
+ % specified inst.
+ ; constrained_inst_vars(set(inst_var), inst)
+ % A defined_inst is possibly recursive
+ % inst whose value is stored in the
+ % inst_table. This is used both for
+ % user-defined insts and for
+ % compiler-generated insts.
+ ; defined_inst(inst_name)
+ % An abstract inst is a defined inst which
+ % has been declared but not actually been
+ % defined (yet).
+ ; abstract_inst(sym_name, list(inst)).
+
+:- type uniqueness
+ ---> shared % there might be other references
+ ; unique % there is only one reference
+ ; mostly_unique % there is only one reference
+ % but there might be more on
+ % backtracking
+ ; clobbered % this was the only reference, but
+ % the data has already been reused
+ ; mostly_clobbered.
+ % this was the only reference, but
+ % the data has already been reused;
+ % however, there may be more references
+ % on backtracking, so we will need to
+ % restore the old value on backtracking
+
+ % The ground_inst_info type gives extra information about ground insts.
+:- type ground_inst_info
+ ---> higher_order(pred_inst_info)
+ % The ground inst is higher-order.
+ ; none.
+ % No extra information is available.
+
+ % higher-order predicate terms are given the inst
+ % `ground(shared, higher_order(PredInstInfo))'
+ % where the PredInstInfo contains the extra modes and the determinism
+ % for the predicate. Note that the higher-order predicate term
+ % itself must be ground.
+
+:- type pred_inst_info
+ ---> pred_inst_info(
+ pred_or_func, % is this a higher-order func
+ % mode or a higher-order pred
+ % mode?
+ list(mode), % the modes of the additional
+ % (i.e. not-yet-supplied)
+ % arguments of the pred;
+ % for a function, this includes
+ % the mode of the return value
+ % as the last element of the
+ % list.
+ determinism % the determinism of the
+ % predicate or function
+ ).
+
+:- type inst_id == pair(sym_name, arity).
+
+:- type bound_inst ---> functor(cons_id, list(inst)).
:- type inst_var_type ---> inst_var_type.
:- type inst_var == var(inst_var_type).
:- type inst_term == term(inst_var_type).
:- type inst_varset == varset(inst_var_type).
+:- type inst_var_sub == map(inst_var, inst).
+
% inst_defn/3 defined above
:- type inst_defn
@@ -1224,6 +1389,8 @@
:- type unify_is_real
---> real_unify
; fake_unify.
+
+:- type mode_id == pair(sym_name, arity).
% mode_defn/3 defined above
Index: prog_io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.225
diff -u -b -r1.225 prog_io.m
--- prog_io.m 31 Oct 2003 03:27:27 -0000 1.225
+++ prog_io.m 12 Jun 2004 10:05:09 -0000
@@ -56,7 +56,6 @@
:- interface.
:- import_module libs__timestamp.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_io_util.
@@ -274,13 +273,19 @@
:- implementation.
-:- import_module parse_tree__prog_io_goal, parse_tree__prog_io_dcg.
-:- import_module parse_tree__prog_io_pragma, parse_tree__prog_io_util.
-:- import_module parse_tree__prog_io_typeclass, parse_tree__modules.
-:- import_module hlds__hlds_data, hlds__hlds_pred, parse_tree__prog_util.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module parse_tree__modules.
+:- import_module parse_tree__modules.
+:- import_module parse_tree__prog_io_dcg.
+:- import_module parse_tree__prog_io_goal.
+:- import_module parse_tree__prog_io_pragma.
+:- import_module parse_tree__prog_io_typeclass.
+:- import_module parse_tree__prog_io_util.
:- import_module parse_tree__prog_out.
-:- import_module libs__globals, libs__options.
-:- import_module parse_tree__modules, recompilation, recompilation__version.
+:- import_module parse_tree__prog_util.
+:- import_module recompilation.
+:- import_module recompilation__version.
:- import_module int, string, std_util, parser, term_io, dir, require.
:- import_module assoc_list, map, time, set.
Index: prog_io_dcg.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_dcg.m,v
retrieving revision 1.24
diff -u -b -r1.24 prog_io_dcg.m
--- prog_io_dcg.m 12 Jan 2004 06:45:50 -0000 1.24
+++ prog_io_dcg.m 12 Jun 2004 11:20:18 -0000
@@ -38,10 +38,10 @@
:- implementation.
-:- import_module check_hlds__purity.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_io_goal.
:- import_module parse_tree__prog_util.
+:- import_module parse_tree__prog_out.
:- import_module int, map, string, std_util, list, counter.
Index: prog_io_goal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_goal.m,v
retrieving revision 1.27
diff -u -b -r1.27 prog_io_goal.m
--- prog_io_goal.m 23 Mar 2004 10:52:11 -0000 1.27
+++ prog_io_goal.m 12 Jun 2004 13:56:05 -0000
@@ -97,10 +97,10 @@
:- implementation.
-:- import_module check_hlds__mode_util.
-:- import_module check_hlds__purity.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_io_util.
+:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_out.
:- import_module term.
:- import_module int, map, string, std_util.
Index: prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.67
diff -u -b -r1.67 prog_io_pragma.m
Index: prog_io_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.29
diff -u -b -r1.29 prog_io_typeclass.m
--- prog_io_typeclass.m 5 Nov 2003 03:17:42 -0000 1.29
+++ prog_io_typeclass.m 12 Jun 2004 11:33:16 -0000
@@ -14,7 +14,6 @@
:- interface.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_io_util.
@@ -44,7 +43,6 @@
:- implementation.
:- import_module check_hlds__type_util.
-:- import_module hlds__hlds_pred.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_io_goal.
:- import_module parse_tree__prog_util.
Index: prog_io_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_util.m,v
retrieving revision 1.29
diff -u -b -r1.29 prog_io_util.m
--- prog_io_util.m 19 Mar 2004 10:19:24 -0000 1.29
+++ prog_io_util.m 12 Jun 2004 11:08:09 -0000
@@ -23,7 +23,6 @@
:- interface.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module list, map, std_util, term.
@@ -140,10 +139,6 @@
:- implementation.
-% XXX we should not need to import hlds*.m here.
-% But currently we need to import hlds_data.m for the `cons_id' type
-% that is used in insts.
-:- import_module hlds__hlds_data.
:- import_module libs__globals.
:- import_module libs__options.
:- import_module parse_tree__prog_io.
Index: prog_mode.m
===================================================================
RCS file: prog_mode.m
diff -N prog_mode.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ prog_mode.m 12 Jun 2004 14:08:57 -0000
@@ -0,0 +1,579 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2004 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% Main author: fjh.
+%
+% Utility predicates dealing with modes and insts that do not require access
+% to the HLDS. (The predicates that do are in mode_util.m.)
+
+:- module parse_tree__prog_mode.
+
+:- interface.
+
+:- import_module parse_tree__prog_data.
+
+:- import_module list.
+
+ % Construct a mode corresponding to the standard
+ % `in', `out', `uo' or `unused' mode.
+:- pred in_mode((mode)::out) is det.
+:- func in_mode = (mode).
+:- pred out_mode((mode)::out) is det.
+:- func out_mode = (mode).
+:- pred uo_mode((mode)::out) is det.
+:- func uo_mode = (mode).
+:- pred unused_mode((mode)::out) is det.
+:- func unused_mode = (mode).
+
+:- func ground_inst = (inst).
+:- func free_inst = (inst).
+
+ % Construct the modes used for `aditi__state' arguments.
+ % XXX These should be unique, but are not yet because that
+ % would require alias tracking.
+:- func aditi_mui_mode = (mode).
+:- func aditi_ui_mode = (mode).
+:- func aditi_di_mode = (mode).
+:- func aditi_uo_mode = (mode).
+
+:- pred make_std_mode(string::in, list(inst)::in, (mode)::out) is det.
+:- func make_std_mode(string, list(inst)) = (mode).
+
+%-----------------------------------------------------------------------------%
+
+ % mode_substitute_arg_list(Mode0, Params, Args, Mode) is true
+ % iff Mode is the mode that results from substituting all
+ % occurrences of Params in Mode0 with the corresponding
+ % value in Args.
+
+:- pred mode_substitute_arg_list((mode)::in, list(inst_var)::in,
+ list(inst)::in, (mode)::out) is det.
+
+ % inst_lists_to_mode_list(InitialInsts, FinalInsts, Modes):
+ % Given two lists of corresponding initial and final
+ % insts, return a list of modes which maps from the
+ % initial insts to the final insts.
+:- pred inst_lists_to_mode_list(list(inst)::in, list(inst)::in,
+ list(mode)::out) is det.
+
+:- pred insts_to_mode((inst)::in, (inst)::in, (mode)::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+ % inst_substitute_arg_list(Inst0, Params, Args, Inst) is true
+ % iff Inst is the inst that results from substituting all
+ % occurrences of Params in Inst0 with the corresponding
+ % value in Args.
+
+:- pred inst_substitute_arg_list((inst)::in, list(inst_var)::in,
+ list(inst)::in, (inst)::out) is det.
+
+ % inst_list_apply_substitution(Insts0, Subst, Insts) is true
+ % iff Inst is the inst that results from applying Subst to Insts0.
+
+:- pred inst_list_apply_substitution(list(inst)::in, inst_var_sub::in,
+ list(inst)::out) is det.
+
+ % mode_list_apply_substitution(Modes0, Subst, Modes) is true
+ % iff Mode is the mode that results from applying Subst to Modes0.
+
+:- pred mode_list_apply_substitution(list(mode)::in, inst_var_sub::in,
+ list(mode)::out) is det.
+
+:- pred rename_apart_inst_vars(inst_varset::in, inst_varset::in,
+ list(mode)::in, list(mode)::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+ % Given an expanded inst and a cons_id and its arity, return the
+ % insts of the arguments of the top level functor, failing if the
+ % inst could not be bound to the functor.
+:- pred get_arg_insts((inst)::in, cons_id::in, arity::in, list(inst)::out)
+ is semidet.
+
+ % Given a list of bound_insts, get the corresponding list of cons_ids
+ %
+:- pred functors_to_cons_ids(list(bound_inst)::in, list(cons_id)::out) is det.
+
+:- pred mode_id_to_int(mode_id::in, int::out) is det.
+
+ % Predicates to make error messages more readable by stripping
+ % "builtin:" module qualifiers from modes.
+
+:- pred strip_builtin_qualifier_from_cons_id(cons_id::in, cons_id::out) is det.
+
+:- pred strip_builtin_qualifiers_from_mode_list(list(mode)::in,
+ list(mode)::out) is det.
+
+:- pred strip_builtin_qualifiers_from_inst_list(list(inst)::in,
+ list(inst)::out) is det.
+
+:- pred strip_builtin_qualifiers_from_inst((inst)::in, (inst)::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module parse_tree__prog_util.
+
+:- import_module map, set, require, std_util, varset, term.
+
+in_mode(in_mode).
+out_mode(out_mode).
+uo_mode(uo_mode).
+unused_mode(unused_mode).
+
+in_mode = make_std_mode("in", []).
+out_mode = make_std_mode("out", []).
+uo_mode = make_std_mode("uo", []).
+unused_mode = make_std_mode("unused", []).
+
+aditi_mui_mode = Mode :- in_mode(Mode).
+aditi_ui_mode = Mode :- in_mode(Mode).
+aditi_di_mode = Mode :- in_mode(Mode).
+aditi_uo_mode = Mode :- out_mode(Mode).
+
+ground_inst = ground(shared, none).
+free_inst = free.
+
+make_std_mode(Name, Args, make_std_mode(Name, Args)).
+
+make_std_mode(Name, Args) = Mode :-
+ mercury_public_builtin_module(MercuryBuiltin),
+ QualifiedName = qualified(MercuryBuiltin, Name),
+ Mode = user_defined_mode(QualifiedName, Args).
+
+%-----------------------------------------------------------------------------%
+
+inst_lists_to_mode_list([], [_|_], _) :-
+ error("inst_lists_to_mode_list: length mis-match").
+inst_lists_to_mode_list([_|_], [], _) :-
+ error("inst_lists_to_mode_list: length mis-match").
+inst_lists_to_mode_list([], [], []).
+inst_lists_to_mode_list([Initial|Initials], [Final|Finals], [Mode|Modes]) :-
+ insts_to_mode(Initial, Final, Mode),
+ inst_lists_to_mode_list(Initials, Finals, Modes).
+
+insts_to_mode(Initial, Final, Mode) :-
+ %
+ % Use some abbreviations.
+ % This is just to make error messages and inferred modes
+ % more readable.
+ %
+ ( Initial = free, Final = ground(shared, none) ->
+ make_std_mode("out", [], Mode)
+ ; Initial = free, Final = ground(unique, none) ->
+ make_std_mode("uo", [], Mode)
+ ; Initial = free, Final = ground(mostly_unique, none) ->
+ make_std_mode("muo", [], Mode)
+ ; Initial = ground(shared, none), Final = ground(shared, none) ->
+ make_std_mode("in", [], Mode)
+ ; Initial = ground(unique, none), Final = ground(clobbered, none) ->
+ make_std_mode("di", [], Mode)
+ ; Initial = ground(mostly_unique, none),
+ Final = ground(mostly_clobbered, none) ->
+ make_std_mode("mdi", [], Mode)
+ ; Initial = ground(unique, none), Final = ground(unique, none) ->
+ make_std_mode("ui", [], Mode)
+ ; Initial = ground(mostly_unique, none),
+ Final = ground(mostly_unique, none) ->
+ make_std_mode("mdi", [], Mode)
+ ; Initial = free ->
+ make_std_mode("out", [Final], Mode)
+ ; Final = ground(clobbered, none) ->
+ make_std_mode("di", [Initial], Mode)
+ ; Initial = Final ->
+ make_std_mode("in", [Initial], Mode)
+ ;
+ Mode = (Initial -> Final)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+mode_substitute_arg_list(Mode0, Params, Args, Mode) :-
+ ( Params = [] ->
+ Mode = Mode0 % optimize common case
+ ;
+ map__from_corresponding_lists(Params, Args, Subst),
+ mode_apply_substitution(Mode0, Subst, Mode)
+ ).
+
+inst_substitute_arg_list(Inst0, Params, Args, Inst) :-
+ ( Params = [] ->
+ Inst = Inst0 % optimize common case
+ ;
+ map__from_corresponding_lists(Params, Args, Subst),
+ inst_apply_substitution(Inst0, Subst, Inst)
+ ).
+
+ % mode_apply_substitution(Mode0, Subst, Mode) is true iff
+ % Mode is the mode that results from apply Subst to Mode0.
+
+:- pred mode_apply_substitution((mode)::in, inst_var_sub::in, (mode)::out)
+ is det.
+
+mode_apply_substitution((I0 -> F0), Subst, (I -> F)) :-
+ inst_apply_substitution(I0, Subst, I),
+ inst_apply_substitution(F0, Subst, F).
+mode_apply_substitution(user_defined_mode(Name, Args0), Subst,
+ user_defined_mode(Name, Args)) :-
+ inst_list_apply_substitution_2(Args0, Subst, Args).
+
+inst_list_apply_substitution(Insts0, Subst, Insts) :-
+ ( map__is_empty(Subst) ->
+ Insts = Insts0
+ ;
+ inst_list_apply_substitution_2(Insts0, Subst, Insts)
+ ).
+
+:- pred inst_list_apply_substitution_2(list(inst)::in, inst_var_sub::in,
+ list(inst)::out) is det.
+
+inst_list_apply_substitution_2([], _, []).
+inst_list_apply_substitution_2([A0 | As0], Subst, [A | As]) :-
+ inst_apply_substitution(A0, Subst, A),
+ inst_list_apply_substitution_2(As0, Subst, As).
+
+ % inst_substitute_arg(Inst0, Subst, Inst) is true
+ % iff Inst is the inst that results from substituting all
+ % occurrences of Param in Inst0 with Arg.
+
+:- pred inst_apply_substitution((inst)::in, inst_var_sub::in, (inst)::out)
+ is det.
+
+inst_apply_substitution(any(Uniq), _, any(Uniq)).
+inst_apply_substitution(free, _, free).
+inst_apply_substitution(free(T), _, free(T)).
+inst_apply_substitution(ground(Uniq, GroundInstInfo0), Subst, Inst) :-
+ ground_inst_info_apply_substitution(GroundInstInfo0, Subst, Uniq, Inst).
+inst_apply_substitution(bound(Uniq, Alts0), Subst, bound(Uniq, Alts)) :-
+ alt_list_apply_substitution(Alts0, Subst, Alts).
+inst_apply_substitution(not_reached, _, not_reached).
+inst_apply_substitution(inst_var(Var), Subst, Result) :-
+ (
+ map__search(Subst, Var, Replacement)
+ ->
+ Result = Replacement
+ ;
+ Result = inst_var(Var)
+ ).
+inst_apply_substitution(constrained_inst_vars(Vars, Inst0), Subst, Result) :-
+ ( set__singleton_set(Vars, Var0) ->
+ Var = Var0
+ ;
+ error("inst_apply_substitution: multiple inst_vars found")
+ ),
+ (
+ map__search(Subst, Var, Replacement)
+ ->
+ Result = Replacement
+ % XXX Should probably have a sanity check here that
+ % Replacement =< Inst0
+ ;
+ inst_apply_substitution(Inst0, Subst, Result0),
+ Result = constrained_inst_vars(Vars, Result0)
+ ).
+inst_apply_substitution(defined_inst(InstName0), Subst,
+ defined_inst(InstName)) :-
+ ( inst_name_apply_substitution(InstName0, Subst, InstName1) ->
+ InstName = InstName1
+ ;
+ InstName = InstName0
+ ).
+inst_apply_substitution(abstract_inst(Name, Args0), Subst,
+ abstract_inst(Name, Args)) :-
+ inst_list_apply_substitution_2(Args0, Subst, Args).
+
+ % This predicate fails if the inst_name is not one of user_inst,
+ % typed_inst or typed_ground. The other types of inst_names are just
+ % used as keys in the inst_table so it does not make sense to apply
+ % substitutions to them.
+:- pred inst_name_apply_substitution(inst_name::in, inst_var_sub::in,
+ inst_name::out) is semidet.
+
+inst_name_apply_substitution(user_inst(Name, Args0), Subst,
+ user_inst(Name, Args)) :-
+ inst_list_apply_substitution_2(Args0, Subst, Args).
+inst_name_apply_substitution(typed_inst(T, Inst0), Subst,
+ typed_inst(T, Inst)) :-
+ inst_name_apply_substitution(Inst0, Subst, Inst).
+inst_name_apply_substitution(typed_ground(Uniq, T), _, typed_ground(Uniq, T)).
+
+:- pred alt_list_apply_substitution(list(bound_inst)::in, inst_var_sub::in,
+ list(bound_inst)::out) is det.
+
+alt_list_apply_substitution([], _, []).
+alt_list_apply_substitution([Alt0|Alts0], Subst, [Alt|Alts]) :-
+ Alt0 = functor(Name, Args0),
+ inst_list_apply_substitution_2(Args0, Subst, Args),
+ Alt = functor(Name, Args),
+ alt_list_apply_substitution(Alts0, Subst, Alts).
+
+:- pred ground_inst_info_apply_substitution(ground_inst_info::in,
+ inst_var_sub::in, uniqueness::in, (inst)::out) is det.
+
+ground_inst_info_apply_substitution(none, _, Uniq, ground(Uniq, none)).
+ground_inst_info_apply_substitution(GII0, Subst, Uniq, ground(Uniq, GII)) :-
+ GII0 = higher_order(pred_inst_info(PredOrFunc, Modes0, Det)),
+ mode_list_apply_substitution(Modes0, Subst, Modes),
+ GII = higher_order(pred_inst_info(PredOrFunc, Modes, Det)).
+
+mode_list_apply_substitution(Modes0, Subst, Modes) :-
+ ( map__is_empty(Subst) ->
+ Modes = Modes0
+ ;
+ mode_list_apply_substitution_2(Modes0, Subst, Modes)
+ ).
+
+:- pred mode_list_apply_substitution_2(list(mode)::in, inst_var_sub::in,
+ list(mode)::out) is det.
+
+mode_list_apply_substitution_2([], _, []).
+mode_list_apply_substitution_2([A0 | As0], Subst, [A | As]) :-
+ mode_apply_substitution(A0, Subst, A),
+ mode_list_apply_substitution_2(As0, Subst, As).
+
+%-----------------------------------------------------------------------------%
+
+rename_apart_inst_vars(VarSet, NewVarSet, Modes0, Modes) :-
+ varset__merge_subst(VarSet, NewVarSet, _, Sub),
+ list__map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes).
+
+:- pred rename_apart_inst_vars_in_mode(substitution(inst_var_type)::in,
+ (mode)::in, (mode)::out) is det.
+
+rename_apart_inst_vars_in_mode(Sub, I0 -> F0, I -> F) :-
+ rename_apart_inst_vars_in_inst(Sub, I0, I),
+ rename_apart_inst_vars_in_inst(Sub, F0, F).
+rename_apart_inst_vars_in_mode(Sub, user_defined_mode(Name, Insts0),
+ user_defined_mode(Name, Insts)) :-
+ list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts).
+
+:- pred rename_apart_inst_vars_in_inst(substitution(inst_var_type)::in,
+ (inst)::in, (inst)::out) is det.
+
+rename_apart_inst_vars_in_inst(_, any(U), any(U)).
+rename_apart_inst_vars_in_inst(_, free, free).
+rename_apart_inst_vars_in_inst(_, free(T), free(T)).
+rename_apart_inst_vars_in_inst(Sub, bound(U, BIs0), bound(U, BIs)) :-
+ list__map((pred(functor(C, Is0)::in, functor(C, Is)::out) is det :-
+ list__map(rename_apart_inst_vars_in_inst(Sub), Is0, Is)),
+ BIs0, BIs).
+rename_apart_inst_vars_in_inst(Sub, ground(U, GI0), ground(U, GI)) :-
+ (
+ GI0 = higher_order(pred_inst_info(PoF, Modes0, Det)),
+ list__map(rename_apart_inst_vars_in_mode(Sub), Modes0, Modes),
+ GI = higher_order(pred_inst_info(PoF, Modes, Det))
+ ;
+ GI0 = none,
+ GI = none
+ ).
+rename_apart_inst_vars_in_inst(_, not_reached, not_reached).
+rename_apart_inst_vars_in_inst(Sub, inst_var(Var0), inst_var(Var)) :-
+ ( map__search(Sub, Var0, term__variable(Var1)) ->
+ Var = Var1
+ ;
+ Var = Var0
+ ).
+rename_apart_inst_vars_in_inst(Sub, constrained_inst_vars(Vars0, Inst0),
+ constrained_inst_vars(Vars, Inst)) :-
+ rename_apart_inst_vars_in_inst(Sub, Inst0, Inst),
+ Vars = set__map(func(Var0) =
+ ( map__search(Sub, Var0, term__variable(Var)) ->
+ Var
+ ;
+ Var0
+ ), Vars0).
+rename_apart_inst_vars_in_inst(Sub, defined_inst(Name0), defined_inst(Name)) :-
+ ( rename_apart_inst_vars_in_inst_name(Sub, Name0, Name1) ->
+ Name = Name1
+ ;
+ Name = Name0
+ ).
+rename_apart_inst_vars_in_inst(Sub, abstract_inst(Sym, Insts0),
+ abstract_inst(Sym, Insts)) :-
+ list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts).
+
+:- pred rename_apart_inst_vars_in_inst_name(substitution(inst_var_type)::in,
+ inst_name::in, inst_name::out) is semidet.
+
+rename_apart_inst_vars_in_inst_name(Sub, user_inst(Sym, Insts0),
+ user_inst(Sym, Insts)) :-
+ list__map(rename_apart_inst_vars_in_inst(Sub), Insts0, Insts).
+rename_apart_inst_vars_in_inst_name(Sub, typed_inst(Type, Name0),
+ typed_inst(Type, Name)) :-
+ rename_apart_inst_vars_in_inst_name(Sub, Name0, Name).
+rename_apart_inst_vars_in_inst_name(_, typed_ground(U, T), typed_ground(U, T)).
+
+%-----------------------------------------------------------------------------%
+
+functors_to_cons_ids([], []).
+functors_to_cons_ids([Functor | Functors], [ConsId | ConsIds]) :-
+ Functor = functor(ConsId, _ArgInsts),
+ functors_to_cons_ids(Functors, ConsIds).
+
+%-----------------------------------------------------------------------------%
+
+get_arg_insts(not_reached, _ConsId, Arity, ArgInsts) :-
+ list__duplicate(Arity, not_reached, ArgInsts).
+get_arg_insts(ground(Uniq, _PredInst), _ConsId, Arity, ArgInsts) :-
+ list__duplicate(Arity, ground(Uniq, none), ArgInsts).
+get_arg_insts(bound(_Uniq, List), ConsId, Arity, ArgInsts) :-
+ ( get_arg_insts_2(List, ConsId, ArgInsts0) ->
+ ArgInsts = ArgInsts0
+ ;
+ % the code is unreachable
+ list__duplicate(Arity, not_reached, ArgInsts)
+ ).
+get_arg_insts(free, _ConsId, Arity, ArgInsts) :-
+ list__duplicate(Arity, free, ArgInsts).
+get_arg_insts(free(_Type), _ConsId, Arity, ArgInsts) :-
+ list__duplicate(Arity, free, ArgInsts).
+get_arg_insts(any(Uniq), _ConsId, Arity, ArgInsts) :-
+ list__duplicate(Arity, any(Uniq), ArgInsts).
+
+:- pred get_arg_insts_2(list(bound_inst)::in, cons_id::in, list(inst)::out)
+ is semidet.
+
+get_arg_insts_2([BoundInst | BoundInsts], ConsId, ArgInsts) :-
+ ( BoundInst = functor(ConsId, ArgInsts0) ->
+ ArgInsts = ArgInsts0
+ ;
+ get_arg_insts_2(BoundInsts, ConsId, ArgInsts)
+ ).
+
+ % In case we later decided to change the representation
+ % of mode_ids.
+
+mode_id_to_int(_ - X, X).
+
+%-----------------------------------------------------------------------------%
+
+ %
+ % Predicates to make error messages more readable by stripping
+ % "builtin:" module qualifiers from modes and insts.
+ % The interesting part is strip_builtin_qualifier_from_sym_name;
+ % the rest is basically just recursive traversals.
+ %
+
+strip_builtin_qualifiers_from_mode_list(Modes0, Modes) :-
+ list__map(strip_builtin_qualifiers_from_mode, Modes0, Modes).
+
+:- pred strip_builtin_qualifiers_from_mode((mode)::in, (mode)::out) is det.
+
+strip_builtin_qualifiers_from_mode((Initial0 -> Final0), (Initial -> Final)) :-
+ strip_builtin_qualifiers_from_inst(Initial0, Initial),
+ strip_builtin_qualifiers_from_inst(Final0, Final).
+
+strip_builtin_qualifiers_from_mode(user_defined_mode(SymName0, Insts0),
+ user_defined_mode(SymName, Insts)) :-
+ strip_builtin_qualifiers_from_inst_list(Insts0, Insts),
+ strip_builtin_qualifier_from_sym_name(SymName0, SymName).
+
+strip_builtin_qualifier_from_cons_id(ConsId0, ConsId) :-
+ ( ConsId0 = cons(Name0, Arity) ->
+ strip_builtin_qualifier_from_sym_name(Name0, Name),
+ ConsId = cons(Name, Arity)
+ ;
+ ConsId = ConsId0
+ ).
+
+:- pred strip_builtin_qualifier_from_sym_name(sym_name::in, sym_name::out)
+ is det.
+
+strip_builtin_qualifier_from_sym_name(SymName0, SymName) :-
+ (
+ SymName0 = qualified(Module, Name),
+ mercury_public_builtin_module(Module)
+ ->
+ SymName = unqualified(Name)
+ ;
+ SymName = SymName0
+ ).
+
+strip_builtin_qualifiers_from_inst_list(Insts0, Insts) :-
+ list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts).
+
+strip_builtin_qualifiers_from_inst(inst_var(V), inst_var(V)).
+strip_builtin_qualifiers_from_inst(constrained_inst_vars(Vars, Inst0),
+ constrained_inst_vars(Vars, Inst)) :-
+ strip_builtin_qualifiers_from_inst(Inst0, Inst).
+strip_builtin_qualifiers_from_inst(not_reached, not_reached).
+strip_builtin_qualifiers_from_inst(free, free).
+strip_builtin_qualifiers_from_inst(free(Type), free(Type)).
+strip_builtin_qualifiers_from_inst(any(Uniq), any(Uniq)).
+strip_builtin_qualifiers_from_inst(ground(Uniq, GII0), ground(Uniq, GII)) :-
+ strip_builtin_qualifiers_from_ground_inst_info(GII0, GII).
+strip_builtin_qualifiers_from_inst(bound(Uniq, BoundInsts0),
+ bound(Uniq, BoundInsts)) :-
+ strip_builtin_qualifiers_from_bound_inst_list(BoundInsts0, BoundInsts).
+strip_builtin_qualifiers_from_inst(defined_inst(Name0), defined_inst(Name)) :-
+ strip_builtin_qualifiers_from_inst_name(Name0, Name).
+strip_builtin_qualifiers_from_inst(abstract_inst(Name0, Args0),
+ abstract_inst(Name, Args)) :-
+ strip_builtin_qualifier_from_sym_name(Name0, Name),
+ strip_builtin_qualifiers_from_inst_list(Args0, Args).
+
+:- pred strip_builtin_qualifiers_from_bound_inst_list(list(bound_inst)::in,
+ list(bound_inst)::out) is det.
+
+strip_builtin_qualifiers_from_bound_inst_list(Insts0, Insts) :-
+ list__map(strip_builtin_qualifiers_from_bound_inst, Insts0, Insts).
+
+:- pred strip_builtin_qualifiers_from_bound_inst(bound_inst::in,
+ bound_inst::out) is det.
+strip_builtin_qualifiers_from_bound_inst(BoundInst0, BoundInst) :-
+ BoundInst0 = functor(ConsId0, Insts0),
+ strip_builtin_qualifier_from_cons_id(ConsId0, ConsId),
+ BoundInst = functor(ConsId, Insts),
+ list__map(strip_builtin_qualifiers_from_inst, Insts0, Insts).
+
+:- pred strip_builtin_qualifiers_from_inst_name(inst_name::in, inst_name::out)
+ is det.
+
+strip_builtin_qualifiers_from_inst_name(user_inst(SymName0, Insts0),
+ user_inst(SymName, Insts)) :-
+ strip_builtin_qualifier_from_sym_name(SymName0, SymName),
+ strip_builtin_qualifiers_from_inst_list(Insts0, Insts).
+strip_builtin_qualifiers_from_inst_name(merge_inst(InstA0, InstB0),
+ merge_inst(InstA, InstB)) :-
+ strip_builtin_qualifiers_from_inst(InstA0, InstA),
+ strip_builtin_qualifiers_from_inst(InstB0, InstB).
+strip_builtin_qualifiers_from_inst_name(unify_inst(Live, InstA0, InstB0, Real),
+ unify_inst(Live, InstA, InstB, Real)) :-
+ strip_builtin_qualifiers_from_inst(InstA0, InstA),
+ strip_builtin_qualifiers_from_inst(InstB0, InstB).
+strip_builtin_qualifiers_from_inst_name(
+ ground_inst(InstName0, Live, Uniq, Real),
+ ground_inst(InstName, Live, Uniq, Real)) :-
+ strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
+strip_builtin_qualifiers_from_inst_name(
+ any_inst(InstName0, Live, Uniq, Real),
+ any_inst(InstName, Live, Uniq, Real)) :-
+ strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
+strip_builtin_qualifiers_from_inst_name(shared_inst(InstName0),
+ shared_inst(InstName)) :-
+ strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
+strip_builtin_qualifiers_from_inst_name(mostly_uniq_inst(InstName0),
+ mostly_uniq_inst(InstName)) :-
+ strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
+strip_builtin_qualifiers_from_inst_name(typed_ground(Uniq, Type),
+ typed_ground(Uniq, Type)).
+strip_builtin_qualifiers_from_inst_name(typed_inst(Type, InstName0),
+ typed_inst(Type, InstName)) :-
+ strip_builtin_qualifiers_from_inst_name(InstName0, InstName).
+
+:- pred strip_builtin_qualifiers_from_ground_inst_info(ground_inst_info::in,
+ ground_inst_info::out) is det.
+
+strip_builtin_qualifiers_from_ground_inst_info(none, none).
+strip_builtin_qualifiers_from_ground_inst_info(higher_order(Pred0),
+ higher_order(Pred)) :-
+ Pred0 = pred_inst_info(PorF, Modes0, Det),
+ Pred = pred_inst_info(PorF, Modes, Det),
+ strip_builtin_qualifiers_from_mode_list(Modes0, Modes).
+
+%-----------------------------------------------------------------------------%
Index: prog_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_out.m,v
retrieving revision 1.50
diff -u -b -r1.50 prog_out.m
--- prog_out.m 20 May 2004 22:18:39 -0000 1.50
+++ prog_out.m 12 Jun 2004 12:50:33 -0000
@@ -21,7 +21,14 @@
:- import_module parse_tree__prog_data.
-:- import_module list, io.
+:- import_module bool, list, io.
+
+:- pred maybe_report_stats(bool::in, io::di, io::uo) is det.
+:- pred maybe_write_string(bool::in, string::in, io::di, io::uo) is det.
+:- pred maybe_flush_output(bool::in, io::di, io::uo) is det.
+
+:- pred report_error(string::in, io::di, io::uo) is det.
+:- pred report_error(io__output_stream::in, string::in, io::di, io::uo) is det.
:- pred prog_out__write_messages(message_list, io__state, io__state).
:- mode prog_out__write_messages(in, di, uo) is det.
@@ -90,6 +97,32 @@
:- mode prog_out__promise_to_string(out) = in is semidet.
:- mode prog_out__promise_to_string(out) = out is multi.
+ % Print "predicate" or "function" depending on the given value.
+:- pred write_pred_or_func(pred_or_func::in, io::di, io::uo) is det.
+
+ % Return "predicate" or "function" depending on the given value.
+:- func pred_or_func_to_full_str(pred_or_func) = string.
+
+ % Return "pred" or "func" depending on the given value.
+:- func pred_or_func_to_str(pred_or_func) = string.
+
+ % Print out a purity name.
+:- pred write_purity(purity::in, io::di, io::uo) is det.
+
+ % Get a purity name as a string.
+:- pred purity_name(purity, string).
+:- mode purity_name(in, out) is det.
+:- mode purity_name(out, in) is semidet.
+
+ % Print out a purity prefix.
+ % This works under the assumptions that all purity names but `pure'
+ % are operators, and that we never need `pure' indicators/declarations.
+:- pred write_purity_prefix(purity::in, io::di, io::uo) is det.
+:- func purity_prefix_to_string(purity) = string.
+
+ % Convert an evaluation method to a string.
+:- func eval_method_to_string(eval_method) = string.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -101,6 +134,26 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
+maybe_report_stats(yes) --> io__report_stats.
+maybe_report_stats(no) --> [].
+
+maybe_write_string(yes, String) --> io__write_string(String).
+maybe_write_string(no, _) --> [].
+
+maybe_flush_output(yes) --> io__flush_output.
+maybe_flush_output(no) --> [].
+
+report_error(ErrorMessage) -->
+ io__write_string("Error: "),
+ io__write_string(ErrorMessage),
+ io__write_string("\n"),
+ io__set_exit_status(1).
+
+report_error(Stream, ErrorMessage) -->
+ io__set_output_stream(Stream, OldStream),
+ report_error(ErrorMessage),
+ io__set_output_stream(OldStream, _).
+
% write out the list of error/warning messages which is
% returned when a module is parsed.
@@ -194,9 +247,8 @@
prog_out__sym_name_to_string(SymName, Separator) = String :-
prog_out__sym_name_to_string(SymName, Separator, String).
-:- pred prog_out__sym_name_to_string_2(sym_name, string,
- list(string), list(string)).
-:- mode prog_out__sym_name_to_string_2(in, in, out, in) is det.
+:- pred prog_out__sym_name_to_string_2(sym_name::in, string::in,
+ list(string)::out, list(string)::in) is det.
prog_out__sym_name_to_string_2(qualified(ModuleSpec,Name), Separator) -->
prog_out__sym_name_to_string_2(ModuleSpec, Separator),
@@ -251,247 +303,298 @@
prog_out__write_promise_type(PromiseType) -->
io__write_string(prog_out__promise_to_string(PromiseType)).
+write_pred_or_func(PorF, !IO) :-
+ io__write_string(pred_or_func_to_full_str(PorF), !IO).
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-% THE REMAINDER OF THIS FILE IS JUNK THAT IS NOT USED.
-% It has been made obsolete by mercury_to_mercury.m.
-% However, the code below handles operator precedence better
-% than mercury_to_mercury.m.
-
-/**************************
+pred_or_func_to_full_str(predicate) = "predicate".
+pred_or_func_to_full_str(function) = "function".
-% Please note that this code is the property of
-% the University of Melbourne and is Copyright 1985, 1986, 1987, 1988 by it.
-%
-% All rights are reserved.
-%
-% Author: Philip Dart, 1988
-% Based on a theme by Lawrence Byrd and Lee Naish.
-% Fixed again by Lee Naish 9/88
-
-% May bear some vague resemblance to some code written by Lawrence Byrd
-% at Edinburgh a long time ago.
-
-prog_out__writeDCGClause(Head, Body, VarSet) -->
- % prog_out__get_op_prec("-->", 1, Prec),
- { Prec = 1199 },
- prog_out__qwrite(Prec, VarSet, Head),
- io__write_string(" -->"),
- prog_out__write_goal(Body, 1, ',', VarSet).
-
-:- type context ---> '(' ; (';') ; (then) ; (else) ; ','.
-
-:- pred prog_out__write_goal(goal, int, context, varset, io__state, io__state).
-:- mode prog_out__write_goal(in, in, in, in, di, uo) is det.
-
-prog_out__write_goal(fail, I0, T, _VarSet) -->
- prog_out__beforelit(T, I0),
- io__write_string("fail").
-
-prog_out__write_goal(true, I0, T, _VarSet) -->
- prog_out__beforelit(T, I0),
- io__write_string("true").
-
-prog_out__write_goal(some(Vars,Goal), I0, T, VarSet) -->
- prog_out__beforelit(T, I0),
- io__write_string("some ["),
- prog_out__write_var_list(Vars, VarSet),
- io__write_string("] ("),
- { I1 is I0 + 1 },
- prog_out__write_goal(Goal, I1, '(', VarSet),
- io__write_string("\n"),
- prog_out__indent(I0),
- io__write_string(")").
+pred_or_func_to_str(predicate) = "pred".
+pred_or_func_to_str(function) = "func".
-prog_out__write_goal(all(Vars,Goal), I0, T, VarSet) -->
- prog_out__beforelit(T, I0),
- io__write_string("all ["),
- prog_out__write_var_list(Vars, VarSet),
- io__write_string("] ("),
- { I1 is I0 + 1 },
- prog_out__write_goal(Goal, I1, '(', VarSet),
- io__write_string("\n"),
- prog_out__indent(I0),
- io__write_string(")").
-
-prog_out__write_goal((P, Q), I0, T, VarSet) -->
- prog_out__write_goal(P, I0, T, VarSet),
- io__write_string(","),
- {if T = (',') then I = I0 else I is I0 + 1},
- prog_out__write_goal(Q, I, (','), VarSet).
-
-prog_out__write_goal(if_then_else(Vars,C,A,B), I, T, VarSet) -->
- {if T = (then) then I1 is I + 1 else I1 = I},
- (if {T = (else)} then
- []
- else
- io__write_string("\n"),
- prog_out__indent(I1)
- ),
- io__write_string(" if "),
- prog_out__write_some_vars(VarSet, Vars),
- prog_out__write_goal(C, I, '(', VarSet),
- io__write_string(" then"),
- prog_out__write_goal(A, I1, (then), VarSet),
- io__write_string("\n"),
- prog_out__indent(I1),
- io__write_string("else"),
- prog_out__write_goal(B, I1, (else), VarSet),
- (if {T = (else)} then
- []
- else
- io__write_string("\n"),
- prog_out__indent(I1),
- io__write_string(")")
+write_purity_prefix(Purity, !IO) :-
+ ( Purity = pure ->
+ true
+ ;
+ write_purity(Purity, !IO),
+ io__write_string(" ", !IO)
).
-prog_out__write_goal(if_then(Vars,C,A), I, T, VarSet) -->
- {if T = (then) then I1 is I + 1 else I1 = I},
- (if {T = (else)} then
- []
- else
- io__write_string("\n"),
- prog_out__indent(I1)
- ),
- io__write_string(" if "),
- prog_out__write_some_vars(VarSet, Vars),
- prog_out__write_goal(C, I, '(', VarSet),
- io__write_string(" then"),
- prog_out__write_goal(A, I1, (then), VarSet),
- (if {T = (else)} then
- []
- else
- io__write_string("\n"),
- prog_out__indent(I1),
- io__write_string(")")
+purity_prefix_to_string(Purity) = String :-
+ ( Purity = pure ->
+ String = ""
+ ;
+ purity_name(Purity, PurityName),
+ String = string__append(PurityName, " ")
).
-prog_out__write_goal((P ; Q), I, T, VarSet) -->
- (if {T = (;)} then
- io__write_string("\t\n"),
- prog_out__write_goal(P, I, (;), VarSet)
- else
- io__write_string("\n"),
- prog_out__indent(I),
- io__write_string("("),
- prog_out__write_goal(P, I, '(', VarSet)
+write_purity(Purity, !IO) :-
+ purity_name(Purity, String),
+ io__write_string(String, !IO).
+
+purity_name(pure, "pure").
+purity_name((semipure), "semipure").
+purity_name((impure), "impure").
+
+eval_method_to_string(eval_normal) = "normal".
+eval_method_to_string(eval_loop_check) = "loop_check".
+eval_method_to_string(eval_memo) = "memo".
+eval_method_to_string(eval_minimal) = "minimal_model".
+eval_method_to_string(eval_table_io(IsDecl, IsUnitize)) = Str :-
+ (
+ IsDecl = table_io_decl,
+ DeclStr = "decl, "
+ ;
+ IsDecl = table_io_proc,
+ DeclStr = "proc, "
),
- io__write_string("\n"),
- prog_out__indent(I),
- io__write_string(";"),
- prog_out__write_goal(Q, I, (;), VarSet),
- (if {T = (;)} then
- []
- else
- io__write_string("\n"),
- prog_out__indent(I),
- io__write_string(")")
- ).
-
-prog_out__write_goal(not(A), I, _, VarSet) -->
- io__write_string("not("),
- prog_out__write_goal(A, I, '(', VarSet),
- io__write_string(")").
-
-prog_out__write_goal(call(X), I, T, VarSet) -->
- prog_out__beforelit(T, I),
- % Pos 1 of (,) has lowest prec of constructs
- % prog_out__get_op_prec(",", 1, Prec),
- { Prec = 999 },
- prog_out__qwrite(Prec, VarSet, X).
-
-prog_out__write_var_list(_VarSet, Vars) -->
- io__write_anything(Vars).
-
-prog_out__write_some_vars(_VarSet, Vars) -->
- io__write_string("some "),
- io__write_anything(Vars). % XXX
-
-:- pred prog_out__beforelit(context, int, io__state, io__state).
-:- mode prog_out__beforelit(in, in, di, uo) is det.
-
-prog_out__beforelit('(', _) -->
- io__write_string("\t").
-prog_out__beforelit((;), I) -->
- io__write_string("\n"),
- { I1 is I + 1 },
- prog_out__indent(I1),
- io__write_string("\t").
-prog_out__beforelit((then), I) -->
- io__write_string("\n"),
- { I1 is I + 1 },
- prog_out__indent(I1).
-prog_out__beforelit((else), I) -->
- io__write_string("\n"),
- { I1 is I + 1 },
- prog_out__indent(I1).
-prog_out__beforelit(',', I) -->
- io__write_string("\n"),
- prog_out__indent(I).
-
-:- pred prog_out__indent(int, io__state, io__state).
-:- mode prog_out__indent(int, di, uo) is det.
-prog_out__indent(N) -->
- (if {N > 0} then
- io__write_string("\t"),
- { N1 is N - 1 },
- prog_out__indent(N1)
- else
- []
- ).
-
-:- pred prog_out__qwrite(int, varset, term, io__state, io__state).
-:- mode prog_out__qwrite(in, in, in, di, uo) is det.
-
- % XXX problems with precedence
-
-prog_out__qwrite(_Prec, VarSet, X) -->
- term_io__write_term(VarSet, X).
-
-:- pred prog_out__get_op_prec(string, int, int, io__state, io__state).
-:- mode prog_out__get_op_prec(in, in, out, di, uo) is det.
-
-prog_out__get_op_prec(Op, Pos, Prec) -->
- term_io__current_ops(Ops),
- { get_prec_and_type(Op, Ops, Prec1, Type),
- prog_out__op_adj(Pos, Type, Adj),
- Prec is Prec1 - Adj
- }.
-
-get_prec_and_type(ThisOp, [Op|Ops], Prec, Type) :-
- (if some [Prec1, Type1]
- Op = op(Prec1, Type1, ThisOp)
- then
- Prec = Prec1,
- Type = Type1
- else
- get_prec_and_type(ThisOp, Ops, Prec, Type)
- ).
-
-:- pred prog_out__op_adj(int, op_type, int).
-:- mode prog_out__op_adj(in, in, out) is det.
+ (
+ IsUnitize = table_io_unitize,
+ UnitizeStr = "unitize"
+ ;
+ IsUnitize = table_io_alone,
+ UnitizeStr = "alone"
+ ),
+ Str = "table_io(" ++ DeclStr ++ UnitizeStr ++ ")".
-prog_out__op_adj(1, xfx, 1).
-prog_out__op_adj(1, xfy, 1).
-prog_out__op_adj(1, fxy, 1).
-prog_out__op_adj(1, fxx, 1).
-prog_out__op_adj(1, yfx, 0).
-% prog_out__op_adj(1, yfy, 0).
-prog_out__op_adj(1, fyx, 0).
-prog_out__op_adj(1, fyy, 0).
-prog_out__op_adj(2, xfx, 1).
-prog_out__op_adj(2, xfy, 0).
-prog_out__op_adj(2, fxy, 0).
-prog_out__op_adj(2, fxx, 1).
-prog_out__op_adj(2, yfx, 1).
-% prog_out__op_adj(2, yfy, 0).
-prog_out__op_adj(2, fyx, 1).
-prog_out__op_adj(2, fyy, 0).
-prog_out__op_adj(1, xf, 1).
-prog_out__op_adj(1, fx, 1).
-prog_out__op_adj(1, yf, 0).
-prog_out__op_adj(1, fy, 0).
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
-******************************/
+% THE REMAINDER OF THIS FILE IS JUNK THAT IS NOT USED.
+% It has been made obsolete by mercury_to_mercury.m.
+% However, the code below handles operator precedence better
+% than mercury_to_mercury.m.
+%
+% % Please note that this code is the property of
+% % the University of Melbourne and is Copyright 1985, 1986, 1987, 1988 by it.
+% %
+% % All rights are reserved.
+% %
+% % Author: Philip Dart, 1988
+% % Based on a theme by Lawrence Byrd and Lee Naish.
+% % Fixed again by Lee Naish 9/88
+%
+% % May bear some vague resemblance to some code written by Lawrence Byrd
+% % at Edinburgh a long time ago.
+%
+% prog_out__writeDCGClause(Head, Body, VarSet) -->
+% % prog_out__get_op_prec("-->", 1, Prec),
+% { Prec = 1199 },
+% prog_out__qwrite(Prec, VarSet, Head),
+% io__write_string(" -->"),
+% prog_out__write_goal(Body, 1, ',', VarSet).
+%
+% :- type context ---> '(' ; (';') ; (then) ; (else) ; ','.
+%
+% :- pred prog_out__write_goal(goal, int, context, varset, io, io).
+% :- mode prog_out__write_goal(in, in, in, in, di, uo) is det.
+%
+% prog_out__write_goal(fail, I0, T, _VarSet) -->
+% prog_out__beforelit(T, I0),
+% io__write_string("fail").
+%
+% prog_out__write_goal(true, I0, T, _VarSet) -->
+% prog_out__beforelit(T, I0),
+% io__write_string("true").
+%
+% prog_out__write_goal(some(Vars,Goal), I0, T, VarSet) -->
+% prog_out__beforelit(T, I0),
+% io__write_string("some ["),
+% prog_out__write_var_list(Vars, VarSet),
+% io__write_string("] ("),
+% { I1 is I0 + 1 },
+% prog_out__write_goal(Goal, I1, '(', VarSet),
+% io__write_string("\n"),
+% prog_out__indent(I0),
+% io__write_string(")").
+%
+% prog_out__write_goal(all(Vars,Goal), I0, T, VarSet) -->
+% prog_out__beforelit(T, I0),
+% io__write_string("all ["),
+% prog_out__write_var_list(Vars, VarSet),
+% io__write_string("] ("),
+% { I1 is I0 + 1 },
+% prog_out__write_goal(Goal, I1, '(', VarSet),
+% io__write_string("\n"),
+% prog_out__indent(I0),
+% io__write_string(")").
+%
+% prog_out__write_goal((P, Q), I0, T, VarSet) -->
+% prog_out__write_goal(P, I0, T, VarSet),
+% io__write_string(","),
+% {if T = (',') then I = I0 else I is I0 + 1},
+% prog_out__write_goal(Q, I, (','), VarSet).
+%
+% prog_out__write_goal(if_then_else(Vars,C,A,B), I, T, VarSet) -->
+% {if T = (then) then I1 is I + 1 else I1 = I},
+% (if {T = (else)} then
+% []
+% else
+% io__write_string("\n"),
+% prog_out__indent(I1)
+% ),
+% io__write_string(" if "),
+% prog_out__write_some_vars(VarSet, Vars),
+% prog_out__write_goal(C, I, '(', VarSet),
+% io__write_string(" then"),
+% prog_out__write_goal(A, I1, (then), VarSet),
+% io__write_string("\n"),
+% prog_out__indent(I1),
+% io__write_string("else"),
+% prog_out__write_goal(B, I1, (else), VarSet),
+% (if {T = (else)} then
+% []
+% else
+% io__write_string("\n"),
+% prog_out__indent(I1),
+% io__write_string(")")
+% ).
+%
+% prog_out__write_goal(if_then(Vars,C,A), I, T, VarSet) -->
+% {if T = (then) then I1 is I + 1 else I1 = I},
+% (if {T = (else)} then
+% []
+% else
+% io__write_string("\n"),
+% prog_out__indent(I1)
+% ),
+% io__write_string(" if "),
+% prog_out__write_some_vars(VarSet, Vars),
+% prog_out__write_goal(C, I, '(', VarSet),
+% io__write_string(" then"),
+% prog_out__write_goal(A, I1, (then), VarSet),
+% (if {T = (else)} then
+% []
+% else
+% io__write_string("\n"),
+% prog_out__indent(I1),
+% io__write_string(")")
+% ).
+%
+% prog_out__write_goal((P ; Q), I, T, VarSet) -->
+% (if {T = (;)} then
+% io__write_string("\t\n"),
+% prog_out__write_goal(P, I, (;), VarSet)
+% else
+% io__write_string("\n"),
+% prog_out__indent(I),
+% io__write_string("("),
+% prog_out__write_goal(P, I, '(', VarSet)
+% ),
+% io__write_string("\n"),
+% prog_out__indent(I),
+% io__write_string(";"),
+% prog_out__write_goal(Q, I, (;), VarSet),
+% (if {T = (;)} then
+% []
+% else
+% io__write_string("\n"),
+% prog_out__indent(I),
+% io__write_string(")")
+% ).
+%
+% prog_out__write_goal(not(A), I, _, VarSet) -->
+% io__write_string("not("),
+% prog_out__write_goal(A, I, '(', VarSet),
+% io__write_string(")").
+%
+% prog_out__write_goal(call(X), I, T, VarSet) -->
+% prog_out__beforelit(T, I),
+% % Pos 1 of (,) has lowest prec of constructs
+% % prog_out__get_op_prec(",", 1, Prec),
+% { Prec = 999 },
+% prog_out__qwrite(Prec, VarSet, X).
+%
+% prog_out__write_var_list(_VarSet, Vars) -->
+% io__write_anything(Vars).
+%
+% prog_out__write_some_vars(_VarSet, Vars) -->
+% io__write_string("some "),
+% io__write_anything(Vars). % XXX
+%
+% :- pred prog_out__beforelit(context, int, io__state, io__state).
+% :- mode prog_out__beforelit(in, in, di, uo) is det.
+%
+% prog_out__beforelit('(', _) -->
+% io__write_string("\t").
+% prog_out__beforelit((;), I) -->
+% io__write_string("\n"),
+% { I1 is I + 1 },
+% prog_out__indent(I1),
+% io__write_string("\t").
+% prog_out__beforelit((then), I) -->
+% io__write_string("\n"),
+% { I1 is I + 1 },
+% prog_out__indent(I1).
+% prog_out__beforelit((else), I) -->
+% io__write_string("\n"),
+% { I1 is I + 1 },
+% prog_out__indent(I1).
+% prog_out__beforelit(',', I) -->
+% io__write_string("\n"),
+% prog_out__indent(I).
+%
+% :- pred prog_out__indent(int, io__state, io__state).
+% :- mode prog_out__indent(int, di, uo) is det.
+% prog_out__indent(N) -->
+% (if {N > 0} then
+% io__write_string("\t"),
+% { N1 is N - 1 },
+% prog_out__indent(N1)
+% else
+% []
+% ).
+%
+% :- pred prog_out__qwrite(int, varset, term, io__state, io__state).
+% :- mode prog_out__qwrite(in, in, in, di, uo) is det.
+%
+% % XXX problems with precedence
+%
+% prog_out__qwrite(_Prec, VarSet, X) -->
+% term_io__write_term(VarSet, X).
+%
+% :- pred prog_out__get_op_prec(string, int, int, io__state, io__state).
+% :- mode prog_out__get_op_prec(in, in, out, di, uo) is det.
+%
+% prog_out__get_op_prec(Op, Pos, Prec) -->
+% term_io__current_ops(Ops),
+% { get_prec_and_type(Op, Ops, Prec1, Type),
+% prog_out__op_adj(Pos, Type, Adj),
+% Prec is Prec1 - Adj
+% }.
+%
+% get_prec_and_type(ThisOp, [Op|Ops], Prec, Type) :-
+% (if some [Prec1, Type1]
+% Op = op(Prec1, Type1, ThisOp)
+% then
+% Prec = Prec1,
+% Type = Type1
+% else
+% get_prec_and_type(ThisOp, Ops, Prec, Type)
+% ).
+%
+% :- pred prog_out__op_adj(int, op_type, int).
+% :- mode prog_out__op_adj(in, in, out) is det.
+%
+% prog_out__op_adj(1, xfx, 1).
+% prog_out__op_adj(1, xfy, 1).
+% prog_out__op_adj(1, fxy, 1).
+% prog_out__op_adj(1, fxx, 1).
+% prog_out__op_adj(1, yfx, 0).
+% % prog_out__op_adj(1, yfy, 0).
+% prog_out__op_adj(1, fyx, 0).
+% prog_out__op_adj(1, fyy, 0).
+% prog_out__op_adj(2, xfx, 1).
+% prog_out__op_adj(2, xfy, 0).
+% prog_out__op_adj(2, fxy, 0).
+% prog_out__op_adj(2, fxx, 1).
+% prog_out__op_adj(2, yfx, 1).
+% % prog_out__op_adj(2, yfy, 0).
+% prog_out__op_adj(2, fyx, 1).
+% prog_out__op_adj(2, fyy, 0).
+% prog_out__op_adj(1, xf, 1).
+% prog_out__op_adj(1, fx, 1).
+% prog_out__op_adj(1, yf, 0).
+% prog_out__op_adj(1, fy, 0).
+%
+% ******************************/
Index: prog_rep.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.25
diff -u -b -r1.25 prog_rep.m
--- prog_rep.m 7 Jun 2004 09:07:04 -0000 1.25
+++ prog_rep.m 12 Jun 2004 10:05:09 -0000
@@ -99,7 +99,7 @@
string__float_to_string(Float, Rep).
prog_rep__represent_cons_id(string_const(String), Rep) :-
string__append_list(["""", String, """"], Rep).
-prog_rep__represent_cons_id(pred_const(_, _, _), Rep) :-
+prog_rep__represent_cons_id(pred_const(_, _), Rep) :-
Rep = "$pred_const".
prog_rep__represent_cons_id(type_ctor_info_const(_, _, _), Rep) :-
Rep = "$type_ctor_info_const".
@@ -109,7 +109,7 @@
Rep = "$type_info_cell_constructor".
prog_rep__represent_cons_id(typeclass_info_cell_constructor, Rep) :-
Rep = "$typeclass_info_cell_constructor".
-prog_rep__represent_cons_id(tabling_pointer_const(_, _), Rep) :-
+prog_rep__represent_cons_id(tabling_pointer_const(_), Rep) :-
Rep = "$tabling_pointer_const".
prog_rep__represent_cons_id(deep_profiling_proc_layout(_), Rep) :-
Rep = "$deep_profiling_procedure_data".
Index: prog_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.66
diff -u -b -r1.66 prog_util.m
--- prog_util.m 12 Jan 2004 06:45:50 -0000 1.66
+++ prog_util.m 12 Jun 2004 12:54:11 -0000
@@ -15,7 +15,7 @@
:- import_module parse_tree__prog_data.
-:- import_module std_util, list, term.
+:- import_module std_util, list, varset, term.
%-----------------------------------------------------------------------------%
@@ -213,11 +213,75 @@
goal::in, goal::out) is det.
%-----------------------------------------------------------------------------%
+
+ % Various predicates for accessing the cons_id type.
+
+ % Given a cons_id and a list of argument terms, convert it into a
+ % term. Fails if the cons_id is a pred_const, or type_ctor_info_const.
+
+:- pred cons_id_and_args_to_term(cons_id::in, list(term(T))::in, term(T)::out)
+ is semidet.
+
+ % Get the arity of a cons_id, aborting on pred_const and
+ % type_ctor_info_const.
+
+:- func cons_id_arity(cons_id) = arity.
+
+ % Get the arity of a cons_id. Return a `no' on those cons_ids
+ % where cons_id_arity/2 would normally abort.
+
+:- func cons_id_maybe_arity(cons_id) = maybe(arity).
+
+ % The reverse conversion - make a cons_id for a functor.
+ % Given a const and an arity for the functor, create a cons_id.
+
+:- func make_functor_cons_id(const, arity) = cons_id.
+
+ % Another way of making a cons_id from a functor.
+ % Given the name, argument types, and type_ctor of a functor,
+ % create a cons_id for that functor.
+
+:- func make_cons_id(sym_name, list(constructor_arg), type_ctor) = cons_id.
+
+ % Another way of making a cons_id from a functor.
+ % Given the name, argument types, and type_ctor of a functor,
+ % create a cons_id for that functor.
+ %
+ % Differs from make_cons_id in that (a) it requires the sym_name
+ % to be already module qualified, which means that it does not
+ % need the module qualification of the type, (b) it can compute the
+ % arity from any list of the right length.
+
+:- func make_cons_id_from_qualified_sym_name(sym_name, list(_)) = cons_id.
+
+%-----------------------------------------------------------------------------%
+
+ % make_n_fresh_vars(Name, N, VarSet0, Vars, VarSet):
+ % `Vars' is a list of `N' fresh variables allocated from
+ % `VarSet0'. The variables will be named "<Name>1", "<Name>2",
+ % "<Name>3", and so on, where <Name> is the value of `Name'.
+ % `VarSet' is the resulting varset.
+
+:- pred make_n_fresh_vars(string::in, int::in, list(var(T))::out,
+ varset(T)::in, varset(T)::out) is det.
+
+ % given the list of predicate arguments for a predicate that
+ % is really a function, split that list into the function arguments
+ % and the function return type.
+:- pred pred_args_to_func_args(list(T)::in, list(T)::out, T::out) is det.
+
+ % Get the last two arguments from the list, failing if there
+ % aren't at least two arguments.
+:- pred get_state_args(list(T)::in, list(T)::out, T::out, T::out) is semidet.
+
+ % Get the last two arguments from the list, aborting if there
+ % aren't at least two arguments.
+:- pred get_state_args_det(list(T)::in, list(T)::out, T::out, T::out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module parse_tree__inst.
:- import_module parse_tree__mercury_to_mercury.
:- import_module bool, require, string, int, map, varset.
@@ -524,3 +588,126 @@
).
%-----------------------------------------------------------------------------%
+
+cons_id_and_args_to_term(int_const(Int), [], Term) :-
+ term__context_init(Context),
+ Term = term__functor(term__integer(Int), [], Context).
+cons_id_and_args_to_term(float_const(Float), [], Term) :-
+ term__context_init(Context),
+ Term = term__functor(term__float(Float), [], Context).
+cons_id_and_args_to_term(string_const(String), [], Term) :-
+ term__context_init(Context),
+ Term = term__functor(term__string(String), [], Context).
+cons_id_and_args_to_term(cons(SymName, _Arity), Args, Term) :-
+ construct_qualified_term(SymName, Args, Term).
+
+cons_id_arity(cons(_, Arity)) = Arity.
+cons_id_arity(int_const(_)) = 0.
+cons_id_arity(string_const(_)) = 0.
+cons_id_arity(float_const(_)) = 0.
+cons_id_arity(pred_const(_, _)) =
+ func_error("cons_id_arity: can't get arity of pred_const").
+cons_id_arity(type_ctor_info_const(_, _, _)) =
+ func_error("cons_id_arity: can't get arity of type_ctor_info_const").
+cons_id_arity(base_typeclass_info_const(_, _, _, _)) =
+ func_error("cons_id_arity: " ++
+ "can't get arity of base_typeclass_info_const").
+cons_id_arity(type_info_cell_constructor(_)) =
+ func_error("cons_id_arity: " ++
+ "can't get arity of type_info_cell_constructor").
+cons_id_arity(typeclass_info_cell_constructor) =
+ func_error("cons_id_arity: " ++
+ "can't get arity of typeclass_info_cell_constructor").
+cons_id_arity(tabling_pointer_const(_)) =
+ func_error("cons_id_arity: can't get arity of tabling_pointer_const").
+cons_id_arity(deep_profiling_proc_layout(_)) =
+ func_error("cons_id_arity: " ++
+ "can't get arity of deep_profiling_proc_layout").
+cons_id_arity(table_io_decl(_)) =
+ func_error("cons_id_arity: can't get arity of table_io_decl").
+
+cons_id_maybe_arity(cons(_, Arity)) = yes(Arity).
+cons_id_maybe_arity(int_const(_)) = yes(0).
+cons_id_maybe_arity(string_const(_)) = yes(0).
+cons_id_maybe_arity(float_const(_)) = yes(0).
+cons_id_maybe_arity(pred_const(_, _)) = no.
+cons_id_maybe_arity(type_ctor_info_const(_, _, _)) = no.
+cons_id_maybe_arity(base_typeclass_info_const(_, _, _, _)) = no.
+cons_id_maybe_arity(type_info_cell_constructor(_)) = no.
+cons_id_maybe_arity(typeclass_info_cell_constructor) = no.
+cons_id_maybe_arity(tabling_pointer_const(_)) = no.
+cons_id_maybe_arity(deep_profiling_proc_layout(_)) = no.
+cons_id_maybe_arity(table_io_decl(_)) = no.
+
+make_functor_cons_id(term__atom(Name), Arity) = cons(unqualified(Name), Arity).
+make_functor_cons_id(term__integer(Int), _) = int_const(Int).
+make_functor_cons_id(term__string(String), _) = string_const(String).
+make_functor_cons_id(term__float(Float), _) = float_const(Float).
+
+make_cons_id(SymName0, Args, TypeCtor) = cons(SymName, Arity) :-
+ % Use the module qualifier on the SymName, if there is one,
+ % otherwise use the module qualifier on the Type, if there is one,
+ % otherwise leave it unqualified.
+ % XXX is that the right thing to do?
+ (
+ SymName0 = qualified(_, _),
+ SymName = SymName0
+ ;
+ SymName0 = unqualified(ConsName),
+ (
+ TypeCtor = unqualified(_) - _,
+ SymName = SymName0
+ ;
+ TypeCtor = qualified(TypeModule, _) - _,
+ SymName = qualified(TypeModule, ConsName)
+ )
+ ),
+ list__length(Args, Arity).
+
+make_cons_id_from_qualified_sym_name(SymName, Args) = cons(SymName, Arity) :-
+ list__length(Args, Arity).
+
+%-----------------------------------------------------------------------------%
+
+make_n_fresh_vars(BaseName, N, Vars, VarSet0, VarSet) :-
+ make_n_fresh_vars_2(BaseName, 0, N, Vars, VarSet0, VarSet).
+
+:- pred make_n_fresh_vars_2(string::in, int::in, int::in, list(var(T))::out,
+ varset(T)::in, varset(T)::out) is det.
+
+make_n_fresh_vars_2(BaseName, N, Max, Vars, !VarSet) :-
+ (N = Max ->
+ Vars = []
+ ;
+ N1 = N + 1,
+ varset__new_var(!.VarSet, Var, !:VarSet),
+ string__int_to_string(N1, Num),
+ string__append(BaseName, Num, VarName),
+ varset__name_var(!.VarSet, Var, VarName, !:VarSet),
+ Vars = [Var | Vars1],
+ make_n_fresh_vars_2(BaseName, N1, Max, Vars1, !VarSet)
+ ).
+
+pred_args_to_func_args(PredArgs, FuncArgs, FuncReturn) :-
+ list__length(PredArgs, NumPredArgs),
+ NumFuncArgs = NumPredArgs - 1,
+ ( list__split_list(NumFuncArgs, PredArgs, FuncArgs0, [FuncReturn0]) ->
+ FuncArgs = FuncArgs0,
+ FuncReturn = FuncReturn0
+ ;
+ error("pred_args_to_func_args: function missing return value?")
+ ).
+
+get_state_args(Args0, Args, State0, State) :-
+ list__reverse(Args0, RevArgs0),
+ RevArgs0 = [State, State0 | RevArgs],
+ list__reverse(RevArgs, Args).
+
+get_state_args_det(Args0, Args, State0, State) :-
+ ( get_state_args(Args0, Args1, State0A, StateA) ->
+ Args = Args1,
+ State0 = State0A,
+ State = StateA
+ ;
+ error("hlds_pred__get_state_args_det")
+ ).
Index: purity.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.65
diff -u -b -r1.65 purity.m
--- purity.m 7 Jun 2004 09:07:04 -0000 1.65
+++ purity.m 12 Jun 2004 14:26:06 -0000
@@ -155,22 +155,6 @@
% Compare two purities.
:- pred less_pure(purity::in, purity::in) is semidet.
-% Print out a purity name.
-:- pred write_purity(purity::in, io__state::di, io__state::uo) is det.
-
-% Print out a purity prefix.
-% This works under the assumptions that all purity names but `pure' are prefix
-% Operators, and that we never need `pure' indicators/declarations.
-
-:- pred write_purity_prefix(purity::in, io__state::di, io__state::uo) is det.
-
-:- func purity_prefix_to_string(purity) = string.
-
-% Get a purity name as a string.
-:- pred purity_name(purity, string).
-:- mode purity_name(in, out) is det.
-:- mode purity_name(out, in) is semidet.
-
% Give an error message for unifications marked impure/semipure that are
% not function calls (e.g. impure X = 4)
:- pred impure_unification_expr_error(prog_context::in, purity::in,
@@ -196,6 +180,7 @@
:- import_module parse_tree__module_qual.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_io_util.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
@@ -231,34 +216,8 @@
less_pure(P1, P2) :-
\+ ( worst_purity(P1, P2) = P2).
-% this works under the assumptions that all purity names but `pure' are prefix
-% operators, and that we never need `pure' indicators/declarations.
-
-write_purity_prefix(Purity, !IO) :-
- ( Purity = pure ->
- true
- ;
- write_purity(Purity, !IO),
- io__write_string(" ", !IO)
- ).
-
-purity_prefix_to_string(Purity) = String :-
- ( Purity = pure ->
- String = ""
- ;
- purity_name(Purity, PurityName),
- String = string__append(PurityName, " ")
- ).
-
-write_purity(Purity, !IO) :-
- purity_name(Purity, String),
- io__write_string(String, !IO).
-
-purity_name(pure, "pure").
-purity_name((semipure), "semipure").
-purity_name((impure), "impure").
-
%-----------------------------------------------------------------------------%
+
% Purity-check the code for all the predicates in a module
:- pred check_preds_purity(bool::in, bool::out,
@@ -985,7 +944,7 @@
{ PredOrFunc = pred_info_is_pred_or_func(PredInfo) },
prog_out__write_context(Context),
io__write_string(" A pure "),
- hlds_out__write_pred_or_func(PredOrFunc),
+ write_pred_or_func(PredOrFunc),
io__write_string(" that invokes impure or semipure code should\n"),
prog_out__write_context(Context),
io__write_string(
@@ -1038,7 +997,7 @@
prog_out__write_context(Context),
{ PredOrFunc = pred_info_is_pred_or_func(PredInfo) },
io__write_string(" This "),
- hlds_out__write_pred_or_func(PredOrFunc),
+ write_pred_or_func(PredOrFunc),
io__write_string(" does not invoke any "),
io__write_string(CodeStr),
io__write_string(" code,\n"),
@@ -1059,7 +1018,7 @@
write_context_and_pred_id(ModuleInfo, PredInfo, PredId),
prog_out__write_context(Context),
io__write_string(" purity error: "),
- hlds_out__write_pred_or_func(PredOrFunc),
+ write_pred_or_func(PredOrFunc),
io__write_string(" is "),
write_purity(Purity),
io__write_string(".\n"),
Index: quantification.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.89
diff -u -b -r1.89 quantification.m
Index: reassign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/reassign.m,v
retrieving revision 1.8
diff -u -b -r1.8 reassign.m
Index: recompilation.check.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.check.m,v
retrieving revision 1.7
diff -u -b -r1.7 recompilation.check.m
Index: recompilation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.m,v
retrieving revision 1.8
diff -u -b -r1.8 recompilation.m
Index: recompilation.usage.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.10
diff -u -b -r1.10 recompilation.usage.m
--- recompilation.usage.m 24 Oct 2003 06:17:47 -0000 1.10
+++ recompilation.usage.m 12 Jun 2004 10:35:13 -0000
@@ -87,10 +87,10 @@
:- import_module libs__globals.
:- import_module libs__options.
:- import_module libs__timestamp.
-:- import_module parse_tree__inst.
:- import_module parse_tree__mercury_to_mercury.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_util.
+:- import_module parse_tree__prog_out.
:- import_module recompilation__version.
:- import_module assoc_list, bool, int, require.
@@ -106,7 +106,8 @@
->
globals__io_lookup_bool_option(verbose, Verbose),
maybe_write_string(Verbose,
- "% Writing recompilation compilation dependency information\n"),
+ "% Writing recompilation compilation " ++
+ "dependency information\n"),
{ module_info_name(ModuleInfo, ModuleName) },
module_name_to_file_name(ModuleName, ".used", yes, FileName),
Index: recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.9
diff -u -b -r1.9 recompilation.version.m
--- recompilation.version.m 9 Jun 2004 07:56:15 -0000 1.9
+++ recompilation.version.m 12 Jun 2004 10:05:10 -0000
@@ -39,7 +39,6 @@
:- import_module check_hlds__mode_util.
:- import_module check_hlds__type_util.
:- import_module hlds__hlds_out.
-:- import_module parse_tree__inst.
:- import_module parse_tree__mercury_to_mercury.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_util.
Index: rl.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl.m,v
retrieving revision 1.27
diff -u -b -r1.27 rl.m
--- rl.m 28 Nov 2003 02:23:07 -0000 1.27
+++ rl.m 12 Jun 2004 10:05:10 -0000
@@ -17,7 +17,6 @@
:- interface.
-:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- import_module hlds__hlds_module.
:- import_module hlds__hlds_pred.
@@ -681,6 +680,7 @@
:- import_module check_hlds__mode_util.
:- import_module check_hlds__type_util.
:- import_module hlds__goal_form.
+:- import_module hlds__hlds_data.
:- import_module libs__globals.
:- import_module libs__options.
:- import_module parse_tree__prog_out.
Index: rl_analyse.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_analyse.m,v
retrieving revision 1.5
diff -u -b -r1.5 rl_analyse.m
Index: rl_block.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_block.m,v
retrieving revision 1.6
diff -u -b -r1.6 rl_block.m
Index: rl_block_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_block_opt.m,v
retrieving revision 1.11
diff -u -b -r1.11 rl_block_opt.m
Index: rl_dump.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_dump.m,v
retrieving revision 1.11
diff -u -b -r1.11 rl_dump.m
Index: rl_exprn.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_exprn.m,v
retrieving revision 1.41
diff -u -b -r1.41 rl_exprn.m
--- rl_exprn.m 7 Jun 2004 09:07:05 -0000 1.41
+++ rl_exprn.m 12 Jun 2004 10:13:58 -0000
@@ -507,7 +507,7 @@
;
Code = Code0
}.
-rl_exprn__set_term_arg_cons_id_code(pred_const(_, _, _), _, _, _, _, _, _) -->
+rl_exprn__set_term_arg_cons_id_code(pred_const(_, _), _, _, _, _, _, _) -->
{ error("rl_exprn__set_term_arg_cons_id_code") }.
rl_exprn__set_term_arg_cons_id_code(type_ctor_info_const(_, _, _),
_, _, _, _, _, _) -->
@@ -521,7 +521,7 @@
rl_exprn__set_term_arg_cons_id_code(typeclass_info_cell_constructor,
_, _, _, _, _, _) -->
{ error("rl_exprn__set_term_arg_cons_id_code") }.
-rl_exprn__set_term_arg_cons_id_code(tabling_pointer_const(_, _),
+rl_exprn__set_term_arg_cons_id_code(tabling_pointer_const(_),
_, _, _, _, _, _) -->
{ error("rl_exprn__set_term_arg_cons_id_code") }.
rl_exprn__set_term_arg_cons_id_code(deep_profiling_proc_layout(_),
@@ -1156,7 +1156,7 @@
{ ConsId = float_const(Float) },
rl_exprn__assign(reg(VarReg), const(float(Float)), Type, Code)
;
- { ConsId = pred_const(_, _, _) },
+ { ConsId = pred_const(_, _) },
{ error("rl_exprn__unify: unsupported cons_id - pred_const") }
;
{ ConsId = type_ctor_info_const(_, _, _) },
@@ -1177,7 +1177,7 @@
{ error("rl_exprn__unify: unsupported cons_id - " ++
"typeclass_info_cell_constructor") }
;
- { ConsId = tabling_pointer_const(_, _) },
+ { ConsId = tabling_pointer_const(_) },
{ error("rl_exprn__unify: unsupported cons_id - " ++
"tabling_pointer_const") }
;
Index: rl_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_gen.m,v
retrieving revision 1.15
diff -u -b -r1.15 rl_gen.m
--- rl_gen.m 1 Dec 2003 15:55:48 -0000 1.15
+++ rl_gen.m 12 Jun 2004 10:14:42 -0000
@@ -41,7 +41,6 @@
:- import_module libs__globals.
:- import_module libs__options.
:- import_module libs__tree.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_out.
:- import_module transform_hlds__dependency_graph.
@@ -1017,7 +1016,7 @@
% between two Aditi calls.
Goal = unify(_, _, _, Uni, _) - _,
Uni = construct(_, ConsId, _, _, _, _, _),
- ConsId = pred_const(_, _, _)
+ ConsId = pred_const(_, _)
->
rl_gen__find_aditi_call(ModuleInfo, Goals,
[Goal | RevBetweenGoals0], BetweenGoals,
@@ -1038,10 +1037,10 @@
(
{ BetweenGoal = unify(_, _, _, Uni, _) - _ },
{ Uni = construct(Var, ConsId, CurriedArgs, _, _, _, _) },
- { ConsId = pred_const(PredId, ProcId, _EvalMethod) }
+ { ConsId = pred_const(ShroudedPredProcId, _EvalMethod) }
->
- { Closure = closure_pred(CurriedArgs,
- proc(PredId, ProcId)) },
+ { PredProcId = unshroud_pred_proc_id(ShroudedPredProcId) },
+ { Closure = closure_pred(CurriedArgs, PredProcId) },
rl_info_set_var_status(Var, Closure),
rl_gen__setup_var_rels(BetweenGoals)
;
Index: rl_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_info.m,v
retrieving revision 1.6
diff -u -b -r1.6 rl_info.m
Index: rl_key.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_key.m,v
retrieving revision 1.17
diff -u -b -r1.17 rl_key.m
Index: rl_liveness.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_liveness.m,v
retrieving revision 1.6
diff -u -b -r1.6 rl_liveness.m
Index: rl_loop.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_loop.m,v
retrieving revision 1.5
diff -u -b -r1.5 rl_loop.m
Index: rl_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_opt.m,v
retrieving revision 1.5
diff -u -b -r1.5 rl_opt.m
Index: rl_relops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_relops.m,v
retrieving revision 1.9
diff -u -b -r1.9 rl_relops.m
Index: rl_sort.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_sort.m,v
retrieving revision 1.13
diff -u -b -r1.13 rl_sort.m
Index: rl_stream.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_stream.m,v
retrieving revision 1.10
diff -u -b -r1.10 rl_stream.m
Index: rtti.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.48
diff -u -b -r1.48 rtti.m
Index: rtti_to_mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.51
diff -u -b -r1.51 rtti_to_mlds.m
Index: simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.131
diff -u -b -r1.131 simplify.m
--- simplify.m 7 Jun 2004 09:07:06 -0000 1.131
+++ simplify.m 12 Jun 2004 14:33:20 -0000
@@ -97,8 +97,8 @@
:- import_module hlds__special_pred.
:- import_module libs__options.
:- import_module libs__trace_params.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_util.
:- import_module transform_hlds__const_prop.
:- import_module transform_hlds__pd_cost.
Index: size_prof.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/size_prof.m,v
retrieving revision 1.7
diff -u -b -r1.7 size_prof.m
--- size_prof.m 7 Jun 2004 09:07:07 -0000 1.7
+++ size_prof.m 12 Jun 2004 10:05:11 -0000
@@ -116,7 +116,6 @@
:- import_module libs__globals.
:- import_module libs__options.
:- import_module check_hlds__mode_util.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_util.
:- import_module transform_hlds__term_norm.
Index: source_file_map.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/source_file_map.m,v
retrieving revision 1.8
diff -u -b -r1.8 source_file_map.m
Index: special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.44
diff -u -b -r1.44 special_pred.m
--- special_pred.m 23 Mar 2004 06:56:42 -0000 1.44
+++ special_pred.m 12 Jun 2004 15:11:15 -0000
@@ -41,9 +41,8 @@
% unification is actually `det', however we need to pretend it
% is `semidet' so that it can be called correctly from the
% polymorphic `unify' procedure.
-:- pred special_pred_interface(special_pred_id, type, list(type),
- list(mode), determinism).
-:- mode special_pred_interface(in, in, out, out, out) is det.
+:- pred special_pred_interface(special_pred_id::in, (type)::in,
+ list(type)::out, list(mode)::out, determinism::out) is det.
% special_pred_name_arity(SpecialPredType, GenericPredName, Arity):
% true iff there is a special predicate of category
@@ -52,11 +51,9 @@
:- mode special_pred_name_arity(in, out, out) is det.
:- mode special_pred_name_arity(out, in, out) is semidet.
-:- pred special_pred_mode_num(special_pred_id, int).
-:- mode special_pred_mode_num(in, out) is det.
+:- pred special_pred_mode_num(special_pred_id::in, int::out) is det.
-:- pred special_pred_list(list(special_pred_id)).
-:- mode special_pred_list(out) is det.
+:- pred special_pred_list(list(special_pred_id)::out) is det.
% Given a special pred id and the list of its arguments, work out
% which argument specifies the type that this special predicate is for.
@@ -69,14 +66,13 @@
% can be found in the last type argument, except for index, for
% which it is the second-last argument.
-:- pred special_pred_get_type(special_pred_id, list(prog_var), prog_var).
-:- mode special_pred_get_type(in, in, out) is semidet.
+:- pred special_pred_get_type(special_pred_id::in, list(prog_var)::in,
+ prog_var::out) is semidet.
-:- pred special_pred_get_type_det(special_pred_id, list(prog_var), prog_var).
-:- mode special_pred_get_type_det(in, in, out) is det.
+:- pred special_pred_get_type_det(special_pred_id::in, list(prog_var)::in,
+ prog_var::out) is det.
-:- pred special_pred_description(special_pred_id, string).
-:- mode special_pred_description(in, out) is det.
+:- pred special_pred_description(special_pred_id::in, string::out) is det.
%
% Succeeds if the declarations and clauses for the special predicates
@@ -84,12 +80,11 @@
% This will succeed for imported types for which the special
% predicates do not need typechecking.
%
-:- pred special_pred_is_generated_lazily(module_info, type_ctor).
-:- mode special_pred_is_generated_lazily(in, in) is semidet.
+:- pred special_pred_is_generated_lazily(module_info::in, type_ctor::in)
+ is semidet.
-:- pred special_pred_is_generated_lazily(module_info, type_ctor,
- hlds_type_body, import_status).
-:- mode special_pred_is_generated_lazily(in, in, in, in) is semidet.
+:- pred special_pred_is_generated_lazily(module_info::in, type_ctor::in,
+ hlds_type_body::in, import_status::in) is semidet.
%
% A compiler-generated predicate only needs type checking if
@@ -97,20 +92,19 @@
% or (b) it is the unification or comparison predicate for an
% existially quantified type.
%
-:- pred special_pred_for_type_needs_typecheck(module_info, hlds_type_body).
-:- mode special_pred_for_type_needs_typecheck(in, in) is semidet.
+:- pred special_pred_for_type_needs_typecheck(module_info::in,
+ hlds_type_body::in) is semidet.
% Succeed if the type can have clauses generated for
% its special predicates. This will fail for abstract
% types and types for which the RTTI information is
% defined by hand.
-:- pred can_generate_special_pred_clauses_for_type(module_info, type_ctor,
- hlds_type_body).
-:- mode can_generate_special_pred_clauses_for_type(in, in, in) is semidet.
+:- pred can_generate_special_pred_clauses_for_type(module_info::in,
+ type_ctor::in, hlds_type_body::in) is semidet.
% Are the special predicates for a builtin type defined in Mercury?
-:- pred is_builtin_types_special_preds_defined_in_mercury(
- type_ctor::in, string::out) is semidet.
+:- pred is_builtin_types_special_preds_defined_in_mercury(type_ctor::in,
+ string::out) is semidet.
% Does the compiler generate the RTTI for the builtin types, or is
% it hand-coded?
@@ -122,6 +116,7 @@
:- import_module check_hlds__type_util.
:- import_module libs__globals.
:- import_module libs__options.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_util.
:- import_module bool, require.
@@ -197,9 +192,8 @@
TypeCtor, Body, Status)
).
-:- pred special_pred_is_generated_lazily_2(module_info,
- type_ctor, hlds_type_body, import_status).
-:- mode special_pred_is_generated_lazily_2(in, in, in, in) is semidet.
+:- pred special_pred_is_generated_lazily_2(module_info::in,
+ type_ctor::in, hlds_type_body::in, import_status::in) is semidet.
special_pred_is_generated_lazily_2(ModuleInfo, _TypeCtor, Body, Status) :-
(
@@ -269,6 +263,5 @@
globals__get_target(Globals, Target),
( Target = il ; Target = java ).
-%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: stack_layout.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stack_layout.m,v
retrieving revision 1.90
diff -u -b -r1.90 stack_layout.m
--- stack_layout.m 23 May 2004 23:14:33 -0000 1.90
+++ stack_layout.m 12 Jun 2004 10:05:11 -0000
@@ -69,7 +69,6 @@
:- import_module ll_backend__prog_rep.
:- import_module ll_backend__static_term.
:- import_module ll_backend__trace.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
Index: stack_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.12
diff -u -b -r1.12 stack_opt.m
Index: store_alloc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/store_alloc.m,v
retrieving revision 1.87
diff -u -b -r1.87 store_alloc.m
Index: stratify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.32
diff -u -b -r1.32 stratify.m
--- stratify.m 7 Jun 2004 09:07:08 -0000 1.32
+++ stratify.m 12 Jun 2004 10:16:47 -0000
@@ -784,8 +784,9 @@
% been transformed to lambda goals. see above
Unification = construct(_Var2, ConsId, _, _, _, _, _)
->
- ( ConsId = pred_const(PredId, ProcId, _) ->
- set__insert(HasAT0, proc(PredId, ProcId), HasAT)
+ ( ConsId = pred_const(ShroudedPredProcId, _) ->
+ PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
+ set__insert(HasAT0, PredProcId, HasAT)
;
HasAT = HasAT0
)
@@ -879,8 +880,9 @@
% been transformed to lambda goals see above
Unification = construct(_Var2, ConsId, _, _, _, _, _)
->
- ( ConsId = pred_const(PredId, ProcId, _) ->
- Calls = [proc(PredId, ProcId) | Calls0]
+ ( ConsId = pred_const(ShroudedPredProcId, _) ->
+ PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
+ Calls = [PredProcId | Calls0]
;
Calls = Calls0
)
Index: switch_detection.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_detection.m,v
retrieving revision 1.104
diff -u -b -r1.104 switch_detection.m
--- switch_detection.m 7 Jun 2004 09:07:08 -0000 1.104
+++ switch_detection.m 12 Jun 2004 14:59:37 -0000
@@ -53,14 +53,13 @@
:- import_module check_hlds__det_util.
:- import_module check_hlds__inst_match.
-:- import_module check_hlds__mode_util.
-:- import_module check_hlds__modes.
:- import_module check_hlds__type_util.
:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- import_module hlds__instmap.
:- import_module hlds__passes_aux.
:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_mode.
:- import_module term.
:- import_module char, int, assoc_list, map, set, std_util, require.
Index: switch_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_gen.m,v
retrieving revision 1.84
diff -u -b -r1.84 switch_gen.m
Index: switch_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.18
diff -u -b -r1.18 switch_util.m
--- switch_util.m 19 May 2004 03:59:38 -0000 1.18
+++ switch_util.m 12 Jun 2004 10:17:27 -0000
@@ -291,8 +291,8 @@
switch_util__switch_priority(type_ctor_info_constant(_, _, _)) = 6.
switch_util__switch_priority(base_typeclass_info_constant(_, _, _)) = 6.
switch_util__switch_priority(tabling_pointer_constant(_, _)) = 6.
-switch_util__switch_priority(deep_profiling_proc_layout_tag(_)) = 6.
-switch_util__switch_priority(table_io_decl_tag(_)) = 6.
+switch_util__switch_priority(deep_profiling_proc_layout_tag(_, _)) = 6.
+switch_util__switch_priority(table_io_decl_tag(_, _)) = 6.
% Determine the range of an atomic type.
% Fail if the type isn't the sort of type that has a range
Index: table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.62
diff -u -b -r1.62 table_gen.m
--- table_gen.m 7 Jun 2004 09:07:08 -0000 1.62
+++ table_gen.m 12 Jun 2004 16:08:47 -0000
@@ -73,8 +73,8 @@
:- import_module ll_backend.
:- import_module ll_backend__continuation_info.
:- import_module parse_tree__error_util.
-:- import_module parse_tree__inst.
:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
:- import_module transform_hlds__const_prop.
@@ -888,9 +888,8 @@
TableDecl = table_io_decl,
PredId = !.TableInfo ^ table_cur_pred_id,
ProcId = !.TableInfo ^ table_cur_proc_id,
- RttiProcLabel = rtti__make_rtti_proc_label(ModuleInfo,
- PredId, ProcId),
- TableIoDeclConsId = table_io_decl(RttiProcLabel),
+ ShroudedPredProcId = shroud_pred_proc_id(proc(PredId, ProcId)),
+ TableIoDeclConsId = table_io_decl(ShroudedPredProcId),
make_const_construction(TableIoDeclConsId, c_pointer_type,
yes("TableIoDeclPtr"), TableIoDeclGoal,
TableIoDeclPtrVar, !VarTypes, !VarSet),
@@ -1382,7 +1381,8 @@
Goal) :-
generate_new_table_var("PredTable", trie_node_type,
!VarTypes, !VarSet, PredTableVar),
- ConsId = tabling_pointer_const(PredId, ProcId),
+ ShroudedPredProcId = shroud_pred_proc_id(proc(PredId, ProcId)),
+ ConsId = tabling_pointer_const(ShroudedPredProcId),
make_const_construction(PredTableVar, ConsId, GoalExpr - GoalInfo0),
goal_info_add_feature(GoalInfo0, impure, GoalInfo),
Goal = GoalExpr - GoalInfo.
@@ -1978,7 +1978,7 @@
Name = pred_info_name(PredInfo),
Arity = pred_info_arity(PredInfo),
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
- PredOrFuncStr = hlds_out__pred_or_func_to_str(PredOrFunc),
+ PredOrFuncStr = pred_or_func_to_str(PredOrFunc),
prog_out__sym_name_to_string(qualified(Module, Name), NameStr),
string__int_to_string(Arity, ArityStr),
string__append_list([Msg, " in ", PredOrFuncStr, " ", NameStr,
Index: tag_switch.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/tag_switch.m,v
retrieving revision 1.60
diff -u -b -r1.60 tag_switch.m
Index: term_norm.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_norm.m,v
retrieving revision 1.3
diff -u -b -r1.3 term_norm.m
--- term_norm.m 8 Dec 2003 03:37:44 -0000 1.3
+++ term_norm.m 12 Jun 2004 10:05:13 -0000
@@ -15,7 +15,6 @@
:- interface.
-:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- import_module hlds__hlds_module.
:- import_module libs__globals.
@@ -56,6 +55,7 @@
:- import_module check_hlds__inst_match.
:- import_module check_hlds__mode_util.
:- import_module check_hlds__type_util.
+:- import_module hlds__hlds_data.
:- import_module libs__options.
:- import_module parse_tree__prog_out.
Index: term_pass1.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_pass1.m,v
retrieving revision 1.17
diff -u -b -r1.17 term_pass1.m
Index: term_pass2.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_pass2.m,v
retrieving revision 1.16
diff -u -b -r1.16 term_pass2.m
Index: term_traversal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_traversal.m,v
retrieving revision 1.30
diff -u -b -r1.30 term_traversal.m
Index: term_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.36
diff -u -b -r1.36 term_util.m
Index: termination.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/termination.m,v
retrieving revision 1.42
diff -u -b -r1.42 termination.m
Index: timestamp.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/timestamp.m,v
retrieving revision 1.8
diff -u -b -r1.8 timestamp.m
Index: trace.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/trace.m,v
retrieving revision 1.66
diff -u -b -r1.66 trace.m
--- trace.m 7 Jun 2004 09:07:09 -0000 1.66
+++ trace.m 12 Jun 2004 10:05:13 -0000
@@ -225,7 +225,6 @@
:- import_module ll_backend__continuation_info.
:- import_module ll_backend__layout_out.
:- import_module ll_backend__llds_out.
-:- import_module parse_tree__inst.
:- import_module list, bool, int, string, map, std_util, require, term, varset.
Index: transform.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/transform.m,v
retrieving revision 1.18
diff -u -b -r1.18 transform.m
Index: transform_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/transform_hlds.m,v
retrieving revision 1.9
diff -u -b -r1.9 transform_hlds.m
--- transform_hlds.m 23 Mar 2004 10:52:13 -0000 1.9
+++ transform_hlds.m 12 Jun 2004 17:07:15 -0000
@@ -17,9 +17,10 @@
%-----------------------------------------------------------------------------%
-:- include_module intermod, trans_opt.
+:- include_module intermod.
+:- include_module trans_opt.
-:- include_module dependency_graph. % XXX imports llds (for profiling labels)
+:- include_module dependency_graph.
:- include_module equiv_type_hlds.
Index: type_class_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_class_info.m,v
retrieving revision 1.4
diff -u -b -r1.4 type_class_info.m
--- type_class_info.m 24 Mar 2004 02:57:13 -0000 1.4
+++ type_class_info.m 12 Jun 2004 10:05:14 -0000
@@ -21,7 +21,6 @@
:- interface.
:- import_module backend_libs__rtti.
-:- import_module hlds__hlds_data.
:- import_module hlds__hlds_module.
:- import_module parse_tree__prog_data.
@@ -37,6 +36,7 @@
:- implementation.
:- import_module check_hlds__type_util.
+:- import_module hlds__hlds_data.
:- import_module hlds__hlds_out.
:- import_module hlds__hlds_pred.
:- import_module libs__globals.
Index: type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.138
diff -u -b -r1.138 type_util.m
--- type_util.m 5 Apr 2004 05:07:43 -0000 1.138
+++ type_util.m 12 Jun 2004 10:05:14 -0000
@@ -531,6 +531,7 @@
:- import_module libs__options.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_io_goal.
+:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
:- import_module bool, char, int, string.
@@ -723,7 +724,7 @@
TypeArgs0)
->
TypeArgs = TypeArgs0,
- PredOrFuncStr = hlds_out__pred_or_func_to_str(PredOrFunc),
+ PredOrFuncStr = pred_or_func_to_str(PredOrFunc),
TypeCtor = unqualified(PredOrFuncStr) - 0
;
type_is_tuple(Type, TypeArgs1)
Index: typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.354
diff -u -b -r1.354 typecheck.m
--- typecheck.m 7 Jun 2004 09:07:10 -0000 1.354
+++ typecheck.m 12 Jun 2004 16:14:05 -0000
@@ -132,7 +132,6 @@
:- import_module check_hlds__clause_to_proc.
:- import_module check_hlds__inst_match.
-:- import_module check_hlds__mode_util.
:- import_module check_hlds__type_util.
:- import_module hlds__goal_util.
:- import_module hlds__hlds_error_util.
@@ -147,6 +146,7 @@
:- import_module parse_tree__modules.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_io_util.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
@@ -5689,7 +5689,7 @@
{ typecheck_info_get_context(Info, Context) },
prog_out__write_context(Context),
io__write_string(" (There is a *"),
- hlds_out__write_pred_or_func(PredOrFunc),
+ write_pred_or_func(PredOrFunc),
io__write_string("* with that name, however."),
( { PredOrFunc = function } ->
io__nl,
@@ -5750,7 +5750,7 @@
io__nl,
prog_out__write_context(Context),
io__write_string(" in call to "),
- hlds_out__write_pred_or_func(PredOrFunc),
+ write_pred_or_func(PredOrFunc),
io__write_string(" `"),
prog_out__write_sym_name(SymName),
io__write_string("'.\n").
Index: unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.142
diff -u -b -r1.142 unify_gen.m
--- unify_gen.m 19 May 2004 03:59:38 -0000 1.142
+++ unify_gen.m 12 Jun 2004 10:27:43 -0000
@@ -19,7 +19,6 @@
:- interface.
:- import_module hlds__code_model.
-:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- import_module ll_backend__code_info.
:- import_module ll_backend__llds.
@@ -48,6 +47,7 @@
:- import_module check_hlds__mode_util.
:- import_module check_hlds__type_util.
:- import_module hlds__arg_info.
+:- import_module hlds__hlds_data.
:- import_module hlds__hlds_module.
:- import_module hlds__hlds_out.
:- import_module hlds__hlds_pred.
@@ -263,10 +263,11 @@
unify_gen__generate_tag_test_rval_2(tabling_pointer_constant(_, _), _, _) :-
% This should never happen
error("Attempted tabling_pointer unification").
-unify_gen__generate_tag_test_rval_2(deep_profiling_proc_layout_tag(_), _, _) :-
+unify_gen__generate_tag_test_rval_2(deep_profiling_proc_layout_tag(_, _),
+ _, _) :-
% This should never happen
error("Attempted deep_profiling_proc_layout_tag unification").
-unify_gen__generate_tag_test_rval_2(table_io_decl_tag(_), _, _) :-
+unify_gen__generate_tag_test_rval_2(table_io_decl_tag(_, _), _, _) :-
% This should never happen
error("Attempted table_io_decl_tag unification").
unify_gen__generate_tag_test_rval_2(no_tag, _Rval, TestRval) :-
@@ -425,13 +426,15 @@
code_info__assign_const_to_var(Var,
const(data_addr_const(DataAddr, no)), !CI).
unify_gen__generate_construction_2(
- deep_profiling_proc_layout_tag(RttiProcLabel),
+ deep_profiling_proc_layout_tag(PredId, ProcId),
Var, Args, _Modes, _, _, empty, !CI) :-
( Args = [] ->
true
;
error("unify_gen: deep_profiling_proc_static has args")
),
+ code_info__get_module_info(!.CI, ModuleInfo),
+ RttiProcLabel = make_rtti_proc_label(ModuleInfo, PredId, ProcId),
IsSpecial = RttiProcLabel ^ pred_is_special_pred,
(
IsSpecial = yes(_),
@@ -444,13 +447,15 @@
DataAddr = layout_addr(proc_layout(RttiProcLabel, ProcKind)),
code_info__assign_const_to_var(Var,
const(data_addr_const(DataAddr, no)), !CI).
-unify_gen__generate_construction_2(table_io_decl_tag(RttiProcLabel),
+unify_gen__generate_construction_2(table_io_decl_tag(PredId, ProcId),
Var, Args, _Modes, _, _, empty, !CI) :-
( Args = [] ->
true
;
error("unify_gen: table_io_decl has args")
),
+ code_info__get_module_info(!.CI, ModuleInfo),
+ RttiProcLabel = make_rtti_proc_label(ModuleInfo, PredId, ProcId),
DataAddr = layout_addr(table_io_decl(RttiProcLabel)),
code_info__assign_const_to_var(Var,
const(data_addr_const(DataAddr, no)), !CI).
@@ -851,10 +856,10 @@
Tag = tabling_pointer_constant(_, _),
Code = empty
;
- Tag = deep_profiling_proc_layout_tag(_),
+ Tag = deep_profiling_proc_layout_tag(_, _),
Code = empty
;
- Tag = table_io_decl_tag(_),
+ Tag = table_io_decl_tag(_, _),
error("unify_gen__generate_det_deconstruction: " ++
"table_io_decl_tag")
;
Index: unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.136
diff -u -b -r1.136 unify_proc.m
--- unify_proc.m 7 Jun 2004 09:07:11 -0000 1.136
+++ unify_proc.m 12 Jun 2004 16:13:27 -0000
@@ -135,7 +135,6 @@
:- import_module check_hlds__cse_detection.
:- import_module check_hlds__det_analysis.
:- import_module check_hlds__inst_match.
-:- import_module check_hlds__mode_util.
:- import_module check_hlds__modes.
:- import_module check_hlds__polymorphism.
:- import_module check_hlds__post_typecheck.
@@ -151,8 +150,8 @@
:- import_module libs__options.
:- import_module libs__tree.
:- import_module parse_tree__error_util.
-:- import_module parse_tree__inst.
:- import_module parse_tree__mercury_to_mercury.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
:- import_module recompilation.
Index: unique_modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.81
diff -u -b -r1.81 unique_modes.m
--- unique_modes.m 7 Jun 2004 09:07:12 -0000 1.81
+++ unique_modes.m 12 Jun 2004 15:02:23 -0000
@@ -73,9 +73,9 @@
:- import_module hlds__hlds_out.
:- import_module hlds__instmap.
:- import_module hlds__passes_aux.
-:- import_module parse_tree__inst.
:- import_module parse_tree__mercury_to_mercury.
:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
:- import_module term, varset.
Index: unneeded_code.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unneeded_code.m,v
retrieving revision 1.19
diff -u -b -r1.19 unneeded_code.m
Index: unused_args.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.93
diff -u -b -r1.93 unused_args.m
--- unused_args.m 7 Jun 2004 09:07:13 -0000 1.93
+++ unused_args.m 12 Jun 2004 10:05:14 -0000
@@ -1616,7 +1616,7 @@
{ Arity = pred_info_arity(PredInfo) },
prog_out__write_context(Context),
io__write_string("In "),
- hlds_out__write_pred_or_func(PredOrFunc),
+ write_pred_or_func(PredOrFunc),
io__write_string(" `"),
prog_out__write_sym_name(Module),
io__write_string("."),
Index: use_local_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/use_local_vars.m,v
retrieving revision 1.9
diff -u -b -r1.9 use_local_vars.m
cvs diff: Diffing notes
Index: notes/compiler_design.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.91
diff -u -b -r1.91 compiler_design.html
--- notes/compiler_design.html 23 Mar 2004 11:02:45 -0000 1.91
+++ notes/compiler_design.html 12 Jun 2004 16:41:23 -0000
@@ -268,14 +268,14 @@
goals), prog_io_pragma.m (which handles pragma declarations),
prog_io_typeclass.m (which handles typeclass and instance declarations)
and prog_io_util.m (which defines predicates and types needed by the
- other prog_io*.m modules. The data structure for insts is stored in
- its own module, inst.m.
+ other prog_io*.m modules.
<p>
The modules prog_out.m and mercury_to_mercury.m contain predicates
for printing the parse tree. prog_util.m contains some utility
- predicates for manipulating the parse tree, while error_util.m
+ predicates for manipulating the parse tree, prog_mode contains utility
+ predicates for manipulating insts and modes, while error_util.m
contains predicates for printing nicely formatting error messages.
<li><p> imports and exports are handled at this point (modules.m)
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list