mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-18 23:35:25 +00:00
Code Issues Projects Releases Wiki Activity
Files
4427723508cac661d7c58c94fe432fd08258bc0c
mercury/compiler/prog_util.m
Mark Brown 4427723508 Remove the assumption made by polymorphism.m that all type variables 
Estimated hours taken: 240
Branches: main

Remove the assumption made by polymorphism.m that all type variables
appearing in class constraints also appear in the type being constrained.
This is a first step towards adding functional dependencies, since in the
presence of functional dependencies (or "improvement" in general) this
assumption no longer holds.

The assumption made by polymorphism manifests itself in the fact that
constraints on atomic goals are reconstructed by unifying the types of
formal parameters with the types of actual arguments, and then applying
the resulting substitution to the constraints.  Any type variables in
constraints that don't appear in the formal parameters will therefore
remain unbound.

This change overcomes the assumption by building up a map from constraint
identifiers to constraints during typechecking, and then looking up this
map in order to reconstruct the constraint during the polymorphism
transformation.

To support this, the type 'class_constraint' has been removed and replaced
by two distinct types, 'prog_constraint' and 'hlds_constraint'.  The former
is part of the parse tree and holds the same information as the old
class_constraint.  The latter is part of the HLDS, and is used during
typechecking; in addition to the information in prog_constraints, it also
stores a set of identifiers that represent where the constraint came from.
These identifiers are used as the keys in the aforementioned map.

At this stage the constraint identifiers are only used by typechecking to
build the constraint map.  Other passes use either prog_constraints or
hlds_constraints with an empty set of identifiers.

compiler/hlds_data.m:
	Define the constraint_id type, which is used to uniquely identify
	class constraints.  A better scheme than this one has been suggested,
	but that will be left to a later change.  An XXX comment to that
	effect has been added.

	Define the hlds_constraint type, which is like prog_constraint but
	it also includes a set of constraint_ids.  Define a set of predicates
	to initialise and manipulate these.

	Define the constraint_map type here.  Move the definition of
	constraint_proof_map to here, where it more sensibly belongs.

	Update the comments in hlds_instance_defn slightly, with information
	that I found I needed to know when making this change.

compiler/hlds_pred.m:
	Add a field to the pred_info to store the constraint_map.

	Move the definition of constraint_proof_map from here.

compiler/hlds_out.m:
	Print out a representation of the constraint map if it isn't empty.

compiler/type_util.m:
	Change the predicates that used to operate on class_constraints so
	that they now operate on hlds_constraints.  The old versions of these
	predicates have now moved to prog_util.

	Add some utility predicates to manipulate constraint_maps.

	Add a predicate to apply a variable renaming to constraint_proof_maps.

compiler/prog_data.m:
	Rename class_constraint(s) to prog_constraint(s).

compiler/prog_util.m:
	Provide a set of predicates for manipulating prog_constraints.

compiler/typecheck.m:
	Ensure that goal_paths are filled in before the first iteration
	of typechecking.

	Pass the hlds_goal_info down through typecheck_goal_2 so that the
	goal_path can be retrieved when needed to assign identifiers to
	constraints.  Thread the goal_path through to wherever it is needed.

	Store hlds_constraints in the args_type_assign rather than
	prog_constraints, so that the required information is available
	when creating the new set of type_assigns.  Do likewise for the
	cons_type_info type.  Don't pass the module_info through
	make_pred_cons_info*, since it isn't used.  Do pass the goal_path,
	though, so that constraints in cons_type_infos can be given the
	correct identifier.

	Add a constraint_map field to the typecheck_info, initialised to empty.

	When retrieving the final information from a typecheck_info, return
	the resulting constraint_map, after applying any type bindings.
	Ensure that any constraints that may not have been entered into the
	constraint_map are put there now.  Call the new predicate in type_util
	to rename the constraint_proof_map, rather than doing it longhand
	here.

	Make the following changes to context reduction:

		- Thread the constraint_map through, so that it can be updated
		as constraints are eliminated.

		- Instead of simply calling sort_and_remove_dups on the
		set of constraints remaining after one iteration, merge the
		constraints in such a way that the complete set of
		constraint_ids is retained.

		- Disregard the constraint_ids when deleting newly introduced
		constraints that are equivalent to constraints that have
		already been seen.

		- Simplify the code of find_matching_instance_rule_2 by
		moving the deterministic code out of the condition of the
		if-then-else.

	Move find_first_map into the library.

compiler/polymorphism.m:
	Ensure that the goal_path is set when constructing lambda goals.

	In process_call, look up the constraints in the constraint_map
	using the goal_path as part of the key, rather than calculating
	the constraints by applying the ParentToActual type substitution.
	Rearrange this code so that it is divided into easier to understand
	blocks.

	Add a field to the poly_info to store the constraint_map, and
	initialise it from the pred_info.

compiler/goal_path.m:
	Fill slots in lambda_goals, since constraints inside these will
	otherwise not be identified properly.  The goal_paths inside here
	do not entirely make sense, since there is no goal_path_step for
	the lambda_goal itself.  However, there is enough information
	retained to distinguish these goal_paths from any other possible
	goal_path, which is all that we require to identify constraints.

	Add a warning not to fill in the goal slots between the typechecking
	and polymorphism passes, since doing so could potentially render the
	constraint_maps incorrect.

compiler/make_hlds.m:
	Initialise the constraint_map to empty in pred_infos.

	Move the code for updating the superclass_table into a separate
	predicate.  Initially this change was made because, in an earlier
	version of the change, the superclass_table had some extra
	information that needed to be filled in.  That part of the change
	is not needed in this diff, but the new predicate simplifies the
	code a bit so I've left it there.

compiler/check_typeclass.m:
	Convert the prog_constraints into hlds_constraints before passing
	them to typecheck.reduce_context_by_rule_application.  They are
	assigned no identifiers, since these constraints are not required
	to be put into the constraint map.

	Change the name of the function get_constraint_id to
	get_constraint_class_id, since it would now be ambiguous otherwise.

compiler/cse_detection.m:
	Import parse_tree__prog_util, since that is where renamings of
	prog_constraints are now defined.

compiler/higher_order.m:
	Initialise pred_infos here with an empty constraint_map.

compiler/post_typecheck.m:
	When binding type vars to void, apply the void substitution to the
	constraint_map.

compiler/table_gen.m:
	Pass the constraint_map when creating a new pred_info.

compiler/unused_args.m:
	Create the pred_info with an empty constraint_map.  The constraint_map
	won't be used by this stage anyway.

compiler/*.m:
	Update to use the new type names.  Also update to use the existing
	type synonyms typeclass_info_varmap and constraint_proof_map.

	Change names of predicates and functions to use prog_constraint
	instead of class_constraint, where applicable.

library/list.m:
	Add find_first_map from typecheck.  Also add find_first_map{2,3},
	since at one stage during development I needed find_first_map3, and,
	although it's not used in the current diff, there is little point
	removing it now.
2005-04-01 14:29:19 +00:00

795 lines
31 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% Copyright (C) 1994-2001, 2003-2005 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
% various utility predicates acting on the parse tree data
% structure defined in prog_data.m.
:- module parse_tree__prog_util.
:- interface.
:- import_module mdbcomp__prim_data.
:- import_module parse_tree__prog_data.
:- import_module list.
:- import_module map.
:- import_module std_util.
:- import_module term.
:- import_module varset.
%-----------------------------------------------------------------------------%
% Returns the name of the module containing public builtins;
% originally this was "mercury_builtin", but it later became
% just "builtin", and it may eventually be renamed "std:builtin".
% This module is automatically imported, as if via `import_module'.
:- pred mercury_public_builtin_module(sym_name::out) is det.
:- func mercury_public_builtin_module = sym_name.
% Returns the name of the module containing private builtins;
% traditionally this was "mercury_builtin", but it later became
% "private_builtin", and it may eventually be renamed
% "std:private_builtin".
% This module is automatically imported, as if via `use_module'.
:- pred mercury_private_builtin_module(sym_name::out) is det.
:- func mercury_private_builtin_module = sym_name.
% Returns the name of the module containing builtins for tabling;
% originally these were in "private_builtin", but they
% may soon be moved into a separate module.
% This module is automatically imported iff tabling is enabled.
:- pred mercury_table_builtin_module(sym_name::out) is det.
:- func mercury_table_builtin_module = sym_name.
% Returns the name of the module containing the builtins for
% deep profiling.
% This module is automatically imported iff deep profiling is
% enabled.
:- pred mercury_profiling_builtin_module(sym_name::out) is det.
:- func mercury_profiling_builtin_module = sym_name.
% Returns the name of the module containing the builtins for
% term size profiling.
% This module is automatically imported iff term size profiling is
% enabled.
:- pred mercury_term_size_prof_builtin_module(sym_name::out) is det.
:- func mercury_term_size_prof_builtin_module = sym_name.
% Returns the name of the module containing the public builtins
% used by the Aditi transaction interface, currently "aditi".
% This module is not automatically imported (XXX should it be?).
:- pred aditi_public_builtin_module(sym_name::out) is det.
:- func aditi_public_builtin_module = sym_name.
% Returns the name of the module containing the private builtins
% used by the Aditi transaction interface, currently
% "aditi_private_builtin".
% This module is automatically imported iff the Aditi interface
% is enabled.
:- pred aditi_private_builtin_module(sym_name::out) is det.
:- func aditi_private_builtin_module = sym_name.
% Succeeds iff the specified module is one of the
% builtin modules listed above which are automatically imported.
:- pred any_mercury_builtin_module(sym_name::in) is semidet.
%-----------------------------------------------------------------------------%
% Given a symbol name, return its unqualified name.
:- pred unqualify_name(sym_name::in, string::out) is det.
% sym_name_get_module_name(SymName, ModName):-
% Given a symbol name, return the module qualifiers(s).
% Fails if the symbol is unqualified.
%
:- pred sym_name_get_module_name(sym_name::in, module_name::out) is semidet.
% sym_name_get_module_name(SymName, DefaultModName, ModName):
% Given a symbol name, return the module qualifier(s).
% If the symbol is unqualified, then return the specified default
% module name.
%
:- pred sym_name_get_module_name(sym_name::in, module_name::in,
module_name::out) is det.
% match_sym_name(PartialSymName, CompleteSymName):
% succeeds iff there is some sequence of module qualifiers
% which when prefixed to PartialSymName gives CompleteSymName.
%
:- pred match_sym_name(sym_name::in, sym_name::in) is semidet.
% remove_sym_name_prefix(SymName0, Prefix, SymName)
% succeeds iff
% SymName and SymName0 have the same module qualifier
% and the unqualified part of SymName0 has the given prefix
% and the unqualified part of SymName is the unqualified
% part of SymName0 with the prefix removed
:- pred remove_sym_name_prefix(sym_name, string, sym_name).
:- mode remove_sym_name_prefix(in, in, out) is semidet.
:- mode remove_sym_name_prefix(out, in, in) is det.
% remove_sym_name_suffix(SymName0, Suffix, SymName)
% succeeds iff
% SymName and SymName0 have the same module qualifier
% and the unqualified part of SymName0 has the given suffix
% and the unqualified part of SymName is the unqualified
% part of SymName0 with the suffix removed
:- pred remove_sym_name_suffix(sym_name::in, string::in, sym_name::out)
is semidet.
% add_sym_name_suffix(SymName0, Suffix, SymName)
% succeeds iff
% SymName and SymName0 have the same module qualifier
% and the unqualified part of SymName is the unqualified
% part of SymName0 with the suffix added
:- pred add_sym_name_suffix(sym_name::in, string::in, sym_name::out) is det.
% transform_sym_base_name(TransformFunc, SymName0) = SymName
% succeeds iff
% SymName and SymName0 have the same module qualifier
% and the unqualified part of SymName is the result of applying
% TransformFunc to the unqualified part of SymName0.
:- func transform_sym_base_name(func(string) = string, sym_name) = sym_name.
% Given a possible module qualified sym_name and a list of
% argument types and a context, construct a term. This is
% used to construct types.
:- pred construct_qualified_term(sym_name::in, list(term(T))::in,
term(T)::out) is det.
:- pred construct_qualified_term(sym_name::in, list(term(T))::in,
prog_context::in, term(T)::out) is det.
% Given a sym_name return the top level qualifier of that name.
:- func outermost_qualifier(sym_name) = string.
%-----------------------------------------------------------------------------%
% adjust_func_arity(PredOrFunc, FuncArity, PredArity).
%
% We internally store the arity as the length of the argument
% list including the return value, which is one more than the
% arity of the function reported in error messages.
:- pred adjust_func_arity(pred_or_func, int, int).
:- mode adjust_func_arity(in, in, out) is det.
:- mode adjust_func_arity(in, out, in) is det.
%-----------------------------------------------------------------------------%
% make_pred_name_with_context(ModuleName, Prefix, PredOrFunc, PredName,
% Line, Counter, SymName).
%
% Create a predicate name with context, e.g. for introduced
% lambda or deforestation predicates.
:- pred make_pred_name(module_name::in, string::in, maybe(pred_or_func)::in,
string::in, new_pred_id::in, sym_name::out) is det.
% make_pred_name_with_context(ModuleName, Prefix, PredOrFunc, PredName,
% Line, Counter, SymName).
%
% Create a predicate name with context, e.g. for introduced
% lambda or deforestation predicates.
:- pred make_pred_name_with_context(module_name::in, string::in,
pred_or_func::in, string::in, int::in, int::in, sym_name::out) is det.
:- type new_pred_id
---> counter(int, int) % Line number, Counter
; type_subst(tvarset, type_subst)
; unused_args(list(int)).
%-----------------------------------------------------------------------------%
% A pred declaration may contains just types, as in
% :- pred list__append(list(T), list(T), list(T)).
% or it may contain both types and modes, as in
% :- pred list__append(list(T)::in, list(T)::in,
% list(T)::output).
%
% This predicate takes the argument list of a pred declaration,
% splits it into two separate lists for the types and (if present)
% the modes.
:- type maybe_modes == maybe(list(mode)).
:- pred split_types_and_modes(list(type_and_mode)::in, list(type)::out,
maybe_modes::out) is det.
:- pred split_type_and_mode(type_and_mode::in, (type)::out, maybe(mode)::out)
is det.
%-----------------------------------------------------------------------------%
% Perform a substitution on a goal.
:- pred prog_util__rename_in_goal(prog_var::in, prog_var::in,
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.
%-----------------------------------------------------------------------------%
:- pred apply_rec_subst_to_prog_constraints(tsubst::in, prog_constraints::in,
prog_constraints::out) is det.
:- pred apply_rec_subst_to_prog_constraint_list(tsubst::in,
list(prog_constraint)::in, list(prog_constraint)::out) is det.
:- pred apply_rec_subst_to_prog_constraint(tsubst::in, prog_constraint::in,
prog_constraint::out) is det.
:- pred apply_subst_to_prog_constraints(tsubst::in, prog_constraints::in,
prog_constraints::out) is det.
:- pred apply_subst_to_prog_constraint_list(tsubst::in,
list(prog_constraint)::in, list(prog_constraint)::out) is det.
:- pred apply_subst_to_prog_constraint(tsubst::in, prog_constraint::in,
prog_constraint::out) is det.
:- pred apply_variable_renaming_to_prog_constraints(map(tvar, tvar)::in,
prog_constraints::in, prog_constraints::out) is det.
:- pred apply_variable_renaming_to_prog_constraint_list(map(tvar, tvar)::in,
list(prog_constraint)::in, list(prog_constraint)::out) is det.
:- pred apply_variable_renaming_to_prog_constraint(map(tvar, tvar)::in,
prog_constraint::in, prog_constraint::out) is det.
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module parse_tree__mercury_to_mercury.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_out.
:- import_module bool.
:- import_module int.
:- import_module require.
:- import_module string.
:- import_module varset.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
% We may eventually want to put the standard library into a package "std":
% mercury_public_builtin_module = qualified(unqualified("std"), "builtin").
% mercury_private_builtin_module(M) =
% qualified(unqualified("std"), "private_builtin"))).
mercury_public_builtin_module = unqualified("builtin").
mercury_public_builtin_module(mercury_public_builtin_module).
mercury_private_builtin_module = unqualified("private_builtin").
mercury_private_builtin_module(mercury_private_builtin_module).
mercury_table_builtin_module = unqualified("table_builtin").
mercury_table_builtin_module(mercury_table_builtin_module).
mercury_profiling_builtin_module = unqualified("profiling_builtin").
mercury_profiling_builtin_module(mercury_profiling_builtin_module).
mercury_term_size_prof_builtin_module = unqualified("term_size_prof_builtin").
mercury_term_size_prof_builtin_module(mercury_term_size_prof_builtin_module).
aditi_public_builtin_module = unqualified("aditi").
aditi_public_builtin_module(aditi_public_builtin_module).
aditi_private_builtin_module = unqualified("aditi_private_builtin").
aditi_private_builtin_module(aditi_private_builtin_module).
any_mercury_builtin_module(Module) :-
( mercury_public_builtin_module(Module)
; mercury_private_builtin_module(Module)
; mercury_table_builtin_module(Module)
; mercury_profiling_builtin_module(Module)
; mercury_term_size_prof_builtin_module(Module)
; aditi_private_builtin_module(Module)
).
unqualify_name(unqualified(PredName), PredName).
unqualify_name(qualified(_ModuleName, PredName), PredName).
sym_name_get_module_name(unqualified(_), _) :- fail.
sym_name_get_module_name(qualified(ModuleName, _), ModuleName).
sym_name_get_module_name(unqualified(_), ModuleName, ModuleName).
sym_name_get_module_name(qualified(ModuleName, _PredName), _, ModuleName).
construct_qualified_term(qualified(Module, Name), Args, Context, Term) :-
construct_qualified_term(Module, [], Context, ModuleTerm),
UnqualifiedTerm = term__functor(term__atom(Name), Args, Context),
Term = term__functor(term__atom("."),
[ModuleTerm, UnqualifiedTerm], Context).
construct_qualified_term(unqualified(Name), Args, Context, Term) :-
Term = term__functor(term__atom(Name), Args, Context).
construct_qualified_term(SymName, Args, Term) :-
term__context_init(Context),
construct_qualified_term(SymName, Args, Context, Term).
outermost_qualifier(unqualified(Name)) = Name.
outermost_qualifier(qualified(Module, _Name)) = outermost_qualifier(Module).
%-----------------------------------------------------------------------------%
adjust_func_arity(predicate, Arity, Arity).
adjust_func_arity(function, Arity - 1, Arity).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
split_types_and_modes(TypesAndModes, Types, MaybeModes) :-
split_types_and_modes_2(TypesAndModes, yes, Types, Modes, Result),
( Result = yes ->
MaybeModes = yes(Modes)
;
MaybeModes = no
).
:- pred split_types_and_modes_2(list(type_and_mode)::in, bool::in,
list(type)::out, list(mode)::out, bool::out) is det.
% T = type, M = mode, TM = combined type and mode
split_types_and_modes_2([], Result, [], [], Result).
split_types_and_modes_2([TM|TMs], Result0, [T|Ts], [M|Ms], Result) :-
split_type_and_mode(TM, Result0, T, M, Result1),
split_types_and_modes_2(TMs, Result1, Ts, Ms, Result).
% if a pred declaration specifies modes for some but
% not all of the arguments, then the modes are ignored
% - should this be an error instead?
% trd: this should never happen because prog_io.m will detect
% these cases
:- pred split_type_and_mode(type_and_mode::in, bool::in,
(type)::out, (mode)::out, bool::out) is det.
split_type_and_mode(type_only(T), _, T, (free -> free), no).
split_type_and_mode(type_and_mode(T,M), R, T, M, R).
split_type_and_mode(type_only(T), T, no).
split_type_and_mode(type_and_mode(T,M), T, yes(M)).
%-----------------------------------------------------------------------------%
prog_util__rename_in_goal(OldVar, NewVar, Goal0 - Context, Goal - Context) :-
prog_util__rename_in_goal_expr(OldVar, NewVar, Goal0, Goal).
:- pred prog_util__rename_in_goal_expr(prog_var::in, prog_var::in,
goal_expr::in, goal_expr::out) is det.
prog_util__rename_in_goal_expr(OldVar, NewVar, (GoalA0, GoalB0),
(GoalA, GoalB)) :-
prog_util__rename_in_goal(OldVar, NewVar, GoalA0, GoalA),
prog_util__rename_in_goal(OldVar, NewVar, GoalB0, GoalB).
prog_util__rename_in_goal_expr(OldVar, NewVar, (GoalA0 & GoalB0),
(GoalA & GoalB)) :-
prog_util__rename_in_goal(OldVar, NewVar, GoalA0, GoalA),
prog_util__rename_in_goal(OldVar, NewVar, GoalB0, GoalB).
prog_util__rename_in_goal_expr(_OldVar, _NewVar, true, true).
prog_util__rename_in_goal_expr(OldVar, NewVar, (GoalA0; GoalB0),
(GoalA; GoalB)) :-
prog_util__rename_in_goal(OldVar, NewVar, GoalA0, GoalA),
prog_util__rename_in_goal(OldVar, NewVar, GoalB0, GoalB).
prog_util__rename_in_goal_expr(_Var, _NewVar, fail, fail).
prog_util__rename_in_goal_expr(OldVar, NewVar, not(Goal0), not(Goal)) :-
prog_util__rename_in_goal(OldVar, NewVar, Goal0, Goal).
prog_util__rename_in_goal_expr(OldVar, NewVar, some(Vars0, Goal0),
some(Vars, Goal)) :-
prog_util__rename_in_vars(OldVar, NewVar, Vars0, Vars),
prog_util__rename_in_goal(OldVar, NewVar, Goal0, Goal).
prog_util__rename_in_goal_expr(OldVar, NewVar, some_state_vars(Vars0, Goal0),
some_state_vars(Vars, Goal)) :-
prog_util__rename_in_vars(OldVar, NewVar, Vars0, Vars),
prog_util__rename_in_goal(OldVar, NewVar, Goal0, Goal).
prog_util__rename_in_goal_expr(OldVar, NewVar, all(Vars0, Goal0),
all(Vars, Goal)) :-
prog_util__rename_in_vars(OldVar, NewVar, Vars0, Vars),
prog_util__rename_in_goal(OldVar, NewVar, Goal0, Goal).
prog_util__rename_in_goal_expr(OldVar, NewVar, all_state_vars(Vars0, Goal0),
all_state_vars(Vars, Goal)) :-
prog_util__rename_in_vars(OldVar, NewVar, Vars0, Vars),
prog_util__rename_in_goal(OldVar, NewVar, Goal0, Goal).
prog_util__rename_in_goal_expr(OldVar, NewVar,
promise_purity(Implicit, Purity, Goal0),
promise_purity(Implicit, Purity, Goal)) :-
prog_util__rename_in_goal(OldVar, NewVar, Goal0, Goal).
prog_util__rename_in_goal_expr(OldVar, NewVar,
promise_equivalent_solutions(Vars0, Goal0),
promise_equivalent_solutions(Vars, Goal)) :-
prog_util__rename_in_vars(OldVar, NewVar, Vars0, Vars),
prog_util__rename_in_goal(OldVar, NewVar, Goal0, Goal).
prog_util__rename_in_goal_expr(OldVar, NewVar, implies(GoalA0, GoalB0),
implies(GoalA, GoalB)) :-
prog_util__rename_in_goal(OldVar, NewVar, GoalA0, GoalA),
prog_util__rename_in_goal(OldVar, NewVar, GoalB0, GoalB).
prog_util__rename_in_goal_expr(OldVar, NewVar, equivalent(GoalA0, GoalB0),
equivalent(GoalA, GoalB)) :-
prog_util__rename_in_goal(OldVar, NewVar, GoalA0, GoalA),
prog_util__rename_in_goal(OldVar, NewVar, GoalB0, GoalB).
prog_util__rename_in_goal_expr(OldVar, NewVar,
if_then(Vars0, StateVars0, Cond0, Then0),
if_then(Vars, StateVars, Cond, Then)) :-
prog_util__rename_in_vars(OldVar, NewVar, Vars0, Vars),
prog_util__rename_in_vars(OldVar, NewVar, StateVars0, StateVars),
prog_util__rename_in_goal(OldVar, NewVar, Cond0, Cond),
prog_util__rename_in_goal(OldVar, NewVar, Then0, Then).
prog_util__rename_in_goal_expr(OldVar, NewVar,
if_then_else(Vars0, StateVars0, Cond0, Then0, Else0),
if_then_else(Vars, StateVars, Cond, Then, Else)) :-
prog_util__rename_in_vars(OldVar, NewVar, Vars0, Vars),
prog_util__rename_in_vars(OldVar, NewVar, StateVars0, StateVars),
prog_util__rename_in_goal(OldVar, NewVar, Cond0, Cond),
prog_util__rename_in_goal(OldVar, NewVar, Then0, Then),
prog_util__rename_in_goal(OldVar, NewVar, Else0, Else).
prog_util__rename_in_goal_expr(OldVar, NewVar, call(SymName, Terms0, Purity),
call(SymName, Terms, Purity)) :-
term__substitute_list(Terms0, OldVar, term__variable(NewVar), Terms).
prog_util__rename_in_goal_expr(OldVar, NewVar, unify(TermA0, TermB0, Purity),
unify(TermA, TermB, Purity)) :-
term__substitute(TermA0, OldVar, term__variable(NewVar), TermA),
term__substitute(TermB0, OldVar, term__variable(NewVar), TermB).
:- pred prog_util__rename_in_vars(prog_var::in, prog_var::in,
list(prog_var)::in, list(prog_var)::out) is det.
prog_util__rename_in_vars(_, _, [], []).
prog_util__rename_in_vars(OldVar, NewVar, [Var0 | Vars0], [Var | Vars]) :-
( Var0 = OldVar ->
Var = NewVar
;
Var = Var0
),
prog_util__rename_in_vars(OldVar, NewVar, Vars0, Vars).
%-----------------------------------------------------------------------------%
% match_sym_name(PartialSymName, CompleteSymName):
% succeeds iff there is some sequence of module qualifiers
% which when prefixed to PartialSymName gives CompleteSymName.
match_sym_name(qualified(Module1, Name), qualified(Module2, Name)) :-
match_sym_name(Module1, Module2).
match_sym_name(unqualified(Name), unqualified(Name)).
match_sym_name(unqualified(Name), qualified(_, Name)).
%-----------------------------------------------------------------------------%
remove_sym_name_prefix(qualified(Module, Name0), Prefix,
qualified(Module, Name)) :-
string__append(Prefix, Name, Name0).
remove_sym_name_prefix(unqualified(Name0), Prefix, unqualified(Name)) :-
string__append(Prefix, Name, Name0).
remove_sym_name_suffix(qualified(Module, Name0), Suffix,
qualified(Module, Name)) :-
string__remove_suffix(Name0, Suffix, Name).
remove_sym_name_suffix(unqualified(Name0), Suffix, unqualified(Name)) :-
string__remove_suffix(Name0, Suffix, Name).
add_sym_name_suffix(qualified(Module, Name0), Suffix,
qualified(Module, Name)) :-
string__append(Name0, Suffix, Name).
add_sym_name_suffix(unqualified(Name0), Suffix, unqualified(Name)) :-
string__append(Name0, Suffix, Name).
transform_sym_base_name(TransformFunc, qualified(Module, Name0)) =
qualified(Module, TransformFunc(Name0)).
transform_sym_base_name(TransformFunc, unqualified(Name0)) =
unqualified(TransformFunc(Name0)).
%-----------------------------------------------------------------------------%
make_pred_name_with_context(ModuleName, Prefix,
PredOrFunc, PredName, Line, Counter, SymName) :-
make_pred_name(ModuleName, Prefix, yes(PredOrFunc), PredName,
counter(Line, Counter), SymName).
make_pred_name(ModuleName, Prefix, MaybePredOrFunc, PredName,
NewPredId, SymName) :-
(
MaybePredOrFunc = yes(PredOrFunc),
(
PredOrFunc = predicate,
PFS = "pred"
;
PredOrFunc = function,
PFS = "func"
)
;
MaybePredOrFunc = no,
PFS = "pred_or_func"
),
(
NewPredId = counter(Line, Counter),
string__format("%d__%d", [i(Line), i(Counter)], PredIdStr)
;
NewPredId = type_subst(VarSet, TypeSubst),
SubstToString = (pred(SubstElem::in, SubstStr::out) is det :-
SubstElem = Var - Type,
varset__lookup_name(VarSet, Var, VarName),
TypeString = mercury_type_to_string(VarSet, Type),
string__append_list([VarName, " = ", TypeString],
SubstStr)
),
list_to_string(SubstToString, TypeSubst, PredIdStr)
;
NewPredId = unused_args(Args),
list_to_string(int_to_string, Args, PredIdStr)
),
string__format("%s__%s__%s__%s",
[s(Prefix), s(PFS), s(PredName), s(PredIdStr)], Name),
SymName = qualified(ModuleName, Name).
:- pred list_to_string(pred(T, string)::in(pred(in, out) is det),
list(T)::in, string::out) is det.
list_to_string(Pred, List, String) :-
list_to_string_2(Pred, List, Strings, ["]"]),
string__append_list(["[" | Strings], String).
:- pred list_to_string_2(pred(T, string)::in(pred(in, out) is det),
list(T)::in, list(string)::out, list(string)::in) is det.
list_to_string_2(_, []) --> [].
list_to_string_2(Pred, [T | Ts]) -->
{ call(Pred, T, String) },
[String],
( { Ts = [] } ->
[]
;
[", "],
list_to_string_2(Pred, Ts)
).
%-----------------------------------------------------------------------------%
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")
).
%-----------------------------------------------------------------------------%
apply_rec_subst_to_prog_constraints(Subst, Constraints0, Constraints) :-
Constraints0 = constraints(UnivCs0, ExistCs0),
apply_rec_subst_to_prog_constraint_list(Subst, UnivCs0, UnivCs),
apply_rec_subst_to_prog_constraint_list(Subst, ExistCs0, ExistCs),
Constraints = constraints(UnivCs, ExistCs).
apply_rec_subst_to_prog_constraint_list(Subst, !Constraints) :-
list__map(apply_rec_subst_to_prog_constraint(Subst), !Constraints).
apply_rec_subst_to_prog_constraint(Subst, Constraint0, Constraint) :-
Constraint0 = constraint(ClassName, Types0),
term__apply_rec_substitution_to_list(Types0, Subst, Types),
Constraint = constraint(ClassName, Types).
apply_subst_to_prog_constraints(Subst,
constraints(UniversalCs0, ExistentialCs0),
constraints(UniversalCs, ExistentialCs)) :-
apply_subst_to_prog_constraint_list(Subst, UniversalCs0, UniversalCs),
apply_subst_to_prog_constraint_list(Subst, ExistentialCs0,
ExistentialCs).
apply_subst_to_prog_constraint_list(Subst, !Constraints) :-
list__map(apply_subst_to_prog_constraint(Subst), !Constraints).
apply_subst_to_prog_constraint(Subst, Constraint0, Constraint) :-
Constraint0 = constraint(ClassName, Types0),
term__apply_substitution_to_list(Types0, Subst, Types),
Constraint = constraint(ClassName, Types).
apply_variable_renaming_to_prog_constraints(Renaming, Constraints0,
Constraints) :-
Constraints0 = constraints(UnivConstraints0, ExistConstraints0),
apply_variable_renaming_to_prog_constraint_list(Renaming,
UnivConstraints0, UnivConstraints),
apply_variable_renaming_to_prog_constraint_list(Renaming,
ExistConstraints0, ExistConstraints),
Constraints = constraints(UnivConstraints, ExistConstraints).
apply_variable_renaming_to_prog_constraint_list(Renaming, !Constraints) :-
list.map(apply_variable_renaming_to_prog_constraint(Renaming),
!Constraints).
apply_variable_renaming_to_prog_constraint(Renaming, !Constraint) :-
!.Constraint = constraint(ClassName, ClassArgTypes0),
term.apply_variable_renaming_to_list(ClassArgTypes0, Renaming,
ClassArgTypes),
!:Constraint = constraint(ClassName, ClassArgTypes).
%-----------------------------------------------------------------------------%
:- end_module prog_util.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink