File: pl-load.c

package info (click to toggle)
swi-prolog 6.6.6-1~bpo70+1
  • links: PTS, VCS
  • area: main
  • in suites: wheezy-backports
  • size: 82,312 kB
  • sloc: ansic: 322,250; perl: 245,822; sh: 6,651; java: 5,254; makefile: 4,423; cpp: 4,153; ruby: 1,594; yacc: 843; xml: 82; sed: 12; sql: 6
file content (332 lines) | stat: -rw-r--r-- 8,039 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (C): 1985-2013, University of Amsterdam
			      VU University Amsterdam

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*/

#include "pl-incl.h"
#ifndef MAXPATHLEN
#define MAXPATHLEN 1024
#endif

#define LOCK()   PL_LOCK(L_FOREIGN)
#define UNLOCK() PL_UNLOCK(L_FOREIGN)

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
SWI-Prolog interface for runtime loading of foreign code (plugins).

Currently, this interface is implemented only  for ELF systems (based on
dlopen()) and HPUX (based on slh_load()).   Despite, this covers a large
number of modern Unix platforms. To name a few: Solaris, Linux, freeBSD,
IRIX, HPUX, MacOS X.

For some platforms we emulate the ELF   interface and set the cpp symbol
EMULATE_DLOPEN. You find examples in pl-nt.c   (for Win32) and pl-beos.c
(for BeOS).

Basically, 3 operations are required:

	open_shared_object(+File, [+Options], -Handle)
	    Load a shared object into the current image.

	call_shared_object_function(+Handle, +FunctionName)
	    Call a named function without arguments.  Return value
	    is ignored too.

	close_shared_object(+Handle)
	    Unload a shared object.

Feel free to add this functionality for your favorite OS and mail me the
contributions.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


		 /*******************************
		 *     DLOPEN() AND FRIENDS	*
		 *******************************/

#ifdef HAVE_DLOPEN			/* sysvr4, elf binaries */

#ifdef HAVE_DLFCN_H
#include <dlfcn.h>
#endif

#else /*HAVE_DLOPEN*/

#ifdef HAVE_SHL_LOAD			/* HPUX */

#include <dl.h>
#define dlopen(path, flags) shl_load((path), (flags), 0L)
#define dlclose(handle)	    shl_unload((handle))
#define dlerror()	    OsError()

void *
dlsym(void *handle, const char *name)
{ void *value;
  shl_t h = handle;

  if ( shl_findsym(&h, name, TYPE_PROCEDURE, &value) < 0 )
    return NULL;

  return value;
}

#define RTLD_LAZY	BIND_DEFERRED
#ifdef BIND_IMMEDIATE
#define RTLD_NOW	BIND_IMMEDIATE
#endif

#endif /*HAVE_SHL_LOAD*/
#endif /*HAVE_DLOPEN*/

#if defined(HAVE_DLOPEN) || defined(HAVE_SHL_LOAD) || defined(EMULATE_DLOPEN)
#define HAVE_SHARED_OBJECTS

#ifndef RTLD_GLOBAL			/* solaris defines this */
#define RTLD_GLOBAL 0
#endif
#ifndef RTLD_NOW			/* implicit on some versions */
#define RTLD_NOW 0
#endif
#ifndef RTLD_LAZY			/* freeBSD doesn't have this? */
#define RTLD_LAZY 0
#endif

typedef int (*dl_funcptr)();

typedef struct dl_entry *DlEntry;
struct dl_entry
{ int	  id;				/* Prolog's identifier */
  void   *dlhandle;			/* DL libraries identifier */
  atom_t  file;				/* Loaded filed */
  DlEntry next;				/* Next in table */
};

int	dl_plid;			/* next id to give */
DlEntry dl_head;			/* loaded DL's */
DlEntry dl_tail;			/* end of this chain */

#define DL_NOW	  0x1
#define DL_GLOBAL 0x2

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
under_valgrind()

True if we are running under valgrind.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#ifdef HAVE_VALGRIND_VALGRIND_H
#include <valgrind/valgrind.h>
#else
#define RUNNING_ON_VALGRIND (getenv("VALGRIND_OPTS") != NULL)
#endif

static int
under_valgrind(void)
{ static int vg = -1;

  if ( vg == -1 )
  {
#ifdef RUNNING_ON_VALGRIND
    if ( RUNNING_ON_VALGRIND )
      vg = TRUE;
    else
#endif
      vg = FALSE;
  }

  return vg;
}


static
PRED_IMPL("$open_shared_object", 3, open_shared_object, 0)
{ PRED_LD
  void *dlhandle;
  char *fn;
  atom_t afile;
  DlEntry e;
  int dlflags;
  int n;

  term_t file     = A1;
  term_t plhandle = A2;
  term_t flags    = A3;


  if ( PL_get_integer(flags, &n) )
  { dlflags = (n & DL_NOW) ? RTLD_NOW : RTLD_LAZY;
    if ( n & DL_GLOBAL )
      dlflags |= RTLD_GLOBAL;
  } else
    dlflags = RTLD_LAZY;

  if ( !PL_get_atom_ex(file, &afile) ||
       !PL_get_file_name(file, &fn, 0) )
    fail;
  if ( !(dlhandle = dlopen(fn, dlflags)) )
    return PL_error(NULL, 0, NULL, ERR_SHARED_OBJECT_OP,
		    ATOM_open, dlerror());

  e = allocHeapOrHalt(sizeof(struct dl_entry));

  LOCK();
  e->id       = ++dl_plid;
  e->dlhandle = dlhandle;
  e->file     = afile;
  e->next     = NULL;

  if ( !dl_tail )
  { dl_tail = e;
    dl_head = e;
  } else
  { dl_tail->next = e;
    dl_tail = e;
  }
  UNLOCK();

  return PL_unify_integer(plhandle, e->id);
}


static DlEntry
find_dl_entry(term_t h)
{ GET_LD
  DlEntry e;
  int id;

  if ( PL_get_integer(h, &id) )
  { for(e = dl_head; e; e = e->next)
    { if ( e->id == id )
	return e;
    }
    PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_shared_object_handle, h);
    return NULL;
  }

  PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_shared_object_handle, h);

  return NULL;
}


static
PRED_IMPL("close_shared_object", 1, close_shared_object, 0)
{ DlEntry e = find_dl_entry(A1);

  if ( e && e->dlhandle)
  { if ( !under_valgrind() )
      dlclose(e->dlhandle);
    e->dlhandle = NULL;

    succeed;
  }

  fail;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Some systems (notably MacOS X) prefixes symbols with _. In some version
of this OS, dlsym() adds an _, in others not.  We'll try to work around
this junk with a runtime test ...
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

static
PRED_IMPL("call_shared_object_function", 2, call_shared_object_function,
	  PL_FA_TRANSPARENT)
{ DlEntry e = find_dl_entry(A1);
  char *fname;
  dl_funcptr ef;

  if ( !e || !e->dlhandle ||
       !PL_get_chars(A2, &fname, CVT_ALL|CVT_EXCEPTION) )
    fail;

#ifdef LD_SYMBOL_PREFIX			/* first try plain anyway */
  if ( !(ef = (dl_funcptr) dlsym(e->dlhandle, fname)) )
  { char symname[MAXSYMBOLLEN+1];

    if ( strlen(fname)+strlen(LD_SYMBOL_PREFIX) > MAXSYMBOLLEN )
      return PL_error(NULL, 0,
		      "Symbol too long",
		      ERR_REPRESENTATION,
		      PL_new_atom("symbol"));

    strcpy(symname, LD_SYMBOL_PREFIX);
    strcat(symname, fname);
    ef = (dl_funcptr) dlsym(e->dlhandle, symname);
  }
#else
  ef = (dl_funcptr) dlsym(e->dlhandle, fname);
#endif
  if ( ef )
  { (*ef)();
    succeed;
  } else
    fail;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Unload all foreign libraries.  As we are doing this at the very end of
the cleanup, it should be safe now.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

void
cleanupForeign(void)
{ DlEntry e, next;

  for(e = dl_head; e; e = next)
  { next = e->next;

    if ( e->dlhandle )
    { if ( !under_valgrind() )
	dlclose(e->dlhandle);
    }

    freeHeap(e, sizeof(*e));
  }

  dl_plid = 0;
  dl_head = dl_tail = NULL;
}

#else /*HAVE_DLOPEN*/

static
PRED_IMPL("$open_shared_object", 3, open_shared_object, 0)
{ return notImplemented("open_shared_object", 3);
}

#endif /*HAVE_DLOPEN*/

		 /*******************************
		 *      PUBLISH PREDICATES	*
		 *******************************/

BeginPredDefs(dlopen)
  PRED_DEF("$open_shared_object", 3, open_shared_object, 0)
#ifdef HAVE_SHARED_OBJECTS
  PRED_DEF("close_shared_object", 1, close_shared_object, 0)
  PRED_DEF("call_shared_object_function", 2, call_shared_object_function,
	   PL_FA_TRANSPARENT)
#endif
EndPredDefs