mercury/compiler/term_util.m

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1997-2007, 2010-2012 The University of Melbourne.
% Copyright (C) 2015 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% File: term_util.m.
% Main author: crs.
%
% This module:
%
% - defines the types used by termination analysis
% - defines some utility predicates
%
%---------------------------------------------------------------------------%

:- module transform_hlds.term_util.
:- interface.

:- import_module hlds.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_data_foreign.
:- import_module parse_tree.prog_data_pragma.
:- import_module parse_tree.var_table.
:- import_module transform_hlds.term_errors.
:- import_module transform_hlds.term_norm.

:- import_module bag.
:- import_module bool.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module unit.

%---------------------------------------------------------------------------%
%
% The `arg_size_info' and `termination_info' structures.
%

% The types `arg_size_info' and `termination_info' hold information about
% procedures which is used for termination analysis. These types are stored
% as fields in the HLDS proc_info. For intermodule analysis, the information
% is written out as `pragma termination_info(...)' declarations in the `.opt'
% and `.trans_opt' files. The module prog_data.m defines types similar to
% these two (but without the `list(term_error)') which are used when parsing
% `termination_info' pragmas.

    % 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 == generic_arg_size_info(list(term_error)).

:- type termination_info ==
    generic_termination_info(unit, list(term_error)).

    % The type `used_args' holds a mapping which specifies for each procedure
    % which of its arguments are used.
    %
:- type used_args == map(pred_proc_id, list(bool)).

:- 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(mer_mode)::in,
    list(prog_var)::in, bag(prog_var)::out, bag(prog_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(module_info::in,
    list(prog_var)::in, list(unify_mode)::in,
    bag(prog_var)::out, bag(prog_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 typeinfos.
    %
    % XXX Replace the bools with a bespoke type.
    %
:- pred make_bool_list(list(_T)::in, list(bool)::in, list(bool)::out) is det.

%---------------------%

    % Succeeds if one or more variables in the list are higher order.
    %
:- pred some_var_is_higher_order(var_table::in, list(prog_var)::in) is semidet.

%---------------------------------------------------------------------------%

:- 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 the termination status of a procedure is known.
    %
:- pred is_termination_known(module_info::in, pred_proc_id::in) is semidet.

    % pred_proc_id_terminates(ModuleInfo, PPId):
    %
    % Succeeds iff the procedure given by 'PPId' has been proven to terminate.
    %
:- pred pred_proc_id_terminates(module_info::in, pred_proc_id::in) is semidet.

%---------------------%

    % Succeed if all arguments of the given procedure of the given predicate
    % are either input or zero size.
    %
:- pred all_args_input_or_zero_size(module_info::in, pred_info::in,
    proc_info::in) is semidet.

%---------------------%

    % 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.

%---------------------%

    % Convert a pragma_termination_info into a termination_info, by adding the
    % appropriate context.
    %
:- pred add_context_to_termination_info(maybe(pragma_termination_info)::in,
    prog_context::in, maybe(termination_info)::out) is det.

    % Convert a pragma_arg_size_info into a arg_size_info, by adding the
    % appropriate context.
    %
:- pred add_context_to_arg_size_info(maybe(pragma_arg_size_info)::in,
    prog_context::in, maybe(arg_size_info)::out) is det.

%---------------------------------------------------------------------------%

:- pred get_context_from_scc(module_info::in, scc::in, prog_context::out)
    is det.

%---------------------------------------------------------------------------%

    % Succeeds if the foreign proc attributes imply that a procedure is
    % terminating.
    %
:- pred attributes_imply_termination(foreign_proc_attributes::in)
    is semidet.

%---------------------------------------------------------------------------%

:- type maybe_believe_check_termination
    --->    do_not_believe_check_termination
    ;       do_believe_check_termination.

    % When we process imported predicates, should we believe that
    % the presence of a 'check_termination' pragma, or rather the pred marker
    % indicating the presence of such a pragma, guarantees that (in the absence
    % of an error from that pragma) the predicate will actually terminate?
    %
    % The check_termination pragma will be checked by the compiler
    % when it compiles the source file that the predicate was imported from.
    % However, when we make .opt files, we do not check whether predicates
    % with check_termination pragmas actually terminate, so we cannot assume
    % that they do, since any violations of that assumption will *not* be
    % reported.
    %
:- pred should_we_believe_check_termination_markers(module_info::in,
    maybe_believe_check_termination::out) is det.

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

:- implementation.

:- import_module check_hlds.
:- import_module check_hlds.inst_test.
:- import_module check_hlds.mode_test.
:- import_module libs.
:- import_module libs.globals.
:- import_module libs.op_mode.
:- import_module parse_tree.prog_type_test.

:- import_module require.
:- import_module set.

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

% 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 should 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.

partition_call_args(ModuleInfo, ArgModes, Args, InVarsBag, OutVarsBag) :-
    partition_call_args_2(ModuleInfo, ArgModes, Args, InVars, OutVars),
    bag.from_list(InVars, InVarsBag),
    bag.from_list(OutVars, OutVarsBag).

:- pred partition_call_args_2(module_info::in, list(mer_mode)::in,
    list(prog_var)::in, list(prog_var)::out, list(prog_var)::out) is det.

partition_call_args_2(_, [], [], [], []).
partition_call_args_2(_, [], [_ | _], _, _) :-
    unexpected($pred, "unmatched variables").
partition_call_args_2(_, [_ | _], [], _, _) :-
    unexpected($pred, "unmatched variables").
partition_call_args_2(ModuleInfo, [ArgMode | ArgModes], [Arg | Args],
        InputArgs, OutputArgs) :-
    partition_call_args_2(ModuleInfo, ArgModes, Args,
        InputArgs1, OutputArgs1),
    ( if mode_is_input(ModuleInfo, ArgMode) then
        InputArgs = [Arg | InputArgs1],
        OutputArgs = OutputArgs1
    else if mode_is_output(ModuleInfo, ArgMode) then
        InputArgs = InputArgs1,
        OutputArgs = [Arg | OutputArgs1]
    else
        InputArgs = InputArgs1,
        OutputArgs = OutputArgs1
    ).

split_unification_vars(_, [], [], Vars, Vars) :-
    bag.init(Vars).
split_unification_vars(_, [], [_ | _], _, _) :-
    unexpected($pred, "unmatched variables").
split_unification_vars(_, [_ | _], [], _, _) :-
    unexpected($pred, "unmatched variables").
split_unification_vars(ModuleInfo, [Arg | Args], [ArgMode | ArgModes],
        InVars, OutVars):-
    split_unification_vars(ModuleInfo, Args, ArgModes, InVars0, OutVars0),
    ArgMode = unify_modes_li_lf_ri_rf(_, _, ArgInit, ArgFinal),
    ( if
        inst_is_bound(ModuleInfo, ArgInit)
    then
        % Variable is an input variable.
        bag.insert(Arg, InVars0, InVars),
        OutVars = OutVars0
    else if
        inst_is_free(ModuleInfo, ArgInit),
        inst_is_bound(ModuleInfo, ArgFinal)
    then
        % Variable is an output variable.
        InVars = InVars0,
        bag.insert(Arg, OutVars0, OutVars)
    else
        InVars = InVars0,
        OutVars = OutVars0
    ).

%---------------------------------------------------------------------------%

make_bool_list(HeadVars0, Bools, Out) :-
    list.length(Bools, Arity),
    ( if list.drop(Arity, HeadVars0, HeadVars1) then
        HeadVars = HeadVars1
    else
        unexpected($pred, "unmatched variables")
    ),
    make_bool_list_2(HeadVars, Bools, Out).

:- pred make_bool_list_2(list(_T)::in, list(bool)::in, list(bool)::out) is det.

make_bool_list_2([], Bools, Bools).
make_bool_list_2([_ | Vars], Bools, [no | Out]) :-
    make_bool_list_2(Vars, Bools, Out).

%---------------------------------------------------------------------------%

some_var_is_higher_order(VarTable, [Var | Vars]) :-
    lookup_var_type(VarTable, Var, Type),
    ( if type_is_higher_order(Type) then
        true
    else
        some_var_is_higher_order(VarTable, Vars)
    ).

%---------------------------------------------------------------------------%

lookup_proc_termination_info(ModuleInfo, PPId, MaybeTermination) :-
    module_info_pred_proc_info(ModuleInfo, PPId, _, ProcInfo),
    proc_info_get_maybe_termination_info(ProcInfo, MaybeTermination).

lookup_proc_arg_size_info(ModuleInfo, PPId, MaybeArgSize) :-
    module_info_pred_proc_info(ModuleInfo, PPId, _, ProcInfo),
    proc_info_get_maybe_arg_size_info(ProcInfo, MaybeArgSize).

is_termination_known(ModuleInfo, PPId) :-
    module_info_pred_proc_info(ModuleInfo, PPId, _, ProcInfo),
    proc_info_get_maybe_termination_info(ProcInfo, yes(_)).

pred_proc_id_terminates(ModuleInfo, PPId) :-
    module_info_pred_proc_info(ModuleInfo, PPId, _, ProcInfo),
    proc_info_get_maybe_termination_info(ProcInfo, TerminationInfo),
    TerminationInfo = yes(cannot_loop(_)).

%---------------------------------------------------------------------------%

all_args_input_or_zero_size(ModuleInfo, PredInfo, ProcInfo) :-
    pred_info_get_arg_types(PredInfo, TypeList),
    proc_info_get_argmodes(ProcInfo, ModeList),
    all_args_input_or_zero_size_2(TypeList, ModeList, ModuleInfo).

:- pred all_args_input_or_zero_size_2(list(mer_type)::in, list(mer_mode)::in,
    module_info::in) is semidet.

all_args_input_or_zero_size_2([], [], _).
all_args_input_or_zero_size_2([], [_|_], _) :-
    unexpected($pred, "unmatched lists").
all_args_input_or_zero_size_2([_|_], [], _) :-
    unexpected($pred, "unmatched lists").
all_args_input_or_zero_size_2([Type | Types], [Mode | Modes], ModuleInfo) :-
    ( if mode_is_input(ModuleInfo, Mode) then
        % The variable is an input variables, so its size is irrelevant.
        all_args_input_or_zero_size_2(Types, Modes, ModuleInfo)
    else
        term_norm.zero_size_type(ModuleInfo, Type),
        all_args_input_or_zero_size_2(Types, Modes, ModuleInfo)
    ).

%---------------------------------------------------------------------------%

set_pred_proc_ids_arg_size_info([], _ArgSize, !ModuleInfo).
set_pred_proc_ids_arg_size_info([PPId | PPIds], ArgSize, !ModuleInfo) :-
    PPId = proc(PredId, ProcId),
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
    pred_info_proc_info(PredInfo0, ProcId, ProcInfo0),
    proc_info_set_maybe_arg_size_info(yes(ArgSize), ProcInfo0, ProcInfo),
    pred_info_set_proc_info(ProcId, ProcInfo, PredInfo0, PredInfo),
    module_info_set_pred_info(PredId, PredInfo, !ModuleInfo),
    set_pred_proc_ids_arg_size_info(PPIds, ArgSize, !ModuleInfo).

set_pred_proc_ids_termination_info([], _Termination, !ModuleInfo).
set_pred_proc_ids_termination_info([PPId | PPIds], Termination, !ModuleInfo) :-
    PPId = proc(PredId, ProcId),
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
    pred_info_proc_info(PredInfo0, ProcId, ProcInfo0),
    proc_info_set_maybe_termination_info(yes(Termination),
        ProcInfo0, ProcInfo),
    pred_info_set_proc_info(ProcId, ProcInfo, PredInfo0, PredInfo),
    module_info_set_pred_info(PredId, PredInfo, !ModuleInfo),
    set_pred_proc_ids_termination_info(PPIds, Termination, !ModuleInfo).

%---------------------------------------------------------------------------%

add_context_to_termination_info(no, _, no).
add_context_to_termination_info(yes(cannot_loop(_)), _,
    yes(cannot_loop(unit))).
add_context_to_termination_info(yes(can_loop(_)), Context,
    yes(can_loop([term_error(Context, imported_pred)]))).

add_context_to_arg_size_info(no, _, no).
add_context_to_arg_size_info(yes(finite(A, B)), _, yes(finite(A, B))).
add_context_to_arg_size_info(yes(infinite(_)), Context,
    yes(infinite([term_error(Context, imported_pred)]))).

%---------------------------------------------------------------------------%

get_context_from_scc(ModuleInfo, SCC, Context) :-
    set.to_sorted_list(SCC, SCCProcs),
    (
        SCCProcs = [proc(PredId, _) | _],
        module_info_pred_info(ModuleInfo, PredId, PredInfo),
        pred_info_get_context(PredInfo, Context)
    ;
        SCCProcs = [],
        unexpected($pred, "empty SCC")
    ).

%---------------------------------------------------------------------------%

attributes_imply_termination(Attributes) :-
    (
        get_terminates(Attributes) = proc_terminates
    ;
        get_terminates(Attributes) = depends_on_mercury_calls,
        get_may_call_mercury(Attributes) = proc_will_not_call_mercury
    ).

%---------------------------------------------------------------------------%

should_we_believe_check_termination_markers(ModuleInfo, Believe) :-
    module_info_get_globals(ModuleInfo, Globals),
    globals.get_op_mode(Globals, OpMode),
    ( if OpMode = opm_top_args(opma_augment(opmau_make_plain_opt), _) then
        Believe = do_not_believe_check_termination
    else
        Believe = do_believe_check_termination
    ).

%---------------------------------------------------------------------------%
:- end_module transform_hlds.term_util.
%---------------------------------------------------------------------------%