/*=====================================================================*/
/*    serrano/prgm/project/bigloo/runtime/Clib/callcc.c                */
/*    -------------------------------------------------------------    */
/*    Author      :  Manuel Serrano                                    */
/*    Creation    :  Mon Sep 14 09:03:27 1992                          */
/*    Last change :  Sun Nov 16 15:04:25 2003 (serrano)                */
/*    -------------------------------------------------------------    */
/*    Implementing call/cc                                             */
/*=====================================================================*/
#include <string.h>
#include <bigloo.h>

/*---------------------------------------------------------------------*/
/*    Quelques petites macros                                          */
/*---------------------------------------------------------------------*/
#define BLOCK_SIZE 100   /* la taille d'accroissement de la pile.      */

/*---------------------------------------------------------------------*/
/*    On recupere la variable de bas de pile                           */
/*---------------------------------------------------------------------*/
extern long glob_dummy;

extern obj_t make_fx_procedure();
extern obj_t c_constant_string_to_string();

extern obj_t restore_stack();
extern obj_t unwind_stack_until( obj_t, obj_t, obj_t, obj_t );
extern bool_t unwind_stack_value_p( obj_t );
extern char *get_top_of_stack();

/*---------------------------------------------------------------------*/
/*    flush_regs_in_stack ...                                          */
/*---------------------------------------------------------------------*/
#if( defined( sparc ) )
extern int flush_regs_in_stack();
#endif

/*---------------------------------------------------------------------*/
/*    void                                                             */
/*    wind_stack ...                                                   */
/*    -------------------------------------------------------------    */
/*    We `wind' a stack. That is, we succesively invoke all the        */
/*    before thunk that have been pushed by `dynamic-wind'. This       */
/*    operation is the contrary of a `unwind-protect' that's why       */
/*    this function is called `wind-stack'.                            */
/*    -------------------------------------------------------------    */
/*    The global variable befored_top that has been restored when      */
/*    the old stack has been re-installed is the head of the list.     */
/*    Unfortunately we have to wind the stack from bottom to top.      */
/*    That is we have to inverse the list. We do this with a simple    */
/*    recursion.                                                       */
/*---------------------------------------------------------------------*/
void
wind_stack( struct befored *bfl ) {
   if( bfl )
   {
      obj_t proc = bfl->before;
      
      wind_stack( bfl->prev );
      
      if( !PROCEDURE_CORRECT_ARITYP( proc, 0 ) )
         the_failure( c_constant_string_to_string( "dynamic-wind" ),
                      c_constant_string_to_string( "illegal arity" ),
                      BINT( PROCEDURE_ARITY( proc ) ) );
      else
	 PROCEDURE_ENTRY( proc )( proc, BEOA );
   }
}
      
/*---------------------------------------------------------------------*/
/*    apply_continuation ...                                           */
/*    -------------------------------------------------------------    */
/*    When applying a continuation, we first unwind the stack.         */
/*    Either we reached the stack bottom and we have to restore        */
/*    the entirer stack. Either, we find the escape procedure          */
/*    and we stop.                                                     */
/*---------------------------------------------------------------------*/
obj_t
apply_continuation( obj_t kont, obj_t value ) {
   obj_t stack;
   obj_t restore;
   obj_t etop;
   obj_t estamp;

   if( !PROCEDUREP( kont ) ||
       ((obj_t)(PROCEDURE_ENTRY( kont )) != ((obj_t)&apply_continuation)) )
      /* We check if a kont is a legal continution by checking if */
      /* it is first a continuation and then if its entry is is   */
      /* apply continuation.                                      */
      the_failure(  c_constant_string_to_string( "apply_continuation" ),
		    c_constant_string_to_string( "continuation" ),
		    kont );
   
   stack   = CREF( PROCEDURE_REF( kont, 0 ) );
   etop    = STACK( stack ).exitd_top;
   estamp  = STACK( stack ).stamp;
   restore = make_fx_procedure( restore_stack, 1, 1 );

   /* restore stack traces */
   BGL_SET_TOP_OF_FRAME( STACK( stack ).top_frame );

   /* We check that the continuation is applied on the same thread */
   if( STACK( stack ).stack_bot != BGL_STACK_BOTTOM() )
      FAILURE( c_constant_string_to_string( "apply_continuation" ),
	       c_constant_string_to_string( "attempted to apply foreign continuation (created in another thread)" ),
 	       kont );
	 
   PROCEDURE_SET( restore, 0, kont );

   return unwind_stack_until( etop, estamp, value, restore );
}
 
/*---------------------------------------------------------------------*/
/*    blowup_window_register ...                                       */
/*    -------------------------------------------------------------    */
/*    On veut etre sur que le `longjmp' va restorer toutes les         */
/*    fenetres de registre. Pour s'assurer de cela, on fait des appels */
/*    recursifs pour que toutes les fenetres soient utilisees.         */
/*    -------------------------------------------------------------    */
/*    Il faut laisse le prototype de cette fonction en K&R autrement   */
/*    certains compilateurs ralent en disant que la fonction est       */
/*    appelee avec un mauvais nombre de parametres !                   */
/*---------------------------------------------------------------------*/
void
blowup_window_register( long counter, obj_t kont, obj_t value, ... ) {
#if( 0 <  NB_WINDOW_REGISTER )   
   if( counter < NB_WINDOW_REGISTER )
   {
      long x;
      
      glob_dummy = x;
       
      blowup_window_register( counter + 1, kont, value, &x );
   }
   else
#endif
   {
      /* from now on we cannot use local variables because */
      /* the stack will be erase.                          */
      static obj_t  stack;
      static char  *stack_top;
      static long   stack_size;
      static obj_t  s_value;
      static obj_t  stamp;

      s_value    = value;
      stack      = PROCEDURE_REF( kont, 0 );
      stack_top  = STACK( stack ).stack_top;
      stack_size = STACK( stack ).size;
      stamp      = STACK( stack ).stamp;
      
      /* on verifie que c'est bien une pile qu'on va restorer */
      if( (!STACKP( stack )) || (!EQP( CREF( stack ), STACK( stack ).self )) )
         FAILURE( c_constant_string_to_string( "apply_continuation" ),
                  c_constant_string_to_string( "not a C stack" ),
                  stack );
      else
      {
         /* restore the stack */
#if( STACK_GROWS_DOWN )
         memcpy( stack_top, &(STACK( stack ).stack), stack_size );
#else
         memcpy( BGL_STACK_BOTTOM(), &(STACK( stack ).stack), stack_size );
#endif
	 /* restore the global before link pointer */
	 BGL_BEFORED_TOP_SET( (STACK( stack ).before_top) );

	 /* and now evaluate all the before thunks */
	 wind_stack( BGL_BEFORED_TOP() );
      
	 /* restore bexit linking */
	 BGL_EXITD_TOP_SET( STACK( stack ).exitd_top );

         /* jump to the continuation */
	 unwind_stack_until( BGL_EXITD_TOP(), stamp, s_value, BFALSE );
      }
   } 
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    restore_stack ...                                                */
/*    -------------------------------------------------------------    */
/*    We cannot give an ANSI prototype for this function. It must be   */
/*    given a traditional declaration because it is invoked with more  */
/*    arguments that its prototype says.                               */
/*---------------------------------------------------------------------*/
obj_t
restore_stack( env, value )
obj_t env, value;
{
   char *stack_top, *actual_stack_top;
   obj_t stack;
   obj_t kont = PROCEDURE_REF( env, 0 );
   
   actual_stack_top = get_top_of_stack();
   stack            = PROCEDURE_REF( kont, 0 );
   stack_top        = STACK( stack ).stack_top;

   /* on fait grandire la pile jusqu'a ce qu'elle depasse stack_top */
#if( STACK_GROWS_DOWN )
   if( ((unsigned long)stack_top) <= (unsigned long)actual_stack_top)
#else 
   if( ((unsigned long)stack_top) >= (unsigned long)actual_stack_top )
#endif
   {
      char *dummy[ BLOCK_SIZE ];

      /* Je fais un appel recursif pour faire grandir la pile.        */
      /* C'est absolument atroce, mais je passe un arg supplementaire */
      /* a la fonction: dummy. La raison est que j'ai peur qu'un      */
      /* compilo tres intelligent s'apercoive que je n'utilise pas    */
      /* cette variable et donc qu'il me la supprime oubien que ce    */
      /* meme compilo fasse une optimisation sur un appel qui est     */
      /* recursif terminal et donc qu'il transforme cela en un goto,  */
      /* sans faire grandir la pile. D'autre part, comme la fonction  */
      /* `alloca' n'est pas standard et donc qu'il ne faut pas        */
      /* pour allouer sur la pile.                                    */
      /* En plus, afin, d'etre sur que dummy ne va pas etre mangee    */
      /* par un compilo trop intelligent, on la range dans une        */
      /* variable globale.                                            */
      glob_dummy = (long)dummy;
      restore_stack( env, value, dummy );
   } 
   else
      blowup_window_register( 0, kont, value );
   
   return BUNSPEC;
}

/*---------------------------------------------------------------------*/
/*    call_cc ...                                                      */
/*---------------------------------------------------------------------*/
obj_t
call_cc( obj_t proc ) {
   /* this variable _must_ be named jmpbuf because of SET_EXIT */
   /* that uses this name.                                     */
   jmp_buf jmpbuf; 

   if( !SET_EXIT( BUNSPEC ) ) 
   {
      obj_t         continuation;
      obj_t         stack;
      char         *stack_top;
      unsigned long stack_size;

      /* We push the exit taking care that it is a _user_ exit. */
      PUSH_EXIT( (obj_t)jmpbuf, ((bool_t) 1) );
      
      /* sur sparc, il est indispensables de flusher les registres. */
#if( defined( sparc ) )      
      flush_regs_in_stack();
#endif

      /* on recupere l'adresse du sommet de pile */
      stack_top = get_top_of_stack();
      
      /* on calcule la taille de la pile, en prevoyant que le GC peut */
      /* flusher les registres dans la pile (REGISTER_SAVE_BUFFER)    */
#if( STACK_GROWS_DOWN )
      stack_size = (unsigned long)BGL_STACK_BOTTOM() - (unsigned long)stack_top;
#else
      stack_size = (unsigned long)stack_top - (unsigned long)BGL_STACK_BOTTOM();
#endif

      { 
         obj_t aux;

         /* on alloue un espace pour la sauvegarder de la pile  */
         stack = MAKE_STACK( stack_size + sizeof(char *), aux );
      }

      STACK( stack ).size       = (long)stack_size;
      STACK( stack ).self       = CREF( stack );
      STACK( stack ).exitd_top  = BGL_EXITD_TOP();
      STACK( stack ).stamp      = ((struct exitd *)BGL_EXITD_TOP())->stamp;
      STACK( stack ).before_top = BGL_BEFORED_TOP();
      STACK( stack ).stack_top  = stack_top;
      STACK( stack ).stack_bot  = BGL_STACK_BOTTOM();
      STACK( stack ).top_frame  = BGL_GET_TOP_OF_FRAME();

      /* on construit la continuation */
      continuation = make_fx_procedure( &apply_continuation, 1, 1 );
      PROCEDURE_SET( continuation, 0, stack );

      /* on duplique la pile */
#if( STACK_GROWS_DOWN )
      memcpy( &(STACK( stack ).stack), (char *)stack_top, stack_size );
#else
      memcpy( &(STACK( stack ).stack), (char *)BGL_STACK_BOTTOM(), stack_size);
#endif
 
      /* on va faire l'application mais avant il faut qu'on test */
      /* que la fonction est correcte. Pour cela, on va verifier */
      /* que la fonction a une arite correcte.                   */
      /* Le test procedurep( proc ) a deja ete effectue dans la  */
      /* definition scheme de `call/cc'.                         */
      if( !PROCEDURE_CORRECT_ARITYP( proc, 1 ) ) {
         return the_failure( c_constant_string_to_string( "call/cc" ),
			     c_constant_string_to_string( "illegal arity" ),
			     BINT( PROCEDURE_ARITY( proc ) ) );
      }
      else
      {
	 obj_t val = PROCEDURE_ENTRY( proc )( proc, continuation, BEOA );

	 POP_EXIT();
	 return val;
      }
   }
   else
   {
      if( unwind_stack_value_p( _exit_value_ ) )
         return the_failure( c_constant_string_to_string( "call/cc" ),
			     c_constant_string_to_string( "illegal continuation" ),
			     BINT( PROCEDURE_ARITY( proc ) ) );
      else
	 return (obj_t)_exit_value_;
   }
}
