annotate keiko/dynlink.c @ 1:b5139af1a420 tip basis

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