mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-14 21:35:49 +00:00
Code Issues Projects Releases Wiki Activity
Files
b3af56e8faaa0957accac177afa6ab5de9c91f63
mercury/compiler/term_util.m
Fergus Henderson 6455e041cb Merge in the changes from the existential types branch, 
Estimated hours taken: 6
	(plus another 80 or so already recorded for
	my commits on the existential_types branch)

Merge in the changes from the existential types branch,
and make some modifications to address dgj's code review comments.

These changes add support for existentially quantified type variables
and type class constraints on functions and predicates.
(Existential data types, however, are not supported -- see below.)

Existentially quantified type variables are introduced with
an explicit `some [T]', e.g. `:- some [T] pred foo(T)'.
Existentially quantified type class constraints are introduced
with `&' instead of `<=', e.g. `:- some [T] (pred foo(T) & ord(T))'.

There's still several limitations:

0.  XXX It's not yet documented in the language reference manual.

1.  XXX It doesn't do any mode checking or mode reordering.
    If you write code that uses existentially typed procedures in the
    wrong order, then you'll get an internal error in polymorphism.m
    or in the code generator.  (Cases where a type_info has no
    producer at all are caught by the check for unbound type
    variables in post_typecheck.m.)

    To support this, we need to change things so that polymorphism.m
    gets invoked before mode checking.

2.  Using `in' modes on arguments of existential type won't work.
    If you try, you will get a compile error.

    It would be nice to extend things to allow this kind of
    "implied mode" for type_infos, where an existential type
    becomes a universal type if some value of that type is
    input.  Supporting this would require first fixing
    limitation 1 (described above) and then

3.  There's no support for `pragma c_code' for procedures
    with existential type class constraints.
    (In fact, there's not really any support for `pragma c_code'
    for procedures with universal type class constraints either --
    the C code has no way of getting access to the type class info.)

4.  XXX Taking the address of something which is existentially typed
    should be illegal, but we don't check this.

In addition, these changes in this batch make a start towards allowing
existentially typed data types.  The compiler now accepts existential
quantifiers and type class constraints on type definitions, and type
checks them accordingly (assuming all functor occurrences are
deconstructors, not constructors -- see limitation 2 above).  But
there's no special handling for them in polymorphism.m, so if you try
to use them, it will abort with an internal error.

The changes also includes fixes for a couple of bugs in typechecking
and polymorphism that I discovered while making the above changes,
and an improvement to the error reporting from typecheck.m in one case.
Those changes are listed separately below.

compiler/prog_data.m:
	Add a new type `class_constraints', which holds two different
	lists of constraints, namely the existentially quantified constraints
	and the universally quantified ones.
	Add a new field to the parse tree representation of pred and
	func declarations to hold a list of the existentially quantified
	type variables, and change the `list(class_constraint)' into
	`class_constraints' so that we can store existential constraints too.
	Add new fields to the `constructor' data type (formerly just a pair)
	to hold the existentially quantified type variables and
	type class constraints.

compiler/hlds_pred.m:
	Add several new fields to the pred_info:
	  - a list of the existentially quantified type variables;
	  - a list of the "HeadTypeParams": type variables which
	    cannot be bound by this predicate (i.e. those whose type_infos
	    come from this pred's caller or are returned from
	    other preds called by this one);
	  - and a list of unsatisfied type class constraints.
	Add a predicate pred_info_get_univ_quant_tvars to compute the
	universally quantified type variables.
	Change the pred constraints field from `list(class_constraint)'
	to `class_constraints' so that it can hold existential constraints too.

compiler/hlds_data.m:
	Add new fields to hlds_cons_defn to hold the existentially
	quantified type variables and type class constraints.

compiler/*.m:
	Minor changes to reflect the above-mentioned data structure
	changes in prog_data.m, hlds_pred.m, and hlds_data.m.

compiler/prog_io.m:
	Add code to parse the new constructs.

	Also rewrite the code for parsing purity specifiers,
	type quantifiers and type class constraints, using basically
	the method suggested by Peter Schachte: treat these as
	"declaration attributes", and have parse_decl strip off
	all the declaration attributes into a seperate list and
	then pass that list to process_decl, which for each different
	kind of declaration processes the attributes which are
	appropriate for that declaration and then calls check_no_attributes
	to ensure that there were no inappropriate attributes.

	The purpose of this rewrite was to allow it to handle the new
	constructs properly, and to avoid unnecessary code duplication.

compiler/mercury_to_mercury.m:
	Add code to pretty-print the new constructs.

compiler/make_hlds.m:
	Copy the new fields in the parse tree into the
	corresponding new fields in the pred_info.
	Add code to check for various misuses of quantifiers.

compiler/hlds_out.m:
	Print out the new fields in the pred_info (except the
	unsatisfied type class constraints -- if these are non-empty,
	post_typecheck.m will print them out in the error message).
	When printing out types, pass the AppendVarNums parameter down,
	so that HLDS dumps will distinguish between different type
	variables that have the same name.
	Delete hlds_out__write_constructor, since it was doing exactly
	the same thing as mercury__output_ctor.

compiler/typecheck.m:
	Lots of changes to handle existential types and existential
	type class constraints.

compiler/post_typecheck.m:
	When checking for unbound type variables,
	use the value of HeadTypeParams from the pred_info.

compiler/type_util.m:
	Delete `type_and_constraint_list_matches_exactly', since it was not
	used.  Add various `apply_variable_renaming_to_*' predicates for
	renaming constraints.

compiler/polymorphism.m:
	Lots of changes to handle existential types and existential
	type class constraints.
	Also some changes to make the code more maintainable:

compiler/prog_data.m:
compiler/hlds_goal.m:
compiler/mercury_to_mercury.m:
	Put curly braces around the definitions of 'some'/2 and '&'/2 functors
	in `:- type' definitions, to avoid them being misinterpreted as
	existential type constraints.

compiler/goal_util.m:
compiler/polymorphism.m:
compiler/hlds_pred.m:
compiler/lambda.m:
	Include type_infos for existentially quantified type variables
	and type_class_infos for existential constraints
	in the set of extra variables computed by
	goal_util__extra_type_info_vars.

compiler/inlining.m:
	Change inlining__do_goal to handle inlining of calls to
	existentially typed predicates -- for them, instead of not
	binding any type variables at all in the caller, it allows the
	call to bind any type variables in the caller except for those
	that are universally quantified.

compiler/inlining.m:
compiler/deforest.m:
	Call pred_info_get_univ_quant_tvars and pass the
	result to inlining__do_inline_goal.

tests/hard_coded/Mmakefile:
tests/hard_coded/existential_types_test.{m,exp}:
tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/existential_type_classes.{m,exp}:
	Test cases for the use of existential types and
	existential type class constraints.

----------

Improve an error message.

compiler/typecheck.m:
	Improve error reporting by checking type class constraints for
	satisfiability as we go and thus reporting unsatisfiable constraints
	as soon as possible, rather than only at the end of the clause.
	Previously we already did that for the case of ground constraints,
	but they are not the only unsatsfiable constraints: constraints
	on head type params (type variables which cannot be bound) are
	also unsatisfiable if they can't be eliminated straight away
	by context reduction.

tests/invalid/Mmakefile:
tests/invalid/typeclass_test_7.{m,err_exp}:
	Regression test for the above change.

----------

Avoid problems where type inference was reporting some
spurious errors for predicates using type classes,
because the check for unsatisfied type class constraints
was being done before the final pass of type inference
had finished.

compiler/hlds_pred.m:
	Add new field to the pred_info containing the unproven
	type class constraints.

compiler/typecheck.m:
	When inferring type class constraints, make sure that before
	we save the results back in the pred_info, we restrict the
	constraints to the head type variables.  Constraints
	on other type variables should be treated as
	unsatisfied constraints.

	Don't check for unsatisfied type class constraints at the
	end of each pass; instead, just save the unproven type class
	constraints in the pred_info.

compiler/post_typecheck.m:
	Check for unsatisfied type class constraints, using
	the new field in the pred_info.

tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/inference_test_2.{m,exp}:
tests/invalid/Mmakefile:
tests/invalid/typeclass_test_8.{m,err_exp}:
	Add regression tests for this change.

----------

Fix a bug with the computation of the non-locals for
predicates with more than one constraint on the same type variable --
it was only including one of the type-class-infos, rather than all of them.

compiler/goal_util.m:
	Change `goal_util__extra_nonlocal_typeinfos' so that it gets
	passed the TypeClassInfoVarMap and uses this to include all
	the appropriate typeclass infos in the extra nonlocals.

compiler/hlds_pred.m:
compiler/lambda.m:
compiler/polymorphism.m:
	Pass the TypeClassInfoVarMap to `goal_util__extra_nonlocal_typeinfos'.

tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/lambda_multi_constraint_same_tvar.{m,exp}:
	Regression test for the above-mentioned bug.
1998-07-08 20:59:50 +00:00

557 lines
19 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% Copyright (C) 1997-1998 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.
%-----------------------------------------------------------------------------%
%
% term_util.m
% Main author: crs.
%
% This module:
%
% - defines the types used by termination analysis
% - defines predicates for computing functor norms
% - defines some utility predicates
%
%-----------------------------------------------------------------------------%
:- module term_util.
:- interface.
:- import_module term_errors, prog_data.
:- import_module hlds_module, hlds_pred, hlds_data, hlds_goal.
:- import_module std_util, bool, int, list, map, bag, term.
%-----------------------------------------------------------------------------%
% The arg size info defines an upper bound on the difference
% between the sizes of the output arguments of a procedure and the sizes
% of the input arguments:
%
% | input arguments | + constant >= | output arguments |
%
% where | | represents a semilinear norm.
:- type arg_size_info
---> finite(int, list(bool))
% The termination constant is a finite integer.
% The list of bool has a 1:1 correspondence
% with the input arguments of the procedure.
% It stores whether the argument contributes
% to the size of the output arguments.
; infinite(list(term_errors__error)).
% There is no finite integer for which the
% above equation is true. The argument says
% why the analysis failed to find a finite
% constant.
:- type termination_info
---> cannot_loop % This procedure terminates for all
% possible inputs.
; can_loop(list(term_errors__error)).
% The analysis could not prove that the
% procedure terminates.
:- type used_args == map(pred_proc_id, list(bool)).
%-----------------------------------------------------------------------------%
% We use semilinear norms (denoted by ||) to compute the sizes of terms.
% These have the form
%
% | f(t1, ... tn) | = weight(f) + sum of | ti |
% where i is an element of a set I, and I is a subset of {1, ... n}
%
% We currently support four kinds of semilinear norms.
:- type functor_info
---> simple % All non-constant functors have weight 1,
% while constants have weight 0.
% Use the size of all subterms (I = {1, ..., n}.
; total % All functors have weight = arity of the functor.
% Use the size of all subterms (I = {1, ..., n}.
; use_map(weight_table)
% The weight of each functor is given by the table.
% Use the size of all subterms (I = {1, ..., n}.
; use_map_and_args(weight_table).
% The weight of each functor is given by the table,
% and so is the set of arguments of the functor whose
% size should be counted (I is given by the table
% entry of the functor).
:- type unify_info == pair(map(var, type), functor_info).
:- type weight_info ---> weight(int, list(bool)).
:- type weight_table == map(pair(type_id, cons_id), weight_info).
:- pred find_weights(module_info::in, weight_table::out) is det.
% This predicate is computes the weight of a functor and the set of arguments
% of that functor whose sizes should be counted towards the size of the whole
% term.
:- pred functor_norm(functor_info::in, type_id::in, cons_id::in,
module_info::in, int::out, list(var)::in, list(var)::out,
list(uni_mode)::in, list(uni_mode)::out) is det.
:- type pass_info
---> pass_info(
functor_info,
int, % Max number of errors to gather.
int % Max number of paths to analyze.
).
%-----------------------------------------------------------------------------%
% This predicate partitions the arguments of a call into a list of input
% variables and a list of output variables,
:- pred partition_call_args(module_info::in, list(mode)::in, list(var)::in,
bag(var)::out, bag(var)::out) is det.
% Given a list of variables from a unification, this predicate divides the
% list into a bag of input variables, and a bag of output variables.
:- pred split_unification_vars(list(var)::in, list(uni_mode)::in,
module_info::in, bag(var)::out, bag(var)::out) is det.
% Used to create lists of boolean values, which are used for used_args.
% make_bool_list(HeadVars, BoolIn, BoolOut) creates a bool list which is
% (length(HeadVars) - length(BoolIn)) `no' followed by BoolIn. This is
% used to set the used args for compiler generated predicates. The no's
% at the start are because the Type infos are not used. length(BoolIn)
% should equal the arity of the predicate, and the difference in length
% between the arity of the procedure and the arity of the predicate is
% the number of type infos.
:- pred term_util__make_bool_list(list(_T)::in, list(bool)::in,
list(bool)::out) is det.
% Removes variables from the InVarBag that are not used in the call.
% remove_unused_args(InVarBag0, VarList, BoolList, InVarBag)
% VarList and BoolList are corresponding lists. Any variable in VarList
% that has a `no' in the corresponding place in the BoolList is removed
% from InVarBag.
:- pred remove_unused_args(bag(var), list(var), list(bool), bag(var)).
:- mode remove_unused_args(in, in, in, out) is det.
% This predicate sets the argument size info of a given a list of procedures.
:- pred set_pred_proc_ids_arg_size_info(list(pred_proc_id)::in,
arg_size_info::in, module_info::in, module_info::out) is det.
% This predicate sets the termination info of a given a list of procedures.
:- pred set_pred_proc_ids_termination_info(list(pred_proc_id)::in,
termination_info::in, module_info::in, module_info::out) is det.
:- pred lookup_proc_termination_info(module_info::in, pred_proc_id::in,
maybe(termination_info)::out) is det.
:- pred lookup_proc_arg_size_info(module_info::in, pred_proc_id::in,
maybe(arg_size_info)::out) is det.
% Succeeds if one or more variables in the list are higher order.
:- pred horder_vars(list(var), map(var, type)).
:- mode horder_vars(in, in) is semidet.
% Succeeds if all values of the given type are zero size (for all norms).
:- pred zero_size_type(type, module_info).
:- mode zero_size_type(in, in) is semidet.
:- pred get_context_from_scc(list(pred_proc_id)::in, module_info::in,
term__context::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module inst_match, prog_out, mode_util, type_util.
:- import_module globals, options.
:- import_module assoc_list, require.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
% Calculate the weight to be assigned to each function symbol for the
% use_map and use_map_and_args semilinear norms.
%
% Given a type definition such as
%
% :- type t(Tk) ---> f1(a11, ... a1n1) where n1 is the arity of f1
% ; ...
% ; fm(am1, ... amnm) where nm is the arity of fm
%
% we check, for each aij, whether its type is recursive (i.e. it is t with
% type variable arguments that are a permutation of Tk). The weight info
% we compute for each functor will have a boolean list that has a `yes'
% for each recursive argument and a `no' for each nonrecursive argument.
% The weight to be assigned to the functor is the number of nonrecursive
% arguments, except that we assign a weight of at least 1 to all functors
% which are not constants.
find_weights(ModuleInfo, Weights) :-
module_info_types(ModuleInfo, TypeTable),
map__to_assoc_list(TypeTable, TypeList),
map__init(Weights0),
find_weights_for_type_list(TypeList, Weights0, Weights).
:- pred find_weights_for_type_list(assoc_list(type_id, hlds_type_defn)::in,
weight_table::in, weight_table::out) is det.
find_weights_for_type_list([], Weights, Weights).
find_weights_for_type_list([TypeId - TypeDefn | TypeList], Weights0, Weights) :-
find_weights_for_type(TypeId, TypeDefn, Weights0, Weights1),
find_weights_for_type_list(TypeList, Weights1, Weights).
:- pred find_weights_for_type(type_id::in, hlds_type_defn::in,
weight_table::in, weight_table::out) is det.
find_weights_for_type(TypeId, TypeDefn, Weights0, Weights) :-
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
TypeBody = du_type(Constructors, _, _, _),
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
find_weights_for_cons_list(Constructors, TypeId, TypeParams,
Weights0, Weights)
;
TypeBody = uu_type(_),
error("undiscriminated union types not yet implemented")
;
% This type does not introduce any functors
TypeBody = eqv_type(_),
Weights = Weights0
;
% This type may introduce some functors,
% but we will never see them in this analysis
TypeBody = abstract_type,
Weights = Weights0
).
:- pred find_weights_for_cons_list(list(constructor)::in,
type_id::in, list(type_param)::in,
weight_table::in, weight_table::out) is det.
find_weights_for_cons_list([], _, _, Weights, Weights).
find_weights_for_cons_list([Constructor | Constructors], TypeId, Params,
Weights0, Weights) :-
find_weights_for_cons(Constructor, TypeId, Params, Weights0, Weights1),
find_weights_for_cons_list(Constructors, TypeId, Params,
Weights1, Weights).
:- pred find_weights_for_cons(constructor::in,
type_id::in, list(type_param)::in,
weight_table::in, weight_table::out) is det.
find_weights_for_cons(Ctor, TypeId, Params, Weights0, Weights) :-
% XXX should we do something about ExistQVars here?
Ctor = ctor(_ExistQVars, _Constraints, SymName, Args),
list__length(Args, Arity),
( Arity > 0 ->
find_and_count_nonrec_args(Args, TypeId, Params,
NumNonRec, ArgInfos0),
( NumNonRec = 0 ->
Weight = 1,
list__duplicate(Arity, yes, ArgInfos)
;
Weight = NumNonRec,
ArgInfos = ArgInfos0
),
WeightInfo = weight(Weight, ArgInfos)
;
WeightInfo = weight(0, [])
),
ConsId = cons(SymName, Arity),
map__det_insert(Weights0, TypeId - ConsId, WeightInfo, Weights).
:- pred find_and_count_nonrec_args(list(constructor_arg)::in,
type_id::in, list(type_param)::in,
int::out, list(bool)::out) is det.
find_and_count_nonrec_args([], _, _, 0, []).
find_and_count_nonrec_args([Arg | Args], Id, Params, NonRecArgs, ArgInfo) :-
find_and_count_nonrec_args(Args, Id, Params, NonRecArgs0, ArgInfo0),
( is_arg_recursive(Arg, Id, Params) ->
NonRecArgs = NonRecArgs0,
ArgInfo = [yes | ArgInfo0]
;
NonRecArgs is NonRecArgs0 + 1,
ArgInfo = [no | ArgInfo0]
).
:- pred is_arg_recursive(constructor_arg::in,
type_id::in, list(type_param)::in) is semidet.
is_arg_recursive(Arg, Id, Params) :-
Arg = _Name - ArgType,
type_to_type_id(ArgType, ArgTypeId, ArgTypeParams),
Id = ArgTypeId,
list__perm(Params, ArgTypeParams).
%-----------------------------------------------------------------------------%
% Although the module info is not used in either of these norms, it could
% be needed for other norms, so it should not be removed.
functor_norm(simple, _, ConsId, _, Int, Args, Args, Modes, Modes) :-
(
ConsId = cons(_, Arity),
Arity \= 0
->
Int = 1
;
Int = 0
).
functor_norm(total, _, ConsId, _Module, Int, Args, Args, Modes, Modes) :-
( ConsId = cons(_, Arity) ->
Int = Arity
;
Int = 0
).
functor_norm(use_map(WeightMap), TypeId, ConsId, _Module, Int,
Args, Args, Modes, Modes) :-
( map__search(WeightMap, TypeId - ConsId, WeightInfo) ->
WeightInfo = weight(Int, _)
;
Int = 0
).
functor_norm(use_map_and_args(WeightMap), TypeId, ConsId, _Module, Int,
Args0, Args, Modes0, Modes) :-
( map__search(WeightMap, TypeId - ConsId, WeightInfo) ->
WeightInfo = weight(Int, UseArgList),
(
functor_norm_filter_args(UseArgList, Args0, Args1,
Modes0, Modes1)
->
Modes = Modes1,
Args = Args1
;
error("Unmatched lists in functor_norm_filter_args.")
)
;
Int = 0,
Modes = Modes0,
Args = Args0
).
% This predicate will fail if the length of the input lists are not matched.
:- pred functor_norm_filter_args(list(bool), list(var), list(var),
list(uni_mode), list(uni_mode)).
:- mode functor_norm_filter_args(in, in, out, in, out) is semidet.
functor_norm_filter_args([], [], [], [], []).
functor_norm_filter_args([yes | Bools], [Arg0 | Args0], [Arg0 | Args],
[Mode0 | Modes0], [Mode0 | Modes]) :-
functor_norm_filter_args(Bools, Args0, Args, Modes0, Modes).
functor_norm_filter_args([no | Bools], [_Arg0 | Args0], Args,
[_Mode0 | Modes0], Modes) :-
functor_norm_filter_args(Bools, Args0, Args, Modes0, Modes).
%-----------------------------------------------------------------------------%
partition_call_args(Module, ArgModes, Args, InVarsBag, OutVarsBag) :-
partition_call_args_2(Module, ArgModes, Args, InVars, OutVars),
bag__from_list(InVars, InVarsBag),
bag__from_list(OutVars, OutVarsBag).
:- pred partition_call_args_2(module_info::in, list(mode)::in, list(var)::in,
list(var)::out, list(var)::out) is det.
partition_call_args_2(_, [], [], [], []).
partition_call_args_2(_, [], [_ | _], _, _) :-
error("Unmatched variables in term_util:partition_call_args").
partition_call_args_2(_, [_ | _], [], _, _) :-
error("Unmatched variables in term_util__partition_call_args").
partition_call_args_2(ModuleInfo, [ArgMode | ArgModes], [Arg | Args],
InputArgs, OutputArgs) :-
partition_call_args_2(ModuleInfo, ArgModes, Args,
InputArgs1, OutputArgs1),
( mode_is_input(ModuleInfo, ArgMode) ->
InputArgs = [Arg | InputArgs1],
OutputArgs = OutputArgs1
; mode_is_output(ModuleInfo, ArgMode) ->
InputArgs = InputArgs1,
OutputArgs = [Arg | OutputArgs1]
;
InputArgs = InputArgs1,
OutputArgs = OutputArgs1
).
% For these next two predicates (split_unification_vars and
% partition_call_args) there is a problem of what needs to be done for
% partially instantiated data structures. The correct answer is that the
% system shoud use a norm such that the size of the uninstantiated parts of
% a partially instantiated structure have no effect on the size of the data
% structure according to the norm. For example when finding the size of a
% list-skeleton, list-length norm should be used. Therefore, the size of
% any term must be given by
% sizeof(term) = constant + sum of the size of each
% (possibly partly) instantiated subterm.
% It is probably easiest to implement this by modifying term_weights.
% The current implementation does not correctly handle partially
% instantiated data structures.
split_unification_vars([], Modes, _ModuleInfo, Vars, Vars) :-
bag__init(Vars),
( Modes = [] ->
true
;
error("term_util:split_unification_vars: Unmatched Variables")
).
split_unification_vars([Arg | Args], Modes, ModuleInfo,
InVars, OutVars):-
( Modes = [UniMode | UniModes] ->
split_unification_vars(Args, UniModes, ModuleInfo,
InVars0, OutVars0),
UniMode = ((_VarInit - ArgInit) -> (_VarFinal - ArgFinal)),
( % if
inst_is_bound(ModuleInfo, ArgInit)
->
% Variable is an input variable
bag__insert(InVars0, Arg, InVars),
OutVars = OutVars0
; % else if
inst_is_free(ModuleInfo, ArgInit),
inst_is_bound(ModuleInfo, ArgFinal)
->
% Variable is an output variable
InVars = InVars0,
bag__insert(OutVars0, Arg, OutVars)
; % else
InVars = InVars0,
OutVars = OutVars0
)
;
error("term_util__split_unification_vars: Unmatched Variables")
).
%-----------------------------------------------------------------------------%
term_util__make_bool_list(HeadVars0, Bools, Out) :-
list__length(Bools, Arity),
( list__drop(Arity, HeadVars0, HeadVars1) ->
HeadVars = HeadVars1
;
error("Unmatched variables in term_util:make_bool_list")
),
term_util__make_bool_list_2(HeadVars, Bools, Out).
:- pred term_util__make_bool_list_2(list(_T), list(bool), list(bool)).
:- mode term_util__make_bool_list_2(in, in, out) is det.
term_util__make_bool_list_2([], Bools, Bools).
term_util__make_bool_list_2([ _ | Vars ], Bools, [no | Out]) :-
term_util__make_bool_list_2(Vars, Bools, Out).
remove_unused_args(Vars, [], [], Vars).
remove_unused_args(Vars, [], [_X | _Xs], Vars) :-
error("Unmatched variables in term_util:remove_unused_args").
remove_unused_args(Vars, [_X | _Xs], [], Vars) :-
error("Unmatched variables in term_util__remove_unused_args").
remove_unused_args(Vars0, [ Arg | Args ], [ UsedVar | UsedVars ], Vars) :-
( UsedVar = yes ->
% The variable is used, so leave it
remove_unused_args(Vars0, Args, UsedVars, Vars)
;
% The variable is not used in producing output vars, so
% dont include it as an input variable.
bag__delete(Vars0, Arg, Vars1),
remove_unused_args(Vars1, Args, UsedVars, Vars)
).
%-----------------------------------------------------------------------------%
set_pred_proc_ids_arg_size_info([], _ArgSize, Module, Module).
set_pred_proc_ids_arg_size_info([PPId | PPIds], ArgSize, Module0, Module) :-
PPId = proc(PredId, ProcId),
module_info_preds(Module0, PredTable0),
map__lookup(PredTable0, PredId, PredInfo0),
pred_info_procedures(PredInfo0, ProcTable0),
map__lookup(ProcTable0, ProcId, ProcInfo0),
proc_info_set_maybe_arg_size_info(ProcInfo0, yes(ArgSize), ProcInfo),
map__det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
pred_info_set_procedures(PredInfo0, ProcTable, PredInfo),
map__det_update(PredTable0, PredId, PredInfo, PredTable),
module_info_set_preds(Module0, PredTable, Module1),
set_pred_proc_ids_arg_size_info(PPIds, ArgSize, Module1, Module).
set_pred_proc_ids_termination_info([], _Termination, Module, Module).
set_pred_proc_ids_termination_info([PPId | PPIds], Termination,
Module0, Module) :-
PPId = proc(PredId, ProcId),
module_info_preds(Module0, PredTable0),
map__lookup(PredTable0, PredId, PredInfo0),
pred_info_procedures(PredInfo0, ProcTable0),
map__lookup(ProcTable0, ProcId, ProcInfo0),
proc_info_set_maybe_termination_info(ProcInfo0, yes(Termination),
ProcInfo),
map__det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
pred_info_set_procedures(PredInfo0, ProcTable, PredInfo),
map__det_update(PredTable0, PredId, PredInfo, PredTable),
module_info_set_preds(Module0, PredTable, Module1),
set_pred_proc_ids_termination_info(PPIds, Termination,
Module1, Module).
lookup_proc_termination_info(Module, PredProcId, MaybeTermination) :-
PredProcId = proc(PredId, ProcId),
module_info_pred_proc_info(Module, PredId, ProcId, _, ProcInfo),
proc_info_get_maybe_termination_info(ProcInfo, MaybeTermination).
lookup_proc_arg_size_info(Module, PredProcId, MaybeArgSize) :-
PredProcId = proc(PredId, ProcId),
module_info_pred_proc_info(Module, PredId, ProcId, _, ProcInfo),
proc_info_get_maybe_arg_size_info(ProcInfo, MaybeArgSize).
horder_vars([Arg | Args], VarType) :-
(
map__lookup(VarType, Arg, Type),
type_is_higher_order(Type, _, _)
;
horder_vars(Args, VarType)
).
zero_size_type(Type, Module) :-
classify_type(Type, Module, TypeCategory),
zero_size_type_category(TypeCategory, Type, Module, yes).
:- pred zero_size_type_category(builtin_type, type, module_info, bool).
:- mode zero_size_type_category(in, in, in, out) is det.
zero_size_type_category(int_type, _, _, yes).
zero_size_type_category(char_type, _, _, yes).
zero_size_type_category(str_type, _, _, yes).
zero_size_type_category(float_type, _, _, yes).
zero_size_type_category(pred_type, _, _, no).
zero_size_type_category(enum_type, _, _, yes).
zero_size_type_category(polymorphic_type, _, _, no).
zero_size_type_category(user_type, _, _, no).
%-----------------------------------------------------------------------------%
get_context_from_scc(SCC, Module, Context) :-
( SCC = [proc(PredId, _) | _] ->
module_info_pred_info(Module, PredId, PredInfo),
pred_info_context(PredInfo, Context)
;
error("Empty SCC in pass 2 of termination analysis")
).
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink