mercury/compiler/clause_to_proc.m

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1995-2007 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.
%-----------------------------------------------------------------------------%

:- module check_hlds.clause_to_proc.
:- interface.

:- import_module hlds.
:- import_module hlds.hlds_clauses.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module hlds.pred_table.

:- import_module list.
:- import_module maybe.

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

    % In the hlds, we initially record the clauses for a predicate
    % in the clauses_info data structure which is part of the
    % pred_info data structure.  But once the clauses have been
    % type-checked, we want to have a separate copy of each clause
    % for each different mode of the predicate, since we may
    % end up reordering the clauses differently in different modes.
    % Here we copy the clauses from the clause_info data structure
    % into the proc_info data structure.  Each clause is marked
    % with a list of the modes for which it applies, so that
    % there can be different code to implement different modes
    % of a predicate (e.g. sort).  For each mode of the predicate,
    % we select the clauses for that mode, disjoin them together,
    % and save this in the proc_info.
    %
:- pred copy_module_clauses_to_procs(list(pred_id)::in,
    module_info::in, module_info::out) is det.

:- pred copy_clauses_to_proc(proc_id::in, clauses_info::in,
    proc_info::in, proc_info::out) is det.

    % Before copying the clauses to the procs, we need to add
    % a default mode of `:- mode foo(in, in, ..., in) = out is det.'
    % for functions that don't have an explicit mode declaration.
    %
:- pred maybe_add_default_func_modes(list(pred_id)::in,
    pred_table::in, pred_table::out) is det.

:- pred maybe_add_default_func_mode(pred_info::in, pred_info::out,
    maybe(proc_id)::out) is det.

    % After copying the clauses to the procs, we need to transform the
    % procedures to introduce any required exists_casts..
    %
:- pred introduce_exists_casts(list(pred_id)::in, module_info::in,
    module_info::out) is det.

    % This version is used by polymorphism.m.
    %
:- pred introduce_exists_casts_proc(module_info::in, pred_info::in,
    proc_info::in, proc_info::out) is det.

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

:- implementation.

:- import_module check_hlds.mode_util.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_args.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_rtti.
:- import_module hlds.make_hlds.
:- import_module libs.
:- import_module libs.compiler_util.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type_subst.

:- import_module assoc_list.
:- import_module int.
:- import_module map.
:- import_module pair.
:- import_module set.
:- import_module string.
:- import_module svmap.
:- import_module svvarset.
:- import_module term.
:- import_module varset.

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

maybe_add_default_func_modes([], Preds, Preds).
maybe_add_default_func_modes([PredId | PredIds], Preds0, Preds) :-
    map.lookup(Preds0, PredId, PredInfo0),
    maybe_add_default_func_mode(PredInfo0, PredInfo, _),
    map.det_update(Preds0, PredId, PredInfo, Preds1),
    maybe_add_default_func_modes(PredIds, Preds1, Preds).

maybe_add_default_func_mode(PredInfo0, PredInfo, MaybeProcId) :-
    pred_info_get_procedures(PredInfo0, Procs0),
    PredOrFunc = pred_info_is_pred_or_func(PredInfo0),
    (
        % Is this a function with no modes?
        PredOrFunc = pf_function,
        map.is_empty(Procs0)
    ->
        % If so, add a default mode of
        %
        %   :- mode foo(in, in, ..., in) = out is det.
        %
        % for this function.  (N.B. functions which can fail must be
        % explicitly declared as semidet.)

        PredArity = pred_info_orig_arity(PredInfo0),
        FuncArity = PredArity - 1,
        in_mode(InMode),
        out_mode(OutMode),
        list.duplicate(FuncArity, InMode, FuncArgModes),
        FuncRetMode = OutMode,
        list.append(FuncArgModes, [FuncRetMode], PredArgModes),
        Determinism = detism_det,
        pred_info_get_context(PredInfo0, Context),
        MaybePredArgLives = no,
        varset.init(InstVarSet),
            % No inst_vars in default func mode.
        add_new_proc(InstVarSet, PredArity, PredArgModes,
            yes(PredArgModes), MaybePredArgLives, yes(Determinism),
            Context, address_is_not_taken, PredInfo0, PredInfo, ProcId),
        MaybeProcId = yes(ProcId)
    ;
        PredInfo = PredInfo0,
        MaybeProcId = no
    ).

copy_module_clauses_to_procs(PredIds, !ModuleInfo) :-
    module_info_preds(!.ModuleInfo, PredTable0),
    list.foldl(copy_pred_clauses_to_procs, PredIds, PredTable0, PredTable),
    module_info_set_preds(PredTable, !ModuleInfo).

    % For each mode of the given predicate, copy the clauses relevant
    % to the mode and the current backend to the proc_info.
    %
    % This is not the only predicate in the compiler that does this task;
    % the other is polymorphism.process_proc.
    %
:- pred copy_pred_clauses_to_procs(pred_id::in,
    pred_table::in, pred_table::out) is det.

copy_pred_clauses_to_procs(PredId, !PredTable) :-
    map.lookup(!.PredTable, PredId, PredInfo0),
    (
        do_copy_clauses_to_procs(PredInfo0)
    ->
        copy_clauses_to_procs(PredInfo0, PredInfo),
        map.det_update(!.PredTable, PredId, PredInfo, !:PredTable)
    ;
        true
    ).

:- pred do_copy_clauses_to_procs(pred_info::in) is semidet.

do_copy_clauses_to_procs(PredInfo) :-
    % Don't process typeclass methods, because their proc_infos
    % are generated already mode-correct.
    pred_info_get_markers(PredInfo, PredMarkers),
    \+ check_marker(PredMarkers, marker_class_method).

:- pred copy_clauses_to_procs(pred_info::in, pred_info::out) is det.

copy_clauses_to_procs(!PredInfo) :-
    pred_info_get_procedures(!.PredInfo, Procs0),
    pred_info_get_clauses_info(!.PredInfo, ClausesInfo),
    ProcIds = pred_info_all_non_imported_procids(!.PredInfo),
    copy_clauses_to_procs_2(ProcIds, ClausesInfo, Procs0, Procs),
    pred_info_set_procedures(Procs, !PredInfo).

:- pred copy_clauses_to_procs_2(list(proc_id)::in, clauses_info::in,
    proc_table::in, proc_table::out) is det.

copy_clauses_to_procs_2([], _, !Procs).
copy_clauses_to_procs_2([ProcId | ProcIds], ClausesInfo, !Procs) :-
    map.lookup(!.Procs, ProcId, Proc0),
    copy_clauses_to_proc(ProcId, ClausesInfo, Proc0, Proc),
    map.det_update(!.Procs, ProcId, Proc, !:Procs),
    copy_clauses_to_procs_2(ProcIds, ClausesInfo, !Procs).

copy_clauses_to_proc(ProcId, ClausesInfo, !Proc) :-
    ClausesInfo = clauses_info(VarSet0, _, _, VarTypes, HeadVars,
        ClausesRep, RttiInfo, _),
    get_clause_list(ClausesRep, Clauses),
    select_matching_clauses(Clauses, ProcId, MatchingClauses),
    get_clause_goals(MatchingClauses, GoalList),
    ( GoalList = [SingleGoal] ->
        SingleGoal = hlds_goal(SingleExpr, _),
        (
            SingleExpr = call_foreign_proc(_, _, _, Args, ExtraArgs,
                MaybeTraceRuntimeCond, _)
        ->
            % Use the original variable names for the headvars of foreign_proc
            % clauses, not the introduced `HeadVar__n' names.
            VarSet = list.foldl(set_arg_names, Args, VarSet0),
            expect(unify(ExtraArgs, []), this_file,
                "copy_clauses_to_proc: extra_args"),
            expect(unify(MaybeTraceRuntimeCond, no), this_file,
                "copy_clauses_to_proc: trace runtime cond")
        ;
            VarSet = VarSet0
        ),
        Goal = SingleGoal
    ;
        VarSet = VarSet0,

        % Convert the list of clauses into a disjunction,
        % and construct a goal_info for the disjunction.

        % We use the context of the first clause, unless there weren't
        % any clauses at all, in which case we use the context of the
        % mode declaration.
        %
        goal_info_init(GoalInfo0),
        ( GoalList = [FirstGoal | _] ->
            FirstGoal = hlds_goal(_, FirstGoalInfo),
            goal_info_get_context(FirstGoalInfo, Context)
        ;
            proc_info_get_context(!.Proc, Context)
        ),
        goal_info_set_context(Context, GoalInfo0, GoalInfo1),

        % The non-local vars are just the head variables.

        NonLocalVars = proc_arg_vector_to_set(HeadVars),
        goal_info_set_nonlocals(NonLocalVars, GoalInfo1, GoalInfo2),

        % The disjunction is impure/semipure if any of the disjuncts
        % is impure/semipure.

        ( contains_nonpure_goal(GoalList) ->
            list.map(goal_get_purity, GoalList, PurityList),
            Purity = list.foldl(worst_purity, PurityList, purity_pure),
            goal_info_set_purity(Purity, GoalInfo2, GoalInfo)
        ;
            GoalInfo2 = GoalInfo
        ),

        Goal = hlds_goal(disj(GoalList), GoalInfo)
    ),
    % XXX ARGVEC - when the proc_info is converted to use proc_arg_vectors
    %     we should just pass the headvar vector in directly.
    HeadVarList = proc_arg_vector_to_list(HeadVars),
    proc_info_set_body(VarSet, VarTypes, HeadVarList, Goal, RttiInfo, !Proc).

:- pred contains_nonpure_goal(list(hlds_goal)::in) is semidet.

contains_nonpure_goal([Goal | Goals]) :-
    (
        goal_get_purity(Goal, Purity),
        Purity \= purity_pure
    ;
        contains_nonpure_goal(Goals)
    ).

:- func set_arg_names(foreign_arg, prog_varset) = prog_varset.

set_arg_names(Arg, Vars0) = Vars :-
    Var = foreign_arg_var(Arg),
    MaybeNameMode = foreign_arg_maybe_name_mode(Arg),
    (
        MaybeNameMode = yes(Name - _),
        varset.name_var(Vars0, Var, Name, Vars)
    ;
        MaybeNameMode = no,
        Vars = Vars0
    ).

:- pred select_matching_clauses(list(clause)::in, proc_id::in,
    list(clause)::out) is det.

select_matching_clauses([], _, []).
select_matching_clauses([Clause | Clauses], ProcId, MatchingClauses) :-
    Clause = clause(ProcIds, _, _, _),
    % An empty list here means that the clause applies to all procs.
    (
        ProcIds = [],
        MatchingClauses = [Clause | MatchingClauses1]
    ;
        ProcIds = [_ | _],
        ( list.member(ProcId, ProcIds) ->
            MatchingClauses = [Clause | MatchingClauses1]
        ;
            MatchingClauses = MatchingClauses1
        )
    ),
    select_matching_clauses(Clauses, ProcId, MatchingClauses1).

:- pred get_clause_goals(list(clause)::in, list(hlds_goal)::out) is det.

get_clause_goals([], []).
get_clause_goals([Clause | Clauses], Goals) :-
    get_clause_goals(Clauses, Goals1),
    Clause = clause(_, Goal, _, _),
    goal_to_disj_list(Goal, GoalList),
    list.append(GoalList, Goals1, Goals).

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

introduce_exists_casts(PredIds, !ModuleInfo) :-
    module_info_preds(!.ModuleInfo, PredTable0),
    list.foldl(introduce_exists_casts_pred(!.ModuleInfo), PredIds,
        PredTable0, PredTable),
    module_info_set_preds(PredTable, !ModuleInfo).

:- pred introduce_exists_casts_pred(module_info::in, pred_id::in,
    pred_table::in, pred_table::out) is det.

introduce_exists_casts_pred(ModuleInfo, PredId, !PredTable) :-
    map.lookup(!.PredTable, PredId, PredInfo0),
    (
        % Optimise the common case.
        pred_info_get_existq_tvar_binding(PredInfo0, Subn),
        \+ map.is_empty(Subn),

        % Only process preds for which we copied clauses to procs.
        do_copy_clauses_to_procs(PredInfo0)
    ->
        pred_info_get_procedures(PredInfo0, Procs0),
        ProcIds = pred_info_all_non_imported_procids(PredInfo0),
        introduce_exists_casts_procs(ModuleInfo, PredInfo0, ProcIds,
            Procs0, Procs),
        pred_info_set_procedures(Procs, PredInfo0, PredInfo),
        svmap.det_update(PredId, PredInfo, !PredTable)
    ;
        true
    ).

:- pred introduce_exists_casts_procs(module_info::in, pred_info::in,
    list(proc_id)::in, proc_table::in, proc_table::out) is det.

introduce_exists_casts_procs(_, _, [], !Procs).
introduce_exists_casts_procs(ModuleInfo, PredInfo, [ProcId | ProcIds],
        !Procs) :-
    map.lookup(!.Procs, ProcId, ProcInfo0),
    introduce_exists_casts_proc(ModuleInfo, PredInfo, ProcInfo0, ProcInfo),
    svmap.det_update(ProcId, ProcInfo, !Procs),
    introduce_exists_casts_procs(ModuleInfo, PredInfo, ProcIds, !Procs).

introduce_exists_casts_proc(ModuleInfo, PredInfo, !ProcInfo) :-
    pred_info_get_arg_types(PredInfo, ArgTypes),
    pred_info_get_existq_tvar_binding(PredInfo, Subn),
    pred_info_get_class_context(PredInfo, PredConstraints),
    OrigArity = pred_info_orig_arity(PredInfo),
    NumExtraHeadVars = list.length(ArgTypes) - OrigArity,

    proc_info_get_varset(!.ProcInfo, VarSet0),
    proc_info_get_vartypes(!.ProcInfo, VarTypes0),
    proc_info_get_headvars(!.ProcInfo, HeadVars0),
    proc_info_get_goal(!.ProcInfo, Body0),
    proc_info_get_rtti_varmaps(!.ProcInfo, RttiVarMaps0),
    proc_info_get_argmodes(!.ProcInfo, ArgModes),

    (
        list.drop(NumExtraHeadVars, ArgTypes, OrigArgTypes0),
        list.split_list(NumExtraHeadVars, HeadVars0, ExtraHeadVars0,
            OrigHeadVars0),
        list.split_list(NumExtraHeadVars, ArgModes, ExtraArgModes0,
            OrigArgModes0)
    ->
        OrigArgTypes = OrigArgTypes0,
        ExtraHeadVars1 = ExtraHeadVars0,
        OrigHeadVars1 = OrigHeadVars0,
        ExtraArgModes = ExtraArgModes0,
        OrigArgModes = OrigArgModes0
    ;
        unexpected(this_file, "introduce_exists_casts_proc: split_list failed")
    ),

    % Add exists_casts for any head vars which are existentially typed,
    % and for which the type is statically bound inside the procedure.  Subn
    % represents which existential types are bound.
    introduce_exists_casts_for_head(ModuleInfo, Subn, OrigArgTypes,
        OrigArgModes, OrigHeadVars1, OrigHeadVars, VarSet0, VarSet1,
        VarTypes0, VarTypes1, [], ExistsCastHeadGoals),

    % Add exists_casts for any existential type_infos or typeclass_infos.
    % We determine which of these are existential by looking at the mode.
    %
    ExistConstraints = PredConstraints ^ exist_constraints,
    assoc_list.from_corresponding_lists(ExtraArgModes, ExtraHeadVars1,
        ExtraModesAndVars),
    introduce_exists_casts_extra(ModuleInfo, Subn, ExistConstraints,
        ExtraModesAndVars, ExtraHeadVars, VarSet1, VarSet, VarTypes1, VarTypes,
        RttiVarMaps0, RttiVarMaps, [], ExistsCastExtraGoals),

    Body0 = hlds_goal(_, GoalInfo0),
    goal_to_conj_list(Body0, Goals0),
    Goals = Goals0 ++ ExistsCastHeadGoals ++ ExistsCastExtraGoals,
    HeadVars = ExtraHeadVars ++ OrigHeadVars,
    set.list_to_set(HeadVars, NonLocals),
    goal_info_set_nonlocals(NonLocals, GoalInfo0, GoalInfo),
    Body = hlds_goal(conj(plain_conj, Goals), GoalInfo),
    proc_info_set_body(VarSet, VarTypes, HeadVars, Body, RttiVarMaps,
        !ProcInfo).

:- pred introduce_exists_casts_for_head(module_info::in, tsubst::in,
    list(mer_type)::in, list(mer_mode)::in, list(prog_var)::in,
    list(prog_var)::out, prog_varset::in, prog_varset::out,
    vartypes::in, vartypes::out, list(hlds_goal)::in, list(hlds_goal)::out)
    is det.

introduce_exists_casts_for_head(ModuleInfo, Subn, ArgTypes, ArgModes,
        !HeadVars, !VarSet, !VarTypes, !ExtraGoals) :-
    (
        ArgTypes = [],
        ArgModes = [],
        !.HeadVars = []
    ->
        true
    ;
        ArgTypes = [ArgType | ArgTypesRest],
        ArgModes = [ArgMode | ArgModesRest],
        !.HeadVars = [HeadVar0 | HeadVarsRest0]
    ->
        introduce_exists_casts_for_head(ModuleInfo, Subn, ArgTypesRest,
            ArgModesRest, HeadVarsRest0, HeadVarsRest, !VarSet, !VarTypes,
            !ExtraGoals),
        introduce_exists_casts_for_arg(ModuleInfo, Subn, ArgType, ArgMode,
            HeadVar0, HeadVar, !VarSet, !VarTypes, !ExtraGoals),
        !:HeadVars = [HeadVar | HeadVarsRest]
    ;
        unexpected(this_file, "introduce_exists_casts_for_head: " ++
            "length mismatch")
    ).

:- pred introduce_exists_casts_for_arg(module_info::in, tsubst::in,
    mer_type::in, mer_mode::in, prog_var::in, prog_var::out,
    prog_varset::in, prog_varset::out, vartypes::in, vartypes::out,
    list(hlds_goal)::in, list(hlds_goal)::out) is det.

introduce_exists_casts_for_arg(ModuleInfo, Subn, ExternalType, ArgMode,
        HeadVar0, HeadVar, !VarSet, !VarTypes, !ExtraGoals) :-
    apply_rec_subst_to_type(Subn, ExternalType, InternalType),
    (
        % Add an exists_cast for the head variable if its type
        % inside the procedure is different from its type at the
        % interface.
        InternalType \= ExternalType
    ->
        term.context_init(Context),
        svmap.det_update(HeadVar0, InternalType, !VarTypes),
        make_new_exist_cast_var(HeadVar0, HeadVar, !VarSet),
        svmap.det_insert(HeadVar, ExternalType, !VarTypes),
        mode_get_insts(ModuleInfo, ArgMode, _, Inst),
        generate_cast_with_insts(exists_cast, HeadVar0, HeadVar, Inst, Inst,
            Context, ExtraGoal),
        !:ExtraGoals = [ExtraGoal | !.ExtraGoals]
    ;
        HeadVar = HeadVar0
    ).

:- pred introduce_exists_casts_extra(module_info::in, tsubst::in,
    list(prog_constraint)::in, assoc_list(mer_mode, prog_var)::in,
    list(prog_var)::out, prog_varset::in, prog_varset::out,
    vartypes::in, vartypes::out, rtti_varmaps::in,  rtti_varmaps::out,
    list(hlds_goal)::in, list(hlds_goal)::out) is det.

introduce_exists_casts_extra(_, _, ExistConstraints, [], [], !VarSet,
        !VarTypes, !RttiVarMaps, !ExtraGoals) :-
    (
        ExistConstraints = []
    ;
        ExistConstraints = [_ | _],
        unexpected(this_file, "introduce_exists_casts_extra: length mismatch")
    ).

introduce_exists_casts_extra(ModuleInfo, Subn, ExistConstraints0,
        [ModeAndVar | ModesAndVars], [Var | Vars], !VarSet, !VarTypes,
        !RttiVarMaps, !ExtraGoals) :-
    ModeAndVar = ArgMode - Var0,
    (
        mode_is_output(ModuleInfo, ArgMode)
    ->
        % Create the exists_cast goal.

        term.context_init(Context),
        make_new_exist_cast_var(Var0, Var, !VarSet),
        map.lookup(!.VarTypes, Var0, VarType),
        svmap.det_insert(Var, VarType, !VarTypes),
        generate_cast(exists_cast, Var0, Var, Context, ExtraGoal),
        !:ExtraGoals = [ExtraGoal | !.ExtraGoals],

        % Update the rtti_varmaps.  The old variable needs to have the
        % substitution applied to its type/constraint.  The new variable
        % needs to be associated with the unsubstituted type/constraint.

        rtti_varmaps_var_info(!.RttiVarMaps, Var0, VarInfo),
        (
            VarInfo = type_info_var(TypeInfoType0),
            % For type_infos, the old variable needs to have the substitution
            % applied to its type, and the new variable needs to be associated
            % with the unsubstituted type.
            apply_rec_subst_to_type(Subn, TypeInfoType0, TypeInfoType),
            rtti_set_type_info_type(Var0, TypeInfoType, !RttiVarMaps),
            rtti_det_insert_type_info_type(Var, TypeInfoType0, !RttiVarMaps),
            ExistConstraints = ExistConstraints0
        ;
            VarInfo = typeclass_info_var(_),
            % For typeclass_infos, the constraint associated with the old
            % variable was derived from the constraint map, so all binding
            % and improvement has been applied.  The new variable needs to
            % be associated with the corresponding existential head constraint,
            % so we pop one off the front of the list.
            (
                ExistConstraints0 = [ExistConstraint | ExistConstraints]
            ;
                ExistConstraints0 = [],
                unexpected(this_file,
                    "introduce_exists_casts_extra: missing constraint")
            ),
            rtti_det_insert_typeclass_info_var(ExistConstraint, Var,
                !RttiVarMaps),
            % We also need to ensure that all type variables in the constraint
            % have a location recorded, so we insert a location now if there
            % is not already one.
            ExistConstraint = constraint(_, ConstraintArgs),
            maybe_add_type_info_locns(ConstraintArgs, Var, 1, !RttiVarMaps)
        ;
            VarInfo = non_rtti_var,
            unexpected(this_file,
                "introduce_exists_casts_extra: rtti_varmaps info not found")
        )
    ;
        Var = Var0,
        ExistConstraints = ExistConstraints0
    ),
    introduce_exists_casts_extra(ModuleInfo, Subn, ExistConstraints,
        ModesAndVars, Vars, !VarSet, !VarTypes, !RttiVarMaps, !ExtraGoals).

:- pred maybe_add_type_info_locns(list(mer_type)::in, prog_var::in, int::in,
    rtti_varmaps::in, rtti_varmaps::out) is det.

maybe_add_type_info_locns([], _, _, !RttiVarMaps).
maybe_add_type_info_locns([ArgType | ArgTypes], Var, Num, !RttiVarMaps) :-
    (
        ArgType = type_variable(TVar, _),
        \+ rtti_search_type_info_locn(!.RttiVarMaps, TVar, _)
    ->
        Locn = typeclass_info(Var, Num),
        rtti_det_insert_type_info_locn(TVar, Locn, !RttiVarMaps)
    ;
        true
    ),
    maybe_add_type_info_locns(ArgTypes, Var, Num + 1, !RttiVarMaps).

:- pred make_new_exist_cast_var(prog_var::in, prog_var::out,
    prog_varset::in, prog_varset::out) is det.

make_new_exist_cast_var(InternalVar, ExternalVar, !VarSet) :-
    svvarset.new_var(ExternalVar, !VarSet),
    varset.lookup_name(!.VarSet, InternalVar, InternalName),
    string.append("ExistQ", InternalName, ExternalName),
    svvarset.name_var(ExternalVar, ExternalName, !VarSet).

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

:- func this_file = string.

this_file = "clause_to_proc.m".

%-----------------------------------------------------------------------------%
:- end_module check_hlds.clause_to_proc.
%-----------------------------------------------------------------------------%