%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2014 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: simplify_goal_unify.m.
%
% This module handles simplification of unifications.
%
%---------------------------------------------------------------------------%

:- module check_hlds.simplify.simplify_goal_unify.
:- interface.

:- import_module check_hlds.simplify.common.
:- import_module check_hlds.simplify.simplify_info.
:- import_module hlds.
:- import_module hlds.hlds_goal.
:- import_module hlds.instmap.

:- pred simplify_goal_unify(
    hlds_goal_expr::in(goal_expr_unify), hlds_goal_expr::out,
    hlds_goal_info::in, hlds_goal_info::out,
    simplify_nested_context::in, instmap::in,
    common_info::in, common_info::out,
    simplify_info::in, simplify_info::out) is det.

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

:- implementation.

:- import_module check_hlds.polymorphism_type_info.
:- import_module check_hlds.proc_requests.
:- import_module check_hlds.simplify.simplify_goal.
:- import_module check_hlds.type_util.
:- import_module hlds.code_model.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_rtti.
:- import_module hlds.make_goal.
:- import_module hlds.pred_table.
:- import_module hlds.special_pred.
:- import_module mdbcomp.
:- import_module mdbcomp.builtin_modules.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_type.
:- 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 require.
:- import_module term_context.
:- import_module uint.

simplify_goal_unify(GoalExpr0, GoalExpr, GoalInfo0, GoalInfo,
        NestedContext0, InstMap0, !Common, !Info) :-
    GoalExpr0 = unify(LHSVar0, RHS0, UnifyMode, Unification0, UnifyContext),
    (
        RHS0 = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
            NonLocals, VarsModes, LambdaDeclaredDetism, LambdaGoal0),
        determinism_to_code_model(LambdaDeclaredDetism, LambdaCodeModel),
        (
            ( LambdaCodeModel = model_det
            ; LambdaCodeModel = model_semi
            ),
            LambdaProcIsModelNon = no
        ;
            LambdaCodeModel = model_non,
            Context = goal_info_get_context(GoalInfo0),
            LambdaProcIsModelNon = yes(imp_lambda(Context))
        ),
        NestedContext0 = simplify_nested_context(InsideDuplForSwitch,
            _ProcModelNon, NumEnclosingBarriers),
        ( if goal_info_has_feature(GoalInfo0, feature_lambda_from_try) then
            LambdaNumEnclosingBarriers = NumEnclosingBarriers
        else
            LambdaNumEnclosingBarriers = NumEnclosingBarriers + 1u
        ),
        LambdaNestedContext = simplify_nested_context(InsideDuplForSwitch,
            LambdaProcIsModelNon, LambdaNumEnclosingBarriers),

        simplify_info_get_module_info(!.Info, ModuleInfo),
        instmap.pre_lambda_update(ModuleInfo, VarsModes,
            InstMap0, LambdaInstMap0),

        % Don't attempt to pass structs into lambda_goals, since that
        % could change the curried non-locals of the lambda_goal, and
        % that would be difficult to fix up.
        simplify_info_get_simplify_tasks(!.Info, SimplifyTasks),
        LambdaCommon0 = common_info_init(SimplifyTasks),

        % Don't attempt to pass structs out of lambda_goals.
        simplify_goal(LambdaGoal0, LambdaGoal, LambdaNestedContext,
            LambdaInstMap0, LambdaCommon0, _, !Info),

        RHS = rhs_lambda_goal(Purity, Groundness, PredOrFunc, EvalMethod,
            NonLocals, VarsModes, LambdaDeclaredDetism, LambdaGoal),
        GoalExpr = unify(LHSVar0, RHS, UnifyMode, Unification0, UnifyContext),
        GoalInfo = GoalInfo0
    ;
        ( RHS0 = rhs_functor(_, _, _)
        ; RHS0 = rhs_var(_)
        ),
        ( if
            % A unification of the form X = X can be safely optimised away.
            RHS0 = rhs_var(LHSVar0)
        then
            Context = goal_info_get_context(GoalInfo0),
            hlds_goal(GoalExpr, GoalInfo) = true_goal_with_context(Context)
        else if
            Unification0 = complicated_unify(ComplMode, CanFail, TypeInfoVars)
        then
            (
                RHS0 = rhs_var(V),
                process_compl_unify(LHSVar0, V, ComplMode, CanFail,
                    TypeInfoVars, UnifyContext, GoalInfo0, GoalExpr1,
                    NestedContext0, InstMap0, !Common, !Info),
                GoalExpr1 = hlds_goal(GoalExpr, GoalInfo)
            ;
                RHS0 = rhs_functor(_, _, _),
                unexpected($pred, "invalid RHS for complicated unify")
            )
        else
            common_optimise_unification(RHS0, UnifyMode, Unification0,
                UnifyContext, GoalExpr0, GoalExpr, GoalInfo0, GoalInfo,
                !Common, !Info)
        )
    ).

:- pred process_compl_unify(prog_var::in, prog_var::in, unify_mode::in,
    can_fail::in, list(prog_var)::in, unify_context::in, hlds_goal_info::in,
    hlds_goal::out, simplify_nested_context::in, instmap::in,
    common_info::in, common_info::out,
    simplify_info::in, simplify_info::out) is det.

process_compl_unify(XVar, YVar, UnifyMode, CanFail, _OldTypeInfoVars,
        UnifyContext, GoalInfo0, Goal, NestedContext0, InstMap0,
        !Common, !Info) :-
    simplify_info_get_module_info(!.Info, ModuleInfo),
    simplify_info_get_var_table(!.Info, VarTable),
    lookup_var_type(VarTable, XVar, Type),
    ( if Type = type_variable(TypeVar, Kind) then
        % Convert polymorphic unifications into calls to `unify/2',
        % the general unification predicate, passing the appropriate type_info:
        %   unify(TypeInfoVar, X, Y)
        % where TypeInfoVar is the type_info variable associated with
        % the type of the variables that are being unified.

        Context = goal_info_get_context(GoalInfo0),
        get_type_info_locn(TypeVar, Kind, Context, TypeInfoVar, ExtraGoals,
            !Info),
        call_generic_unify(TypeInfoVar, XVar, YVar, ModuleInfo, !.Info,
            UnifyContext, GoalInfo0, Call)
    else if type_is_higher_order(Type) then
        % Convert higher-order unifications into calls to
        % builtin_unify_pred (which calls error/1).
        Context = goal_info_get_context(GoalInfo0),
        generate_plain_call(ModuleInfo, pf_predicate,
            mercury_private_builtin_module, "builtin_unify_pred",
            [], [XVar, YVar], instmap_delta_bind_no_var, mode_no(0),
            detism_semi, purity_pure, [], Context, hlds_goal(Call0, _)),
        simplify_goal_expr(Call0, Call1, GoalInfo0, GoalInfo,
            NestedContext0, InstMap0, !Common, !Info),
        Call = hlds_goal(Call1, GoalInfo),
        ExtraGoals = []
    else
        type_to_ctor_and_args_det(Type, TypeCtor, TypeArgs),
        determinism_components(Detism, CanFail, at_most_one),
        lookup_mode_num(ModuleInfo, TypeCtor, UnifyMode, Detism, ProcId),
        ( if
            % On the Erlang backend, it was faster for us to use builtin
            % comparison operators on high level data structures than to
            % deconstruct the data structure and compare the atomic
            % constituents. We can only do this on values of a type
            % if that type does not have user-defined equality.
            %
            % The Erlang backend was the only one on which
            % can_compare_compound_values could ever be "yes".
            %
            % globals.lookup_bool_option(Globals,
            %   can_compare_compound_values, yes),
            semidet_fail,
            hlds_pred.in_in_unification_proc_id(ProcId),
            type_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type)
        then
            ExtraGoals = [],
            Context = goal_info_get_context(GoalInfo0),
            generate_plain_call(ModuleInfo, pf_predicate,
                mercury_private_builtin_module, "builtin_compound_eq",
                [], [XVar, YVar], instmap_delta_bind_no_var, only_mode,
                detism_semi, purity_pure, [], Context, Call)
        else if
            hlds_pred.in_in_unification_proc_id(ProcId),

            % For most imported types, we only generate unification
            % predicate declarations if they are needed for complicated
            % unifications other than proc_id 0. higher_order.m will
            % specialize these cases if possible.
            special_pred_is_generated_lazily(ModuleInfo, TypeCtor)
        then
            make_type_info_vars([Type], TypeInfoVars, ExtraGoals, !Info),
            ( if TypeInfoVars = [TypeInfoVarPrime] then
                TypeInfoVar = TypeInfoVarPrime
            else
                unexpected($pred, "more than one typeinfo for one type var")
            ),
            call_generic_unify(TypeInfoVar, XVar, YVar, ModuleInfo, !.Info,
                UnifyContext, GoalInfo0, Call)
        else
            % Convert other complicated unifications into calls to
            % specific unification predicates, inserting extra typeinfo
            % arguments if necessary.
            make_type_info_vars(TypeArgs, TypeInfoVars, ExtraGoals, !Info),
            call_specific_unify(TypeCtor, TypeInfoVars, XVar, YVar, ProcId,
                ModuleInfo, UnifyContext, GoalInfo0, Call0, CallGoalInfo0),
            simplify_goal_expr(Call0, Call1, CallGoalInfo0, CallGoalInfo1,
                NestedContext0, InstMap0, !Common, !Info),
            Call = hlds_goal(Call1, CallGoalInfo1)
        )
    ),
    Conjuncts = ExtraGoals ++ [Call],
    conj_list_to_goal(Conjuncts, GoalInfo0, Goal).

:- pred call_generic_unify(prog_var::in, prog_var::in,  prog_var::in,
    module_info::in, simplify_info::in, unify_context::in,
    hlds_goal_info::in, hlds_goal::out) is det.

call_generic_unify(TypeInfoVar, XVar, YVar, ModuleInfo, _, _, GoalInfo,
        Call) :-
    Context = goal_info_get_context(GoalInfo),
    generate_plain_call(ModuleInfo, pf_predicate,
        mercury_public_builtin_module, "unify",
        [TypeInfoVar], [XVar, YVar], instmap_delta_bind_no_var, mode_no(0),
        detism_semi, purity_pure, [], Context, Call).

:- pred call_specific_unify(type_ctor::in, list(prog_var)::in,
    prog_var::in, prog_var::in, proc_id::in,
    module_info::in, unify_context::in, hlds_goal_info::in,
    hlds_goal_expr::out, hlds_goal_info::out) is det.

call_specific_unify(TypeCtor, TypeInfoVars, XVar, YVar, ProcId, ModuleInfo,
        Context, GoalInfo0, CallExpr, CallGoalInfo) :-
    % Create the new call goal.
    ArgVars = TypeInfoVars ++ [XVar, YVar],
    module_info_get_special_pred_maps(ModuleInfo, SpecialPredMaps),
    UnifyMap = SpecialPredMaps ^ spm_unify_map,
    map.lookup(UnifyMap, TypeCtor, PredId),
    module_info_pred_info(ModuleInfo, PredId, PredInfo),
    ModuleName = pred_info_module(PredInfo),
    PredName = pred_info_name(PredInfo),
    SymName = qualified(ModuleName, PredName),
    CallContext = call_unify_context(XVar, rhs_var(YVar), Context),
    CallExpr = plain_call(PredId, ProcId, ArgVars, not_builtin,
        yes(CallContext), SymName),

    % Add the extra type_info vars to the nonlocals for the call.
    NonLocals0 = goal_info_get_nonlocals(GoalInfo0),
    set_of_var.insert_list(TypeInfoVars, NonLocals0, NonLocals),
    goal_info_set_nonlocals(NonLocals, GoalInfo0, CallGoalInfo).

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

:- pred make_type_info_vars(list(mer_type)::in, list(prog_var)::out,
    list(hlds_goal)::out, simplify_info::in, simplify_info::out) is det.

make_type_info_vars(Types, TypeInfoVars, TypeInfoGoals, !Info) :-
    % Extract the information from simplify_info.
    simplify_info_get_var_table(!.Info, VarTable0),
    simplify_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
    simplify_info_get_module_info(!.Info, ModuleInfo0),
    simplify_info_get_pred_proc_id(!.Info, PredProcId),

    some [!PredInfo, !ProcInfo] (
        % The varset, var_table and rtti_varmaps get updated by the call to
        % polymorphism_make_type_info_vars_raw_store below, which will get
        % this information from the pred_info and proc_info.
        module_info_pred_proc_info(ModuleInfo0, PredProcId,
            !:PredInfo, !:ProcInfo),
        proc_info_set_var_table(VarTable0, !ProcInfo),
        proc_info_set_rtti_varmaps(RttiVarMaps0, !ProcInfo),

        % Generate the code that creates the type_infos.
        polymorphism_make_type_info_vars_mi(Types, dummy_context,
            TypeInfoVars, TypeInfoGoals, ModuleInfo0, ModuleInfo1,
            !PredInfo, !ProcInfo),

        proc_info_get_var_table(!.ProcInfo, VarTable),
        proc_info_get_rtti_varmaps(!.ProcInfo, RttiVarMaps),
        simplify_info_set_var_table(VarTable, !Info),
        simplify_info_set_rtti_varmaps(RttiVarMaps, !Info),

        % Put the new proc_info and pred_info back in the module_info
        % and put the new module_info back in the simplify_info.
        module_info_set_pred_proc_info(PredProcId, !.PredInfo, !.ProcInfo,
            ModuleInfo1, ModuleInfo),
        simplify_info_set_module_info(ModuleInfo, !Info)
    ).

:- pred get_type_info_locn(tvar::in, kind::in, prog_context::in, prog_var::out,
    list(hlds_goal)::out, simplify_info::in, simplify_info::out) is det.

get_type_info_locn(TypeVar, Kind, Context, TypeInfoVar, Goals, !Info) :-
    simplify_info_get_rtti_varmaps(!.Info, RttiVarMaps),
    rtti_lookup_type_info_locn(RttiVarMaps, TypeVar, TypeInfoLocn),
    (
        % If the typeinfo is available in a variable, just use it.
        TypeInfoLocn = type_info(TypeInfoVar),
        Goals = []
    ;
        % If the typeinfo is in a typeclass_info then we need to extract it.
        TypeInfoLocn = typeclass_info(TypeClassInfoVar, Index),
        extract_type_info(TypeVar, Kind, TypeClassInfoVar, Index, Context,
            Goals, TypeInfoVar, !Info)
    ).

:- pred extract_type_info(tvar::in, kind::in, prog_var::in, int::in,
    prog_context::in, list(hlds_goal)::out, prog_var::out,
    simplify_info::in, simplify_info::out) is det.

extract_type_info(TypeVar, Kind, TypeClassInfoVar, Index, Context,
        Goals, TypeInfoVar, !Info) :-
    simplify_info_get_module_info(!.Info, ModuleInfo),
    simplify_info_get_var_table(!.Info, VarTable0),
    simplify_info_get_rtti_varmaps(!.Info, RttiVarMaps0),

    polymorphism_type_info.gen_extract_type_info(ModuleInfo, TypeVar, Kind,
        TypeClassInfoVar, iov_int(Index), Context, Goals, TypeInfoVar,
        VarTable0, VarTable, RttiVarMaps0, RttiVarMaps),

    simplify_info_set_var_table(VarTable, !Info),
    simplify_info_set_rtti_varmaps(RttiVarMaps, !Info).

%---------------------------------------------------------------------------%
:- end_module check_hlds.simplify.simplify_goal_unify.
%---------------------------------------------------------------------------%
