mercury/compiler/closure_analysis.m

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2005-2012 The University of Melbourne.
% Copyright (C) 2017 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: closure_analysis.m
% Main author: juliensf
%
% Perform local closure analysis on procedures. This involves tracking
% the possible values that a higher-order variable can take within a
% procedure. We attach this information to places where knowing the
% possible values of a higher-order call may be useful.
%
% This is similar to the analysis done by higher-order specialization, except
% that here, we do care if a higher-order variable can take multiple values.
%
%-----------------------------------------------------------------------------%

:- module transform_hlds.closure_analysis.
:- interface.

:- import_module hlds.
:- import_module hlds.hlds_module.

:- import_module io.

:- pred closure_analyse_module(io.text_output_stream::in,
    module_info::in, module_info::out) is det.

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

:- implementation.

:- import_module check_hlds.
:- import_module check_hlds.mode_test.
:- import_module hlds.hlds_dependency_graph.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_pred.
:- import_module hlds.passes_aux.
:- import_module libs.
:- import_module libs.dependency_graph.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module parse_tree.
:- import_module parse_tree.parse_tree_out_misc.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_data_foreign.
:- import_module parse_tree.prog_type_test.
:- import_module parse_tree.set_of_var.
:- import_module parse_tree.var_table.

:- import_module bool.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module string.

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

closure_analyse_module(ProgressStream, !ModuleInfo) :-
    % XXX At the moment it is not necessary to do this on a per-SCC basis,
    % since the analysis is only procedure-local, but we would eventually
    % like to extend it.

    module_info_get_globals(!.ModuleInfo, Globals),
    globals.lookup_bool_option(Globals, debug_closure, Debug),
    module_info_ensure_dependency_info(!ModuleInfo, DepInfo),
    SCCs = dependency_info_get_bottom_up_sccs(DepInfo),
    list.foldl(closure_analyse_scc(ProgressStream, Debug), SCCs, !ModuleInfo).

%----------------------------------------------------------------------------%
%
% Perform closure analysis on an SCC.
%

:- pred closure_analyse_scc(io.text_output_stream::in, bool::in, scc::in,
    module_info::in, module_info::out) is det.

closure_analyse_scc(ProgressStream, Debug, SCC, !ModuleInfo) :-
    set.foldl(closure_analyse_proc(ProgressStream, Debug), SCC, !ModuleInfo).

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

    % This type represents the possible values of a higher-order valued
    % variable.
    %
:- type closure_values
    --->    unknown
            % The higher-order variable may be bound to something,
            % but we don't know what it is.

    ;       partial(set(pred_proc_id))
            % The higher-order variable may be bound to these values,
            % or it may be bound to something else we don't know about.
            % (This is intended to be useful in producing error messages
            % for the termination analysis; if one of the higher-order values
            % is definitely non-terminating, we can certainly let the user
            % know about it.)

    ;       exclusive(set(pred_proc_id)).
            % The higher-order variable can be bound only to one of the
            % procedures identified by this set.

    % We attach a closure_info to each goal where it may be of interest;
    % at the moment calls and generic_calls.
    %
:- type closure_info == map(prog_var, closure_values).

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

:- func closure_info_init(module_info, var_table,
    list(prog_var), list(mer_mode)) = closure_info.

closure_info_init(ModuleInfo, VarTable, HeadVars, ArgModes) = ClosureInfo :-
    partition_higher_order_arguments(ModuleInfo, VarTable, HeadVars, ArgModes,
        set_of_var.init, Inputs0, set_of_var.init, _Outputs),
    Inputs = set_of_var.filter(var_has_ho_type(VarTable), Inputs0),
    set_of_var.fold(insert_unknown, Inputs, map.init, ClosureInfo).

    % Succeeds iff the given variable has a higher-order type.
    %
:- pred var_has_ho_type(var_table::in, prog_var::in) is semidet.

var_has_ho_type(VarTable, Var) :-
    lookup_var_type(VarTable, Var, Type),
    type_is_higher_order(Type).

    % Insert the given prog_var into the closure_info, and set the
    % possible values to unknown.
    %
:- pred insert_unknown(prog_var::in, closure_info::in, closure_info::out)
    is det.

insert_unknown(Var, !ClosureInfo) :-
    map.det_insert(Var, unknown, !ClosureInfo).

%----------------------------------------------------------------------------%
%
% Perform local closure analysis on a procedure.
%

:- pred closure_analyse_proc(io.text_output_stream::in, bool::in,
    pred_proc_id::in, module_info::in, module_info::out) is det.

closure_analyse_proc(ProgressStream, Debug, PPId, !ModuleInfo) :-
    module_info_pred_proc_info(!.ModuleInfo, PPId, PredInfo, ProcInfo0),
    proc_info_get_headvars(ProcInfo0, HeadVars),
    proc_info_get_var_table(ProcInfo0, VarTable),
    proc_info_get_argmodes(ProcInfo0, ArgModes),
    ClosureInfo0 = closure_info_init(!.ModuleInfo, VarTable, HeadVars,
        ArgModes),
    trace [io(!TIO)] (
        maybe_write_proc_progress_message(ProgressStream, !.ModuleInfo,
            "Analysing closures in", PPId, !TIO)
    ),
    proc_info_get_goal(ProcInfo0, BodyGoal0),
    closure_analyse_goal(!.ModuleInfo, VarTable, BodyGoal0, BodyGoal,
        ClosureInfo0, _ClosureInfo),
    (
        Debug = yes,
        trace [io(!IO)] (
            get_debug_output_stream(!.ModuleInfo, DebugStream, !IO),
            dump_closure_info(DebugStream, VarTable, BodyGoal, !IO),
            io.flush_output(DebugStream, !IO)
        )
    ;
        Debug = no
    ),
    proc_info_set_goal(BodyGoal, ProcInfo0, ProcInfo),
    module_info_set_pred_proc_info(PPId, PredInfo, ProcInfo, !ModuleInfo).

%-----------------------------------------------------------------------------%
%
% Track higher-order values through goals.
%

:- pred closure_analyse_goal(module_info::in, var_table::in,
    hlds_goal::in, hlds_goal::out, closure_info::in, closure_info::out) is det.

closure_analyse_goal(ModuleInfo, VarTable, Goal0, Goal, !ClosureInfo) :-
    Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
    (
        GoalExpr0 = conj(ConjType, Goals0),
        list.map_foldl(closure_analyse_goal(ModuleInfo, VarTable),
            Goals0, Goals, !ClosureInfo),
        GoalExpr = conj(ConjType, Goals),
        Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = plain_call(CallPredId, CallProcId, CallArgs, _, _, _),

        % Look for any higher-order arguments and divide them
        % into sets of input and output arguments.
        module_info_pred_proc_info(ModuleInfo, CallPredId, CallProcId,
            _CallPredInfo, CallProcInfo),
        proc_info_get_argmodes(CallProcInfo, CallArgModes),

        % NOTE: We construct sets of arguments, rather than lists,
        % in case there are duplicate arguments.
        partition_higher_order_arguments(ModuleInfo, VarTable,
            CallArgs, CallArgModes,
            set_of_var.init, InputArgs, set_of_var.init, OutputArgs),

        % Update the goal_info to include any information about the
        % values of higher-order valued variables.
        set_of_var.fold(add_any_exclusive_ho_values(!.ClosureInfo), InputArgs,
            map.init, HoValueMap),
        goal_info_set_higher_order_value_map(HoValueMap, GoalInfo0, GoalInfo),

        % Insert any information about higher-order outputs from this call
        % into the closure_info.
        set_of_var.fold(insert_unknown, OutputArgs, !ClosureInfo),
        Goal = hlds_goal(GoalExpr0, GoalInfo)
    ;
        GoalExpr0 = generic_call(GenericDetails, GCallArgs, GCallModes, _, _),
        partition_higher_order_arguments(ModuleInfo, VarTable,
            GCallArgs, GCallModes,
            set_of_var.init, InputArgs0, set_of_var.init, OutputArgs),

        % For higher-order calls we need to make sure that the actual
        % higher-order variable being called is also considered (it will
        % typically be the variable of interest). This variable is not included
        % in 'GCallArgs' so we need to include in the set of input argument
        % separately.
        (
            GenericDetails = higher_order(CalledClosure0, _, _, _, _),
            set_of_var.insert(CalledClosure0, InputArgs0, InputArgs)
        ;
            ( GenericDetails = class_method(_, _, _, _)
            ; GenericDetails = event_call(_)
            ; GenericDetails = cast(_)
            ),
            InputArgs = InputArgs0
        ),
        % The closure_info won't yet contain any information about
        % higher-order outputs from this call.
        set_of_var.fold(add_any_exclusive_ho_values(!.ClosureInfo), InputArgs,
            map.init, HoValueMap),
        goal_info_set_higher_order_value_map(HoValueMap, GoalInfo0, GoalInfo),

        % Insert any information about higher-order outputs from this call
        % into the closure_info.
        set_of_var.fold(insert_unknown, OutputArgs, !ClosureInfo),
        Goal = hlds_goal(GoalExpr0, GoalInfo)
    ;
        GoalExpr0 = switch(SwitchVar, SwitchCanFail, Cases0),
        closure_analyse_cases(ModuleInfo, VarTable, Cases0, Cases,
            !.ClosureInfo, map.init, !:ClosureInfo),
        GoalExpr = switch(SwitchVar, SwitchCanFail, Cases),
        Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = unify(_, _, _, Unification, _),
        (
            Unification = construct(LHS, RHS, _, _, _, _, _),
            ( if RHS = closure_cons(ShroudedPPId) then
                PPId = unshroud_pred_proc_id(ShroudedPPId),
                HO_Value = set.make_singleton_set(PPId),
                map.det_insert(LHS, exclusive(HO_Value), !ClosureInfo)
            else
                true
            )
        ;
            Unification = deconstruct(_, _, Args, _, _, _),
            % XXX We don't currently support tracking the values of closures
            % that are stored in data structures.
            HO_Args = list.filter(var_has_ho_type(VarTable), Args),
            list.foldl(insert_unknown, HO_Args, !ClosureInfo)
        ;
            Unification = assign(LHS, RHS),
            ( if var_has_ho_type(VarTable, LHS) then
                % Sanity check: make sure the rhs is also a higher-order
                % variable.
                ( if var_has_ho_type(VarTable, RHS) then
                    true
                else
                    unexpected($pred, "not a higher-order var")
                ),
                Values = map.lookup(!.ClosureInfo, RHS),
                map.det_insert(LHS, Values, !ClosureInfo)
            else
                true
            )
        ;
            Unification = simple_test(_, _)
        ;
            Unification = complicated_unify(_, _, _)
        ),
        Goal = Goal0
    ;
        GoalExpr0 = disj(Goals0),
        closure_analyse_disjuncts(ModuleInfo, VarTable, Goals0, Goals,
            !.ClosureInfo, map.init, !:ClosureInfo),
        GoalExpr = disj(Goals),
        Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = negation(NegatedGoal0),
        closure_analyse_goal(ModuleInfo, VarTable, NegatedGoal0, NegatedGoal,
            !.ClosureInfo, _),
        GoalExpr = negation(NegatedGoal),
        Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = scope(Reason, SubGoal0),
        ( if
            Reason = from_ground_term(_, FGT),
            ( FGT = from_ground_term_construct
            ; FGT = from_ground_term_deconstruct
            )
        then
            SubGoal = SubGoal0
        else
            closure_analyse_goal(ModuleInfo, VarTable,
                SubGoal0, SubGoal, !ClosureInfo)
        ),
        GoalExpr = scope(Reason, SubGoal),
        Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = if_then_else(ExistQVars, Cond0, Then0, Else0),
        closure_analyse_goal(ModuleInfo, VarTable, Cond0, Cond,
            !.ClosureInfo, CondInfo),
        closure_analyse_goal(ModuleInfo, VarTable, Then0, Then,
            CondInfo, CondThenInfo),
        closure_analyse_goal(ModuleInfo, VarTable, Else0, Else,
            !.ClosureInfo, ElseInfo),
        map.union(merge_closure_values, CondThenInfo, ElseInfo, !:ClosureInfo),
        GoalExpr = if_then_else(ExistQVars, Cond, Then, Else),
        Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = call_foreign_proc(_, _, _, Args, _ExtraArgs, _, _),
        % XXX We may eventually want to annotate foreign_procs with
        % clousure_infos as well. It isn't useful at the moment however.

        ForeignHOArgs =
            ( pred(Arg::in, Out::out) is semidet :-
                Arg = foreign_arg(Var, NameMode, Type, _BoxPolicy),

                % A 'no' here means that the foreign argument is unused.
                NameMode = yes(foreign_arg_name_mode(_, Mode)),
                mode_is_output(ModuleInfo, Mode),
                type_is_higher_order(Type),
                Out = Var - unknown
            ),
        list.filter_map(ForeignHOArgs, Args, OutputForeignHOArgs),
        map.det_insert_from_assoc_list(OutputForeignHOArgs, !ClosureInfo),
        Goal = Goal0
    ;
        GoalExpr0 = shorthand(_),
        unexpected($pred, "shorthand")
    ).

:- pred closure_analyse_disjuncts(module_info::in, var_table::in,
    list(hlds_goal)::in, list(hlds_goal)::out,
    closure_info::in, closure_info::in, closure_info::out) is det.

closure_analyse_disjuncts(_, _, [], [], _, !MergedDisjunctClosureInfo).
closure_analyse_disjuncts(ModuleInfo, VarTable,
        [Disjunct0 | Disjuncts0], [Disjunct | Disjuncts],
        ClosureInfo0, !MergedDisjunctClosureInfo) :-
    closure_analyse_goal(ModuleInfo, VarTable, Disjunct0, Disjunct,
        ClosureInfo0, DisjunctClosureInfo),
    merge_closure_infos(DisjunctClosureInfo, !MergedDisjunctClosureInfo),
    closure_analyse_disjuncts(ModuleInfo, VarTable, Disjuncts0, Disjuncts,
        ClosureInfo0, !MergedDisjunctClosureInfo).

:- pred closure_analyse_cases(module_info::in, var_table::in,
    list(case)::in, list(case)::out,
    closure_info::in, closure_info::in, closure_info::out) is det.

closure_analyse_cases(_, _, [], [], _, !MergedCaseClosureInfo).
closure_analyse_cases(ModuleInfo, VarTable, [Case0 | Cases0], [Case | Cases],
        ClosureInfo0, !MergedCaseClosureInfo) :-
    closure_analyse_case(ModuleInfo, VarTable, Case0, Case,
        ClosureInfo0, CaseClosureInfo),
    merge_closure_infos(CaseClosureInfo, !MergedCaseClosureInfo),
    closure_analyse_cases(ModuleInfo, VarTable, Cases0, Cases,
        ClosureInfo0, !MergedCaseClosureInfo).

:- pred closure_analyse_case(module_info::in, var_table::in,
    case::in, case::out, closure_info::in, closure_info::out) is det.

closure_analyse_case(ModuleInfo, VarTable, Case0, Case,
        ClosureInfo0, CaseClosureInfo) :-
    Case0 = case(MainConsId, OtherConsIds, CaseGoal0),
    closure_analyse_goal(ModuleInfo, VarTable, CaseGoal0, CaseGoal,
        ClosureInfo0, CaseClosureInfo),
    Case = case(MainConsId, OtherConsIds, CaseGoal).

:- pred add_any_exclusive_ho_values(closure_info::in, prog_var::in,
    higher_order_value_map::in, higher_order_value_map::out) is det.

add_any_exclusive_ho_values(ClosureInfo, Var, !HoValueMap) :-
    ( if map.search(ClosureInfo, Var, PossibleValues) then
        (
            PossibleValues = unknown
        ;
            PossibleValues = partial(_)
        ;
            PossibleValues = exclusive(KnownValues),
            map.det_insert(Var, KnownValues, !HoValueMap)
        )
    else
        true
    ).

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

:- pred partition_higher_order_arguments(module_info::in, var_table::in,
    list(prog_var)::in, list(mer_mode)::in,
    set_of_progvar::in, set_of_progvar::out,
    set_of_progvar::in, set_of_progvar::out) is det.

partition_higher_order_arguments(_, _, [],    [], !Inputs, !Outputs).
partition_higher_order_arguments(_, _, [_ | _], [], _, _, _, _) :-
    unexpected($pred, "unequal length lists.").
partition_higher_order_arguments(_, _, [],    [_ | _], _, _, _, _) :-
    unexpected($pred, "unequal length lists.").
partition_higher_order_arguments(ModuleInfo, VarTable,
        [Var | Vars], [Mode | Modes], !Inputs, !Outputs) :-
    ( if var_has_ho_type(VarTable, Var) then
        ( if mode_is_input(ModuleInfo, Mode) then
            set_of_var.insert(Var, !Inputs)
        else if mode_is_output(ModuleInfo, Mode) then
            set_of_var.insert(Var, !Outputs)
        else
            true
        )
    else
        true
    ),
    partition_higher_order_arguments(ModuleInfo, VarTable, Vars, Modes,
        !Inputs, !Outputs).

:- pred merge_closure_infos(closure_info::in, closure_info::in,
    closure_info::out) is det.

merge_closure_infos(A, B, C) :-
    map.union(merge_closure_values, A, B, C).

:- pred merge_closure_values(closure_values::in, closure_values::in,
    closure_values::out) is det.

merge_closure_values(unknown,      unknown,      unknown).
merge_closure_values(unknown,      partial(A),   partial(A)).
merge_closure_values(unknown,      exclusive(A), partial(A)).
merge_closure_values(partial(A),   unknown,      partial(A)).
merge_closure_values(partial(A),   partial(B),   partial(A `set.union` B)).
merge_closure_values(partial(A),   exclusive(B), partial(A `set.union` B)).
merge_closure_values(exclusive(A), unknown,      partial(A)).
merge_closure_values(exclusive(A), partial(B),   partial(A `set.union` B)).
merge_closure_values(exclusive(A), exclusive(B), exclusive(A `set.union` B)).

%----------------------------------------------------------------------------%
%
% Debugging code, used if the '--debug-closure' option is given.
%

:- pred dump_closure_info(io.text_output_stream::in, var_table::in,
    hlds_goal::in, io::di, io::uo) is det.

dump_closure_info(DebugStream, VarTable, Goal, !IO) :-
    % XXX zs: It seems to me that the output from this predicate
    % would be much easier to understand if each piece of the output
    % was preceded by the identity of the goal that it came from.
    Goal = hlds_goal(GoalExpr, GoalInfo),
    (
        GoalExpr = unify(_, _, _, _, _)
    ;
        GoalExpr = plain_call(_, _, _, _, _, _),
        dump_ho_values(DebugStream, VarTable, GoalInfo, !IO)
    ;
        GoalExpr = generic_call(_, _, _, _, _),
        dump_ho_values(DebugStream, VarTable, GoalInfo, !IO)
    ;
        GoalExpr = call_foreign_proc(_, _, _, _, _, _, _)
    ;
        GoalExpr = conj(_ConjType, SubGoals),
        list.foldl(dump_closure_info(DebugStream, VarTable), SubGoals, !IO)
    ;
        GoalExpr = disj(SubGoals),
        list.foldl(dump_closure_info(DebugStream, VarTable), SubGoals, !IO)
    ;
        GoalExpr = switch(_, _, Cases),
        SubGoals = list.map((func(case(_, _, CaseGoal)) = CaseGoal), Cases),
        list.foldl(dump_closure_info(DebugStream, VarTable), SubGoals, !IO)
    ;
        GoalExpr = if_then_else(_, CondGoal, ThenGoal, ElseGoal),
        dump_closure_info(DebugStream, VarTable, CondGoal, !IO),
        dump_closure_info(DebugStream, VarTable, ThenGoal, !IO),
        dump_closure_info(DebugStream, VarTable, ElseGoal, !IO)
    ;
        GoalExpr = negation(SubGoal),
        dump_closure_info(DebugStream, VarTable, SubGoal, !IO)
    ;
        GoalExpr = scope(_, SubGoal),
        dump_closure_info(DebugStream, VarTable, SubGoal, !IO)
    ;
        GoalExpr = shorthand(_),
        unexpected($pred, "shorthand")
    ).

:- pred dump_ho_values(io.text_output_stream::in, var_table::in,
    hlds_goal_info::in, io::di, io::uo) is det.

dump_ho_values(DebugStream, VarTable, GoalInfo, !IO) :-
    HoValueMap = goal_info_get_higher_order_value_map(GoalInfo),
    ( if map.is_empty(HoValueMap) then
        true
    else
        Context = goal_info_get_context(GoalInfo),
        parse_tree_out_misc.write_context(DebugStream, Context, !IO),
        io.nl(DebugStream, !IO),
        map.foldl(dump_ho_value_map_entry(DebugStream, VarTable),
            HoValueMap, !IO)
    ).

:- pred dump_ho_value_map_entry(io.text_output_stream::in, var_table::in,
    prog_var::in, set(pred_proc_id)::in, io::di, io::uo) is det.

dump_ho_value_map_entry(DebugStream, VarTable, Var, Values, !IO) :-
    VarName = var_table_entry_name(VarTable, Var),
    io.format(DebugStream, "%s =\n", [s(VarName)], !IO),
    WritePPIds =
        ( pred(PPId::in, !.IO::di, !:IO::uo) is det :-
            io.write_string(DebugStream, "\t", !IO),
            io.write_line(DebugStream, PPId, !IO)
        ),
    set.fold(WritePPIds, Values, !IO).

%----------------------------------------------------------------------------%
:- end_module transform_hlds.closure_analysis.
%----------------------------------------------------------------------------%