mercury/compiler/foreign.m

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2000-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: foreign.m.
% Main authors: trd, dgj.
%
% This module defines predicates for interfacing with foreign languages.
% In particular, this module supports interfacing with languages
% other than the target of compilation.
%
% Parts of this code were originally written by dgj, and have since been moved
% here.
%
%-----------------------------------------------------------------------------%

:- module backend_libs.foreign.
:- interface.

:- import_module hlds.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_module.
:- import_module libs.
:- import_module libs.globals.
:- 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 parse_tree.prog_data_foreign.
:- import_module parse_tree.prog_foreign.

:- import_module bool.
:- import_module list.
:- import_module maybe.

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

:- type foreign_type_and_assertions
    --->    foreign_type_and_assertions(sym_name, foreign_type_assertions).
            % A type defined by a pragma foreign_type, and the assertions
            % on that foreign_type.

    % Given an arbitrary mercury type, get the exported_type representation
    % of that type on the current backend.
    %
:- func is_this_a_foreign_type(module_info, mer_type)
    = maybe(foreign_type_and_assertions).

    % Given a type, determine the string which corresponds to that type
    % in the specified foreign language, for use with foreign language
    % interfacing (`pragma export' or `pragma foreign_proc').
    %
:- func exported_type_to_string(module_info, foreign_language, mer_type)
    = string.
:- func exported_type_to_c_string(module_info, mer_type) = string.

:- func maybe_foreign_type_to_string(foreign_language, mer_type,
    maybe(foreign_type_and_assertions)) = string.
:- func maybe_foreign_type_to_c_string(mer_type,
    maybe(foreign_type_and_assertions)) = string.
:- func foreign_type_to_c_string(foreign_type_and_assertions) = string.
:- func maybe_foreign_type_to_csharp_string(mer_type,
    maybe(foreign_type_and_assertions)) = string.
:- func maybe_foreign_type_to_java_string(mer_type,
    maybe(foreign_type_and_assertions)) = string.

:- func exported_builtin_type_to_c_string(builtin_type) = string.
:- func exported_builtin_type_to_csharp_string(builtin_type) = string.
:- func exported_builtin_type_to_java_string(builtin_type) = string.

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

    % Find the current target backend from the module_info, and given
    % a foreign_type_body, return the name of the foreign language type
    % the identity of any user-defined unify/compare predicates, and the
    % assertions applicable to that backend.
    %
:- pred foreign_type_body_to_exported_type(module_info::in,
    foreign_type_body::in, sym_name::out, maybe_canonical::out,
    foreign_type_assertions::out) is det.

    % Does the foreign_type_body contain a definition usable
    % when compiling to the given target.
    %
:- pred have_foreign_type_for_backend(compilation_target::in,
    foreign_type_body::in, bool::out) is det.

    % Does the implementation of the given foreign type body on
    % the current backend use a user-defined comparison predicate.
    %
:- pred foreign_type_body_has_user_defined_eq_comp_pred(module_info::in,
    foreign_type_body::in, noncanonical::out) is semidet.

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

    % Filter the decls for the given foreign language.
    % The first return value is the list of matches, the second is
    % the list of mis-matches.
    %
:- pred filter_decls(foreign_language::in, list(foreign_decl_code)::in,
    list(foreign_decl_code)::out, list(foreign_decl_code)::out) is det.

    % Filter the bodys for the given foreign language.
    % The first return value is the list of matches, the second is
    % the list of mis-matches.
    %
:- pred filter_bodys(foreign_language::in, list(foreign_body_code)::in,
    list(foreign_body_code)::out, list(foreign_body_code)::out) is det.

    % Filter the foreign exports for the given foreign language.
    % The first return value is the list of matches, the second is
    % the list of mis-matches.
    %
:- pred filter_exports(foreign_language::in,
    list(pragma_exported_proc)::in,
    list(pragma_exported_proc)::out, list(pragma_exported_proc)::out)
    is det.

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

    % Given some foreign code, generate some suitable proxy code for
    % calling the code via one of the given languages.
    % This might mean, for example, generating a call to a
    % forwarding function in C.
    % The foreign language argument specifies which language is the
    % target language, the other inputs are the name, types, input
    % variables and so on for a piece of pragma foreign code.
    % The outputs are the new attributes and implementation for this
    % code.
    % XXX This implementation is currently incomplete, so in future
    % this interface may change.
    %
:- pred extrude_pragma_implementation(list(foreign_language)::in,
    list(pragma_var)::in, sym_name::in, pred_or_func::in, prog_context::in,
    module_info::in, module_info::out,
    pragma_foreign_proc_attributes::in, pragma_foreign_proc_attributes::out,
    pragma_foreign_proc_impl::in, pragma_foreign_proc_impl::out) is det.

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

    % The name of the #define which can be used to guard declarations with
    % to prevent entities being declared twice.
    %
:- func decl_guard(sym_name) = string.

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

:- implementation.

:- import_module parse_tree.prog_type.

:- import_module require.
:- import_module string.
:- import_module term.

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

is_this_a_foreign_type(ModuleInfo, Type) = MaybeForeignTypeAssertions :-
    module_info_get_type_table(ModuleInfo, TypeTable),
    ( if
        type_to_ctor(Type, TypeCtor),
        search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn)
    then
        hlds_data.get_type_defn_body(TypeDefn, TypeBody),
        (
            TypeBody = hlds_foreign_type(ForeignTypeBody),
            foreign_type_body_to_exported_type(ModuleInfo, ForeignTypeBody,
                ForeignTypeName, _, Assertions),
            MaybeForeignTypeAssertions =
                yes(foreign_type_and_assertions(ForeignTypeName, Assertions))
        ;
            ( TypeBody = hlds_du_type(_, _, _, _)
            ; TypeBody = hlds_eqv_type(_)
            ; TypeBody = hlds_solver_type(_)
            ; TypeBody = hlds_abstract_type(_)
            ),
            MaybeForeignTypeAssertions = no
        )
    else
        MaybeForeignTypeAssertions = no
    ).

exported_type_to_string(ModuleInfo, Lang, Type) = String :-
    MaybeForeignType = is_this_a_foreign_type(ModuleInfo, Type),
    String = maybe_foreign_type_to_string(Lang, Type, MaybeForeignType).

exported_type_to_c_string(ModuleInfo, Type) = String :-
    MaybeForeignType = is_this_a_foreign_type(ModuleInfo, Type),
    String = maybe_foreign_type_to_c_string(Type, MaybeForeignType).

maybe_foreign_type_to_string(Lang, Type, MaybeForeignType) = String :-
    (
        Lang = lang_c,
        String = maybe_foreign_type_to_c_string(Type, MaybeForeignType)
    ;
        Lang = lang_csharp,
        String = maybe_foreign_type_to_csharp_string(Type, MaybeForeignType)
    ;
        Lang = lang_java,
        String = maybe_foreign_type_to_java_string(Type, MaybeForeignType)
    ).

maybe_foreign_type_to_c_string(Type, MaybeForeignType) = String :-
    (
        MaybeForeignType = yes(ForeignTypeAndAssertions),
        String = foreign_type_to_c_string(ForeignTypeAndAssertions)
    ;
        MaybeForeignType = no,
        % With --high-level-code, the value we return here should agree
        % with what happens is generated (indirectly) through
        % mercury_type_to_mlds_type.
        %
        % XXX I don't think this is yet true in all cases. -zs
        %
        % It is possible that in some cases, the right type name may depend
        % on whether --high-level-code is set.
        (
            Type = builtin_type(BuiltinType),
            String = exported_builtin_type_to_c_string(BuiltinType)
        ;
            Type = tuple_type(_, _),
            String = "MR_Tuple"
        ;
            % XXX Is MR_Word the right thing for any of these kinds of
            % types for high level code, with or without high level data?
            ( Type = defined_type(_, _, _)
            ; Type = higher_order_type(_, _, _, _, _)
            ; Type = apply_n_type(_, _, _)
            ),
            String = "MR_Word"
        ;
            Type = type_variable(_, _),
            String = "MR_Word"
        ;
            Type = kinded_type(_, _),
            unexpected($pred, "kinded type")
        )
    ).

foreign_type_to_c_string(ForeignTypeAndAssertions) = String :-
    ForeignTypeAndAssertions = foreign_type_and_assertions(ForeignType, _),
    (
        ForeignType = unqualified(String)
    ;
        ForeignType = qualified(_, _),
        unexpected($pred, "qualified C type")
    ).

maybe_foreign_type_to_csharp_string(Type, MaybeForeignType) = String :-
    (
        MaybeForeignType = yes(foreign_type_and_assertions(ForeignType, _)),
        String = sym_name_to_string(ForeignType)
    ;
        MaybeForeignType = no,
        (
            Type = builtin_type(BuiltinType),
            String = exported_builtin_type_to_csharp_string(BuiltinType)
        ;
            ( Type = tuple_type(_, _)
            ; Type = defined_type(_, _, _)
            ; Type = higher_order_type(_, _, _, _, _)
            ; Type = apply_n_type(_, _, _)
            ; Type = type_variable(_, _)
            ; Type = kinded_type(_, _)
            ),
            % This is here so we can share some code between C/C#/Java
            % backends. This is not the correct type to use in general.
            String = "object"
        )
    ).

maybe_foreign_type_to_java_string(Type, MaybeForeignType) = String :-
    (
        MaybeForeignType = yes(foreign_type_and_assertions(ForeignType, _)),
        String = sym_name_to_string(ForeignType)
    ;
        MaybeForeignType = no,
        (
            Type = builtin_type(BuiltinType),
            String = exported_builtin_type_to_java_string(BuiltinType)
        ;
            ( Type = tuple_type(_, _)
            ; Type = defined_type(_, _, _)
            ; Type = higher_order_type(_, _, _, _, _)
            ; Type = apply_n_type(_, _, _)
            ; Type = type_variable(_, _)
            ; Type = kinded_type(_, _)
            ),
            % This is here so we can share some code between C/C#/Java
            % backends. This is not the correct type to use in general.
            String = "java.lang.Object"
        )
    ).

exported_builtin_type_to_c_string(BuiltinType) = CTypeName :-
    (
        BuiltinType = builtin_type_int(IntType),
        (
            IntType = int_type_int,
            CTypeName = "MR_Integer"
        ;
            IntType = int_type_uint,
            CTypeName = "MR_Unsigned"
        ;
            IntType = int_type_int8,
            CTypeName = "int8_t"
        ;
            IntType = int_type_uint8,
            CTypeName = "uint8_t"
        ;
            IntType = int_type_int16,
            CTypeName = "int16_t"
        ;
            IntType = int_type_uint16,
            CTypeName = "uint16_t"
        ;
            IntType = int_type_int32,
            CTypeName = "int32_t"
        ;
            IntType = int_type_uint32,
            CTypeName = "uint32_t"
        ;
            IntType = int_type_int64,
            CTypeName = "int64_t"
        ;
            IntType = int_type_uint64,
            CTypeName = "uint64_t"
        )
    ;
        BuiltinType = builtin_type_float,
        CTypeName = "MR_Float"
    ;
        BuiltinType = builtin_type_string,
        CTypeName = "MR_String"
    ;
        BuiltinType = builtin_type_char,
        CTypeName = "MR_Char"
    ).

exported_builtin_type_to_csharp_string(BuiltinType) = CsharpTypeName :-
    (
        BuiltinType = builtin_type_int(IntType),
        (
            IntType = int_type_int,
            CsharpTypeName = "int"
        ;
            IntType = int_type_uint,
            CsharpTypeName = "uint"
        ;
            IntType = int_type_int8,
            CsharpTypeName = "sbyte"
        ;
            IntType = int_type_uint8,
            CsharpTypeName = "byte"
        ;
            IntType = int_type_int16,
            CsharpTypeName = "short"
        ;
            IntType = int_type_uint16,
            CsharpTypeName = "ushort"
        ;
            IntType = int_type_int32,
            CsharpTypeName = "int"
        ;
            IntType = int_type_uint32,
            CsharpTypeName = "uint"
        ;
            IntType = int_type_int64,
            CsharpTypeName = "long"
        ;
            IntType = int_type_uint64,
            CsharpTypeName = "ulong"
        )
    ;
        BuiltinType = builtin_type_float,
        CsharpTypeName = "double"
    ;
        BuiltinType = builtin_type_string,
        CsharpTypeName = "string"
    ;
        BuiltinType = builtin_type_char,
        CsharpTypeName = "char"
    ).

exported_builtin_type_to_java_string(BuiltinType) = JavaTypeName :-
    (
        BuiltinType = builtin_type_int(IntType),
        (
            IntType = int_type_int,
            JavaTypeName = "int"
        ;
            IntType = int_type_uint,
            JavaTypeName = "int"
        ;
            IntType= int_type_int8,
            JavaTypeName = "byte"
        ;
            IntType = int_type_uint8,
            JavaTypeName = "byte"
        ;
            IntType = int_type_int16,
            JavaTypeName = "short"
        ;
            IntType = int_type_uint16,
            JavaTypeName = "short"
        ;
            IntType = int_type_int32,
            JavaTypeName = "int"
        ;
            IntType = int_type_uint32,
            JavaTypeName = "int"
        ;
            IntType = int_type_int64,
            JavaTypeName = "long"
        ;
            IntType = int_type_uint64,
            JavaTypeName = "long"
        )
    ;
        BuiltinType = builtin_type_float,
        JavaTypeName = "double"
    ;
        BuiltinType = builtin_type_string,
        JavaTypeName = "java.lang.String"
    ;
        BuiltinType = builtin_type_char,
        JavaTypeName = "char"
    ).

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

foreign_type_body_to_exported_type(ModuleInfo, ForeignTypeBody, Name,
        MaybeUserEqComp, Assertions) :-
    % The body of this function is very similar to the function
    % foreign_type_to_mlds_type in mlds.m.
    % Any changes here may require changes there as well.

    ForeignTypeBody = foreign_type_body(MaybeC, MaybeJava, MaybeCSharp),
    module_info_get_globals(ModuleInfo, Globals),
    globals.get_target(Globals, Target),
    (
        Target = target_c,
        (
            MaybeC = yes(Data),
            Data = type_details_foreign(c_type(NameStr), MaybeUserEqComp,
                Assertions),
            Name = unqualified(NameStr)
        ;
            MaybeC = no,
            unexpected($pred, "no C type")
        )
    ;
        Target = target_csharp,
        (
            MaybeCSharp = yes(Data),
            Data = type_details_foreign(csharp_type(NameStr),
                MaybeUserEqComp, Assertions),
            Name = unqualified(NameStr)
        ;
            MaybeCSharp = no,
            unexpected($pred, "no C# type")
        )
    ;
        Target = target_java,
        (
            MaybeJava = yes(Data),
            Data = type_details_foreign(java_type(NameStr), MaybeUserEqComp,
                Assertions),
            Name = unqualified(NameStr)
        ;
            MaybeJava = no,
            unexpected($pred, "no Java type")
        )
    ).

have_foreign_type_for_backend(Target, ForeignTypeBody, Have) :-
    (
        Target = target_c,
        Have = ( if ForeignTypeBody ^ c = yes(_) then yes else no )
    ;
        Target = target_java,
        Have = ( if ForeignTypeBody ^ java = yes(_) then yes else no )
    ;
        Target = target_csharp,
        Have = ( if ForeignTypeBody ^ csharp = yes(_) then yes else no )
    ).

foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo, Body,
        NonCanonical) :-
    foreign_type_body_to_exported_type(ModuleInfo, Body, _,
        MaybeCanonical, _),
    MaybeCanonical = noncanon(NonCanonical).

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

filter_decls(WantedLang, Decls0, LangDecls, NotLangDecls) :-
    IsWanted = (pred(foreign_decl_code(Lang, _, _, _)::in) is semidet :-
        WantedLang = Lang),
    list.filter(IsWanted, Decls0, LangDecls, NotLangDecls).

filter_bodys(WantedLang, Bodys0, LangBodys, NotLangBodys) :-
    IsWanted = (pred(foreign_body_code(Lang, _, _)::in) is semidet :-
        WantedLang = Lang),
    list.filter(IsWanted, Bodys0, LangBodys, NotLangBodys).

filter_exports(WantedLang, Exports0, LangExports, NotLangExports) :-
    IsWanted = (pred(pragma_exported_proc(Lang, _, _, _, _)::in) is semidet :-
        WantedLang = Lang),
    list.filter(IsWanted, Exports0, LangExports, NotLangExports).

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

extrude_pragma_implementation([], _PragmaVars, _PredName, _PredOrFunc,
        _Context, !ModuleInfo, !NewAttributes, !Impl) :-
    unexpected($pred, "no suitable target languages available").
extrude_pragma_implementation([TargetLang | TargetLangs], _PragmaVars,
        _PredName, _PredOrFunc, _Context, !ModuleInfo, !Attributes, !Impl) :-
    % We just use the first target language for now, it might be nice
    % to try a few others if the backend supports multiple ones.
    ForeignLanguage = get_foreign_language(!.Attributes),

    % If the foreign language is available as a target language,
    % we don't need to do anything.
    ( if list.member(ForeignLanguage, [TargetLang | TargetLangs]) then
        true
    else
        set_foreign_language(TargetLang, !Attributes),
        extrude_pragma_implementation_2(TargetLang, ForeignLanguage,
            !ModuleInfo, !Impl)
    ).

:- pred extrude_pragma_implementation_2(
    foreign_language::in, foreign_language::in,
    module_info::in, module_info::out,
    pragma_foreign_proc_impl::in, pragma_foreign_proc_impl::out) is det.

extrude_pragma_implementation_2(TargetLanguage, ForeignLanguage,
        !ModuleInfo, !Impl) :-
    % This isn't finished yet, and we probably won't implement it for C
    % calling MC++.  For C calling normal C++ we would generate a proxy
    % function in C++ (implemented in a piece of C++ body code) with C
    % linkage, and import that function.  The backend would spit the C++
    % body code into a separate file.
    (
        TargetLanguage = lang_c,
        (
            ForeignLanguage = lang_c
        ;
            ( ForeignLanguage = lang_csharp
            ; ForeignLanguage = lang_java
            ),
            unimplemented_combination(TargetLanguage, ForeignLanguage)
        )
    ;
        TargetLanguage = lang_csharp,
        (
            ForeignLanguage = lang_csharp
        ;
            ( ForeignLanguage = lang_c
            ; ForeignLanguage = lang_java
            ),
            unimplemented_combination(TargetLanguage, ForeignLanguage)
        )
    ;
        TargetLanguage = lang_java,
        (
            ForeignLanguage = lang_java
        ;
            ( ForeignLanguage = lang_c
            ; ForeignLanguage = lang_csharp
            ),
            unimplemented_combination(TargetLanguage, ForeignLanguage)
        )
    ).

:- pred unimplemented_combination(foreign_language::in, foreign_language::in)
    is erroneous.

unimplemented_combination(Lang1, Lang2) :-
    sorry($pred, "unimplemented: calling "
        ++ foreign_language_string(Lang2) ++ " foreign code from "
        ++ foreign_language_string(Lang1)).

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

decl_guard(ModuleName) = UppercaseModuleName ++ "_DECL_GUARD" :-
    MangledModuleName = sym_name_mangle(ModuleName),
    string.to_upper(MangledModuleName, UppercaseModuleName).

%-----------------------------------------------------------------------------%
:- end_module backend_libs.foreign.
%-----------------------------------------------------------------------------%