diff options
Diffstat (limited to 'Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c')
-rw-r--r-- | Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c | 275 |
1 files changed, 275 insertions, 0 deletions
diff --git a/Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c b/Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c new file mode 100644 index 00000000000..064a9b76db0 --- /dev/null +++ b/Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c @@ -0,0 +1,275 @@ +/* + * dynlink.c + * + * This file is part of the Oxford Oberon-2 compiler + * Copyright (c) 2006--2016 J. M. Spivey + * All rights reserved + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +/* +Initially, the procedure descriptor for each such primitive has the +trap handler |dltrap| as its interpreter, and the CP_CODE field of +the descriptor points to the name of the primitive as a string. +When the primitive is first called, the |dltrap| primitive looks up +the symbol and binds the primitive to its value for future use. +Finally, it calls the newly-loaded primitive to complete the first +call. + +Function |load_lib| loads a dynamic library. Each Oberon module that +links to a dynamic library should call |DynLink.Load("path")| +in its initialization part. +*/ + +#include "obx.h" +#include <string.h> +#include <stdlib.h> + +#ifdef DYNLINK + +#ifndef __USE_GNU +#define __USE_GNU +#endif +#include <dlfcn.h> + +#ifdef USE_FFI +#include <ffi.h> +#endif + +void load_lib(char *fname) { + char buf[128]; + + /* If the library name starts with '@', look in the OBC lib directory + and append the extension ".so" or ".dylib" au chois */ + if (fname[0] == '@') { + char *dir = getenv("OBC_LIB"); + if (dir == NULL) dir = libpath; + if (dir == NULL) panic("no runtime library"); + strcpy(buf, dir); + strcat(buf, "/"); + strcat(buf, fname+1); + strcat(buf, DLEXT); + fname = buf; + } + + /* Load the library */ + if (dlopen(fname, RTLD_LAZY|RTLD_GLOBAL) == NULL) + panic(dlerror()); +} + +#ifdef USE_FFI +#define MAXP 16 + +typedef struct { + void (*fun)(void); + ffi_cif cif; +} wrapper; + +static ffi_type *ffi_decode(char c) { + switch (c) { + case 'C': + case 'S': + case 'I': + return &ffi_type_sint32; + case 'L': + return &ffi_type_sint64; + case 'F': + return &ffi_type_float; + case 'D': + return &ffi_type_double; + case 'P': + case 'Q': + case 'X': + return &ffi_type_pointer; + case 'V': + return &ffi_type_void; + default: + panic("Bad type %c", c); + return NULL; + } +} + +value *dlstub(value *bp) { + value *cp = valptr(bp[CP]); + char *tstring = pointer(cp[CP_CODE]); + value *sp = bp; + + ffi_raw avals[MAXP], rval[2]; + int i, p = 0, q = 0; + double d; longint z; + + FPINIT; + + for (i = 0; tstring[i+1] != '\0'; i++) { + switch (tstring[i+1]) { + case 'C': + avals[q].sint = align_byte(bp[HEAD+p].i); + p += 1; q += 1; break; + case 'S': + avals[q].sint = align_short(bp[HEAD+p].i); + p += 1; q += 1; break; + case 'I': + avals[q].sint = bp[HEAD+p].i; + p += 1; q += 1; break; + case 'L': + z = get_long(&bp[HEAD+p]); + memcpy(avals[q].data, &z, sizeof(longint)); + p += 2; q += sizeof(longint)/sizeof(ffi_raw); break; + case 'F': + avals[q].flt = bp[HEAD+p].f; + p += 1; q += 1; break; + case 'D': + d = get_double(&bp[HEAD+p]); + memcpy(avals[q].data, &d, sizeof(double)); + p += 2; q += sizeof(double)/sizeof(ffi_raw); break; + case 'P': + avals[q].ptr = pointer(bp[HEAD+p]); + p += 1; q += 1; break; + case 'X': + avals[q].ptr = pointer(bp[HEAD+p]); + p += 2; q += 1; break; + case 'Q': + avals[q].ptr = ptrcast(uchar, get_long(&bp[HEAD+p])); + p += 2; q += 1; break; +#ifdef SPECIALS + case 'S': + /* Static link for compilers course -- ignored */ + p += 1; break; +#endif + default: + panic("Bad type 2 %c", tstring[i+1]); + } + } + + wrapper *w = pointer(cp[CP_CONST]); + ffi_raw_call(&w->cif, w->fun, rval, avals); + + switch (tstring[0]) { + case 'C': + case 'S': + case 'I': + (*--sp).i = rval->sint; + break; + case 'L': + memcpy(&z, rval, sizeof(longint)); + sp -= 2; + put_long(sp, z); + break; + case 'F': + (*--sp).f = rval->flt; + break; + case 'D': + memcpy(&d, rval, sizeof(double)); + sp -= 2; + put_double(sp, d); + break; + case 'P': + (*--sp).a = rval->uint; + break; + case 'Q': + sp -= 2; + put_long(sp, (ptrtype) rval->ptr); + break; + case 'V': + break; + default: + panic("Bad type 3"); + } + + return sp; +} +#endif + +primitive *find_prim(char *name) { + return (primitive *) dlsym(RTLD_DEFAULT, name); +} + +#else + +void load_lib(char *fname) { +} + +primitive *find_prim(char *name) { + int i; + + for (i = 0; primtab[i].p_name != NULL; i++) { + if (strcmp(name, primtab[i].p_name) == 0) + return primtab[i].p_prim; + } + + return NULL; +} + +#endif + +value *dltrap(value *bp) { + value *cp = valptr(bp[CP]); + char *tstring = pointer(cp[CP_CODE]); + char *name = tstring + strlen(tstring) + 1; + primitive *prim = NULL; + + if (*name == '=') name++; + + if (tstring[0] == '*') + prim = find_prim(name); + else { + /* Look for a static wrapper */ + char primname[32]; + sprintf(primname, "P_%s", name); + prim = find_prim(primname); + } + + if (prim != NULL) { + cp[CP_PRIM].a = wrap_prim(prim); + return (*prim)(bp); + } + +#ifdef DYNLINK +#ifdef USE_FFI + /* Build a wrapper with FFI */ + void (*fun)(void) = (void(*)(void)) dlsym(RTLD_DEFAULT, name); + + if (fun != NULL && tstring[0] != '*') { + int np = strlen(tstring)-1; + ffi_type *rtype = ffi_decode(tstring[0]); + ffi_type **atypes = scratch_alloc_atomic(np * sizeof(ffi_type *)); + for (int i = 0; tstring[i+1] != '\0'; i++) + atypes[i] = ffi_decode(tstring[i+1]); + + word a = virtual_alloc_atomic(sizeof(wrapper)); + wrapper *w = ptrcast(wrapper, a); + w->fun = fun; + ffi_prep_cif(&w->cif, FFI_DEFAULT_ABI, np, rtype, atypes); + + cp[CP_PRIM].a = dynstub; + cp[CP_CONST].a = a; + + return dlstub(bp); + } +#endif +#endif + + panic("Couldn't find primitive %s", name); + return NULL; +} |