* goops.c (TEST_CHANGE_CLASS): Use scm_change_object_class instead

[bpt/guile.git] / libguile / continuations.c

diff --git a/libguile/continuations.c b/libguile/continuations.c
index 3bf0f90..c44465b 100644 (file)
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -39,8 +39,6 @@
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.  */
 
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
-   gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
 
 \f
 
@@ -75,6 +73,12 @@ continuation_mark (SCM obj)
 
   scm_gc_mark (continuation->throw_value);
   scm_mark_locations (continuation->stack, continuation->num_stack_items);
+#ifdef __ia64__
+  if (continuation->backing_store)
+    scm_mark_locations (continuation->backing_store, 
+                        continuation->backing_store_size / 
+                        sizeof (SCM_STACKITEM));
+#endif /* __ia64__ */
   return continuation->dynenv;
 }
 
@@ -88,9 +92,13 @@ continuation_free (SCM obj)
     : 0;
   size_t bytes_free = sizeof (scm_t_contregs)
     + extra_items * sizeof (SCM_STACKITEM);
-  
-  scm_must_free (continuation);
-  return bytes_free;
+
+#ifdef __ia64__
+  scm_gc_free (continuation->backing_store, continuation->backing_store_size,
+              "continuation backing store");
+#endif /* __ia64__ */ 
+  scm_gc_free (continuation, bytes_free, "continuation");
+  return 0;
 }
 
 static int
@@ -106,6 +114,19 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
   return 1;
 }
 
+#ifdef __ia64__
+/* Extern declaration of getcontext()/setcontext() in order to redefine
+   getcontext() since on ia64-linux the second return value indicates whether
+   it returned from getcontext() itself or by running setcontext(). */
+struct rv
+{
+  long retval;
+  long first_return;
+};
+extern struct rv getcontext (ucontext_t *);
+extern int setcontext (ucontext_t *);
+#endif /* __ia64__ */
+
 /* this may return more than once: the first time with the escape
    procedure, then subsequently with the value to be passed to the
    continuation.  */
@@ -118,13 +139,16 @@ scm_make_continuation (int *first)
   scm_t_contregs *rootcont = SCM_CONTREGS (scm_rootcont);
   long stack_size;
   SCM_STACKITEM * src;
+#ifdef __ia64__
+  struct rv rv;
+#endif /* __ia64__ */
 
   SCM_ENTER_A_SECTION;
   SCM_FLUSH_REGISTER_WINDOWS;
   stack_size = scm_stack_size (rootcont->base);
-  continuation = scm_must_malloc (sizeof (scm_t_contregs)
-                                 + (stack_size - 1) * sizeof (SCM_STACKITEM),
-                                 FUNC_NAME);
+  continuation = scm_gc_malloc (sizeof (scm_t_contregs)
+                               + (stack_size - 1) * sizeof (SCM_STACKITEM),
+                               "continuation");
   continuation->num_stack_items = stack_size;
   continuation->dynenv = scm_dynwinds;
   continuation->throw_value = SCM_EOL;
@@ -141,16 +165,44 @@ scm_make_continuation (int *first)
 #endif
   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
 
+#ifdef __ia64__
+  rv = getcontext (&continuation->ctx);
+  if (rv.first_return)
+    {
+      continuation->backing_store_size = 
+        continuation->ctx.uc_mcontext.sc_ar_bsp - 
+        (unsigned long) __libc_ia64_register_backing_store_base;
+      continuation->backing_store = NULL;
+      continuation->backing_store = 
+        scm_gc_malloc (continuation->backing_store_size,
+                      "continuation backing store");
+      memcpy (continuation->backing_store, 
+              (void *) __libc_ia64_register_backing_store_base, 
+              continuation->backing_store_size);
+      *first = 1;
+      return cont;
+    }
+  else
+    {
+      SCM ret = continuation->throw_value;
+      *first = 0;
+      continuation->throw_value = SCM_BOOL_F;
+      return ret;
+    }
+#else /* !__ia64__ */
   if (setjmp (continuation->jmpbuf))
     {
+      SCM ret = continuation->throw_value;
       *first = 0;
-      return continuation->throw_value;
+      continuation->throw_value = SCM_BOOL_F;
+      return ret;
     }
   else
     {
       *first = 1;
       return cont;
     }
+#endif /* !__ia64__ */
 }
 #undef FUNC_NAME
 
@@ -191,7 +243,14 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
 #endif
 
   continuation->throw_value = val;
+#ifdef __ia64__
+  memcpy ((void *) __libc_ia64_register_backing_store_base,
+          continuation->backing_store,
+          continuation->backing_store_size);
+  setcontext (&continuation->ctx);
+#else
   longjmp (continuation->jmpbuf, 1);
+#endif
 }
 
 
@@ -211,7 +270,7 @@ scm_dynthrow (SCM cont, SCM val)
     grow_stack (cont, val);
 #else
   dst -= continuation->num_stack_items;
-  if (SCM_PTR_LE (dst, &stack_top_element))
+  if (dst <= &stack_top_element)
     grow_stack (cont, val);
 #endif /* def SCM_STACK_GROWS_UP */
 
@@ -232,7 +291,7 @@ continuation_apply (SCM cont, SCM args)
       || continuation->base != rootcont->base)
     {
       SCM_MISC_ERROR ("continuation from wrong top level: ~S", 
-                     SCM_LIST1 (cont));
+                     scm_list_1 (cont));
     }
   
   scm_dowinds (continuation->dynenv,
@@ -253,9 +312,7 @@ scm_init_continuations ()
   scm_set_smob_free (scm_tc16_continuation, continuation_free);
   scm_set_smob_print (scm_tc16_continuation, continuation_print);
   scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
-#ifndef SCM_MAGIC_SNARFER
 #include "libguile/continuations.x"
-#endif
 }
 
 /*