mercury/compiler/term_constr_util.m

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%------------------------------------------------------------------------------%
% Copyright (C) 1997-2003, 2005-2012 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.
%------------------------------------------------------------------------------%
%
% File: term_constr_util.m.
% Main author: juliensf.
%
% This module defines some utility predicates used by the termination analyser.
%
%------------------------------------------------------------------------------%

:- module transform_hlds.term_constr_util.
:- interface.

:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_module.
:- import_module libs.lp_rational.
:- import_module libs.polyhedron.
:- import_module parse_tree.prog_data.
:- import_module transform_hlds.term_constr_data.
:- import_module transform_hlds.term_constr_main.

:- import_module bool.
:- import_module io.
:- import_module list.
:- import_module map.
:- import_module maybe.

%------------------------------------------------------------------------------%
%
% Predicates for storing things in the HLDS.
%

    % This predicate sets the argument size info (in terms of constraints
    % on inter-argument size relationships) of a given list of procedures.
    %
:- pred set_pred_proc_ids_constr_arg_size_info(list(pred_proc_id)::in,
    constr_arg_size_info::in, module_info::in, module_info::out) is det.

:- func lookup_proc_constr_arg_size_info(module_info, pred_proc_id) =
    maybe(constr_arg_size_info).

    % Retrieve the abstraction representation from the module_info.
    %
:- func get_abstract_scc(module_info, list(pred_proc_id)) = abstract_scc.

:- func get_abstract_proc(module_info, pred_proc_id) = abstract_proc.

%------------------------------------------------------------------------------%
%
% Predicates for size_vars.
%

    % Given a list of prog_vars, allocate one size_var per prog_var.
    % Return the varset from which the size_vars were allocated and
    % a map between prog_vars and size_vars.
    %
:- pred make_size_var_map(list(prog_var)::in, size_varset::out,
    size_var_map::out) is det.

    % Given a list of prog_vars, allocate one size_var per prog_var.
    % Allocate the size_vars from the provided size_varset.  Return
    % a map between prog_vars and size_vars.
    %
:- pred make_size_var_map(list(prog_var)::in,
    size_varset::in, size_varset::out, size_var_map::out) is det.

    % Takes a list of prog_vars and outputs the corresponding
    % list of size_vars, based on the given map.
    %
:- func prog_vars_to_size_vars(size_var_map, prog_vars) = size_vars.
:- func prog_var_to_size_var(size_var_map, prog_var) = size_var.

    % Returns a set containing all the size_vars corresponding to prog_vars
    % that have a type that is always of zero size. i.e. all those for which
    % the functor norm returns zero for all values of the type.
    %
:- func find_zero_size_vars(module_info, size_var_map, vartypes) = zero_vars.

    % create_nonneg_constraints(SizeVarMap, Zeros) = Constraints.
    %
    % Returns a list of constraints of the form "x >= 0" for every size_var
    % x that is is in `SizeVarMap' and is not in the set `Zeros'.
    %
:- func create_nonneg_constraints(size_var_map, zero_vars) = constraints.

:- type var_substitution == map(size_var, size_var).

    % create_var_substition(FromVars, ToVars) = Substitution.
    % Create a mapping that maps elements of `FromVars' to their
    % corresponding elements in `ToVars'.  This mapping is many-one.
    % An exception is thrown if `FromVars' contains any duplicate elements.
    %
:- func create_var_substitution(size_vars, size_vars) = var_substitution.

    % Create a non-negativity constraint for each size_var in the list,
    % *except* if it has zero size type.
    %
:- func make_arg_constraints(size_vars, zero_vars) = constraints.

    % Check that a size_var is a member of the set of zero size_vars.
    % XXX Ideally we would just use set.member directly but the arguments
    % of that procedure are around the wrong way for use in most higher
    % order procedures.
    %
:- pred is_zero_size_var(zero_vars::in, size_var::in) is semidet.

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

:- pred add_context_to_constr_termination_info(
    maybe(pragma_termination_info)::in, prog_context::in,
    maybe(constr_termination_info)::out) is det.

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

    % substitute_size_vars: Takes a list of constraints and a
    % var_substitution.  Returns the constraints with the specified
    % substitutions made.
    %
:- func substitute_size_vars(constraints, map(size_var, size_var))
    = constraints.

%------------------------------------------------------------------------------%
%
% Predicates for printing out debugging traces. The first boolean argument
% of these predicates should be the value of the --debug-term option.
%

    % Call the specified predicate.
    %
:- pred maybe_write_trace(bool::in, pred(io, io)::in(pred(di, uo) is det),
    io::di, io::uo) is det.

    % As above but if the boolean argument is `yes', print a newline
    % to stdout before flushing the output.
    %
:- pred maybe_write_trace_nl(bool::in, pred(io, io)::in(pred(di, uo) is det),
    bool::in, io::di, io::uo) is det.

:- pred maybe_write_scc_procs(list(pred_proc_id)::in, module_info::in,
    int::in, io::di, io::uo) is det.

:- pred maybe_write_proc_name(pred_proc_id::in, string::in, module_info::in,
    int::in, io::di, io::uo) is det.

:- pred write_size_vars(size_varset::in, size_vars::in, io::di, io::uo) is det.

:- pred dump_size_varset(size_varset::in, io::di, io::uo) is det.

:- pred dump_size_vars(size_vars::in, size_varset::in, io::di, io::uo) is det.

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

:- pred update_arg_size_info(pred_proc_id::in, polyhedron::in, module_info::in,
    module_info::out) is det.

    % change_procs_constr_termination_info(SCC, Override, TermInfo,
    %   !ProcTable).
    %
    % If Override is yes, then this predicate overrides any existing
    % termination information. If Override is no, then it leaves the
    % proc_info of a procedure unchanged unless the proc_info had no
    % termination information (i.e. the maybe(termination_info)
    % field was set to "no").
    %
:- pred change_procs_constr_termination_info(list(proc_id)::in, bool::in,
    constr_termination_info::in, proc_table::in, proc_table::out) is det.

    % change_procs_constr_arg_size_info(SCC, Override, ArgSizeInfo,
    %   !ProcTable).
    %
    % This predicate sets the arg_size_info property of the given
    % list of procedures.  If Override is yes, then this predicate
    % overrides any existing arg_size information. If Override is
    % no, then it leaves the proc_info of a procedure unchanged
    % unless the proc_info had no arg_size information (i.e. the
    % maybe(arg_size_info) field was set to "no").
    %
:- pred change_procs_constr_arg_size_info(list(proc_id)::in, bool::in,
    constr_arg_size_info::in, proc_table::in, proc_table::out) is det.

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

:- implementation.

:- import_module check_hlds.type_util.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_out.
:- import_module hlds.hlds_out.hlds_out_util.
:- import_module hlds.hlds_pred.
:- import_module libs.rat.
:- import_module transform_hlds.term_constr_errors.
:- import_module transform_hlds.term_norm.

:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module std_util.
:- import_module string.
:- import_module term.
:- import_module varset.

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

set_pred_proc_ids_constr_arg_size_info([], _ArgSize, !ModuleInfo).
set_pred_proc_ids_constr_arg_size_info([PPId | PPIds], ArgSize, !ModuleInfo) :-
    PPId = proc(PredId, ProcId),
    module_info_get_preds(!.ModuleInfo, PredTable0),
    map.lookup(PredTable0, PredId, PredInfo0),
    pred_info_get_procedures(PredInfo0, ProcTable0),
    map.lookup(ProcTable0, ProcId, ProcInfo0),
    proc_info_get_termination2_info(ProcInfo0, TermInfo0),
    TermInfo = TermInfo0 ^ success_constrs := yes(ArgSize),
    proc_info_set_termination2_info(TermInfo, ProcInfo0, ProcInfo),
    map.det_update(ProcId, ProcInfo, ProcTable0, ProcTable),
    pred_info_set_procedures(ProcTable, PredInfo0, PredInfo),
    map.det_update(PredId, PredInfo, PredTable0, PredTable),
    module_info_set_preds(PredTable, !ModuleInfo),
    set_pred_proc_ids_constr_arg_size_info(PPIds, ArgSize, !ModuleInfo).

lookup_proc_constr_arg_size_info(ModuleInfo, PredProcId) = MaybeArgSizeInfo :-
    PredProcId = proc(PredId, ProcId),
    module_info_pred_proc_info(ModuleInfo, PredId, ProcId, _, ProcInfo),
    proc_info_get_termination2_info(ProcInfo, TermInfo),
    MaybeArgSizeInfo = TermInfo ^ success_constrs.

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

make_size_var_map(ProgVars, SizeVarset, SizeVarMap) :-
    make_size_var_map(ProgVars, varset.init, SizeVarset, SizeVarMap).

make_size_var_map(ProgVars, !SizeVarset, SizeVarMap) :-
    list.foldl2(make_size_var_map_2, ProgVars,
        map.init, SizeVarMap, !SizeVarset).

:- pred make_size_var_map_2(prog_var::in, size_var_map::in, size_var_map::out,
    size_varset::in, size_varset::out) is det.

make_size_var_map_2(ProgVar, !SizeVarMap, !SizeVarset) :-
    varset.new_var(SizeVar, !SizeVarset),
    map.set(ProgVar, SizeVar, !SizeVarMap).

prog_vars_to_size_vars(SizeVarMap, Vars)
    = list.map(prog_var_to_size_var(SizeVarMap), Vars).

prog_var_to_size_var(SizeVarMap, Var) = SizeVar :-
    ( if map.search(SizeVarMap, Var, SizeVar0) then
        SizeVar = SizeVar0
    else
        unexpected($module, $pred, "prog_var not in size_var_map")
    ).

find_zero_size_vars(ModuleInfo, SizeVarMap, VarTypes) = Zeros :-
    ProgVars = map.keys(SizeVarMap),
    ZeroProgVars = list.filter(is_zero_size_prog_var(ModuleInfo, VarTypes),
        ProgVars),

    % Build zeros from corresponding size_vars.
    ZerosList = prog_vars_to_size_vars(SizeVarMap, ZeroProgVars),
    Zeros = set.from_list(ZerosList).

:- pred is_zero_size_prog_var(module_info::in, vartypes::in,
    prog_var::in) is semidet.

is_zero_size_prog_var(ModuleInfo, VarTypes, Var) :-
    lookup_var_type(VarTypes, Var, Type),
    (
        term_norm.zero_size_type(ModuleInfo, Type)
    ;
        % We don't include dummy types in the constraints - they won't tell us
        % anything useful.
        check_dummy_type(ModuleInfo, Type) = is_dummy_type
    ).

add_context_to_constr_termination_info(no, _, no).
add_context_to_constr_termination_info(yes(cannot_loop(_)), _,
        yes(cannot_loop(term_reason_import_supplied))).
add_context_to_constr_termination_info(yes(can_loop(_)), Context,
        yes(can_loop([Context - imported_pred]))).

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

substitute_size_vars(Constraints0, SubstMap) = Constraints :-
    SubVarInCoeff = (func(OldVar - Rat) = NewVar - Rat :-
        map.lookup(SubstMap, OldVar, NewVar)
    ),
    SubVarInEqn = (func(Constr0) = Constr :-
        deconstruct_constraint(Constr0, Coeffs0, Op, Rat),
        Coeffs = list.map(SubVarInCoeff, Coeffs0),
        Constr = construct_constraint(Coeffs, Op, Rat)
    ),
    Constraints = list.map(SubVarInEqn, Constraints0).

%------------------------------------------------------------------------------%
%
% Utility procedures used by various parts of the IR analysis.
%

create_nonneg_constraints(SizeVarMap, Zeros) = Constraints :-
    create_nonneg_constraints_2(SizeVarMap, Zeros, Constraints).

:- pred create_nonneg_constraints_2(size_var_map::in, zero_vars::in,
    constraints::out) is det.

create_nonneg_constraints_2(SizeVarMap, Zeros, NonNegs) :-
    SizeVars = map.values(SizeVarMap),
    list.filter(isnt(is_zero_size_var(Zeros)), SizeVars, NonZeroSizeVars),
    NonNegs = list.map(make_nonneg_constr, NonZeroSizeVars).

create_var_substitution(Args, HeadVars) = SubstMap :-
    create_var_substitution_2(Args, HeadVars, map.init, SubstMap).

:- pred create_var_substitution_2(size_vars::in, size_vars::in,
    var_substitution::in, var_substitution::out) is det.

create_var_substitution_2([], [], !Subst).
create_var_substitution_2([_|_], [], _, _) :-
    unexpected($module, $pred, "unmatched lists").
create_var_substitution_2([], [_|_], _, _) :-
    unexpected($module, $pred, "unmatched lists").
create_var_substitution_2([Arg | Args], [HeadVar | HeadVars],  !Subst) :-
    map.det_insert(HeadVar, Arg, !Subst),
    create_var_substitution_2(Args, HeadVars, !Subst).

make_arg_constraints([], _) = [].
make_arg_constraints([Var | Vars], Zeros) = Constraints :-
    Constraints0 = make_arg_constraints(Vars, Zeros),
    ( set.member(Var, Zeros) ->
        Constraints = Constraints0
    ;
        NewConstraint = construct_constraint([Var - one], lp_gt_eq, zero),
        Constraints = [NewConstraint | Constraints0]
    ).

is_zero_size_var(Zeros, SizeVar) :- set.member(SizeVar, Zeros).

%------------------------------------------------------------------------------%
%
% Predicates for printing out debugging traces ...
%

maybe_write_trace(DebugTerm, TracePred, !IO) :-
    maybe_write_trace_nl(DebugTerm, TracePred, no, !IO).

maybe_write_trace_nl(DebugTerm, TracePred, NewLine, !IO) :-
    (
        DebugTerm = yes,
        TracePred(!IO),
        (
            NewLine = yes,
            io.nl(!IO)
        ;
            NewLine = no
        ),
        io.flush_output(!IO)
    ;
        DebugTerm = no
    ).

maybe_write_scc_procs(SCC, ModuleInfo, _, !IO) :-
    write_scc_procs_2(SCC, ModuleInfo, !IO),
    io.nl(!IO).

:- pred write_scc_procs_2(list(pred_proc_id)::in, module_info::in,
    io::di, io::uo) is det.

write_scc_procs_2([], _, !IO).
write_scc_procs_2([PPId | PPIds], ModuleInfo, !IO) :-
    io.write_char('\t', !IO),
    write_pred_proc_id(ModuleInfo, PPId, !IO),
    io.nl(!IO),
    write_scc_procs_2(PPIds, ModuleInfo, !IO).

maybe_write_proc_name(PPId, String, ModuleInfo, _, !IO) :-
    io.write_string(String, !IO),
    write_pred_proc_id(ModuleInfo, PPId, !IO),
    io.nl(!IO).

write_size_vars(Varset, Vars, !IO) :-
    WriteSizeVar = (pred(Var::in, !.IO::di, !:IO::uo) is det :-
        varset.lookup_name(Varset, Var, Name),
        io.write_string(Name, !IO)
    ),
    io.write_char('[', !IO),
    io.write_list(Vars, ", ", WriteSizeVar, !IO),
    io.write_char(']', !IO).

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

dump_size_vars(Vars, Varset, !IO) :-
    dump_size_varset_2(Vars, Varset, !IO).

dump_size_varset(Varset, !IO) :-
    Vars = varset.vars(Varset),
    dump_size_varset_2(Vars, Varset, !IO).

:- pred dump_size_varset_2(size_vars::in, size_varset::in, io::di, io::uo)
    is det.

dump_size_varset_2([], _, !IO).
dump_size_varset_2([Var | Vars], Varset, !IO) :-
    Name = varset.lookup_name(Varset, Var),
    io.write(Var, !IO),
    io.format(" = %s\n", [s(Name)], !IO),
    dump_size_varset_2(Vars, Varset, !IO).

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

update_arg_size_info(PPID, Polyhedron, !ModuleInfo) :-
    set_pred_proc_ids_constr_arg_size_info([PPID], Polyhedron, !ModuleInfo).

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

change_procs_constr_termination_info([], _, _, !ProcTable).
change_procs_constr_termination_info([ProcId | ProcIds], Override, Termination,
        !ProcTable) :-
    ProcInfo0 = !.ProcTable ^ det_elem(ProcId),
    proc_info_get_termination2_info(ProcInfo0, TermInfo0),
    (
        ( Override = yes
        ; TermInfo0 ^ term_status = no
        )
    ->
        TermInfo = TermInfo0 ^ term_status := yes(Termination),
        proc_info_set_termination2_info(TermInfo, ProcInfo0, ProcInfo),
        map.det_update(ProcId, ProcInfo, !ProcTable)
    ;
        true
    ),
    change_procs_constr_termination_info(ProcIds, Override, Termination,
        !ProcTable).

change_procs_constr_arg_size_info([], _, _, !ProcTable).
change_procs_constr_arg_size_info([ProcId | ProcIds], Override, ArgSize,
        !ProcTable) :-
    ProcInfo0 = !.ProcTable ^ det_elem(ProcId),
    proc_info_get_termination2_info(ProcInfo0, TermInfo0),
    (
        ( Override = yes
        ; TermInfo0 ^ success_constrs = no
        )
    ->
        TermInfo = TermInfo0 ^ success_constrs := yes(ArgSize),
        proc_info_set_termination2_info(TermInfo, ProcInfo0, ProcInfo),
        map.det_update(ProcId, ProcInfo, !ProcTable)
    ;
        true
    ),
    change_procs_constr_arg_size_info(ProcIds, Override, ArgSize, !ProcTable).

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

get_abstract_scc(ModuleInfo, SCC) =
    list.map(get_abstract_proc(ModuleInfo), SCC).

get_abstract_proc(ModuleInfo, PPId) = AbstractProc :-
    module_info_pred_proc_info(ModuleInfo, PPId, _, ProcInfo),
    proc_info_get_termination2_info(ProcInfo, TermInfo),
    MaybeAbstractProc = TermInfo ^ abstract_rep,
    (
        MaybeAbstractProc = yes(AbstractProc)
    ;
        MaybeAbstractProc = no,
        unexpected($module, $pred, "no abstract rep. for proc")
    ).

%------------------------------------------------------------------------------%
:- end_module transform_hlds.term_constr_util.
%------------------------------------------------------------------------------%