for review: extras/dynamic_linking
Fergus Henderson
fjh at cs.mu.OZ.AU
Sat Dec 5 18:08:32 AEDT 1998
I started writing an email explaining how to implement
dynamic linking, but in the end it seemed that the best
way of explaining it was to just go ahead and do it.
So, could someone please review this?
--------------------
Estimated hours taken: 5
extras/dynamic_linking/dl.m:
New module, containing support for dynamic linking
(i.e. a binding to dlopen(), dlsym(), and dlclose()).
extras/dynamic_linking/name_mangle.m:
New module, containing a representation for Mercury procedure
specifiers and a function for mangling them into symbol names.
extras/dynamic_linking/dl_test.m:
extras/dynamic_linking/dl_test.exp:
extras/dynamic_linking/hello.m:
A test case (and sample program) for the use of dynamic linking.
extras/dynamic_linking/README:
A brief README file describing the files in this directory.
NEWS:
Mention the new dynamic linking support.
compiler/llds_out.m:
Add some comments warning about code duplication
between the code here and that in extras/dynamic_linking/name_mangle.m
(and also profiler/demangle.m and util/mdemangle.c).
Index: NEWS
===================================================================
RCS file: /home/mercury1/repository/mercury/NEWS,v
retrieving revision 1.130
diff -u -r1.130 NEWS
--- NEWS 1998/12/03 04:59:31 1.130
+++ NEWS 1998/12/05 06:27:24
@@ -3,3 +3,10 @@
* We've added a new predicate to the Mercury standard library:
bag__count_value/3.
+
+* The extras distribution now includes support for dynamic linking.
+
+ The interface is a based on the C functions dlopen(), dlsym(), and co.,
+ which are supported by most modern Unix systems.
+ See the files in extras/dynamic_linking for details.
+
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.95
diff -u -r1.95 llds_out.m
--- llds_out.m 1998/11/05 03:52:20 1.95
+++ llds_out.m 1998/12/05 06:40:14
@@ -2806,6 +2806,11 @@
string__append("_i", NumStr, NumSuffix),
string__append(ProcLabelStr, NumSuffix, LabelStr).
+%
+% Warning: any changes to the name mangling algorithm here will also
+% require changes to extras/dynamic_linking/name_mangle.m,
+% profiler/demangle.m and util/mdemangle.c.
+%
llds_out__get_proc_label(proc(DefiningModule, PredOrFunc, PredModule,
PredName, Arity, ModeNum0), AddPrefix, ProcLabelString) :-
get_label_name(DefiningModule, PredOrFunc, PredModule,
@@ -2863,6 +2868,11 @@
bool, string).
:- mode get_label_name(in, in, in, in, in, in, out) is det.
+%
+% Warning: any changes to the name mangling algorithm here will also
+% require changes to extras/dynamic_linking/name_mangle.m,
+% profiler/demangle.m and util/mdemangle.c.
+%
get_label_name(DefiningModule, PredOrFunc, DeclaringModule,
Name0, Arity, AddPrefix, LabelName) :-
llds_out__sym_name_mangle(DeclaringModule, DeclaringModuleName),
@@ -3494,6 +3504,12 @@
string__append(Tmp, ")", Description).
%-----------------------------------------------------------------------------%
+
+%
+% Warning: any changes to the name mangling algorithm here will also
+% require changes to extras/dynamic_linking/name_mangle.m,
+% profiler/demangle.m and util/mdemangle.c.
+%
llds_out__sym_name_mangle(unqualified(Name), MangledName) :-
llds_out__name_mangle(Name, MangledName).
cvs diff -N extras/dynamic_linking/README extras/dynamic_linking/dl.m extras/dynamic_linking/dl_test.exp extras/dynamic_linking/dl_test.m extras/dynamic_linking/hello.m extras/dynamic_linking/name_mangle.m
Index: extras/dynamic_linking/README
===================================================================
RCS file: README
diff -N README
--- /dev/null Sat Dec 5 18:05:01 1998
+++ README Sat Dec 5 18:01:55 1998
@@ -0,0 +1,16 @@
+This directory contains the following files:
+
+dl.m:
+ A module containing support for dynamic linking
+ (i.e. a binding to the C functions dlopen(), dlsym(), and dlclose()).
+
+name_mangle.m:
+ A module containing a representation for Mercury procedure
+ specifiers and a function for mangling them into symbol names
+ suitable for passing to dlsym().
+
+dl_test.m:
+hello.m:
+dl_test.exp:
+ A sample program (and test case) for the use of dynamic linking.
+
Index: extras/dynamic_linking/dl.m
===================================================================
RCS file: dl.m
diff -N dl.m
--- /dev/null Sat Dec 5 18:05:01 1998
+++ dl.m Sat Dec 5 17:10:17 1998
@@ -0,0 +1,198 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1998 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 dl.
+:- interface.
+:- import_module io.
+:- import_module name_mangle.
+
+:- type (mode) ---> lazy ; now. % RTLD_LAZY or RTLD_NOW
+:- type scope ---> local ; global. % RTLD_GLOBAL or not.
+:- type handle.
+:- type result(T) ---> ok(T) ; error(string).
+:- type result ---> ok ; error(string).
+
+% interface to the C function dlopen()
+:- pred dl__open(string::in, (mode)::in, scope::in, dl__result(handle)::out,
+ io__state::di, io__state::uo) is det.
+
+% low-level interface to the C function dlsym() -- returns a c_pointer.
+:- pred dl__sym(handle::in, string::in, dl__result(c_pointer)::out,
+ io__state::di, io__state::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 c_code)
+% 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 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.)
+:- pred dl__mercury_sym(handle::in, mercury_proc::in, dl__result(T)::out,
+ io__state::di, io__state::uo) is det.
+
+% interface to the C function dlclose()
+:- pred dl__close(handle::in, dl__result::out,
+ io__state::di, io__state::uo) is det.
+
+:- implementation.
+:- import_module std_util, require, string, list.
+
+:- pragma c_header_code("#include <stdio.h>").
+:- pragma c_header_code("#include <dlfcn.h>").
+
+:- type handle ---> handle(c_pointer).
+
+:- pred is_null(c_pointer::in) is semidet.
+:- pragma c_code(is_null(Pointer::in),
+ [will_not_call_mercury, thread_safe],
+ "SUCCESS_INDICATOR = ((void *)Pointer == NULL)").
+
+open(FileName, Mode, Scope, Result) -->
+ dlopen(FileName, Mode, Scope, Pointer),
+ ( { is_null(Pointer) } ->
+ dlerror(ErrorMsg),
+ { Result = error(ErrorMsg) }
+ ;
+ { Result = ok(handle(Pointer)) }
+ ).
+
+/*
+** Note that dlopen() may call startup code (e.g. constructors for global
+** variables in C++) which may end up calling Mercury, so it's not safe
+** to declare this as `will_not_call_mercury'.
+*/
+
+:- pred dlopen(string::in, (mode)::in, scope::in, c_pointer::out,
+ io__state::di, io__state::uo) is det.
+:- pragma c_code(dlopen(FileName::in, Mode::in, Scope::in, Result::out,
+ _IO0::di, _IO::uo), [], "
+{
+ int mode = (Mode ? RTLD_NOW : RTLD_LAZY);
+ /* not all systems have RTLD_GLOBAL */
+ #ifdef RTLD_GLOBAL
+ if (Scope) mode |= RTLD_GLOBAL;
+ #endif
+ Result = (Word) dlopen(FileName, mode);
+}").
+
+:- type closure ---> closure(int, c_pointer).
+
+mercury_sym(Handle, MercuryProc0, Result) -->
+ { check_proc_spec_matches_result_type(Result, _,
+ MercuryProc0, MercuryProc) },
+ { MangledName = proc_name_mangle(MercuryProc) },
+ sym(Handle, MangledName, Result0),
+ {
+ Result0 = error(Msg),
+ Result = error(Msg)
+ ;
+ Result0 = ok(Address),
+ %
+ % convert the procedure address to a closure
+ %
+ NumCurriedInputArgs = 0,
+ Closure = closure(NumCurriedInputArgs, Address),
+ private_builtin__unsafe_type_cast(Closure, Value),
+ Result = ok(Value)
+ }.
+
+%
+% 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),
+ type_ctor_name_and_arity(type_ctor(type_of(Value)),
+ TypeModule, TypeName, TypeArity),
+ (
+ ( TypeModule \= "builtin"
+ ; TypeName \= "pred", TypeName \= "func"
+ )
+ ->
+ error(
+ "dl__mercury_sym: result type is not a higher-order type")
+ ;
+ IsPredOrFunc = predicate, TypeName \= "pred"
+ ->
+ string__append(
+ "dl__mercury_sym: predicate/function mismatch: ",
+ "argument is a predicate, result type is a function",
+ Msg),
+ error(Msg)
+ ;
+ IsPredOrFunc = function, TypeName \= "func"
+ ->
+ string__append(
+ "dl__mercury_sym: predicate/function mismatch: ",
+ "argument is a function, result type is a predicate",
+ Msg),
+ error(Msg)
+ ;
+ ProcArity \= TypeArity
+ ->
+ string__int_to_string(ProcArity, ProcArityString),
+ string__int_to_string(TypeArity, TypeArityString),
+ string__append_list([
+ "dl__mercury_sym: arity mismatch: ",
+ "argument has ", ProcArityString, " argument(s), ",
+ "result type has ", TypeArityString, " arguments(s)"],
+ Msg),
+ error(Msg)
+ ;
+ Proc = Proc0
+ ).
+
+sym(handle(Handle), Name, Result) -->
+ dlsym(Handle, Name, Pointer),
+ ( { is_null(Pointer) } ->
+ dlerror(ErrorMsg),
+ { Result = error(ErrorMsg) }
+ ;
+ { Result = ok(Pointer) }
+ ).
+
+:- pred dlsym(c_pointer::in, string::in, c_pointer::out,
+ io__state::di, io__state::uo) is det.
+:- pragma c_code(dlsym(Handle::in, Name::in, Pointer::out,
+ _IO0::di, _IO::uo), [will_not_call_mercury], "
+{
+ Pointer = (Word) dlsym((void *) Handle, Name);
+}").
+
+:- pred dlerror(string::out, io__state::di, io__state::uo) is det.
+:- pragma c_code(dlerror(ErrorMsg::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury], "
+{
+ const char *msg = dlerror();
+ if (msg == NULL) msg = """";
+ make_aligned_string_copy(ErrorMsg, msg);
+}").
+
+close(handle(Handle), Result) -->
+ dlclose(Handle),
+ dlerror(ErrorMsg),
+ { Result = (if ErrorMsg = "" then ok else error(ErrorMsg)) }.
+
+:- pred dlclose(c_pointer::in, io__state::di, io__state::uo) is det.
+:- pragma c_code(dlclose(Handle::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury], "dlclose((void *)Handle)").
Index: extras/dynamic_linking/dl_test.exp
===================================================================
RCS file: dl_test.exp
diff -N dl_test.exp
--- /dev/null Sat Dec 5 18:05:01 1998
+++ dl_test.exp Sat Dec 5 17:10:42 1998
@@ -0,0 +1 @@
+Hello, world
Index: extras/dynamic_linking/dl_test.m
===================================================================
RCS file: dl_test.m
diff -N dl_test.m
--- /dev/null Sat Dec 5 18:05:01 1998
+++ dl_test.m Sat Dec 5 17:58:25 1998
@@ -0,0 +1,76 @@
+% Example program using dynamic linking.
+% This module loads in the object code for the module `hello'
+% from the file `libhello.so', looks up the address of the
+% procedure hello/2 in that module, and then calls that procedure.
+
+% This source file is hereby placed in the public domain. -fjh (the author).
+
+:- module dl_test.
+:- interface.
+:- import_module io.
+
+:- pred main(state::di, state::uo) is det.
+
+:- implementation.
+:- import_module dl, name_mangle.
+
+main -->
+ %
+ % Load in the object code for the module `hello' from
+ % the file `libhello.so'.
+ %
+ dl__open("./libhello.so", lazy, local, MaybeHandle),
+ (
+ { MaybeHandle = error(Msg) },
+ print("dlopen failed: "), print(Msg), nl
+ ;
+ { MaybeHandle = ok(Handle) },
+ %
+ % Look up the address of the first mode (mode number 0)
+ % of the predicate hello/2 in the module hello.
+ %
+ { HelloProc = mercury_proc(predicate, unqualified("hello"),
+ "hello", 2, 0) },
+ dl__mercury_sym(Handle, HelloProc, MaybeHello),
+ (
+ { MaybeHello = error(Msg) },
+ print("dlsym failed: "), print(Msg), nl
+ ;
+ { MaybeHello = ok(HelloPred0) },
+ %
+ % Cast the higher-order term that we obtained
+ % to the correct higher-order inst.
+ %
+ { HelloPred = inst_cast(HelloPred0) },
+ %
+ % Call the procedure whose address
+ % we just obtained.
+ %
+ HelloPred
+ ),
+ %
+ % unload the object code in the libhello.so file
+ %
+ dl__close(Handle, Result),
+ (
+ { Result = error(CloseMsg) },
+ print("dlclose failed: "), print(CloseMsg), nl
+ ;
+ { Result = ok }
+ )
+ ).
+
+%
+% dl__mercury_sym returns a higher-order term with inst `ground'.
+% We need to cast it to the right higher-order inst, namely
+% `pred(di, uo) is det' before we can actually call it.
+% The function inst_cast/1 defined below does that.
+%
+
+:- type io_pred == pred(io__state, io__state).
+:- inst io_pred == (pred(di, uo) is det).
+
+:- func inst_cast(io_pred) = io_pred.
+:- mode inst_cast(in) = out(io_pred) is det.
+:- pragma c_code(inst_cast(X::in) = (Y::out(io_pred)),
+ [will_not_call_mercury, thread_safe], "Y = X").
Index: extras/dynamic_linking/hello.m
===================================================================
RCS file: hello.m
diff -N hello.m
--- /dev/null Sat Dec 5 18:05:01 1998
+++ hello.m Sat Dec 5 17:49:11 1998
@@ -0,0 +1,15 @@
+% Example module for use with dynamic linking.
+% The driver program dl_test.m dynamically loads the object code
+% for this module and then calls the predicate hello/2.
+
+% This source file is hereby placed in the public domain. -fjh (the author).
+
+:- module hello.
+:- interface.
+:- import_module io.
+
+:- pred hello(state::di, state::uo) is det.
+
+:- implementation.
+
+hello --> print("Hello, world\n").
Index: extras/dynamic_linking/name_mangle.m
===================================================================
RCS file: name_mangle.m
diff -N name_mangle.m
--- /dev/null Sat Dec 5 18:05:01 1998
+++ name_mangle.m Sat Dec 5 17:31:02 1998
@@ -0,0 +1,224 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1998 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: name_mangle.m.
+% Purpose: name mangling support.
+% Main author: fjh.
+% Stability: low.
+
+% This module provides the proc_name_mangle/1 function, which takes a value of
+% type `mercury_proc' and returns a string which is the symbol name for
+% specified procedure, and which is suitable for use in a call to dl__sym.
+%
+% The details of name mangling are implementation-dependent, so unfortunately
+% the values stored in the `mercury_proc' type might be subject to change
+% in different Mercury implementations. Any code which creates or
+% examines values of that type should be carefully isolated so that
+% it can be easily changed if the representation of `mercury_proc' changes.
+
+%-----------------------------------------------------------------------------%
+:- module name_mangle.
+:- interface.
+
+ % Given a mercury_proc specifying the module name,
+ % predicate or function indicator, predicate name, arity,
+ % and mode number of a Mercury procedure,
+ % return the label name of that procedure.
+ % The label name returned is suitable for passing to dl__sym.
+ %
+:- func proc_name_mangle(mercury_proc) = string.
+
+:- type mercury_proc --->
+ mercury_proc(is_pred_or_func, module_name, pred_name, arity, mode_num).
+
+:- type is_pred_or_func
+ ---> predicate
+ ; function.
+
+:- type module_name == sym_name.
+
+:- type sym_name
+ ---> qualified(sym_name, string)
+ ; unqualified(string).
+
+:- type pred_name == string.
+
+:- type arity == int.
+
+:- type mode_num == int. % mode numbers start from zero
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+:- import_module string, char, int, list.
+
+% XXX most of the code below is very similar to the code in
+% compiler/llds_out.m. Any changes there may require changes here
+% and vice versa.
+
+%-----------------------------------------------------------------------------%
+
+proc_name_mangle(MercuryProc) = LabelName :-
+ MercuryProc = mercury_proc(PredOrFunc, Module, Name0, Arity, ModeNum),
+ sym_name_mangle(Module, ModuleName),
+ (
+ (
+ Module = unqualified("builtin")
+ ;
+ Name0 = "main",
+ Arity = 2
+ )
+ % The conditions above define which labels are printed without
+ % module qualification.
+ ->
+ LabelName0 = Name0
+ ;
+ qualify_name(ModuleName, Name0, LabelName0)
+ ),
+ name_mangle(LabelName0, LabelName1),
+ ( PredOrFunc = function ->
+ OrigArity is Arity - 1
+ ;
+ OrigArity = Arity
+ ),
+ string__int_to_string(OrigArity, ArityString),
+ string__int_to_string(ModeNum, ModeNumString),
+ string__append_list([LabelName1, "_", ArityString, "_", ModeNumString],
+ LabelName2),
+ (
+ PredOrFunc = function,
+ string__append("fn__", LabelName2, LabelName3)
+ ;
+ PredOrFunc = predicate,
+ LabelName3 = LabelName2
+ ),
+ string__append("mercury__", LabelName3, LabelName4),
+ ( use_asm_labels ->
+ string__append("_entry_", LabelName4, LabelName)
+ ;
+ LabelName = LabelName4
+ ).
+
+:- pred sym_name_mangle(sym_name, string).
+:- mode sym_name_mangle(in, out) is det.
+
+sym_name_mangle(unqualified(Name), MangledName) :-
+ name_mangle(Name, MangledName).
+sym_name_mangle(qualified(ModuleName, PlainName), MangledName) :-
+ sym_name_mangle(ModuleName, MangledModuleName),
+ name_mangle(PlainName, MangledPlainName),
+ qualify_name(MangledModuleName, MangledPlainName,
+ MangledName).
+
+ % Convert a Mercury predicate name into something that can form
+ % part of a C identifier. This predicate is necessary because
+ % quoted names such as 'name with embedded spaces' are valid
+ % predicate names in Mercury.
+
+:- pred name_mangle(string, string).
+:- mode name_mangle(in, out) is det.
+
+name_mangle(Name, MangledName) :-
+ (
+ string__is_alnum_or_underscore(Name)
+ ->
+ % any names that start with `f_' are changed so that
+ % they start with `f__', so that we can use names starting
+ % with `f_' (followed by anything except an underscore)
+ % without fear of name collisions
+ (
+ string__append("f_", Suffix, Name)
+ ->
+ string__append("f__", Suffix, MangledName)
+ ;
+ MangledName = Name
+ )
+ ;
+ convert_to_valid_c_identifier(Name, MangledName)
+ ).
+
+:- pred convert_to_valid_c_identifier(string, string).
+:- mode convert_to_valid_c_identifier(in, out) is det.
+
+convert_to_valid_c_identifier(String, Name) :-
+ (
+ name_conversion_table(String, Name0)
+ ->
+ Name = Name0
+ ;
+ convert_to_valid_c_identifier_2(String, Name0),
+ string__append("f", Name0, Name)
+ ).
+
+:- pred qualify_name(string, string, string).
+:- mode qualify_name(in, in, out) is det.
+
+qualify_name(Module0, Name0, Name) :-
+ string__append_list([Module0, "__", Name0], Name).
+
+ % A table used to convert Mercury functors into
+ % C identifiers. Feel free to add any new translations you want.
+ % The C identifiers should start with "f_",
+ % to avoid introducing name clashes.
+ % If the functor name is not found in the table, then
+ % we use a fall-back method which produces ugly names.
+
+:- pred name_conversion_table(string, string).
+:- mode name_conversion_table(in, out) is semidet.
+
+name_conversion_table("\\=", "f_not_equal").
+name_conversion_table(">=", "f_greater_or_equal").
+name_conversion_table("=<", "f_less_or_equal").
+name_conversion_table("=", "f_equal").
+name_conversion_table("<", "f_less_than").
+name_conversion_table(">", "f_greater_than").
+name_conversion_table("-", "f_minus").
+name_conversion_table("+", "f_plus").
+name_conversion_table("*", "f_times").
+name_conversion_table("/", "f_slash").
+name_conversion_table(",", "f_comma").
+name_conversion_table(";", "f_semicolon").
+name_conversion_table("!", "f_cut").
+
+ % This is the fall-back method.
+ % Given a string, produce a C identifier
+ % for that string by concatenating the decimal
+ % expansions of the character codes in the string,
+ % separated by underlines.
+ % The C identifier will start with "f_"; this predicate
+ % constructs everything except the initial "f".
+ %
+ % For example, given the input "\n\t" we return "_10_8".
+
+:- pred convert_to_valid_c_identifier_2(string, string).
+:- mode convert_to_valid_c_identifier_2(in, out) is det.
+
+convert_to_valid_c_identifier_2(String, Name) :-
+ (
+ string__first_char(String, Char, Rest)
+ ->
+ char__to_int(Char, Code),
+ string__int_to_string(Code, CodeString),
+ string__append("_", CodeString, ThisCharString),
+ convert_to_valid_c_identifier_2(Rest, Name0),
+ string__append(ThisCharString, Name0, Name)
+ ;
+ % String is the empty string
+ Name = String
+ ).
+
+:- pred use_asm_labels is semidet.
+:- pragma c_code(use_asm_labels, [will_not_call_mercury, thread_safe], "
+#ifdef USE_ASM_LABELS
+ SUCCESS_INDICATOR = TRUE;
+#else
+ SUCCESS_INDICATOR = FALSE;
+#endif
+").
+
+
+%-----------------------------------------------------------------------------%
--
Fergus Henderson <fjh at cs.mu.oz.au> | "Binaries may die
WWW: <http://www.cs.mu.oz.au/~fjh> | but source code lives forever"
PGP: finger fjh at 128.250.37.3 | -- leaked Microsoft memo.
More information about the developers
mailing list