mercury/compiler/special_pred.m

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1995-2000,2002-2011 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: special_pred.m.
% Main author: fjh.
%
% Certain predicates are implicitly defined for every type by the compiler.
% This module defines most of the characteristics of those predicates.
% (The actual code for these predicates is generated in unify_proc.m.)
%
%-----------------------------------------------------------------------------%

:- module hlds.special_pred.
:- interface.

:- import_module hlds.hlds_data.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module hlds.status.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.
:- import_module parse_tree.prog_data.

:- import_module list.
:- import_module map.

:- type special_pred_maps
    --->    special_pred_maps(
                spm_unify_map           :: map(type_ctor, pred_id),
                spm_index_map           :: map(type_ctor, pred_id),
                spm_compare_map         :: map(type_ctor, pred_id)
            ).

:- pred search_special_pred_maps(special_pred_maps::in,
    special_pred_id::in, type_ctor::in, pred_id::out) is semidet.
:- pred lookup_special_pred_maps(special_pred_maps::in,
    special_pred_id::in, type_ctor::in, pred_id::out) is det.

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

:- pred special_pred_list(list(special_pred_id)::out) is det.

:- pred special_pred_description(special_pred_id::in, string::out) is det.

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

:- pred special_pred_mode_num(special_pred_id::in, int::out) is det.

    % This predicate always returns determinism `semidet' for unification
    % procedures. For types with only one value, the unification is actually
    % `det', however we need to pretend it is `semidet' so that it can be
    % called correctly from the polymorphic `unify' procedure.
    %
:- pred special_pred_interface(special_pred_id::in, mer_type::in,
    list(mer_type)::out, list(mer_mode)::out, determinism::out) is det.

    % Given a special pred id and the list of its arguments, work out which
    % argument specifies the type that this special predicate is for. Note that
    % this gets called after the polymorphism.m pass, so type_info arguments
    % may have been inserted at the start; hence we find the type at a known
    % position from the end of the list (by using list.reverse).
    %
    % Currently for most of the special predicates the type variable can be
    % found in the last type argument, except for index, for which it is the
    % second-last argument.
    %
:- pred special_pred_get_type(special_pred_id::in, list(prog_var)::in,
    prog_var::out) is semidet.

:- pred special_pred_get_type_det(special_pred_id::in, list(prog_var)::in,
    prog_var::out) is det.

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

    % Succeeds if the declarations and clauses for the special predicates
    % for the given type generated only when required. This will succeed
    % for imported types for which the special predicates do not need
    % typechecking.
    %
:- pred special_pred_is_generated_lazily(module_info::in, type_ctor::in)
    is semidet.

    % XXX Document me, and the relationship to the /2 pred just above.
    %
:- pred special_pred_is_generated_lazily_for_defn(module_info::in,
    type_ctor::in, hlds_type_body::in, type_status::in) is semidet.

    % A compiler-generated predicate only needs type checking if
    % (a) it is a user-defined equality pred, or
    % (b) it is the unification or comparison predicate for an existentially
    %     quantified type, or
    % (c) it is the initialisation predicate for a solver type.
    %
:- pred special_pred_for_type_needs_typecheck(module_info::in,
    special_pred_id::in, hlds_type_body::in) is semidet.

    % Succeed if the type can have clauses generated for its special
    % predicates. This will fail for abstract types and types for which
    % the RTTI information is defined by hand.
    %
:- pred can_generate_special_pred_clauses_for_type(module_info::in,
    type_ctor::in, hlds_type_body::in) is semidet.

    % Is this a builtin type whose special predicates are defined in Mercury?
    % If yes, return the name of the type.
    %
:- pred is_builtin_type_special_preds_defined_in_mercury(type_ctor::in,
    string::out) is semidet.

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

    % Does the compiler generate the RTTI for the builtin types, or is it
    % hand-coded?
    %
:- pred compiler_generated_rtti_for_builtins(module_info::in) is semidet.

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

    % Look up the pred_id and proc_id for a type specific
    % unification/comparison/index predicate.
    %
:- pred get_special_proc(module_info::in, type_ctor::in,
    special_pred_id::in, sym_name::out, pred_id::out, proc_id::out) is semidet.
:- pred get_special_proc_det(module_info::in, type_ctor::in,
    special_pred_id::in, sym_name::out, pred_id::out, proc_id::out) is det.

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

:- implementation.

:- import_module check_hlds.
:- import_module check_hlds.type_util.
:- import_module hlds.pred_table.
:- import_module libs.
:- import_module libs.globals.
:- import_module mdbcomp.builtin_modules.
:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.

:- import_module bool.
:- import_module maybe.
:- import_module one_or_more.
:- import_module require.
:- import_module string.

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

search_special_pred_maps(SpecMaps, SpecialPredId, TypeCtor, PredId) :-
    select_special_pred_map(SpecMaps, SpecialPredId, SpecMap),
    map.search(SpecMap, TypeCtor, PredId).

lookup_special_pred_maps(SpecMaps, SpecialPredId, TypeCtor, PredId) :-
    select_special_pred_map(SpecMaps, SpecialPredId, SpecMap),
    map.lookup(SpecMap, TypeCtor, PredId).

:- pred select_special_pred_map(special_pred_maps::in,
    special_pred_id::in, map(type_ctor, pred_id)::out) is det.
:- pragma inline(pred(select_special_pred_map/3)).

select_special_pred_map(SpecMaps, SpecialPredId, SpecMap) :-
    (
        SpecialPredId = spec_pred_unify,
        SpecMap = SpecMaps ^ spm_unify_map
    ;
        SpecialPredId = spec_pred_index,
        SpecMap = SpecMaps ^ spm_index_map
    ;
        SpecialPredId = spec_pred_compare,
        SpecMap = SpecMaps ^ spm_compare_map
    ).

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

special_pred_list([spec_pred_unify, spec_pred_index, spec_pred_compare]).

special_pred_description(spec_pred_unify,   "unification predicate").
special_pred_description(spec_pred_compare, "comparison predicate").
special_pred_description(spec_pred_index,   "indexing predicate").

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

special_pred_mode_num(_, 0).
    % Mode num for special procs is always 0 (the first mode).

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

special_pred_interface(SpecialPredId, Type, ArgTypes, ArgModes, Detism) :-
    (
        SpecialPredId = spec_pred_unify,
        ArgTypes = [Type, Type],
        in_mode(In),
        ArgModes = [In, In],
        Detism = detism_semi
    ;
        SpecialPredId = spec_pred_index,
        ArgTypes = [Type, int_type],
        in_mode(In),
        out_mode(Out),
        ArgModes = [In, Out],
        Detism = detism_det
    ;
        SpecialPredId = spec_pred_compare,
        ArgTypes = [comparison_result_type, Type, Type],
        in_mode(In),
        uo_mode(Uo),
        ArgModes = [Uo, In, In],
        Detism = detism_det
    ).

special_pred_get_type(spec_pred_unify, Types, T) :-
    list.reverse(Types, [T | _]).
special_pred_get_type(spec_pred_index, Types, T) :-
    list.reverse(Types, [_, T | _]).
special_pred_get_type(spec_pred_compare, Types, T) :-
    list.reverse(Types, [T | _]).

special_pred_get_type_det(SpecialId, ArgTypes, Type) :-
    ( if special_pred_get_type(SpecialId, ArgTypes, TypePrime) then
        Type = TypePrime
    else
        unexpected($pred, "special_pred_get_type failed")
    ).

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

special_pred_is_generated_lazily(ModuleInfo, TypeCtor) :-
    ( if classify_type_ctor_if_special(TypeCtor, CtorCat0) then
        MaybeCtorCat = yes(CtorCat0)
    else
        MaybeCtorCat = no
    ),
    (
        MaybeCtorCat = yes(ctor_cat_tuple)
    ;
        (
            MaybeCtorCat = no
        ;
            MaybeCtorCat = yes(CtorCat),
            is_introduced_type_info_type_category(CtorCat) = yes
        ),
        module_info_get_type_table(ModuleInfo, TypeTable),
        search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
        hlds_data.get_type_defn_body(TypeDefn, TypeBody),
        hlds_data.get_type_defn_status(TypeDefn, TypeStatus),
        special_pred_is_generated_lazily_2(ModuleInfo, TypeBody, TypeStatus)
    ).

special_pred_is_generated_lazily_for_defn(ModuleInfo, TypeCtor,
        TypeBody, TypeStatus) :-
    % We don't want special preds for solver types to be generated lazily
    % because we have to insert calls to their initialisation preds during
    % mode analysis and we therefore require the appropriate names to
    % appear in the symbol table.

    TypeBody \= hlds_solver_type(_),
    TypeBody \= hlds_abstract_type(abstract_solver_type),

    ( if classify_type_ctor_if_special(TypeCtor, CtorCat0) then
        MaybeCtorCat = yes(CtorCat0)
    else
        MaybeCtorCat = no
    ),
    (
        MaybeCtorCat = yes(ctor_cat_tuple)
    ;
        (
            MaybeCtorCat = no
        ;
            MaybeCtorCat = yes(CtorCat),
            is_introduced_type_info_type_category(CtorCat) = yes
        ),
        special_pred_is_generated_lazily_2(ModuleInfo, TypeBody, TypeStatus)
    ).

:- pred special_pred_is_generated_lazily_2(module_info::in,
    hlds_type_body::in, type_status::in) is semidet.

special_pred_is_generated_lazily_2(ModuleInfo, TypeBody, TypeStatus) :-
    type_status_defined_in_this_module(TypeStatus) = no,

    % We can't generate clauses for unification predicates for foreign types
    % lazily because they call the polymorphic procedure
    % private_builtin.nyi_foreign_type_unify.
    % polymorphism.process_generated_pred can't handle calls to polymorphic
    % procedures after the initial polymorphism pass.
    TypeBody \= hlds_foreign_type(_),

    % The special predicates for types with user-defined equality or
    % existentially typed constructors are always generated immediately
    % by make_hlds.m.
    not special_pred_for_type_needs_typecheck(ModuleInfo, spec_pred_unify,
        TypeBody).

special_pred_for_type_needs_typecheck(ModuleInfo, SpecialPredId, TypeBody) :-
    (
        (
            SpecialPredId = spec_pred_unify,
            type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody,
                NonCanonical),
            require_complete_switch [NonCanonical]
            (
                ( NonCanonical = noncanon_uni_cmp(_, _)
                ; NonCanonical = noncanon_uni_only(_)
                ; NonCanonical = noncanon_cmp_only(_)
                )
            ;
                ( NonCanonical = noncanon_abstract(_)
                ; NonCanonical = noncanon_subtype
                ),
                fail
            )
        ;
            SpecialPredId = spec_pred_compare,
            type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody,
                NonCanonical),
            require_complete_switch [NonCanonical]
            (
                ( NonCanonical = noncanon_uni_cmp(_, _)
                ; NonCanonical = noncanon_cmp_only(_)
                )
            ;
                ( NonCanonical = noncanon_uni_only(_)
                ; NonCanonical = noncanon_abstract(_)
                ; NonCanonical = noncanon_subtype
                ),
                fail
            )
        )
    ;
        TypeBody = hlds_du_type(TypeBodyDu),
        one_or_more(HeadCtor, TailCtors) = TypeBodyDu ^ du_type_ctors,
        some [Ctor] (
            ( Ctor = HeadCtor
            ; list.member(Ctor, TailCtors)
            ),
            Ctor = ctor(_, MaybeExistConstraints, _, _, _, _),
            MaybeExistConstraints = exist_constraints(_)
        )
    ).

can_generate_special_pred_clauses_for_type(ModuleInfo, TypeCtor, TypeBody) :-
    (
        TypeBody \= hlds_abstract_type(_)
    ;
        % The types which have their unification and comparison
        % predicates defined in private_builtin.m.
        compiler_generated_rtti_for_builtins(ModuleInfo),
        is_builtin_type_special_preds_defined_in_mercury(TypeCtor, _)
    ),
    not type_ctor_has_hand_defined_rtti(TypeCtor, TypeBody),
    not (
        type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody,
            NonCanonical),
        NonCanonical = noncanon_abstract(_IsSolverType)
    ).

is_builtin_type_special_preds_defined_in_mercury(TypeCtor, TypeName) :-
    Builtin = mercury_public_builtin_module,
    TypeCtor = type_ctor(qualified(Builtin, TypeName), 0),
    % XXX Treating "pred" as a builtin type without also treating "func"
    % the same way looks wrong to me. -zs
    ( is_builtin_type_name(TypeName)
    ; TypeName = "pred"
    ).

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

compiler_generated_rtti_for_builtins(ModuleInfo) :-
    % The compiler generates the rtti for the builtins when we are on the
    % non-C backends. We don't generate the rtti on the C backends as the
    % C runtime contains references to this rtti, so the rtti must be defined
    % in the runtime, not the library.

    module_info_get_globals(ModuleInfo, Globals),
    globals.get_target(Globals, Target),
    ( Target = target_csharp
    ; Target = target_java
    ).

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

get_special_proc(ModuleInfo, TypeCtor, SpecialPredId,
        PredName, PredId, ProcId) :-
    TypeCategory = classify_type_ctor(ModuleInfo, TypeCtor),
    get_ctor_cat_builtin_type_name(TypeCategory) = MaybeBuiltinTypeName,
    (
        MaybeBuiltinTypeName = no,
        module_info_get_special_pred_maps(ModuleInfo, SpecialPredMaps),
        search_special_pred_maps(SpecialPredMaps, SpecialPredId, TypeCtor,
            PredId),
        module_info_pred_info(ModuleInfo, PredId, PredInfo),
        Module = pred_info_module(PredInfo),
        Name = pred_info_name(PredInfo),
        PredName = qualified(Module, Name),
        special_pred_mode_num(SpecialPredId, ProcInt),
        proc_id_to_int(ProcId, ProcInt)
    ;
        MaybeBuiltinTypeName = yes(BuiltinTypeName),
        special_pred_name_arity(SpecialPredId, SpecialName, _, Arity),
        Name = "builtin_" ++ SpecialName ++ "_" ++ BuiltinTypeName,
        % None of the special preds are in fact functions, so for them,
        % user arity and pred form arity are the same.
        UserArity = user_arity(Arity),
        lookup_builtin_pred_proc_id(ModuleInfo, mercury_private_builtin_module,
            Name, pf_predicate, UserArity, only_mode, PredId, ProcId),
        PredName = qualified(mercury_private_builtin_module, Name)
    ).

get_special_proc_det(ModuleInfo, TypeCtor, SpecialPredId, PredName,
        PredId, ProcId) :-
    ( if
        get_special_proc(ModuleInfo, TypeCtor, SpecialPredId,
            PredNamePrime, PredIdPrime, ProcIdPrime)
    then
        PredName = PredNamePrime,
        PredId = PredIdPrime,
        ProcId = ProcIdPrime
    else
        unexpected($pred, "get_special_proc failed")
    ).

:- func get_ctor_cat_builtin_type_name(type_ctor_category) = maybe(string).

get_ctor_cat_builtin_type_name(CtorCat) = MaybeName :-
    (
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int)),
        MaybeName = yes("int")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint)),
        MaybeName = yes("uint")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int8)),
        MaybeName = yes("int8")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint8)),
        MaybeName = yes("uint8")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int16)),
        MaybeName = yes("int16")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint16)),
        MaybeName = yes("uint16")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int32)),
        MaybeName = yes("int32")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint32)),
        MaybeName = yes("uint32")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_int64)),
        MaybeName = yes("int64")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_int(int_type_uint64)),
        MaybeName = yes("uint64")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_char),
        MaybeName = yes("character")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_float),
        MaybeName = yes("float")
    ;
        CtorCat = ctor_cat_builtin(cat_builtin_string),
        MaybeName = yes("string")
    ;
        CtorCat = ctor_cat_higher_order,
        MaybeName = yes("pred")
    ;
        CtorCat = ctor_cat_tuple,
        MaybeName = yes("tuple")
    ;
        ( CtorCat = ctor_cat_enum(_)
        ; CtorCat = ctor_cat_builtin_dummy
        ; CtorCat = ctor_cat_user(_)
        ; CtorCat = ctor_cat_system(_)
        ),
        MaybeName = no
    ;
        CtorCat = ctor_cat_variable,
        unexpected($pred, "variable type")
    ;
        CtorCat = ctor_cat_void,
        unexpected($pred, "void_type")
    ).

%-----------------------------------------------------------------------------%
:- end_module hlds.special_pred.
%-----------------------------------------------------------------------------%