comparison keiko/dynlink.c @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 /*
2 * dynlink.c
3 *
4 * This file is part of the Oxford Oberon-2 compiler
5 * Copyright (c) 2006--2016 J. M. Spivey
6 * All rights reserved
7 *
8 * Redistribution and use in source and binary forms, with or without
9 * modification, are permitted provided that the following conditions are met:
10 *
11 * 1. Redistributions of source code must retain the above copyright notice,
12 * this list of conditions and the following disclaimer.
13 * 2. Redistributions in binary form must reproduce the above copyright notice,
14 * this list of conditions and the following disclaimer in the documentation
15 * and/or other materials provided with the distribution.
16 * 3. The name of the author may not be used to endorse or promote products
17 * derived from this software without specific prior written permission.
18 *
19 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
20 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
21 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
22 * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
24 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
25 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
27 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
28 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 */
30
31 /*
32 Initially, the procedure descriptor for each such primitive has the
33 trap handler |dltrap| as its interpreter, and the CP_CODE field of
34 the descriptor points to the name of the primitive as a string.
35 When the primitive is first called, the |dltrap| primitive looks up
36 the symbol and binds the primitive to its value for future use.
37 Finally, it calls the newly-loaded primitive to complete the first
38 call.
39
40 Function |load_lib| loads a dynamic library. Each Oberon module that
41 links to a dynamic library should call |DynLink.Load("path")|
42 in its initialization part.
43 */
44
45 #include "obx.h"
46
47 #ifdef DYNLINK
48
49 #ifndef __USE_GNU
50 #define __USE_GNU
51 #endif
52 #include <dlfcn.h>
53
54 #ifdef USEFFI
55 #include <ffi.h>
56 #endif
57
58 void load_lib(char *fname) {
59 char buf[128];
60
61 /* If the library name starts with '@', look in the OBC lib directory
62 and append the extension ".so" or ".dylib" au chois */
63 if (fname[0] == '@') {
64 char *dir = getenv("OBC_LIB");
65 if (dir == NULL) dir = libpath;
66 if (dir == NULL) panic("no runtime library");
67 strcpy(buf, dir);
68 strcat(buf, "/");
69 strcat(buf, fname+1);
70 strcat(buf, DLEXT);
71 fname = buf;
72 }
73
74 /* Load the library */
75 if (dlopen(fname, RTLD_LAZY|RTLD_GLOBAL) == NULL)
76 panic(dlerror());
77 }
78
79 #ifdef USEFFI
80 #define MAXP 16
81
82 typedef struct {
83 void (*fun)(void);
84 ffi_cif cif;
85 } wrapper;
86
87 static ffi_type *ffi_decode(char c) {
88 switch (c) {
89 case 'C':
90 case 'I':
91 return &ffi_type_sint32;
92 case 'L':
93 return &ffi_type_sint64;
94 case 'F':
95 return &ffi_type_float;
96 case 'D':
97 return &ffi_type_double;
98 case 'P':
99 case 'Q':
100 case 'X':
101 return &ffi_type_pointer;
102 case 'V':
103 return &ffi_type_void;
104 default:
105 panic("Bad type %c", c);
106 return NULL;
107 }
108 }
109
110 void dlstub(value *bp) {
111 value *cp = valptr(bp[CP]);
112 char *tstring = (char *) pointer(cp[CP_CODE]);
113
114 ffi_raw avals[MAXP], rval[2];
115 int i, p = 0, q = 0;
116 double d; longint z;
117
118 FPINIT;
119
120 for (i = 0; tstring[i+1] != '\0'; i++) {
121 switch (tstring[i+1]) {
122 case 'C':
123 avals[q].sint = align_byte(bp[HEAD+p].i);
124 p += 1; q += 1; break;
125 case 'I':
126 avals[q].sint = bp[HEAD+p].i;
127 p += 1; q += 1; break;
128 case 'L':
129 z = get_long(&bp[HEAD+p]);
130 memcpy(avals[q].data, &z, sizeof(longint));
131 p += 2; q += sizeof(longint)/sizeof(ffi_raw); break;
132 case 'F':
133 avals[q].flt = bp[HEAD+p].f;
134 p += 1; q += 1; break;
135 case 'D':
136 d = get_double(&bp[HEAD+p]);
137 memcpy(avals[q].data, &d, sizeof(double));
138 p += 2; q += sizeof(double)/sizeof(ffi_raw); break;
139 case 'P':
140 avals[q].ptr = pointer(bp[HEAD+p]);
141 p += 1; q += 1; break;
142 case 'X':
143 avals[q].ptr = pointer(bp[HEAD+p]);
144 p += 2; q += 1; break;
145 case 'Q':
146 avals[q].ptr = ptrcast(uchar, get_long(&bp[HEAD+p]));
147 p += 2; q += 1; break;
148 #ifdef SPECIALS
149 case 'S':
150 /* Static link for compilers course -- ignored */
151 p += 1; break;
152 #endif
153 default:
154 panic("Bad type 2 %c", tstring[i+1]);
155 }
156 }
157
158 wrapper *w = (wrapper *) pointer(cp[CP_CONST]);
159 ffi_raw_call(&w->cif, w->fun, rval, avals);
160
161 switch (tstring[0]) {
162 case 'C':
163 case 'I':
164 ob_res.i = rval->sint;
165 break;
166 case 'L':
167 memcpy(&z, rval, sizeof(longint));
168 put_long(&ob_res, z);
169 break;
170 case 'F':
171 ob_res.f = rval->flt;
172 break;
173 case 'D':
174 memcpy(&d, rval, sizeof(double));
175 put_double(&ob_res, d);
176 break;
177 case 'P':
178 ob_res.a = rval->uint;
179 break;
180 case 'Q':
181 put_long(&ob_res, (ptrtype) rval->ptr);
182 break;
183 case 'V':
184 break;
185 default:
186 panic("Bad type 3");
187 }
188 }
189 #endif
190
191 primitive *find_prim(char *name) {
192 return (primitive *) dlsym(RTLD_DEFAULT, name);
193 }
194
195 #else
196
197 void load_lib(char *fname) {
198 }
199
200 primitive *find_prim(char *name) {
201 int i;
202
203 for (i = 0; primtab[i].p_name != NULL; i++) {
204 if (strcmp(name, primtab[i].p_name) == 0)
205 return primtab[i].p_prim;
206 }
207
208 return NULL;
209 }
210
211 #endif
212
213 void dltrap(value *bp) {
214 value *cp = valptr(bp[CP]);
215 char *tstring = (char *) pointer(cp[CP_CODE]);
216 char *name = tstring + strlen(tstring) + 1;
217 primitive *prim = NULL;
218
219 if (tstring[0] == '*')
220 prim = find_prim(name);
221 else {
222 /* Look for a static wrapper */
223 char primname[32];
224 sprintf(primname, "P_%s", name);
225 prim = find_prim(primname);
226 }
227
228 if (prim != NULL) {
229 cp[CP_PRIM].a = wrap_prim(prim);
230 (*prim)(bp);
231 return;
232 }
233
234 #ifdef DYNLINK
235 #ifdef USEFFI
236 /* Build a wrapper with FFI */
237 void (*fun)(void) = (void(*)(void)) dlsym(RTLD_DEFAULT, name);
238
239 if (fun != NULL && tstring[0] != '*') {
240 int np = strlen(tstring)-1;
241 ffi_type *rtype = ffi_decode(tstring[0]);
242 ffi_type **atypes =
243 (ffi_type **) scratch_alloc(np * sizeof(ffi_type *));
244 for (int i = 0; tstring[i+1] != '\0'; i++)
245 atypes[i] = ffi_decode(tstring[i+1]);
246
247 wrapper *w = (wrapper *) scratch_alloc(sizeof(wrapper));
248 w->fun = fun;
249 ffi_prep_cif(&w->cif, FFI_DEFAULT_ABI, np, rtype, atypes);
250
251 cp[CP_PRIM].a = dynstub;
252 cp[CP_CONST].a = address(w);
253
254 dlstub(bp);
255 return;
256 }
257 #endif
258 #endif
259
260 panic("Couldn't find primitive %s", name);
261 }