This is the mail archive of the guile@cygnus.com mailing list for the guile project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]

Re: Guile multiple interpreters / closed environments?


forcer wrote:
> 
> Hi there..
> I'm thinking about implementing a mod_guile (server-parsed files,
> similar to PHP, just with our favorite language) as a sparetime-job.
> 
> I hit a first problem there - If i add guile to apache via a module,
> it will have one global environment.
> Since i don't really want the parsed files to permanently change
> anything in the global environment, i'd like them to run in seperate
> interpreters (like tclinter, or a PerlInterpreter), but i don't see
> this possible from the current guile-implementation.
> 
> How can i accomplish something similar? E.g. using a seperate
> environment that will be gc'd after the script isn't running anymore?
> 

You could use a fresh module and root continuation for each script.
They would still be able to break things if they _really_ wanted
to, but I don't think it would be very easy to extend Guile to
supoport multiple interpreters. I can take a look though.

One thing you might find useful is the following patch which enhances
Guile with a scm_init_guile() function which can be called at any
time and will properly find the top of the stack and initialize
the Guile interpreter, so there is no need to use the 
gh_enter/scm_boot_guile protocol, which wants to take over your 
main(). I have not tested it heavily (just got it to work, in fact)
but I would appreciate others testing it and reporting back.

First, here's a trivial test program:


#include <guile/gh.h>

int
main(int argc, char **argv)
{
  scm_init_guile();
  gh_repl(argc, argv);
}


And here's the actual patch (against current Guile cvs, and you will
need to rerun autoheader and autoconf for it to work):

Index: configure.in
===================================================================
RCS file: /cvs/guile/guile/guile-core/configure.in,v
retrieving revision 1.79
diff -u -r1.79 configure.in
--- configure.in	1999/02/12 08:19:54	1.79
+++ configure.in	1999/02/26 12:27:05
@@ -288,10 +288,223 @@
 #
 #--------------------------------------------------------------------
 
+AC_MSG_CHECKING(which way stack grows)
+
 AC_TRY_RUN(aux (l) unsigned long l;
 	     { int x; exit (l >= ((unsigned long)&x)); }
 	   main () { int q; aux((unsigned long)&q); }, 
-	   AC_DEFINE(SCM_STACK_GROWS_UP),,AC_MSG_WARN(Guessing that stack grows down -- see
scmconfig.h.in))
+	[
+		AC_DEFINE(SCM_STACK_GROWS_UP)
+		AC_MSG_RESULT(up)
+	],[
+		AC_MSG_RESULT(down)
+	],AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h.in))
+
+
+AC_MSG_CHECKING(for __libc_stack_end)
+
+AC_TRY_LINK([
+],[
+*__libc_stack_end;
+],[
+    AC_DEFINE(HAVE_LIBC_STACK_END)
+    HAVE_LIBC_STACK_END=yes;
+], [
+    HAVE_LIBC_STACK_END=no;
+])
+
+AC_MSG_RESULT(${HAVE_LIBC_STACK_END})
+
+AC_MSG_CHECKING(for environ)
+
+AC_TRY_LINK([
+extern char **environ;
+],[
+*environ;
+],[
+    AC_DEFINE(HAVE_ENVIRON)
+    HAVE_ENVIRON=yes;
+],[
+    HAVE_ENVIRON=no;
+])
+
+
+AC_MSG_RESULT(${HAVE_ENVIRON})
+
+if test ${HAVE_ENVIRON}=yes
+then
+    AC_MSG_CHECKING(if environ points before the C stack)
+
+    AC_TRY_RUN([
+extern char **environ;
+
+int main()
+{
+    int test_var;
+#ifdef STACK_GROWS_UP
+    exit (!((void *)(&test_var) > (void *)(environ)));
+#else
+    exit (!((void *)(&test_var) < (void *)(environ)));
+#endif
+}
+    ],[
+	ENVIRON_ABOVE_STACK=yes;
+	AC_DEFINE(HAVE_ENVIRON_ABOVE_STACK)
+    ],[
+	ENVIRON_ABOVE_STACK=no;
+    ],[
+	ENVIRON_ABOVE_STACK=no;
+])
+
+    AC_MSG_RESULT(${HAVE_ENVIRON_ABOVE_STACK})
+fi
+
+AC_CHECK_FUNCS(siglongjmp sigsetjmp)
+
+AC_MSG_CHECKING(if walking the stack finds the stack limit)
+
+AC_TRY_RUN([
+#include <signal.h>
+#include <setjmp.h>
+
+#ifdef HAVE_SIGLONGJMP
+#define xlongjmp siglongjmp
+#define xsetjmp(buf) sigsetjmp(buf,0)
+#define xjmp_buf sigjmp_buf
+#elif defined(HAVE_LONGJMP)
+#define xlongjmp longjmp
+#define xsetjmp(buf) setjmp(buf)
+#define xjmp_buf jmp_buf
+#endif
+
+static xjmp_buf jbuf;
+
+void catch_segfault(int sig)
+{
+  xlongjmp(jbuf, 1);
+}
+    
+#ifdef HAVE_SIGACTION
+static struct sigaction saved_sigsegv_action;
+static struct sigaction saved_sigbus_action;
+
+void override_segfault_handler()
+{
+  struct sigaction act;
+  
+  act.sa_handler = catch_segfault;
+  act.sa_flags = 0;
+  
+  sigemptyset(&act.sa_mask);
+  sigaction(SIGSEGV, &act, &saved_sigsegv_action);
+#if defined(SIGBUS) && !(SIGSEGV == SIGBUS)
+  sigaction(SIGBUS, &act, &saved_sigbus_action);
+#endif
+}
+
+void restore_segfault_handler()
+{
+  sigaction(SIGSEGV, &saved_sigsegv_action, 0);
+#if defined(SIGBUS) && !(SIGSEGV == SIGBUS)
+  sigaction(SIGBUS, &saved_sigbus_action, 0);
+#endif
+}
+
+#elif defined(HAVE_SIGNAL)
+
+static void (*saved_sigsegv)();
+static void (*saved_sigbus)();
+
+void override_segfault_handler()
+{
+  saved_sigsegv = signal(SIGSEGV, catch_segfault);
+#if defined(SIGBUS) && !(SIGSEGV == SIGBUS)
+  saved_sigbus = signal(SIGBUS, catch_segfault);
+#endif
+}
+
+void restore_segfault_handler()
+{
+  signal(SIGSEGV, saved_sigsegv);
+#if defined(SIGBUS) && !(SIGBUS == SIGSEGV) 
+  signal(SIGBUS, saved_sigbus);
+#endif
+}
+#endif
+
+
+#define PAGE_SIZE_GUESS 256
+
+/* Return the contiguous readable address that is farthest from start
+   opposite the direction of stack growth. */
+
+void *walk_stack(void *start)
+{
+  volatile void *answer;
+  volatile unsigned long dummy;
+
+  override_segfault_handler();
+
+  if (xsetjmp(jbuf) == 0) {
+    answer = (void *)(((unsigned long)(start)) -
+                      ((unsigned long)(start) % PAGE_SIZE_GUESS));
+    while (1) {
+#ifdef STACK_GROWS_UP
+        answer = (void *)((char *)answer - PAGE_SIZE_GUESS);
+#else
+        answer = (void *)((char *)answer + PAGE_SIZE_GUESS);
+#endif
+      /* I believe this can't be optimized away, since dummy is
+         volatile. */
+        dummy=*((unsigned long *)answer);
+    }
+  }
+  restore_segfault_handler();
+
+#ifndef STACK_GROWS_UP
+    answer = (void *)((char *)answer + PAGE_SIZE_GUESS-1);
+#endif
+  
+  return (void *)(answer);
+}
+
+void *find_stack_base()
+{
+  unsigned long dummy;
+  
+  return(walk_stack((void *)(&dummy)));
+}
+
+
+int main()
+{
+  unsigned long outer_var;
+  void *base;
+
+  base=find_stack_base();
+
+#ifdef STACK_GROWS_UP
+  exit(!((unsigned long)base < (unsigned long)(void *)(&outer_var)));
+#else
+  exit(!((unsigned long)base > (unsigned long)(void *)(&outer_var)));
+#endif
+}
+    ],[
+	WALKING_STACK_WORKS=yes;
+	AC_DEFINE(GUILE_WALKING_STACK_WORKS)
+    ],[
+	WALKING_STACK_WORKS=no;
+    ],[
+	WALKING_STACK_WORKS=no;
+])
+
+AC_MSG_RESULT(${WALKING_STACK_WORKS})
+
+if test x${HAVE_LIBC_STACK_END} = xyes || test x${HAVE_ENVIORON_ABOVE_STACK} = xyes || \
+test x${WALKING_STACK_WORKS} = xyes; then
+    AC_DEFINE(GUILE_INIT)
+fi
+
 
 AC_CACHE_CHECK([whether floats fit in longs], guile_cv_type_float_fits_long,
     [AC_TRY_RUN([main () { exit (sizeof(float) > sizeof(long)); }],
Index: acconfig.h
===================================================================
RCS file: /cvs/guile/guile/guile-core/acconfig.h,v
retrieving revision 1.24
diff -u -r1.24 acconfig.h
--- acconfig.h	1999/01/10 07:41:56	1.24
+++ acconfig.h	1999/02/26 12:27:05
@@ -98,6 +98,9 @@
 /* Define to implement scm_internal_select */
 #undef GUILE_ISELECT
 
+/* Define to implement scm_init */
+#undef GUILE_INIT
+
 /* Define if using cooperative multithreading.  */
 #undef USE_COOP_THREADS
 
@@ -151,3 +154,23 @@
 
 /* Define if the compiler supports long longs.  */
 #undef HAVE_LONG_LONGS
+
+/* Define if the C library has a __libc_stack_end variable.  */
+#undef HAVE_LIBC_STACK_END
+
+/* Define if the C library has an environ variable.  */
+#undef HAVE_ENVIRON
+
+/* Define if environ points above the C stack. */
+#undef HAVE_ENVIRON_ABOVE_STACK
+
+/* Define if walking the stack until you segfault finds the top OK. */
+#undef GUILE_WALKING_STACK_WORKS
+
+
+
+
+
+
+
+
Index: libguile/init.c
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/init.c,v
retrieving revision 1.60
diff -u -r1.60 init.c
--- init.c	1999/01/10 07:54:50	1.60
+++ init.c	1999/02/26 12:27:05
@@ -330,8 +330,8 @@
 };
 
 
-static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base, 
-				     struct main_func_closure *closure));
+static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base));
+static SCM post_boot SCM_P ((void *body_data));
 static SCM invoke_main_func SCM_P ((void *body_data));
 
 
@@ -374,15 +374,66 @@
      end of the stack, and the address of one of its own local
      variables as the other end.  */
   SCM_STACKITEM dummy;
+  setjmp_type setjmp_val;
   struct main_func_closure c;
 
   c.main_func = main_func;
   c.closure = closure;
   c.argc = argc;
   c.argv = argv;
+
+  scm_boot_guile_1 (&dummy);
+
+  setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
+  if (!setjmp_val)
+    {
+      scm_set_program_arguments (argc, argv, 0);
+      scm_internal_lazy_catch (SCM_BOOL_T, invoke_main_func, &c,
+			       scm_handle_by_message, 0);
+    }
+
+  scm_restore_signals ();
+
+  /* This tick gives any pending
+   * asyncs a chance to run.  This must be done after
+   * the call to scm_restore_signals.
+   */
+  SCM_ASYNC_TICK;
+
+  /* If the caller doesn't want this, they should return from
+     main_func themselves.  */
+  exit (0);
+
+}
+
+
+#ifdef GUILE_INIT
+static void *find_stack_top(void);
+
+int
+scm_init_guile ()
+{
+  SCM_STACKITEM *start;
+  setjmp_type setjmp_val;
+
+  start = find_stack_top();
+
+  if (start != NULL) {
+    scm_boot_guile_1 (start);
+
+    setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
+    if (!setjmp_val)
+      {
+	scm_set_program_arguments(0, NULL, 0);
+	scm_internal_lazy_catch (SCM_BOOL_T, post_boot, NULL,
+				 scm_handle_by_message, 0);
+	return 1;
+      }
+  }
 
-  scm_boot_guile_1 (&dummy, &c);
+  return 0;
 }
+#endif
 
 
 /* Record here whether SCM_BOOT_GUILE_1 has already been called.  This
@@ -393,13 +444,11 @@
 int scm_boot_guile_1_live = 0;
 
 static void
-scm_boot_guile_1 (base, closure)
+scm_boot_guile_1 (base)
      SCM_STACKITEM *base;
-     struct main_func_closure *closure;
 {
   static int initialized = 0;
   /* static int live = 0; */
-  setjmp_type setjmp_val;
 
   /* This function is not re-entrant. */
   if (scm_boot_guile_1_live)
@@ -517,41 +566,175 @@
 #ifdef STACK_CHECKING
   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 #endif
-
-  setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
-  if (!setjmp_val)
-    {
-      scm_set_program_arguments (closure->argc, closure->argv, 0);
-      scm_internal_lazy_catch (SCM_BOOL_T, invoke_main_func, closure,
-			       scm_handle_by_message, 0);
-    }
 
-  scm_restore_signals ();
+}
 
-  /* This tick gives any pending
-   * asyncs a chance to run.  This must be done after
-   * the call to scm_restore_signals.
-   */
-  SCM_ASYNC_TICK;
+static SCM
+post_boot (body_data)
+     void *body_data;
+{
+  scm_load_startup_files ();
+  scm_post_boot_init_modules ();
 
-  /* If the caller doesn't want this, they should return from
-     main_func themselves.  */
-  exit (0);
+  return SCM_UNDEFINED;
 }
 
-
 static SCM
 invoke_main_func (body_data)
      void *body_data;
 {
   struct main_func_closure *closure = (struct main_func_closure *) body_data;
-
-  scm_load_startup_files ();
 
-  scm_post_boot_init_modules ();
-
+  post_boot(NULL);
   (*closure->main_func) (closure->closure, closure->argc, closure->argv);
 
   /* never reached */
   return SCM_UNDEFINED;
 }
+
+
+#ifdef GUILE_INIT
+
+#ifndef HAVE_LIBC_STACK_START
+/* This stuff is unnecessary if we have __libc_stack_start */
+
+#if defined(HAVE_SIGLONGJMP) && defined(HAVE_SIGSETJMP)
+#define ws_xlongjmp siglongjmp
+#define ws_xsetjmp(buf) sigsetjmp(buf,0)
+#define ws_xjmp_buf sigjmp_buf
+#else
+#define ws_xlongjmp longjmp
+#define ws_xsetjmp(buf) setjmp(buf)
+#define ws_xjmp_buf jmp_buf
+#endif
+
+static void walk_stack_catch_segfault(int sig);
+static void walk_stack_override_segfault_handler(void);
+static void walk_stack_restore_segfault_handler(void);
+static void *walk_stack(void *start);
+
+
+static ws_xjmp_buf ws_jbuf;
+
+static void 
+walk_stack_catch_segfault(int sig)
+{
+  ws_xlongjmp(ws_jbuf, 1);
+}
+
+    
+#ifdef HAVE_SIGACTION
+static struct sigaction saved_sigsegv_action;
+static struct sigaction saved_sigbus_action;
+
+static void 
+walk_stack_override_segfault_handler()
+{
+  struct sigaction act;
+  
+  act.sa_handler = walk_stack_catch_segfault;
+  act.sa_flags = 0;
+  
+  sigemptyset(&act.sa_mask);
+  sigaction(SIGSEGV, &act, &saved_sigsegv_action);
+#if defined(SIGBUS) && !(SIGSEGV == SIGBUS)
+  sigaction(SIGBUS, &act, &saved_sigbus_action);
+#endif
+}
+
+static void 
+walk_stack_restore_segfault_handler()
+{
+  sigaction(SIGSEGV, &saved_sigsegv_action, 0);
+#if defined(SIGBUS) && !(SIGSEGV == SIGBUS)
+  sigaction(SIGBUS, &saved_sigbus_action, 0);
+#endif
+}
+
+#elif defined(HAVE_SIGNAL)
+
+static void (*saved_sigsegv)();
+static void (*saved_sigbus)();
+
+static void 
+walk_stack_override_segfault_handler()
+{
+  saved_sigsegv = signal(SIGSEGV, walk_stack_catch_segfault);
+#if defined(SIGBUS) && !(SIGSEGV == SIGBUS)
+  saved_sigbus = signal(SIGBUS, walk_stack_catch_segfault);
+#endif
+}
+
+static void 
+walk_stack_restore_segfault_handler()
+{
+  signal(SIGSEGV, saved_sigsegv);
+#if defined(SIGBUS) && !(SIGBUS == SIGSEGV) 
+  signal(SIGBUS, saved_sigbus);
+#endif
+}
+#endif
+
+
+#define PAGE_SIZE_GUESS 256
+
+/* Return the contiguous readable address that is farthest from start
+   opposite the direction of stack growth. */
+
+
+static void *
+walk_stack(void *start)
+{
+  volatile void *answer;
+  volatile unsigned long dummy;
+
+  answer = NULL;
+
+  walk_stack_override_segfault_handler();
+
+  if (ws_xsetjmp(ws_jbuf) == 0) {
+    answer = (void *)(((unsigned long)(start)) -
+                      ((unsigned long)(start) % PAGE_SIZE_GUESS));
+    while (1) {
+      puts("step");
+#ifdef SCM_STACK_GROWS_UP
+        answer = (void *)((char *)answer - PAGE_SIZE_GUESS);
+#else
+        answer = (void *)((char *)answer + PAGE_SIZE_GUESS);
+#endif
+      /* I believe this can't be optimized away, since dummy is
+         volatile. */
+        dummy=*((unsigned long *)answer);
+    }
+  }
+  walk_stack_restore_segfault_handler();
+
+
+#ifndef SCM_STACK_GROWS_UP
+    answer = (void *)((char *)answer + PAGE_SIZE_GUESS-1);
+#endif
+  
+    return (void *)(answer);
+}
+#endif
+
+static void *
+find_stack_top()
+{
+#ifdef HAVE_LIBC_STACK_END
+  return *libc_stack_end;
+#elif defined(WALKING_STACK_WORKS)
+  int start;
+
+  return walk_stack((void *)(&start));
+#else /* HAVE_ENVIRON_ABOVE_STACK must be defined */
+  return environ;
+#endif
+
+}
+
+#endif
+
+
+
+