1 /* load.c -*- mode:c; coding:utf-8; -*-
2 *
3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com>
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 *
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 *
12 * 2. Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditions and the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 *
16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 *
28 * $Id: $
29 */
30 #include <string.h>
31 #include <ctype.h>
32 #define LIBSAGITTARIUS_BODY
33 #include "sagittarius/private/load.h"
34 #include "sagittarius/private/core.h"
35 #include "sagittarius/private/codec.h"
36 #include "sagittarius/private/error.h"
37 #include "sagittarius/private/file.h"
38 #include "sagittarius/private/gloc.h"
39 #include "sagittarius/private/library.h"
40 #include "sagittarius/private/number.h"
41 #include "sagittarius/private/pair.h"
42 #include "sagittarius/private/port.h"
43 #include "sagittarius/private/reader.h"
44 #include "sagittarius/private/string.h"
45 #include "sagittarius/private/symbol.h"
46 #include "sagittarius/private/system.h"
47 #include "sagittarius/private/transcoder.h"
48 #include "sagittarius/private/writer.h"
49 #include "sagittarius/private/vm.h"
50 #include "sagittarius/private/thread.h"
51 #include "sagittarius/private/unicode.h"
52
53 /* need to redirect dlopen */
54 #include "gc-incl.inc"
55
56
57 static SgInternalMutex load_lock;
58 static SgInternalMutex dso_lock;
59
Sg_Load(SgString * path)60 int Sg_Load(SgString *path)
61 {
62 static SgObject load_stub = SG_UNDEF;
63 SgObject r = SG_FALSE;
64 SgVM *vm = Sg_VM();
65 /* flags(#!** etc) are only per file.
66 so we need to save/restore.
67 TODO: do we need to lock?
68 */
69 int save = vm->flags;
70 if (SG_UNDEFP(load_stub)) {
71 SgObject gloc;
72 Sg_LockMutex(&load_lock);
73 gloc = Sg_FindBinding(SG_INTERN("(sagittarius)"),
74 SG_INTERN("load"),
75 SG_UNBOUND);
76 if (SG_UNBOUNDP(gloc)) {
77 Sg_Panic("load was not found.");
78 }
79 load_stub = SG_GLOC_GET(SG_GLOC(gloc));
80 Sg_UnlockMutex(&load_lock);
81 }
82 r = Sg_Apply1(load_stub, path);
83 vm->flags = save;
84 return (SG_INTP(r) ? (int)SG_INT_VALUE(r) : 0);
85 }
86
Sg_LoadFromPort(SgPort * port)87 int Sg_LoadFromPort(SgPort *port)
88 {
89 static SgObject load_stub = SG_UNDEF;
90 SgObject r = SG_FALSE;
91 SgVM *vm = Sg_VM();
92 /* flags(#!** etc) are only per file.
93 so we need to save/restore.
94 TODO: do we need to lock?
95 */
96 int save = vm->flags;
97 if (SG_UNDEFP(load_stub)) {
98 SgObject gloc;
99 Sg_LockMutex(&load_lock);
100 gloc = Sg_FindBinding(SG_INTERN("(sagittarius)"),
101 SG_INTERN("load-from-port"),
102 SG_UNBOUND);
103 if (SG_UNBOUNDP(gloc)) {
104 Sg_Panic("load was not found.");
105 }
106 load_stub = SG_GLOC_GET(SG_GLOC(gloc));
107 Sg_UnlockMutex(&load_lock);
108 }
109 r = Sg_Apply1(load_stub, port);
110 vm->flags = save;
111 return (SG_INTP(r) ? (int)SG_INT_VALUE(r) : 0);
112 }
113
114 /*
115 DynLoad
116
117 load shared objects
118 */
119
120 typedef struct dlobj_rec dlobj;
121 typedef struct dlobj_initfn_rec dlobj_initfn;
122 typedef void (*SgDynLoadInitFn)(void);
123
124 static struct
125 {
126 SgObject dso_suffix;
127 dlobj *dso_list;
128 } dynldinfo = { (SgObject)&dynldinfo, };
129
130 struct dlobj_initfn_rec
131 {
132 dlobj_initfn *next;
133 const char *name;
134 SgDynLoadInitFn fn;
135 int initialized;
136 };
137
138 struct dlobj_rec
139 {
140 dlobj *next;
141 SgString *path;
142 int loaded;
143 void *handle;
144 SgVM *loader;
145 dlobj_initfn *initfns;
146 SgInternalMutex mutex;
147 SgInternalCond cv;
148 };
149
150
find_dlobj(SgString * path)151 static dlobj* find_dlobj(SgString *path)
152 {
153 dlobj *z = NULL;
154 Sg_LockMutex(&dso_lock);
155 for (z = dynldinfo.dso_list; z; z = z->next) {
156 if (Sg_StringEqual(z->path, path)) break;
157 }
158 if (z == NULL) {
159 z = SG_NEW(dlobj);
160 z->path = path;
161 z->loader = NULL;
162 z->loaded = FALSE;
163 z->initfns = NULL;
164 Sg_InitMutex(&z->mutex, FALSE);
165 Sg_InitCond(&z->cv);
166 z->next = dynldinfo.dso_list;
167 dynldinfo.dso_list = z;
168 }
169 Sg_UnlockMutex(&dso_lock);
170 return z;
171 }
172
lock_dlobj(dlobj * dlo)173 static void lock_dlobj(dlobj *dlo)
174 {
175 SgVM *vm = Sg_VM();
176 Sg_LockMutex(&dlo->mutex);
177 while (dlo->loader != vm) {
178 if (dlo->loader == NULL) break;
179 Sg_Wait(&dlo->cv, &dlo->mutex);
180 }
181 dlo->loader = vm;
182 Sg_UnlockMutex(&dlo->mutex);
183 }
184
unlock_dlobj(dlobj * dlo)185 static void unlock_dlobj(dlobj *dlo)
186 {
187 Sg_LockMutex(&dlo->mutex);
188 dlo->loader = NULL;
189 Sg_NotifyAll(&dlo->cv);
190 Sg_UnlockMutex(&dlo->mutex);
191 }
192
193 #define DYNLOAD_PREFIX "_Sg_Init_"
194
195 #ifdef _MSC_VER
196 #define s_strcpy(dst, src, size) strcpy_s(dst, size, src)
197 #else
198 #define s_strcpy(dst, src, size) strcpy(dst, src)
199 #endif
200
201
derive_dynload_initfn(const char * filename)202 static const char* derive_dynload_initfn(const char *filename)
203 {
204 const char *head, *tail, *s;
205 char *name, *d;
206 size_t size;
207
208 head = strrchr(filename, '/');
209 if (head == NULL) {
210 head = strrchr(filename, '\\');
211 if (head == NULL) head = filename;
212 else head++;
213 }
214 else head++;
215 tail = strchr(head, '.');
216 if (tail == NULL) tail = filename + strlen(filename);
217
218 size = sizeof(DYNLOAD_PREFIX) + tail - head;
219 name = SG_NEW_ATOMIC2(char *, size);
220 s_strcpy(name, DYNLOAD_PREFIX, size);
221 for (s = head, d = name + sizeof(DYNLOAD_PREFIX) - 1; s < tail; s++, d++) {
222 if (isalnum((int)*s)) *d = tolower((int)*s);
223 else *d = '_';
224 }
225 *d = '\0';
226 return name;
227 }
228
get_initfn_name(SgObject initfn,SgString * dsopath)229 const char* get_initfn_name(SgObject initfn, SgString *dsopath)
230 {
231 if (SG_STRINGP(initfn)) {
232 /* WATCOM has weird export symbol name */
233 #ifdef __WATCOMC__
234 SgObject _initfn = Sg_StringAppend2(SG_STRING(initfn),
235 SG_STRING(SG_MAKE_STRING("_")));
236 #else
237 SgObject _initfn = Sg_StringAppend2(SG_STRING(SG_MAKE_STRING("_")),
238 SG_STRING(initfn));
239 #endif
240 return Sg_Utf32sToUtf8s(SG_STRING(_initfn));
241 } else {
242 return derive_dynload_initfn(Sg_Utf32sToUtf8s(dsopath));
243 }
244 }
245
246 #ifdef HAVE_DLFCN_H
247 # include "dl_dlopen.c"
248 #elif defined(_MSC_VER) || defined(_SG_WIN_SUPPORT)
249 # include "dl_win.c"
250 #else
251 # include "dl_dummy.c"
252 #endif
253
load_dlo(dlobj * dlo)254 static void load_dlo(dlobj *dlo)
255 {
256 SgVM *vm = Sg_VM();
257 if (SG_VM_LOG_LEVEL(Sg_VM(), SG_INFO_LEVEL)) {
258 Sg_Printf(vm->logPort, UC(";; Dynamically Loading %S...\n"), dlo->path);
259 }
260 dlo->handle = dl_open(dlo->path);
261 if (dlo->handle == NULL) {
262 const SgString *err = dl_error();
263 if (err == NULL) {
264 Sg_Error(UC("failed to link %S dynamically"), dlo->path);
265 } else {
266 Sg_Error(UC("failed to link %S dynamically: %S"), dlo->path, err);
267 }
268 }
269 dlo->loaded = TRUE;
270 }
271
find_initfn(dlobj * dlo,const char * name)272 static dlobj_initfn* find_initfn(dlobj *dlo, const char *name)
273 {
274 dlobj_initfn *fns = dlo->initfns;
275 for (; fns != NULL; fns = fns->next) {
276 if (strcmp(name, fns->name) == 0) return fns;
277 }
278 fns = SG_NEW(dlobj_initfn);
279 fns->name = name;
280 fns->fn = NULL;
281 fns->initialized = FALSE;
282 fns->next = dlo->initfns;
283 dlo->initfns = fns;
284 return fns;
285 }
286
call_initfn(dlobj * dlo,const char * name)287 static void call_initfn(dlobj *dlo, const char *name)
288 {
289 dlobj_initfn *ifn = find_initfn(dlo, name);
290
291 if (ifn->initialized) return;
292 if (!ifn->fn) {
293 ifn->fn = dl_sym(dlo->handle, name + 1);
294 if (ifn->fn == NULL) {
295 ifn->fn = (void(*)(void))dl_sym(dlo->handle, name);
296 if (ifn->fn == NULL) {
297 dl_close(dlo->handle);
298 dlo->handle = NULL;
299 Sg_Error(UC("dynamic linking of %S failed: "
300 "couldn't find initialization function %S"
301 "(%A)"),
302 dlo->path, Sg_MakeStringC(name),
303 dl_error());
304 }
305 }
306 }
307 ifn->fn();
308 ifn->initialized = TRUE;
309 }
310
311 /* .dll or .so loader */
Sg_DynLoad(SgString * filename,SgObject initfn,unsigned long flags)312 SgObject Sg_DynLoad(SgString *filename, SgObject initfn, unsigned long flags)
313 {
314 SgVM *vm = Sg_VM();
315 SgObject spath;
316 const char * volatile initname;
317 dlobj * volatile dlo;
318
319 spath = Sg_FindFile(filename, vm->dynamicLoadPath,
320 dynldinfo.dso_suffix, TRUE);
321 if (SG_FALSEP(spath)) {
322 Sg_Error(UC("can't find dlopen-able library %S"), filename);
323 }
324 initname = get_initfn_name(initfn, SG_STRING(spath));
325 dlo = find_dlobj(spath);
326
327 lock_dlobj(dlo);
328 if (!dlo->loaded) {
329 SG_UNWIND_PROTECT { load_dlo(dlo); }
330 SG_WHEN_ERROR{ unlock_dlobj(dlo); SG_NEXT_HANDLER; }
331 SG_END_PROTECT;
332 }
333 ASSERT(dlo->loaded);
334
335 SG_UNWIND_PROTECT { call_initfn(dlo, initname); }
336 SG_WHEN_ERROR{ unlock_dlobj(dlo); SG_NEXT_HANDLER; }
337 SG_END_PROTECT;
338
339 unlock_dlobj(dlo);
340 return SG_TRUE;
341 }
342
Sg_OpenSharedObject(SgString * filename)343 void* Sg_OpenSharedObject(SgString *filename)
344 {
345 return dl_open(filename);
346 }
347
Sg_LookupSharedObject(void * handle,const char * symbol)348 void* Sg_LookupSharedObject(void *handle, const char *symbol)
349 {
350 /* dl_sym returns SgDynLoadInitFn so cast it*/
351 return (void*)dl_sym(handle, symbol);
352 }
353
Sg_CloseSharedObject(void * handle)354 void Sg_CloseSharedObject(void *handle)
355 {
356 dl_close(handle);
357 }
358
Sg_GetSharedError()359 SgObject Sg_GetSharedError()
360 {
361 return SG_OBJ(dl_error());
362 }
363
364 #ifndef __CYGWIN__
real_cleanup()365 static void real_cleanup()
366 {
367 dlobj *z;
368 for (z = dynldinfo.dso_list; z; z = z->next) {
369 if (z->handle) {
370 dl_close(z->handle);
371 z->handle = NULL;
372 }
373 }
374 }
375 #endif
376
377 /* to avoid invalid class reference during port flushing
378 (it calls Sg_HasPortPosition which reads class cpa and
379 if the shared object is already detached, it crashes).
380 e.g. socket port, we need to delay the cleanup.
381 */
cleanup_shared_objects(void * data)382 static void cleanup_shared_objects(void *data)
383 {
384 /* Not sure if this is only Cygwin issue but at least on
385 Cygwin atexit is called *after* all resources are released.
386 (haven't seen any official document for this but if I check
387 with GDB it seems like that.) At that moment, there is no
388 DLL is atached on the process and Win32 API tries to release
389 it with invalid handle or something. Then it causes SEGV.*/
390 #ifndef __CYGWIN__
391 atexit(real_cleanup);
392 #endif
393 }
394
Sg__InitLoad()395 void Sg__InitLoad()
396 {
397 Sg_InitMutex(&load_lock, TRUE);
398 Sg_InitMutex(&dso_lock, TRUE);
399 dynldinfo.dso_suffix = SG_MAKE_STRING(SHLIB_SO_SUFFIX);
400 dynldinfo.dso_list = NULL;
401
402 Sg_AddCleanupHandler(cleanup_shared_objects, NULL);
403 }
404