1 /* foreign.c
2 * Copyright 1984-2017 Cisco Systems, Inc.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 */
16
17 #define debug(y) /* (void)printf(y) *//* uncomment printf for debug */
18 /* #define UNLINK(x) 0 *//* uncomment #define to preserve temp files */
19
20
21 #include "system.h"
22
23 /* we can now return arbitrary values (aligned or not)
24 * since the garbage collector ignores addresses outside of the heap
25 * or within foreign segments */
26 #define ptr_to_addr(p) TO_VOIDP(p)
27 #define addr_to_ptr(a) TO_PTR(a)
28
29 /* buckets should be prime */
30 #define buckets 457
31 #define multiplier 3
32
33 #define ptrhash(x) ((uptr)x % buckets)
34
35 #ifdef LOAD_SHARED_OBJECT
36 #if defined(HPUX)
37 #include <dl.h>
38 #define dlopen(path,flags) (void *)shl_load(path, BIND_IMMEDIATE, 0L)
39 #define s_dlerror() Sstring_utf8(strerror(errno), -1)
40 #elif defined(WIN32)
41 #define dlopen(path,flags) S_ntdlopen(path)
42 #define dlsym(h,s) S_ntdlsym(h,s)
43 #define s_dlerror() S_ntdlerror()
44 #else
45 #include <dlfcn.h>
46 #define s_dlerror() Sstring_utf8(dlerror(), -1)
47 #ifndef RTLD_NOW
48 #define RTLD_NOW 2
49 #endif /* RTLD_NOW */
50 #endif /* machine types */
51 #endif /* LOAD_SHARED_OBJECT */
52
53 /* locally defined functions */
54 static iptr symhash PROTO((const char *s));
55 static ptr lookup_static PROTO((const char *s));
56 #ifdef LOAD_SHARED_OBJECT
57 static ptr lookup_dynamic PROTO((const char *s, ptr tbl));
58 #endif
59 static ptr lookup PROTO((const char *s));
60 static ptr remove_foreign_entry PROTO((const char *s));
61 static void *lookup_foreign_entry PROTO((const char *s));
62 static ptr foreign_entries PROTO((void));
63 static ptr foreign_static_table PROTO((void));
64 static ptr foreign_dynamic_table PROTO((void));
65 static ptr bvstring PROTO((const char *s));
66
67 #ifdef LOAD_SHARED_OBJECT
68 static void load_shared_object PROTO((const char *path));
69 #endif /* LOAD_SHARED_OBJECT */
70
71 #ifdef HPUX
proc2entry(void * f,ptr name)72 void *proc2entry(void *f, ptr name) {
73 if (((uptr)f & 2) == 0)
74 if (name == NULL)
75 S_error("Sforeign_symbol", "invalid entry");
76 else
77 S_error1("Sforeign_symbol", "invalid entry for ~s", name);
78 return (void *)((uptr)f & ~0x3);
79 }
80 #endif /* HPUX */
81
bvstring(const char * s)82 static ptr bvstring(const char *s) {
83 iptr n = strlen(s) + 1;
84 ptr x = S_bytevector(n);
85 memcpy(&BVIT(x, 0), s, n);
86 return x;
87 }
88
89 /* multiplier weights each character, h = n factors in the length */
symhash(s)90 static iptr symhash(s) const char *s; {
91 uptr n, h;
92
93 h = n = strlen(s);
94 while (n--) h = h * multiplier + *s++;
95 return (h & 0x7fffffff) % buckets;
96 }
97
lookup_static(s)98 static ptr lookup_static(s) const char *s; {
99 iptr b; ptr p;
100
101 b = symhash(s);
102 for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
103 if (strcmp(s, (char *)&BVIT(Scar(Scar(p)),0)) == 0)
104 return Scdr(Scar(p));
105
106 return addr_to_ptr(0);
107 }
108
109 #ifdef LOAD_SHARED_OBJECT
110 #define LOOKUP_DYNAMIC
lookup_dynamic(s,tbl)111 static ptr lookup_dynamic(s, tbl) const char *s; ptr tbl; {
112 ptr p;
113
114 for (p = tbl; p != Snil; p = Scdr(p)) {
115 #ifdef HPUX
116 (void *)value = (void *)0; /* assignment to prevent compiler warning */
117 shl_t handle = (shl_t)ptr_to_addr(Scar(p));
118
119 if (shl_findsym(&handle, s, TYPE_PROCEDURE, (void *)&value) == 0)
120 return addr_to_ptr(proc2entry(value, NULL));
121 #else /* HPUX */
122 void *value;
123
124 value = dlsym(ptr_to_addr(Scar(p)), s);
125 if (value != (void *)0) return addr_to_ptr(value);
126 #endif /* HPUX */
127 }
128
129 return addr_to_ptr(0);
130 }
131 #endif /* LOAD_SHARED_OBJECT */
132
lookup(s)133 static ptr lookup(s) const char *s; {
134 iptr b; ptr p;
135 ptr x;
136
137 #ifdef LOOKUP_DYNAMIC
138 x = lookup_dynamic(s, S_foreign_dynamic);
139 if (x == addr_to_ptr(0))
140 #endif /* LOOKUP_DYNAMIC */
141
142 x = lookup_static(s);
143 if (x == addr_to_ptr(0)) return x;
144
145 tc_mutex_acquire();
146
147 b = ptrhash(x);
148 for (p = Svector_ref(S_G.foreign_names, b); p != Snil; p = Scdr(p)) {
149 if (Scar(Scar(p)) == x) {
150 SETCDR(Scar(p),bvstring(s));
151 goto quit;
152 }
153 }
154 SETVECTIT(S_G.foreign_names, b, Scons(Scons(addr_to_ptr(x),bvstring(s)),
155 Svector_ref(S_G.foreign_names, b)));
156
157 quit:
158 tc_mutex_release();
159 return x;
160 }
161
Sforeign_symbol(s,v)162 void Sforeign_symbol(s, v) const char *s; void *v; {
163 iptr b; ptr x;
164
165 tc_mutex_acquire();
166
167 #ifdef HPUX
168 v = proc2entry(v,name);
169 #endif
170
171 if ((x = lookup(s)) == addr_to_ptr(0)) {
172 b = symhash(s);
173 SETVECTIT(S_G.foreign_static, b, Scons(Scons(bvstring(s), addr_to_ptr(v)),
174 Svector_ref(S_G.foreign_static, b)));
175 } else if (ptr_to_addr(x) != v)
176 S_error1("Sforeign_symbol", "duplicate symbol entry for ~s", Sstring_utf8(s, -1));
177
178 tc_mutex_release();
179 }
180
181 /* like Sforeign_symbol except it silently redefines the symbol
182 if it's already in S_G.foreign_static */
Sregister_symbol(s,v)183 void Sregister_symbol(s, v) const char* s; void *v; {
184 iptr b; ptr p;
185
186 tc_mutex_acquire();
187
188 b = symhash(s);
189 for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
190 if (strcmp(s, (char *)&BVIT(Scar(Scar(p)),0)) == 0) {
191 INITCDR(Scar(p)) = addr_to_ptr(v);
192 goto quit;
193 }
194 SETVECTIT(S_G.foreign_static, b, Scons(Scons(bvstring(s), addr_to_ptr(v)),
195 Svector_ref(S_G.foreign_static, b)));
196
197 quit:
198 tc_mutex_release();
199 }
200
remove_foreign_entry(s)201 static ptr remove_foreign_entry(s) const char *s; {
202 iptr b;
203 ptr tbl, p1, p2;
204
205 tc_mutex_acquire();
206
207 b = symhash(s);
208 tbl = S_G.foreign_static;
209 p1 = Snil;
210 p2 = Svector_ref(tbl, b);
211 for (; p2 != Snil; p1 = p2, p2 = Scdr(p2)) {
212 if (strcmp(s, (char *)&BVIT(Scar(Scar(p2)), 0)) == 0) {
213 if (p1 == Snil) {
214 SETVECTIT(tbl, b, Scdr(p2))
215 } else {
216 SETCDR(p1, Scdr(p2))
217 }
218 tc_mutex_release();
219 return Strue;
220 }
221 }
222 tc_mutex_release();
223 return Sfalse;
224 }
225
226 #ifdef LOAD_SHARED_OBJECT
load_shared_object(path)227 static void load_shared_object(path) const char *path; {
228 void *handle;
229
230 tc_mutex_acquire();
231
232 handle = dlopen(path, RTLD_NOW);
233 if (handle == (void *)NULL)
234 S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), s_dlerror());
235 S_foreign_dynamic = Scons(addr_to_ptr(handle), S_foreign_dynamic);
236
237 tc_mutex_release();
238
239 return;
240 }
241 #endif /* LOAD_SHARED_OBJECT */
242
S_foreign_entry()243 void S_foreign_entry() {
244 ptr tc = get_thread_context();
245 ptr name, x, bvname;
246 iptr i, n;
247
248 name = AC0(tc);
249 if (Sfixnump(name) || Sbignump(name)) {
250 AC0(tc) = (ptr)Sinteger_value(name);
251 return;
252 }
253
254 if (!(Sstringp(name))) {
255 S_error1("foreign-procedure", "invalid foreign procedure handle ~s", name);
256 }
257
258 n = Sstring_length(name);
259 bvname = S_bytevector(n + 1);
260 for (i = 0; i != n; i += 1) {
261 int k = Sstring_ref(name, i);
262 if (k >= 256) k = '?';
263 BVIT(bvname, i) = k;
264 }
265 BVIT(bvname, n) = 0;
266
267 if ((x = lookup((char *)&BVIT(bvname, 0))) == addr_to_ptr(0)) {
268 S_error1("foreign-procedure", "no entry for ~s", name);
269 }
270
271 AC0(tc) = x;
272 }
273
lookup_foreign_entry(s)274 static void *lookup_foreign_entry(s) const char *s; {
275 return ptr_to_addr(lookup(s));
276 }
277
foreign_entries()278 static ptr foreign_entries() {
279 iptr b; ptr p, entries;
280
281 entries = Snil;
282
283 for (b = 0; b < buckets; b++)
284 for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
285 entries = Scons(Sstring_utf8((char *)&BVIT(Scar(Scar(p)), 0), -1), entries);
286
287 return entries;
288 }
289
foreign_static_table()290 static ptr foreign_static_table() { return S_G.foreign_static; }
291 #ifdef LOAD_SHARED_OBJECT
foreign_dynamic_table()292 static ptr foreign_dynamic_table() { return S_foreign_dynamic; }
293 #else
foreign_dynamic_table()294 static ptr foreign_dynamic_table() { return Sfalse; }
295 #endif /* LOAD_SHARED_OBJECT */
296
foreign_address_name(ptr addr)297 static octet *foreign_address_name(ptr addr) {
298 iptr b; ptr p;
299
300 b = ptrhash(addr);
301 for (p = Svector_ref(S_G.foreign_names, b); p != Snil; p = Scdr(p))
302 if (Scar(Scar(p)) == (ptr)addr)
303 return &BVIT(Scdr(Scar(p)),0);
304
305 return NULL;
306 }
307
S_foreign_init()308 void S_foreign_init() {
309 if (S_boot_time) {
310 S_protect(&S_G.foreign_static);
311 S_G.foreign_static = S_vector(buckets);
312 {iptr i; for (i = 0; i < buckets; i++) INITVECTIT(S_G.foreign_static,i) = Snil;}
313
314 S_protect(&S_G.foreign_names);
315 S_G.foreign_names = S_vector(buckets);
316 {iptr i; for (i = 0; i < buckets; i++) INITVECTIT(S_G.foreign_names,i) = Snil;}
317
318 #ifdef LOAD_SHARED_OBJECT
319 S_protect(&S_foreign_dynamic);
320 S_foreign_dynamic = Snil;
321 Sforeign_symbol("(cs)load_shared_object", (void *)load_shared_object);
322 #endif /* LOAD_SHARED_OBJECT */
323
324 Sforeign_symbol("(cs)lookup_foreign_entry", (void *)lookup_foreign_entry);
325 Sforeign_symbol("(cs)remove_foreign_entry", (void *)remove_foreign_entry);
326 Sforeign_symbol("(cs)foreign_entries", (void *)foreign_entries);
327 Sforeign_symbol("(cs)foreign_static_table", (void *)foreign_static_table);
328 Sforeign_symbol("(cs)foreign_dynamic_table", (void *)foreign_dynamic_table);
329 Sforeign_symbol("(cs)foreign_address_name", (void *)foreign_address_name);
330 }
331
332 #ifdef LOAD_SHARED_OBJECT
333 S_foreign_dynamic = Snil;
334 #endif /* LOAD_SHARED_OBJECT */
335 }
336