1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* This file contains the interface to the unix dynamic loader. */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "usrdef.h"
32 #include "syscall.h"
33 #include "os.h"
34 #include <dlfcn.h>
35
36
37 static bool cleanup_registered_p = false;
38 static unsigned int loaded_handles_size = 0;
39 static unsigned int n_loaded_handles = 0;
40 static void ** loaded_handles = 0;
41
42 static void * dld_load (const char *);
43 static void dld_unload (void *);
44 static void dld_unload_all (void);
45 static void * dld_lookup (void *, const char *);
46
47 #define ARG_HANDLE(n) ((void *) (arg_ulong_integer (n)))
48
49 DEFINE_PRIMITIVE ("DLD-LOAD-FILE", Prim_dld_load_file, 2, 2,
50 "(FILENAME WEAK-PAIR)\n\
51 Load the shared library FILENAME and store its handle\n\
52 in the cdr of WEAK-PAIR.")
53 {
54 PRIMITIVE_HEADER (2);
55 CHECK_ARG (2, WEAK_PAIR_P);
56 SET_PAIR_CDR ((ARG_REF (2)),
57 (ulong_to_integer
58 ((unsigned long)
59 (dld_load (((ARG_REF (1)) == SHARP_F)
60 ? 0
61 : (STRING_ARG (1)))))));
62 PRIMITIVE_RETURN (UNSPECIFIC);
63 }
64
65 DEFINE_PRIMITIVE ("DLD-LOOKUP-SYMBOL", Prim_dld_lookup_symbol, 2, 2,
66 "(HANDLE STRING)\n\
67 Look up the symbol named STRING in the shared library specified by HANDLE.\n\
68 Return the symbol's address, or #F if no such symbol.")
69 {
70 PRIMITIVE_HEADER (2);
71 PRIMITIVE_RETURN
72 (ulong_to_integer
73 ((unsigned long) (dld_lookup ((ARG_HANDLE (1)), (STRING_ARG (2))))));
74 }
75
76 DEFINE_PRIMITIVE ("DLD-UNLOAD-FILE", Prim_dld_unload_file, 1, 1,
77 "(HANDLE)\n\
78 Unload the shared library specified by HANDLE.\n\
79 The file is unmapped from memory, and its symbols become unbound.")
80 {
81 PRIMITIVE_HEADER (1);
82 dld_unload (ARG_HANDLE (1));
83 PRIMITIVE_RETURN (UNSPECIFIC);
84 }
85
86 DEFINE_PRIMITIVE ("INVOKE-C-THUNK", Prim_invoke_C_thunk, 1, 1,
87 "(ADDRESS)\n\
88 Treat ADDRESS, a Scheme integer corresponding to a C unsigned long, as\n\
89 the address of a C procedure of no arguments that returns an unsigned\n\
90 long. Invoke it, and return the corresponding Scheme integer.")
91 {
92 PRIMITIVE_HEADER (1);
93 PRIMITIVE_RETURN
94 (ulong_to_integer
95 ((* ((unsigned long (*) (void)) (arg_ulong_integer (1))))
96 ()));
97 }
98
99 DEFINE_PRIMITIVE ("ADDRESS-TO-STRING", Prim_address_to_string, 1, 1,
100 "(ADDRESS)\n\
101 Treat ADDRESS, a Scheme integer corresponding to a C unsigned long, as\n\
102 a C char * pointer. Allocate and return a Scheme string with the same\n\
103 contents.")
104 {
105 PRIMITIVE_HEADER (1);
106 PRIMITIVE_RETURN (char_pointer_to_string ((char *) (arg_ulong_integer (1))));
107 }
108
109 static void *
dld_load(const char * path)110 dld_load (const char * path)
111 {
112 void * handle;
113
114 if (!cleanup_registered_p)
115 {
116 add_reload_cleanup (dld_unload_all);
117 cleanup_registered_p = true;
118 }
119
120 handle = (dlopen (path, (RTLD_NOW | RTLD_GLOBAL)));
121 if (handle == 0)
122 {
123 SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
124 VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
125 VECTOR_SET (v, 1, (char_pointer_to_string ("dlopen")));
126 VECTOR_SET (v, 2, (char_pointer_to_string (dlerror ())));
127 error_with_argument (v);
128 }
129 if (n_loaded_handles == loaded_handles_size)
130 {
131 if (loaded_handles_size == 0)
132 {
133 loaded_handles_size = 16;
134 loaded_handles
135 = (OS_malloc (loaded_handles_size * (sizeof (void *))));
136 }
137 else
138 {
139 loaded_handles_size *= 2;
140 loaded_handles
141 = (OS_realloc (loaded_handles,
142 (loaded_handles_size * (sizeof (void *)))));
143 }
144 }
145 (loaded_handles[n_loaded_handles++]) = handle;
146 return (handle);
147 }
148
149 static void
dld_finalize(void * handle)150 dld_finalize (void * handle)
151 {
152 void * address = (dlsym (handle, "dld_finalize_file"));
153 if (address != 0)
154 {
155 void (*finalize) (void) = address;
156 (*finalize) ();
157 }
158 }
159
160 static void
dld_unload(void * handle)161 dld_unload (void * handle)
162 {
163 dld_finalize (handle);
164 if ((dlclose (handle)) != 0)
165 {
166 SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
167 VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
168 VECTOR_SET (v, 1, (char_pointer_to_string ("dlclose")));
169 VECTOR_SET (v, 2, (char_pointer_to_string (dlerror ())));
170 error_with_argument (v);
171 }
172 {
173 void ** scan = loaded_handles;
174 void ** end = (scan + n_loaded_handles);
175 for (; (scan < end); scan += 1)
176 if ((*scan) == handle)
177 {
178 (*scan) = (* (end - 1));
179 n_loaded_handles -= 1;
180 break;
181 }
182 }
183 }
184
185 static void
dld_unload_all(void)186 dld_unload_all (void)
187 {
188 if (loaded_handles_size > 0)
189 {
190 void ** scan = loaded_handles;
191 void ** end = (scan + n_loaded_handles);
192 while (scan < end)
193 {
194 void * handle = (*scan++);
195 dld_finalize (handle);
196 dlclose (handle);
197 }
198
199 OS_free (loaded_handles);
200 loaded_handles_size = 0;
201 n_loaded_handles = 0;
202 loaded_handles = 0;
203 }
204 }
205
206 static void *
dld_lookup(void * handle,const char * symbol)207 dld_lookup (void * handle, const char * symbol)
208 {
209 void * address;
210 const char * error_string;
211
212 dlerror (); /* discard any outstanding errors */
213 address = (dlsym (handle, symbol));
214 error_string = (dlerror ());
215 if (error_string != 0)
216 {
217 SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
218 VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
219 VECTOR_SET (v, 1, (char_pointer_to_string ("dlsym")));
220 VECTOR_SET (v, 2, (char_pointer_to_string (error_string)));
221 error_with_argument (v);
222 }
223 return (address);
224 }
225