polymorphism.m

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1995-2012 The University of Melbourne.
% Copyright (C) 2013-2024 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: polymorphism.m.
% Main authors: fjh and zs.
%
% This module and its subcontractors implement a pass over the HLDS.
% This pass does a syntactic transformation to implement both parametric
% and ad-hoc (typeclass-based) polymorphism, by passing extra `type_info'
% and `typeclass_info' arguments between predicates and functions.
% These arguments are structures that contain, amongst other things,
% higher order predicate terms for the polymorphic procedures or methods.
%
% See notes/type_class_transformation.html for a description of the
% transformation and data structures used to implement type classes.
%
% XXX The way the code in this pass handles existential type classes
% and type class constraints is a bit ad hoc, in general; there are
% definitely parts of this code (marked with XXXs) that could do with
% a rewrite to make it more consistent, and hence more maintainable.
%
%---------------------------------------------------------------------------%
%
% Transformation of polymorphic code:
%
% Every polymorphic predicate is transformed so that it takes one additional
% argument for every type variable in the predicate's type declaration.
% The argument gives information about the type, including higher order
% predicate variables for each of the builtin polymorphic operations
% (currently unify/2, compare/3).
%
%---------------------------------------------------------------------------%
%
% Example of transformation:
%
% Take the following code as an example, ignoring the requirement for
% superhomogeneous form for clarity:
%
%   :- pred p(T1).
%   :- pred q(T2).
%   :- pred r(T3).
%
%   p(X) :- q([X]), r(0).
%
% We add an extra argument for each type variable:
%
%   :- pred p(type_info(T1), T1).
%   :- pred q(type_info(T2), T2).
%   :- pred r(type_info(T3), T3).
%
% We transform the body of p to this:
%
%   p(TypeInfoT1, X) :-
%       TypeCtorInfoT2 = type_ctor_info(list/1),
%       TypeInfoT2 = type_info(TypeCtorInfoT2, TypeInfoT1),
%       q(TypeInfoT2, [X]),
%       TypeInfoT3 = type_ctor_info(int/0),
%       r(TypeInfoT3, 0).
%
% Note that type_ctor_infos are actually generated as references to a
% single shared type_ctor_info.
%
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
%
% Transformation of code using existentially quantified types:
%
% The transformation for existential types is similar to the transformation
% for universally quantified types, except that the type_infos and
% type_class_infos have mode `out' rather than mode `in'.
%
% The argument passing convention is that the new parameters
% introduced by this pass are placed in the following order:
%
%   First the type_infos for unconstrained universally quantified type
%   variables, in the order that the type variables first appear in the
%   argument types;
%
%   then the type_infos for unconstrained existentially quantified type
%   variables, in the order that the type variables first appear in the
%   argument types;
%
%   then the typeclass_infos for universally quantified constraints,
%   in the order that the constraints appear in the class context;
%
%   then the typeclass_infos for existentially quantified constraints,
%   in the order that the constraints appear in the class context;
%
%   and finally the original arguments of the predicate.
%
% Bear in mind that for the purposes of this (and most other) calculations,
% the return parameter of a function counts as the _last_ argument.
%
% The convention for class method implementations is slightly different
% to match the order that the type_infos and typeclass_infos are passed
% in by do_call_class_method (in runtime/mercury_ho_call.c):
%
%   First the type_infos for the unconstrained type variables in the
%   instance declaration, in the order that the type variables first appear
%   in the instance arguments;
%
%   then the typeclass_infos for the class constraints on the instance
%   declaration, in the order that the constraints appear in the declaration;
%
%   then the remainder of the arguments as above.
%
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

:- module check_hlds.polymorphism.
:- interface.

:- import_module hlds.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module parse_tree.
:- import_module parse_tree.error_spec.
:- import_module parse_tree.maybe_error.

:- import_module io.
:- import_module list.

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

    % Run the polymorphism pass over the whole HLDS.
    %
:- pred polymorphism_process_module(io.text_output_stream::in,
    module_info::in, module_info::out, list(pred_id)::out,
    maybe_safe_to_continue::out, list(error_spec)::out) is det.

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

    % Run the polymorphism pass over a single pred. This is used to transform
    % clauses introduced by unify_proc.m for complicated unification predicates
    % for types for which unification predicates are generated lazily.
    %
    % This predicate should be used with caution. polymorphism.m expects that
    % the argument types of called predicates have not been transformed yet.
    % This predicate will not work correctly after the original pass of
    % polymorphism has been run if the predicate to be processed calls
    % any polymorphic predicates which require type_infos or typeclass_infos
    % to be added to the argument list.
    %
    % For backwards compatibility, this predicate also does the tasks
    % that older versions of the polymorphism pass used to do: copying
    % goals from clauses to procedures, and doing the post-copying parts
    % of the polymorphism transformation.
    %
:- pred polymorphism_process_generated_pred(pred_id::in,
    module_info::in, module_info::out) is det.

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

:- implementation.

:- import_module check_hlds.clause_to_proc.
:- import_module check_hlds.introduce_exists_casts.
:- import_module check_hlds.polymorphism_clause.
:- import_module check_hlds.polymorphism_info.
:- import_module hlds.const_struct.
:- import_module hlds.hlds_args.
:- import_module hlds.hlds_clauses.
:- import_module hlds.passes_aux.
:- import_module mdbcomp.
:- import_module mdbcomp.program_representation.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_data_pragma.
:- import_module parse_tree.prog_type_unify.
:- import_module parse_tree.var_table.

:- import_module int.
:- import_module map.
:- import_module maybe.
:- import_module one_or_more.
:- import_module require.
:- import_module term_context.
:- import_module varset.

%---------------------------------------------------------------------------%
%
% This whole section just traverses the module structure.
% We do two passes, the first to fix up the clauses_info and proc_infos
% (and in fact everything except the pred_info argtypes), the second to fix up
% the pred_info argtypes. The reason we need two passes is that the first pass
% looks at the argtypes of the called predicates, and so we need to make
% sure we don't muck them up before we have finished the first pass.
%

polymorphism_process_module(ProgressStream, !ModuleInfo, ExistsCastPredIds,
        SafeToContinue, Specs) :-
    module_info_get_pred_id_table(!.ModuleInfo, PredIdTable0),
    map.keys(PredIdTable0, PredIds0),
    list.foldl3(maybe_polymorphism_process_pred(ProgressStream), PredIds0,
        safe_to_continue, SafeToContinue, [], Specs, !ModuleInfo),
    module_info_get_pred_id_table(!.ModuleInfo, PredIdTable1),
    map.keys(PredIdTable1, PredIds1),
    list.foldl2(polymorphism_update_arg_types(yes(ProgressStream)), PredIds1,
        [], ExistsCastPredIds, !ModuleInfo).

:- pred maybe_polymorphism_process_pred(io.text_output_stream::in, pred_id::in,
    maybe_safe_to_continue::in, maybe_safe_to_continue::out,
    list(error_spec)::in, list(error_spec)::out,
    module_info::in, module_info::out) is det.

maybe_polymorphism_process_pred(ProgressStream, PredId, !SafeToContinue,
        !Specs, !ModuleInfo) :-
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
    ( if
        PredModule = pred_info_module(PredInfo),
        PredName = pred_info_name(PredInfo),
        pred_info_get_orig_arity(PredInfo, pred_form_arity(PredFormArityInt)),
        no_type_info_builtin(PredModule, PredName, PredFormArityInt)
    then
        true
    else
        polymorphism_process_pred_msg(ProgressStream, PredId, !SafeToContinue,
            !Specs, !ModuleInfo)
    ).

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

:- pred polymorphism_process_pred_msg(io.text_output_stream::in, pred_id::in,
    maybe_safe_to_continue::in, maybe_safe_to_continue::out,
    list(error_spec)::in, list(error_spec)::out,
    module_info::in, module_info::out) is det.

polymorphism_process_pred_msg(ProgressStream, PredId,
        !SafeToContinue, !Specs, !ModuleInfo) :-
    % Since polymorphism transforms not just the procedures defined
    % in the module being compiled, but also all the procedures in
    % all the imported modules, this message can be printed A LOT,
    % even though it is almost never of interest.
    % That is why we enable it only when requested.
    trace [compiletime(flag("poly_msgs")), io(!IO)] (
        maybe_write_pred_progress_message(ProgressStream, !.ModuleInfo,
            "Transforming polymorphism for", PredId, !IO)
    ),
    polymorphism_process_pred(PredId, PredSafeToContinue, !Specs, !ModuleInfo),
    (
        PredSafeToContinue = safe_to_continue
    ;
        PredSafeToContinue = unsafe_to_continue,
        !:SafeToContinue = unsafe_to_continue
    ).

polymorphism_process_generated_pred(PredId, !ModuleInfo) :-
    polymorphism_process_pred(PredId, SafeToContinue, [], Specs, !ModuleInfo),
    expect(unify(Specs, []), $pred,
        "generated pred has errors"),
    expect(unify(SafeToContinue, safe_to_continue), $pred,
        "generated pred has errors"),
    polymorphism_update_arg_types(maybe.no, PredId, [], ExistsPredIds,
        !ModuleInfo),
    copy_clauses_to_procs_for_pred_in_module_info(PredId, !ModuleInfo),
    list.foldl(introduce_exists_casts_poly, ExistsPredIds, !ModuleInfo).

:- pred polymorphism_process_pred(pred_id::in, maybe_safe_to_continue::out,
    list(error_spec)::in, list(error_spec)::out,
    module_info::in, module_info::out) is det.

polymorphism_process_pred(PredId, SafeToContinue, !Specs, !ModuleInfo) :-
    trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
        % Replace 99999 with the id of the predicate you want to debug.
        ( if pred_id_to_int(PredId) = 99999 then
            poly_info_set_selected_pred(is_selected_pred, !IO)
        else
            true
        )
    ),

    % Run the polymorphism pass over the clauses_info, updating the headvars,
    % goals, varsets, types, etc., and computing some information in the
    % poly_info.
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
    pred_info_get_clauses_info(PredInfo0, ClausesInfo0),
    init_poly_info(!.ModuleInfo, PredInfo0, ClausesInfo0, PolyInfo0),
    polymorphism_process_clause_info(PredInfo0, ExtraArgModes,
        ClausesInfo0, ClausesInfo, PolyInfo0, PolyInfo),
    poly_info_get_module_info(PolyInfo, !:ModuleInfo),
    poly_info_get_const_struct_db(PolyInfo, ConstStructDb),
    module_info_set_const_struct_db(ConstStructDb, !ModuleInfo),

    poly_info_get_typevarset(PolyInfo, TypeVarSet),
    pred_info_set_typevarset(TypeVarSet, PredInfo0, PredInfo1),
    pred_info_set_clauses_info(ClausesInfo, PredInfo1, PredInfo2),

    poly_info_get_errors(PolyInfo, PredSpecs),
    (
        PredSpecs = [],
        SafeToContinue = safe_to_continue
    ;
        PredSpecs = [_ | _],
        SafeToContinue = unsafe_to_continue,
        !:Specs = PredSpecs ++ !.Specs
    ),

    % Do a pass over the proc_infos, updating all the argmodes with
    % modes for the extra arguments.
    pred_info_get_proc_table(PredInfo2, ProcMap0),
    map.map_values_only(add_extra_arg_modes_to_proc(ExtraArgModes),
        ProcMap0, ProcMap),
    pred_info_set_proc_table(ProcMap, PredInfo2, PredInfo),
    module_info_set_pred_info(PredId, PredInfo, !ModuleInfo),

    trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
        poly_info_set_selected_pred(is_not_selected_pred, !IO)
    ).

:- pred add_extra_arg_modes_to_proc(poly_arg_vector(mer_mode)::in,
    proc_info::in, proc_info::out) is det.

add_extra_arg_modes_to_proc(ExtraArgModes, !ProcInfo) :-
    % Add the ExtraArgModes to the proc_info argmodes.
    % XXX ARGVEC - revisit this when the proc_info uses proc_arg_vectors.
    proc_info_get_argmodes(!.ProcInfo, ArgModes1),
    ExtraArgModesList = poly_arg_vector_to_list(ExtraArgModes),
    ArgModes = ExtraArgModesList ++ ArgModes1,
    proc_info_set_argmodes(ArgModes, !ProcInfo).

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

:- pred polymorphism_update_arg_types(maybe(io.text_output_stream)::in,
    pred_id::in, list(pred_id)::in, list(pred_id)::out,
    module_info::in, module_info::out) is det.

polymorphism_update_arg_types(MaybeProgressStream, PredId,
        !ExistsCastPredIds, !ModuleInfo) :-
    % Recompute the arg types by finding the headvars and the var->type mapping
    % (from the clauses_info) and applying the type mapping to the extra
    % headvars to get the new arg types. Note that we are careful to only apply
    % the mapping to the extra head vars, not to the originals, because
    % otherwise we would stuff up the arg types for unification predicates for
    % equivalence types.

    % Since polymorphism transforms not just the procedures defined
    % in the module being compiled, but also all the procedures in
    % all the imported modules, this message can be printed A LOT,
    % even though it is almost never of interest.
    % That is why we enable it only when requested.
    trace [compiletime(flag("poly_msgs")), io(!IO)] (
        (
            MaybeProgressStream = no
        ;
            MaybeProgressStream = yes(ProgressStream),
            maybe_write_pred_progress_message(ProgressStream, !.ModuleInfo,
                "Update polymorphism arg types for", PredId, !IO)
        )
    ),

    module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
    pred_info_get_clauses_info(PredInfo0, ClausesInfo0),
    clauses_info_get_var_table(ClausesInfo0, VarTable0),
    clauses_info_get_headvars(ClausesInfo0, HeadVars),
    proc_arg_vector_partition_poly_args(HeadVars, ExtraHeadVarList,
        OldHeadVarList),
    % We need ExistQVars whether or not ExtraHeadVarList is empty or not.
    pred_info_get_arg_types(PredInfo0, TypeVarSet, ExistQVars, ArgTypes0),
    list.length(ExtraHeadVarList, NumExtraHeadVars),
    (
        ExtraHeadVarList = [],
        PredInfo2 = PredInfo0
    ;
        ExtraHeadVarList = [_ | _],
        lookup_var_types(VarTable0, ExtraHeadVarList, ExtraArgTypes),
        ArgTypes = ExtraArgTypes ++ ArgTypes0,
        pred_info_set_arg_types(TypeVarSet, ExistQVars, ArgTypes,
            PredInfo0, PredInfo1),
        pred_info_get_format_call(PredInfo1, MaybeFormatCall1),
        (
            MaybeFormatCall1 = no,
            PredInfo2 = PredInfo1
        ;
            MaybeFormatCall1 = yes(format_call(Context, OoMFormatStrsValues1)),
            % Update the argument numbers in the format_call field
            % to account for the new arguments we just added at the front
            % of the argument list.
            one_or_more.map(increment_arg_nums(NumExtraHeadVars),
                OoMFormatStrsValues1, OoMFormatStrsValues2),
            MaybeFormatCall2 = yes(format_call(Context, OoMFormatStrsValues2)),
            pred_info_set_format_call(MaybeFormatCall2, PredInfo1, PredInfo2)
        )
    ),

    % If the clauses bind some existentially quantified type variables,
    % introduce exists_casts goals for affected head variables, including
    % the new type_info and typeclass_info arguments. Make sure the types
    % of the internal versions of type_infos for those type variables
    % in the variable types map are as specific as possible.

    ( if
        ExistQVars = [_ | _],
        % This can fail for unification procedures of equivalence types.
        lookup_var_types(VarTable0, OldHeadVarList, OldHeadVarTypes),
        type_list_subsumes(ArgTypes0, OldHeadVarTypes, Subn),
        not map.is_empty(Subn)
    then
        pred_info_set_existq_tvar_binding(Subn, PredInfo2, PredInfo3),
        !:ExistsCastPredIds = [PredId | !.ExistsCastPredIds]
    else
        PredInfo3 = PredInfo2
    ),

    pred_info_set_polymorphism_added_args(NumExtraHeadVars,
        PredInfo3, PredInfo),
    module_info_set_pred_info(PredId, PredInfo, !ModuleInfo).

:- pred increment_arg_nums(int::in,
    format_string_values::in, format_string_values::out) is det.

increment_arg_nums(Inc, FSV0, FSV) :-
    FSV0 = format_string_values(OrigFormatStrArgNum, OrigValuesListArgNum,
        CurFormatStrArgNum, CurValuesListArgNum),
    FSV = format_string_values(OrigFormatStrArgNum, OrigValuesListArgNum,
        CurFormatStrArgNum + Inc, CurValuesListArgNum + Inc).

%---------------------------------------------------------------------------%
:- end_module check_hlds.polymorphism.
%---------------------------------------------------------------------------%