diff 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
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/dynlink.c	Thu Oct 05 08:04:15 2017 +0100
@@ -0,0 +1,261 @@
+/*
+ * 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"
+
+#ifdef DYNLINK
+
+#ifndef __USE_GNU
+#define __USE_GNU
+#endif
+#include <dlfcn.h>
+
+#ifdef USEFFI
+#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 USEFFI
+#define MAXP 16
+
+typedef struct {
+     void (*fun)(void);
+     ffi_cif cif;
+} wrapper;
+
+static ffi_type *ffi_decode(char c) {
+     switch (c) {
+     case 'C':
+     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;
+     }
+}
+
+void dlstub(value *bp) {
+     value *cp = valptr(bp[CP]);
+     char *tstring = (char *) pointer(cp[CP_CODE]);
+
+     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 '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 = (wrapper *) pointer(cp[CP_CONST]);
+     ffi_raw_call(&w->cif, w->fun, rval, avals);
+     
+     switch (tstring[0]) {
+     case 'C':
+     case 'I':
+          ob_res.i = rval->sint;
+          break;
+     case 'L':
+          memcpy(&z, rval, sizeof(longint));
+          put_long(&ob_res, z);
+          break;
+     case 'F':
+          ob_res.f = rval->flt;
+          break;
+     case 'D':
+          memcpy(&d, rval, sizeof(double));
+          put_double(&ob_res, d);
+          break;
+     case 'P':
+          ob_res.a = rval->uint;
+          break;
+     case 'Q':
+          put_long(&ob_res, (ptrtype) rval->ptr);
+          break;
+     case 'V':
+          break;
+     default:
+          panic("Bad type 3");
+     }
+}
+#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
+
+void dltrap(value *bp) {
+     value *cp = valptr(bp[CP]);
+     char *tstring = (char *) pointer(cp[CP_CODE]);
+     char *name = tstring + strlen(tstring) + 1;
+     primitive *prim = NULL;
+
+     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);
+          (*prim)(bp);
+          return;
+     }
+
+#ifdef DYNLINK
+#ifdef USEFFI
+     /* 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 =
+               (ffi_type **) scratch_alloc(np * sizeof(ffi_type *));
+          for (int i = 0; tstring[i+1] != '\0'; i++)
+               atypes[i] = ffi_decode(tstring[i+1]);
+
+          wrapper *w = (wrapper *) scratch_alloc(sizeof(wrapper));
+          w->fun = fun;
+          ffi_prep_cif(&w->cif, FFI_DEFAULT_ABI, np, rtype, atypes);
+
+          cp[CP_PRIM].a = dynstub;
+          cp[CP_CONST].a = address(w);
+
+          dlstub(bp);
+          return;
+     }
+#endif
+#endif
+
+     panic("Couldn't find primitive %s", name);
+}