mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-15 13:55:07 +00:00
3d848cfc50
browser/*.m:
deep_profiler/*.m:
profiler/*.m:
library/backjump.m:
library/injection.m:
library/stm_builtin.m:
library/thread.barrier.m:
Fix spelling errors.
Replace tabs with spaces in a couple of spots.
Delete trailing whitespace.
387 lines
13 KiB
Mathematica
387 lines
13 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1998-2006 The University of Melbourne.
|
|
% This file may only be copied under the terms of the GNU Library General
|
|
% Public License - see the file COPYING.LIB in the Mercury distribution.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% File: dl.m.
|
|
% Purpose: dynamic linking support.
|
|
% Main author: fjh.
|
|
% Stability: medium.
|
|
%
|
|
% This file provides an interface to the C functions dlopen(), dlsym(),
|
|
% and dlclose(). For details about the behaviour of those procedures,
|
|
% see the documentation for those procedures (i.e. `man dlopen').
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module mdb.dl.
|
|
|
|
:- interface.
|
|
|
|
:- import_module mdb.name_mangle.
|
|
:- import_module io.
|
|
|
|
:- type link_mode
|
|
---> lazy % RTLD_LAZY
|
|
; now. % RTLD_NOW
|
|
|
|
:- type scope
|
|
---> local
|
|
; global. % RTLD_GLOBAL or not.
|
|
|
|
:- type handle.
|
|
:- type dl_result(T)
|
|
---> dl_ok(T)
|
|
; dl_error(string).
|
|
|
|
:- type dl_result
|
|
---> dl_ok
|
|
; dl_error(string).
|
|
|
|
% Interface to the C function dlopen().
|
|
%
|
|
:- pred open(string::in, link_mode::in, scope::in, dl_result(handle)::out,
|
|
io::di, io::uo) is det.
|
|
|
|
% Low-level interface to the C function dlsym() -- returns a c_pointer.
|
|
%
|
|
:- pred sym(handle::in, string::in, dl_result(c_pointer)::out,
|
|
io::di, io::uo) is det.
|
|
|
|
% High-level interface to the C function dlsym().
|
|
%
|
|
% This version returns a higher-order predicate or function term.
|
|
% The user must use an inst cast (implemented using pragma foreign_proc)
|
|
% to cast this term to the appropriate higher-order inst before calling it;
|
|
% see dl_test.m for an example of this.
|
|
%
|
|
% The type `T' below must be a higher-order type whose arity and
|
|
% argument types exactly match that of the specified procedure.
|
|
% The implementation may check this at runtime, but is not required
|
|
% to do so. (The current implementation checks that the type is a
|
|
% higher-order type with the appropriate arity, but it does not
|
|
% check the argument types.)
|
|
%
|
|
% WARNING: for the `--high-level-code' back-end (the `hl*' grades),
|
|
% calling mercury_sym for procedures with argument types `float'
|
|
% or `char' is not supported.
|
|
%
|
|
:- pred mercury_sym(handle::in, mercury_proc::in, dl_result(T)::out,
|
|
io::di, io::uo) is det.
|
|
|
|
% Interface to the C function dlclose().
|
|
%
|
|
% WARNING: dlclose() is form of manual memory management.
|
|
% You need to make sure that no remaining references to code or
|
|
% static data in the dynamically linked module before you call close,
|
|
% because if you do reference code or static data from the dynamically
|
|
% linked module after close has been called, then the behaviour is
|
|
% undefined (and probably harmful!).
|
|
%
|
|
% This can be difficult to ensure. You need to make sure that you
|
|
% don't keep any references to the higher-order terms return by sym.
|
|
% Furthermore you need to make sure that you don't keep any references
|
|
% to terms constructed by procedures in the dynamically loaded module,
|
|
% since such terms may contain references to static data in the
|
|
% dynamically loaded module. You must also ensure that you don't keep
|
|
% any references to types or instances defined in the dynamically loaded
|
|
% module, as might be the case if you're using existentially quantified
|
|
% data types, since they too can contain references to static data.
|
|
%
|
|
% (Note that using builtin.copy/2, to make copies rather than
|
|
% keeping references, is *not* guaranteed to work in all cases.)
|
|
%
|
|
:- pred close(handle::in, dl_result::out, io::di, io::uo) is det.
|
|
|
|
:- implementation.
|
|
|
|
:- import_module int.
|
|
:- import_module list.
|
|
:- import_module require.
|
|
:- import_module string.
|
|
:- import_module type_desc.
|
|
|
|
:- pragma foreign_decl("C", "
|
|
#include <stdio.h>
|
|
#include ""mercury_conf.h""
|
|
#include ""mercury_string.h"" /* for MR_make_aligned_string_copy() */
|
|
#include ""mercury_ho_call.h""
|
|
#ifdef MR_HAVE_DLFCN_H
|
|
#include <dlfcn.h>
|
|
#endif
|
|
").
|
|
|
|
:- type handle
|
|
---> handle(c_pointer).
|
|
|
|
:- pred is_null(c_pointer::in) is semidet.
|
|
:- pragma foreign_proc("C",
|
|
is_null(Pointer::in),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
SUCCESS_INDICATOR = ((void *) Pointer == NULL)
|
|
").
|
|
|
|
is_null(_) :-
|
|
private_builtin.sorry("is_null").
|
|
|
|
open(FileName, Mode, Scope, Result, !IO) :-
|
|
dlopen(FileName, Mode, Scope, Pointer, !IO),
|
|
( if is_null(Pointer) then
|
|
dlerror(ErrorMsg, !IO),
|
|
Result = dl_error(ErrorMsg)
|
|
else
|
|
Result = dl_ok(handle(Pointer))
|
|
).
|
|
|
|
:- pred dlopen(string::in, link_mode::in, scope::in, c_pointer::out,
|
|
io::di, io::uo) is det.
|
|
|
|
:- pragma foreign_proc("C",
|
|
dlopen(FileName::in, Mode::in, Scope::in, Result::out, _IO0::di, _IO::uo),
|
|
% Note that dlopen() may call startup code (e.g. constructors for global
|
|
% variables in C++) which may end up calling Mercury, so it is NOT safe
|
|
% to assert that it `will_not_call_mercury'.
|
|
[may_call_mercury, promise_pure, tabled_for_io],
|
|
"{
|
|
#if defined(MR_HAVE_DLFCN_H) && defined(MR_HAVE_DLOPEN) \
|
|
&& defined(RTLD_NOW) && defined(RTLD_LAZY)
|
|
int mode = (Mode ? RTLD_NOW : RTLD_LAZY);
|
|
/* not all systems have RTLD_GLOBAL */
|
|
#ifdef RTLD_GLOBAL
|
|
if (Scope) mode |= RTLD_GLOBAL;
|
|
#endif
|
|
Result = (MR_Word) dlopen(FileName, mode);
|
|
#else
|
|
Result = (MR_Word) NULL;
|
|
#endif
|
|
}").
|
|
|
|
dlopen(_, _, _, _, !IO) :-
|
|
private_builtin.sorry("dlopen").
|
|
|
|
mercury_sym(Handle, MercuryProc0, Result, !IO) :-
|
|
check_proc_spec_matches_result_type(Result, _, MercuryProc0, MercuryProc1),
|
|
check_type_is_supported(Result, _, MercuryProc1, MercuryProc),
|
|
MangledName = proc_name_mangle(MercuryProc),
|
|
sym(Handle, MangledName, Result0, !IO),
|
|
(
|
|
Result0 = dl_error(Msg),
|
|
Result = dl_error(Msg)
|
|
;
|
|
Result0 = dl_ok(Address),
|
|
private_builtin.unsafe_type_cast(make_closure(Address), Closure),
|
|
Result = dl_ok(Closure)
|
|
).
|
|
|
|
:- pragma foreign_decl("C",
|
|
"
|
|
#include ""mercury_ho_call.h""
|
|
").
|
|
|
|
% Convert the given procedure address to a closure.
|
|
%
|
|
:- func make_closure(c_pointer) = c_pointer.
|
|
|
|
:- pragma foreign_proc("C",
|
|
make_closure(ProcAddr::in) = (Closure::out),
|
|
[will_not_call_mercury, promise_pure],
|
|
"{
|
|
MR_save_transient_hp();
|
|
Closure = (MR_Word) MR_make_closure((MR_Code *) ProcAddr);
|
|
MR_restore_transient_hp();
|
|
}").
|
|
|
|
make_closure(_) = _ :-
|
|
private_builtin.sorry("make_closure").
|
|
|
|
% Check that the result type matches the information in the
|
|
% procedure specification.
|
|
%
|
|
:- pred check_proc_spec_matches_result_type(dl_result(T)::unused, T::unused,
|
|
mercury_proc::in, mercury_proc::out) is det.
|
|
|
|
check_proc_spec_matches_result_type(_Result, Value, Proc0, Proc) :-
|
|
Proc0 = mercury_proc(IsPredOrFunc, _Module, _Name, ProcArity, _Mode),
|
|
ResultType = type_of(Value),
|
|
type_ctor_name_and_arity(type_ctor(ResultType),
|
|
TypeModule, TypeName, TypeArity),
|
|
( if TypeName = "func" then
|
|
TypeProcArity = TypeArity - 1
|
|
else
|
|
TypeProcArity = TypeArity
|
|
),
|
|
( if
|
|
( TypeModule \= "builtin"
|
|
; TypeName \= "pred", TypeName \= "func"
|
|
)
|
|
then
|
|
unexpected($module, $pred,
|
|
"result type (`" ++ type_name(ResultType) ++ "')" ++
|
|
" is not a higher-order type")
|
|
else if
|
|
IsPredOrFunc = predicate, TypeName \= "pred"
|
|
then
|
|
unexpected($module, $pred,
|
|
"predicate/function mismatch: " ++
|
|
"argument is a predicate, result type is a function")
|
|
else if
|
|
IsPredOrFunc = function, TypeName \= "func"
|
|
then
|
|
unexpected($module, $pred,
|
|
"predicate/function mismatch: " ++
|
|
"argument is a function, result type is a predicate")
|
|
else if
|
|
ProcArity \= TypeProcArity
|
|
then
|
|
string.int_to_string(ProcArity, ProcArityString),
|
|
string.int_to_string(TypeProcArity, TypeArityString),
|
|
string.append_list(["arity mismatch: ",
|
|
"argument has ", ProcArityString, " argument(s), ",
|
|
"result type has ", TypeArityString, " arguments(s)"], Msg),
|
|
unexpected($module, $pred, Msg)
|
|
else
|
|
Proc = Proc0
|
|
).
|
|
|
|
% Check that the given higher-order type is supported.
|
|
%
|
|
% For the MLDS back-end, we normally need wrapper functions for closures;
|
|
% the wrapper functions convert from type MR_Box to the appropriate
|
|
% argument type, and then call the function with the unboxed argument
|
|
% types. Generating those on-the-fly here would be tricky! Instead,
|
|
% we only try to handle the cases where we can use a single generic
|
|
% wrapper, i.e. arguments with types other than `char' or `float'.
|
|
% All other argument types are word-sized, and will hopefully be passed
|
|
% in the same way by the C compiler.
|
|
%
|
|
% This procedure checks, for the MLDS back-end, that you are not using it
|
|
% on a procedure with argument types `char' or `float', and that the
|
|
% procedure doesn't have more arguments than the generic wrapper
|
|
% can handle.
|
|
%
|
|
% XXX This doesn't catch the case of no_tag types that end up
|
|
% being equivalent to `float' or `char'.
|
|
%
|
|
:- pred check_type_is_supported(dl_result(T)::unused, T::unused,
|
|
mercury_proc::in, mercury_proc::out) is det.
|
|
|
|
check_type_is_supported(_Result, Value, Proc0, Proc) :-
|
|
( if
|
|
high_level_code,
|
|
list.member(ArgType, type_args(type_of(Value))),
|
|
% The following line might be more efficient,
|
|
% but is not yet supported by the MLDS back-end
|
|
% ArgType = type_of(_ `with_type` float))
|
|
ArgTypeCtor = type_ctor(ArgType),
|
|
( type_ctor_name(ArgTypeCtor) = "float"
|
|
; type_ctor_name(ArgTypeCtor) = "char"
|
|
),
|
|
type_ctor_module_name(ArgTypeCtor) = "builtin"
|
|
then
|
|
sorry($module, $pred,
|
|
"procedure with argument type `float' or `char'")
|
|
else if
|
|
high_level_code,
|
|
% The generic wrapper only works for procedures with up to 20
|
|
% arguments. For nondet procedures, two of the arguments get used up
|
|
% for the continuation function and the environment pointer, so we can
|
|
% only support 18 other arguments.
|
|
type_ctor_arity(type_ctor(type_of(Value))) > 18
|
|
then
|
|
sorry($module, $pred, "procedure with more than 18 arguments")
|
|
else
|
|
Proc = Proc0
|
|
).
|
|
|
|
sym(handle(Handle), Name, Result, !IO) :-
|
|
dlsym(Handle, Name, Pointer, !IO),
|
|
( if is_null(Pointer) then
|
|
dlerror(ErrorMsg, !IO),
|
|
Result = dl_error(ErrorMsg)
|
|
else
|
|
Result = dl_ok(Pointer)
|
|
).
|
|
|
|
:- pred dlsym(c_pointer::in, string::in, c_pointer::out,
|
|
io::di, io::uo) is det.
|
|
|
|
:- pragma foreign_proc("C",
|
|
dlsym(Handle::in, Name::in, Pointer::out, _IO0::di, _IO::uo),
|
|
[will_not_call_mercury, promise_pure, tabled_for_io],
|
|
"{
|
|
#if defined(MR_HAVE_DLFCN_H) && defined(MR_HAVE_DLSYM)
|
|
Pointer = (MR_Word) dlsym((void *) Handle, Name);
|
|
#else
|
|
Pointer = (MR_Word) NULL;
|
|
#endif
|
|
}").
|
|
|
|
dlsym(_, _, _, !IO) :-
|
|
private_builtin.sorry("dlsym").
|
|
|
|
:- pred dlerror(string::out, io::di, io::uo) is det.
|
|
|
|
:- pragma foreign_proc("C",
|
|
dlerror(ErrorMsg::out, _IO0::di, _IO::uo),
|
|
[will_not_call_mercury, promise_pure, tabled_for_io],
|
|
"{
|
|
const char *msg;
|
|
|
|
#if defined(MR_HAVE_DLFCN_H) && defined(MR_HAVE_DLERROR)
|
|
msg = dlerror();
|
|
if (msg == NULL) msg = """";
|
|
#else
|
|
MR_make_aligned_string(msg, ""sorry, not implemented: ""
|
|
""dynamic linking not supported on this platform"");
|
|
#endif
|
|
|
|
MR_make_aligned_string_copy(ErrorMsg, msg);
|
|
}").
|
|
|
|
dlerror(_, !IO) :-
|
|
private_builtin.sorry("dlerror").
|
|
|
|
close(handle(Handle), Result, !IO) :-
|
|
dlclose(Handle, !IO),
|
|
dlerror(ErrorMsg, !IO),
|
|
Result = (if ErrorMsg = "" then dl_ok else dl_error(ErrorMsg)).
|
|
|
|
:- pred dlclose(c_pointer::in, io::di, io::uo) is det.
|
|
|
|
% Note that dlclose() may call finalization code (e.g. destructors
|
|
% for global variables in C++) which may end up calling Mercury,
|
|
% so it's not safe to declare this as `will_not_call_mercury'.
|
|
:- pragma foreign_proc("C",
|
|
dlclose(Handle::in, _IO0::di, _IO::uo),
|
|
[may_call_mercury, promise_pure, tabled_for_io],
|
|
"
|
|
#if defined(MR_HAVE_DLFCN_H) && defined(MR_HAVE_DLCLOSE)
|
|
dlclose((void *) Handle);
|
|
#endif
|
|
").
|
|
dlclose(_, !IO) :-
|
|
private_builtin.sorry("dlclose").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred high_level_code is semidet.
|
|
:- pragma foreign_proc("C",
|
|
high_level_code,
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
#ifdef MR_HIGHLEVEL_CODE
|
|
SUCCESS_INDICATOR = MR_TRUE;
|
|
#else
|
|
SUCCESS_INDICATOR = MR_FALSE;
|
|
#endif
|
|
").
|
|
|
|
high_level_code :-
|
|
private_builtin.sorry("high_level_code").
|
|
|
|
%-----------------------------------------------------------------------------%
|