1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 1985-2020, University of Amsterdam
7 VU University Amsterdam
8 All rights reserved.
9
10 Redistribution and use in source and binary forms, with or without
11 modification, are permitted provided that the following conditions
12 are met:
13
14 1. Redistributions of source code must retain the above copyright
15 notice, this list of conditions and the following disclaimer.
16
17 2. Redistributions in binary form must reproduce the above copyright
18 notice, this list of conditions and the following disclaimer in
19 the documentation and/or other materials provided with the
20 distribution.
21
22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33 POSSIBILITY OF SUCH DAMAGE.
34 */
35
36 #include "pl-incl.h"
37 #ifndef MAXPATHLEN
38 #define MAXPATHLEN 1024
39 #endif
40
41 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
42 SWI-Prolog interface for runtime loading of foreign code (plugins).
43
44 Currently, this interface is implemented only for ELF systems (based on
45 dlopen()) and HPUX (based on slh_load()). Despite, this covers a large
46 number of modern Unix platforms. To name a few: Solaris, Linux, freeBSD,
47 IRIX, HPUX, MacOS X.
48
49 For some platforms we emulate the ELF interface and set the cpp symbol
50 EMULATE_DLOPEN. You find examples in pl-nt.c (for Win32) and pl-beos.c
51 (for BeOS).
52
53 Basically, 3 operations are required:
54
55 open_shared_object(+File, [+Options], -Handle)
56 Load a shared object into the current image.
57
58 call_shared_object_function(+Handle, +FunctionName)
59 Call a named function without arguments. Return value
60 is ignored too.
61
62 close_shared_object(+Handle)
63 Unload a shared object.
64
65 Feel free to add this functionality for your favorite OS and mail me the
66 contributions.
67 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
68
69
70 /*******************************
71 * DLOPEN() AND FRIENDS *
72 *******************************/
73
74 #ifndef EMULATE_DLOPEN
75 #ifdef HAVE_DLOPEN /* sysvr4, elf binaries */
76
77 #ifdef HAVE_DLFCN_H
78 #define _GNU_SOURCE /* get RTLD_DEFAULT */
79 #include <dlfcn.h>
80 #endif
81
82 #else /*HAVE_DLOPEN*/
83
84 #ifdef HAVE_SHL_LOAD /* HPUX */
85
86 #include <dl.h>
87 #define dlopen(path, flags) shl_load((path), (flags), 0L)
88 #define dlclose(handle) shl_unload((handle))
89 #define dlerror() OsError()
90
91 void *
dlsym(void * handle,const char * name)92 dlsym(void *handle, const char *name)
93 { void *value;
94 shl_t h = handle;
95
96 if ( shl_findsym(&h, name, TYPE_PROCEDURE, &value) < 0 )
97 return NULL;
98
99 return value;
100 }
101
102 #define RTLD_LAZY BIND_DEFERRED
103 #ifdef BIND_IMMEDIATE
104 #define RTLD_NOW BIND_IMMEDIATE
105 #endif
106
107 #endif /*HAVE_SHL_LOAD*/
108 #endif /*HAVE_DLOPEN*/
109 #endif /*EMULATE_DLOPEN*/
110
111 #if defined(HAVE_DLOPEN) || defined(HAVE_SHL_LOAD) || defined(EMULATE_DLOPEN)
112 #define HAVE_SHARED_OBJECTS
113
114 #ifndef RTLD_GLOBAL /* solaris defines this */
115 #define RTLD_GLOBAL 0
116 #endif
117 #ifndef RTLD_NOW /* implicit on some versions */
118 #define RTLD_NOW 0
119 #endif
120 #ifndef RTLD_LAZY /* freeBSD doesn't have this? */
121 #define RTLD_LAZY 0
122 #endif
123
124 typedef int (*dl_funcptr)();
125
126 typedef struct dl_entry *DlEntry;
127 struct dl_entry
128 { int id; /* Prolog's identifier */
129 void *dlhandle; /* DL libraries identifier */
130 atom_t file; /* Loaded filed */
131 DlEntry next; /* Next in table */
132 };
133
134 int dl_plid; /* next id to give */
135 DlEntry dl_head; /* loaded DL's */
136 DlEntry dl_tail; /* end of this chain */
137
138 #define DL_NOW 0x1
139 #define DL_GLOBAL 0x2
140
141 #ifndef EMULATE_DLOPEN
142 void *
PL_dlopen(const char * file,int flags)143 PL_dlopen(const char *file, int flags)
144 { return dlopen(file, flags);
145 }
146
147 const char *
PL_dlerror(void)148 PL_dlerror(void)
149 { return dlerror();
150 }
151
152 void *
PL_dlsym(void * handle,char * symbol)153 PL_dlsym(void *handle, char *symbol)
154 {
155 #ifdef RTLD_DEFAULT
156 if ( !handle )
157 handle = RTLD_DEFAULT;
158 #endif
159 return dlsym(handle, symbol);
160 }
161
162 int
PL_dlclose(void * handle)163 PL_dlclose(void *handle)
164 { return dlclose(handle);
165 }
166
167 #endif /*EMULATE_DLOPEN*/
168
169
170 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
171 under_valgrind()
172
173 True if we are running under valgrind.
174 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
175
176 #ifdef HAVE_VALGRIND_VALGRIND_H
177 #include <valgrind/valgrind.h>
178 #else
179 #define RUNNING_ON_VALGRIND (getenv("VALGRIND_OPTS") != NULL)
180 #endif
181
182 static int
under_valgrind(void)183 under_valgrind(void)
184 { static int vg = -1;
185
186 if ( vg == -1 )
187 {
188 #ifdef RUNNING_ON_VALGRIND
189 if ( RUNNING_ON_VALGRIND )
190 vg = TRUE;
191 else
192 #endif
193 vg = FALSE;
194 }
195
196 return vg;
197 }
198
199
200 static
201 PRED_IMPL("$open_shared_object", 3, open_shared_object, 0)
202 { PRED_LD
203 void *dlhandle;
204 char *fn;
205 atom_t afile;
206 DlEntry e;
207 int dlflags;
208 int n;
209
210 term_t file = A1;
211 term_t plhandle = A2;
212 term_t flags = A3;
213
214
215 if ( PL_get_integer(flags, &n) )
216 { dlflags = (n & DL_NOW) ? RTLD_NOW : RTLD_LAZY;
217 if ( n & DL_GLOBAL )
218 dlflags |= RTLD_GLOBAL;
219 } else
220 dlflags = RTLD_LAZY;
221
222 if ( !PL_get_atom_ex(file, &afile) ||
223 !PL_get_file_name(file, &fn, 0) )
224 fail;
225 if ( !(dlhandle = PL_dlopen(fn, dlflags)) )
226 return PL_error(NULL, 0, NULL, ERR_SHARED_OBJECT_OP,
227 ATOM_open, PL_dlerror());
228
229 e = allocHeapOrHalt(sizeof(struct dl_entry));
230
231 PL_LOCK(L_FOREIGN);
232 e->id = ++dl_plid;
233 e->dlhandle = dlhandle;
234 e->file = afile;
235 e->next = NULL;
236
237 if ( !dl_tail )
238 { dl_tail = e;
239 dl_head = e;
240 } else
241 { dl_tail->next = e;
242 dl_tail = e;
243 }
244 PL_UNLOCK(L_FOREIGN);
245
246 return PL_unify_integer(plhandle, e->id);
247 }
248
249
250 static DlEntry
find_dl_entry(term_t h)251 find_dl_entry(term_t h)
252 { GET_LD
253 DlEntry e;
254 int id;
255
256 if ( PL_get_integer(h, &id) )
257 { for(e = dl_head; e; e = e->next)
258 { if ( e->id == id )
259 return e;
260 }
261 PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_shared_object_handle, h);
262 return NULL;
263 }
264
265 PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_shared_object_handle, h);
266
267 return NULL;
268 }
269
270
271 static
272 PRED_IMPL("close_shared_object", 1, close_shared_object, 0)
273 { DlEntry e = find_dl_entry(A1);
274
275 if ( e && e->dlhandle)
276 { if ( !under_valgrind() )
277 PL_dlclose(e->dlhandle);
278 e->dlhandle = NULL;
279
280 succeed;
281 }
282
283 fail;
284 }
285
286
287 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
288 Some systems (notably MacOS X) prefixes symbols with _. In some version
289 of this OS, dlsym() adds an _, in others not. We'll try to work around
290 this junk with a runtime test ...
291 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
292
293 static
294 PRED_IMPL("call_shared_object_function", 2, call_shared_object_function,
295 PL_FA_TRANSPARENT)
296 { DlEntry e = find_dl_entry(A1);
297 char *fname;
298 dl_funcptr ef;
299
300 if ( !e || !e->dlhandle ||
301 !PL_get_chars(A2, &fname, CVT_ALL|CVT_EXCEPTION) )
302 fail;
303
304 #ifdef LD_SYMBOL_PREFIX /* first try plain anyway */
305 if ( !(ef = (dl_funcptr) PL_dlsym(e->dlhandle, fname)) )
306 { char symname[MAXSYMBOLLEN+1];
307
308 if ( strlen(fname)+strlen(LD_SYMBOL_PREFIX) > MAXSYMBOLLEN )
309 return PL_error(NULL, 0,
310 "Symbol too long",
311 ERR_REPRESENTATION,
312 PL_new_atom("symbol"));
313
314 strcpy(symname, LD_SYMBOL_PREFIX);
315 strcat(symname, fname);
316 ef = (dl_funcptr) dlsym(e->dlhandle, symname);
317 }
318 #else
319 ef = (dl_funcptr) PL_dlsym(e->dlhandle, fname);
320 #endif
321 if ( ef )
322 { (*ef)();
323 succeed;
324 } else
325 fail;
326 }
327
328
329 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
330 Unload all foreign libraries. As we are doing this at the very end of
331 the cleanup, it should be safe now.
332 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
333
334 void
cleanupForeign(void)335 cleanupForeign(void)
336 { DlEntry e, next;
337
338 for(e = dl_head; e; e = next)
339 { next = e->next;
340
341 if ( e->dlhandle )
342 { if ( !under_valgrind() )
343 PL_dlclose(e->dlhandle);
344 }
345
346 freeHeap(e, sizeof(*e));
347 }
348
349 dl_plid = 0;
350 dl_head = dl_tail = NULL;
351 }
352
353 #else /*HAVE_DLOPEN*/
354
355 /* No-op stub for pl-init.c to call. */
356 void
cleanupForeign(void)357 cleanupForeign(void)
358 {}
359
360 static
361 PRED_IMPL("$open_shared_object", 3, open_shared_object, 0)
362 { return notImplemented("open_shared_object", 3);
363 }
364
365 #endif /*HAVE_DLOPEN*/
366
367 /*******************************
368 * PUBLISH PREDICATES *
369 *******************************/
370
371 BeginPredDefs(dlopen)
372 PRED_DEF("$open_shared_object", 3, open_shared_object, 0)
373 #ifdef HAVE_SHARED_OBJECTS
374 PRED_DEF("close_shared_object", 1, close_shared_object, 0)
375 PRED_DEF("call_shared_object_function", 2, call_shared_object_function,
376 PL_FA_TRANSPARENT)
377 #endif
378 EndPredDefs
379