Skip to content
Snippets Groups Projects
Select Git revision
21 results Searching

interpret.c

Blame
  • interpret.c 95.22 KiB
    /*
    || This file is part of Pike. For copyright information see COPYRIGHT.
    || Pike is distributed under GPL, LGPL and MPL. See the file COPYING
    || for more information.
    */
    
    #include "global.h"
    #include "interpret.h"
    #include "object.h"
    #include "program.h"
    #include "svalue.h"
    #include "array.h"
    #include "mapping.h"
    #include "pike_error.h"
    #include "stralloc.h"
    #include "constants.h"
    #include "pike_macros.h"
    #include "multiset.h"
    #include "backend.h"
    #include "operators.h"
    #include "opcodes.h"
    #include "pike_embed.h"
    #include "lex.h"
    #include "builtin_functions.h"
    #include "signal_handler.h"
    #include "gc.h"
    #include "threads.h"
    #include "callback.h"
    #include "fd_control.h"
    #include "pike_security.h"
    #include "bignum.h"
    #include "pike_types.h"
    #include "pikecode.h"
    
    #include <fcntl.h>
    #include <errno.h>
    #include <ctype.h>
    
    #ifdef HAVE_MMAP
    #ifdef HAVE_SYS_TYPES_H
    #include <sys/types.h>
    #endif
    
    #ifdef HAVE_SYS_MMAN_H
    #include <sys/mman.h>
    #endif
    
    #ifdef MAP_NORESERVE
    #define USE_MMAP_FOR_STACK
    #endif
    #endif
    
    #ifdef USE_DTRACE
    #include "dtrace_probes.h"
    #else
    #include "dtrace/dtrace_probes_disabled.h"
    #endif
    
    /*
     * Define the default evaluator stack size, used for just about everything.
     */
    #define EVALUATOR_STACK_SIZE	100000
    
    #define TRACE_LEN (100 + Pike_interpreter.trace_level * 10)
    
    /* Keep some margin on the stack space checks. They're lifted when
     * handle_error runs to give it some room. */
    /* Observed in 7.1: 40 was enough, 30 wasn't. */
    #define SVALUE_STACK_MARGIN (100 + LOW_SVALUE_STACK_MARGIN)
    /* Observed in 7.4: 11000 was enough, 10000 wasn't. */
    #define C_STACK_MARGIN (20000 + LOW_C_STACK_MARGIN)
    
    /* Another extra margin to use while dumping the raw error in
     * exit_on_error, so that backtrace_frame._sprintf can be called
     * then. */
    #define LOW_SVALUE_STACK_MARGIN 20
    #define LOW_C_STACK_MARGIN 500
    
    #ifdef HAVE_COMPUTED_GOTO
    PIKE_OPCODE_T *fcode_to_opcode = NULL;
    struct op_2_f *opcode_to_fcode = NULL;
    #endif /* HAVE_COMPUTED_GOTO */
    
    PMOD_EXPORT const char Pike_check_stack_errmsg[] =
      "Svalue stack overflow. "
      "(%ld of %ld entries on stack, needed %ld more entries)\n";
    PMOD_EXPORT const char Pike_check_mark_stack_errmsg[] =
      "Mark stack overflow.\n";
    PMOD_EXPORT const char Pike_check_c_stack_errmsg[] =
      "C stack overflow.\n";
    #ifdef PIKE_DEBUG
    PMOD_EXPORT const char msg_stack_error[] =
      "Stack error.\n";
    PMOD_EXPORT const char msg_pop_neg[] =
      "Popping negative number of args.... (%"PRINTPTRDIFFT"d) \n";
    #endif
    
    
    #ifdef PIKE_DEBUG
    static char trace_buffer[2000];
    #endif
    
    #ifdef INTERNAL_PROFILING
    PMOD_EXPORT unsigned long evaluator_callback_calls = 0;
    #endif
    
    
    int fast_check_threads_counter = 0;
    
    PMOD_EXPORT int Pike_stack_size = EVALUATOR_STACK_SIZE;
    
    static void do_trace_call(INT32 args, dynamic_buffer *old_buf);
    static void do_trace_func_return (int got_retval, struct object *o, int fun);
    static void do_trace_return (int got_retval, dynamic_buffer *old_buf);
    
    void push_sp_mark(void)
    {
      if(Pike_mark_sp == Pike_interpreter.mark_stack + Pike_stack_size)
        Pike_error("No more mark stack!\n");
      *Pike_mark_sp++=Pike_sp;
    }
    ptrdiff_t pop_sp_mark(void)
    {
    #ifdef PIKE_DEBUG
      if(Pike_mark_sp < Pike_interpreter.mark_stack)
        Pike_fatal("Mark stack underflow!\n");
    #endif
      return Pike_sp - *--Pike_mark_sp;
    }
    
    
    #ifdef PIKE_DEBUG
    void gc_mark_stack_external (struct pike_frame *f,
    			     struct svalue *stack_p, struct svalue *stack)
    {
      for (; f; f = f->next)
        GC_ENTER (f, T_PIKE_FRAME) {
          if (!debug_gc_check (f, " as frame on stack")) {
    	gc_mark_external (f->current_object, " in current_object in frame on stack");
    	gc_mark_external (f->current_program, " in current_program in frame on stack");
    	if (f->locals) {		/* Check really needed? */
    	  if (f->flags & PIKE_FRAME_MALLOCED_LOCALS) {
    	    gc_mark_external_svalues(f->locals, f->num_locals,
    				     " in malloced locals of trampoline frame on stack");
    	  } else {
    	    if (f->locals > stack_p || (stack_p - f->locals) >= 0x10000) {
    	      fatal("Unreasonable locals: stack:%p locals:%p\n",
    		    stack_p, f->locals);
    	    }
    	    gc_mark_external_svalues (f->locals, stack_p - f->locals, " on svalue stack");
    	    stack_p = f->locals;
    	  }
    	}
          }
        } GC_LEAVE;
      if (stack != stack_p)
        gc_mark_external_svalues (stack, stack_p - stack, " on svalue stack");
    }
    
    static void gc_check_stack_callback(struct callback *UNUSED(foo), void *UNUSED(bar), void *UNUSED(gazonk))
    {
      if (Pike_interpreter.evaluator_stack
    #ifdef PIKE_DEBUG
          /* Avoid this if the thread is swapped out. Useful when calling
           * locate_references from gdb. */
          && Pike_sp != (void *) -1
    #endif
         )
        gc_mark_stack_external (Pike_fp, Pike_sp, Pike_interpreter.evaluator_stack);
    }
    #endif
    
    /* Execute Pike code starting at pc.
     *
     * Called once with NULL to initialize tables.
     *
     * Returns 0 if pc is NULL.
     *
     * Returns -1 if the code terminated due to a RETURN.
     *
     * Note: All callers except catching_eval_instruction need to save
     * Pike_interpreter.catching_eval_jmpbuf, zero it, and restore it
     * afterwards.
     */
    static int eval_instruction(PIKE_OPCODE_T *pc);
    
    PMOD_EXPORT int low_init_interpreter(struct Pike_interpreter_struct *interpreter)
    {
    #ifdef USE_MMAP_FOR_STACK
      static int fd = -1;
    
    #ifndef MAP_VARIABLE
    #define MAP_VARIABLE 0
    #endif
    
    #ifndef MAP_PRIVATE
    #define MAP_PRIVATE 0
    #endif
    
    #ifndef MAP_FAILED
    #define MAP_FAILED -1
    #endif
    
    #ifndef MAP_ANONYMOUS
    #define MAP_ANONYMOUS 0
      if(fd == -1)
      {
        while(1)
        {
          fd=open("/dev/zero",O_RDONLY);
          if(fd >= 0) break;
          if(errno != EINTR)
          {
    	interpreter->evaluator_stack=0;
    	interpreter->mark_stack=0;
    	goto use_malloc;
    #define NEED_USE_MALLOC_LABEL
          }
        }
        /* Don't keep this fd on exec() */
        set_close_on_exec(fd, 1);
      }
    #endif
    
    #define MMALLOC(X,Y)							\
      (Y *)mmap(0, (X)*sizeof(Y), PROT_READ|PROT_WRITE,			\
    	    MAP_NORESERVE|MAP_PRIVATE|MAP_ANONYMOUS, fd, 0)
    
      interpreter->evaluator_stack_malloced = 0;
      interpreter->mark_stack_malloced = 0;
      interpreter->evaluator_stack = MMALLOC(Pike_stack_size,struct svalue);
      interpreter->mark_stack = MMALLOC(Pike_stack_size, struct svalue *);
      if((char *)MAP_FAILED == (char *)interpreter->evaluator_stack) {
        interpreter->evaluator_stack = 0;
        interpreter->evaluator_stack_malloced = 1;
      }
      if((char *)MAP_FAILED == (char *)interpreter->mark_stack) {
        interpreter->mark_stack = 0;
        interpreter->mark_stack_malloced = 1;
      }
    
    #ifdef NEED_USE_MALLOC_LABEL
    use_malloc:
    #endif /* NEED_USE_MALLOC_LABEL */
    
    #else /* !USE_MMAP_FOR_STACK */
      interpreter->evaluator_stack = 0;
      interpreter->evaluator_stack_malloced = 1;
      interpreter->mark_stack = 0;
      interpreter->mark_stack_malloced = 1;
    #endif /* USE_MMAP_FOR_STACK */
    
      if(!interpreter->evaluator_stack)
      {
        if (!(interpreter->evaluator_stack =
    	  (struct svalue *)malloc(Pike_stack_size*sizeof(struct svalue))))
          return 1;	/* Out of memory (evaluator stack). */
      }
    
      if(!interpreter->mark_stack)
      {
        if (!(interpreter->mark_stack =
    	  (struct svalue **)malloc(Pike_stack_size*sizeof(struct svalue *))))
          return 2;	/* Out of memory (mark stack). */
      }
    
      interpreter->stack_pointer = interpreter->evaluator_stack;
      interpreter->mark_stack_pointer = interpreter->mark_stack;
      interpreter->frame_pointer = 0;
      interpreter->catch_ctx = NULL;
      interpreter->catching_eval_jmpbuf = NULL;
    
      interpreter->svalue_stack_margin = SVALUE_STACK_MARGIN;
      interpreter->c_stack_margin = C_STACK_MARGIN;
    
    #ifdef PROFILING
      interpreter->unlocked_time = 0;
      interpreter->accounted_time = 0;
    #endif
    
      interpreter->trace_level = default_t_flag;
    
      return 0;	/* OK. */
    }
    
    static struct pike_frame *free_pike_frame;
    
    PMOD_EXPORT void init_interpreter(void)
    {
    #ifdef USE_VALGRIND
      {
        static int create_mempool = 1;
    
        if (create_mempool) {
          PIKE_MEMPOOL_CREATE(&free_pike_frame);
          create_mempool = 0;
        }
      }
    #endif
      if (low_init_interpreter(Pike_interpreter_pointer)) {
        Pike_fatal("Out of memory initializing the interpreter stack.\n");
      }
    
    #ifdef PIKE_DEBUG
      {
        static struct callback *spcb;
        if(!spcb)
        {
          spcb=add_gc_callback(gc_check_stack_callback,0,0);
          dmalloc_accept_leak(spcb);
        }
      }
    #endif
    #if defined(HAVE_COMPUTED_GOTO) || defined(PIKE_USE_MACHINE_CODE)
      {
        static int tables_need_init=1;
        if(tables_need_init) {
          /* Initialize the fcode_to_opcode table / jump labels. */
    #if !defined(OPCODE_INLINE_RETURN)
          eval_instruction(NULL);
    #endif
    #if defined(PIKE_USE_MACHINE_CODE) && !defined(PIKE_DEBUG)
          /* Simple operator opcodes... */
    #define SET_INSTR_ADDRESS(X, Y)	(instrs[(X)-F_OFFSET].address = (void *)Y)
          SET_INSTR_ADDRESS(F_COMPL,		o_compl);
          SET_INSTR_ADDRESS(F_LSH,			o_lsh);
          SET_INSTR_ADDRESS(F_RSH,			o_rsh);
          SET_INSTR_ADDRESS(F_SUBTRACT,		o_subtract);
          SET_INSTR_ADDRESS(F_AND,			o_and);
          SET_INSTR_ADDRESS(F_OR,			o_or);
          SET_INSTR_ADDRESS(F_XOR,			o_xor);
          SET_INSTR_ADDRESS(F_MULTIPLY,		o_multiply);
          SET_INSTR_ADDRESS(F_DIVIDE,		o_divide);
          SET_INSTR_ADDRESS(F_MOD,			o_mod);
          SET_INSTR_ADDRESS(F_CAST,			f_cast);
          SET_INSTR_ADDRESS(F_CAST_TO_INT,		o_cast_to_int);
          SET_INSTR_ADDRESS(F_CAST_TO_STRING,	o_cast_to_string);
          SET_INSTR_ADDRESS(F_RANGE,		o_range2);
          SET_INSTR_ADDRESS(F_SSCANF,		o_sscanf);
    #endif /* PIKE_USE_MACHINE_CODE && !PIKE_DEBUG */
          tables_need_init=0;
    #ifdef INIT_INTERPRETER_STATE
          INIT_INTERPRETER_STATE();
    #endif
        }
      }
    #endif /* HAVE_COMPUTED_GOTO || PIKE_USE_MACHINE_CODE */
    }
    
    /*
     * lvalues are stored in two svalues in one of these formats:
     * array[index]   : { array, index } 
     * mapping[index] : { mapping, index } 
     * multiset[index] : { multiset, index } 
     * object[index] : { object, index } (external object indexing)
     * local variable : { svalue pointer (T_SVALUE_PTR), nothing (T_VOID) }
     * global variable : { object, identifier index (T_OBJ_INDEX) } (internal object indexing)
     * lvalue array: { T_ARRAY_LVALUE, array with lvalue pairs }
     */
    
    void lvalue_to_svalue_no_free(struct svalue *to,struct svalue *lval)
    {
    #ifdef PIKE_SECURITY
      if(TYPEOF(*lval) <= MAX_COMPLEX)
        if(!CHECK_DATA_SECURITY(lval->u.array, SECURITY_BIT_INDEX))
          Pike_error("Index permission denied.\n");
    #endif
      switch(TYPEOF(*lval))
      {
       case T_ARRAY_LVALUE:
        {
          INT32 e;
          struct array *a;
          TYPE_FIELD types = 0;
          ONERROR err;
          a=allocate_array(lval[1].u.array->size>>1);
          SET_ONERROR(err, do_free_array, a);
          for(e=0;e<a->size;e++) {
    	lvalue_to_svalue_no_free(ITEM(a)+e, ITEM(lval[1].u.array)+(e<<1));
    	types |= 1 << TYPEOF(ITEM(a)[e]);
          }
          a->type_field = types;
          SET_SVAL(*to, T_ARRAY, 0, array, a);
          UNSET_ONERROR(err);
          break;
        }
          
        case T_SVALUE_PTR:
          dmalloc_touch_svalue(lval->u.lval);
          assign_svalue_no_free(to, lval->u.lval);
          break;
    
        case T_OBJECT:
          /* FIXME: Object subtypes! */
          if (TYPEOF(lval[1]) == T_OBJ_INDEX)
    	low_object_index_no_free (to, lval->u.object, lval[1].u.identifier);
          else
    	object_index_no_free(to, lval->u.object, SUBTYPEOF(*lval), lval+1);
          break;
          
        case T_ARRAY:
          simple_array_index_no_free(to, lval->u.array, lval+1);
          break;
          
        case T_MAPPING:
          mapping_index_no_free(to, lval->u.mapping, lval+1);
          break;
          
        case T_MULTISET:
          if(multiset_member(lval->u.multiset,lval+1))
          {
    	SET_SVAL(*to, T_INT, NUMBER_NUMBER, integer, 1);
          }else{
    	SET_SVAL(*to, T_INT, NUMBER_UNDEFINED, integer, 0);
          }
          break;
          
        default:
          if(SAFE_IS_ZERO(lval))
    	index_error(0,0,0,lval,lval+1,"Indexing the NULL value.\n");
          else
    	index_error(0,0,0,lval,lval+1,"Indexing a basic type.\n");
      }
    }
    
    PMOD_EXPORT void assign_lvalue(struct svalue *lval,struct svalue *from)
    {
    #ifdef PIKE_SECURITY
      if(TYPEOF(*lval) <= MAX_COMPLEX)
        if(!CHECK_DATA_SECURITY(lval->u.array, SECURITY_BIT_SET_INDEX))
          Pike_error("Assign index permission denied.\n");
    #endif
    
      switch(TYPEOF(*lval))
      {
        case T_ARRAY_LVALUE:
        {
          INT32 e;
          if(TYPEOF(*from) != T_ARRAY)
    	Pike_error("Trying to assign combined lvalue from non-array.\n");
    
          if(from->u.array->size < (lval[1].u.array->size>>1))
    	Pike_error("Not enough values for multiple assign.\n");
    
          if(from->u.array->size > (lval[1].u.array->size>>1))
    	Pike_error("Too many values for multiple assign.\n");
    
          for(e=0;e<from->u.array->size;e++)
    	assign_lvalue(lval[1].u.array->item+(e<<1),from->u.array->item+e);
        }
        break;
    
      case T_SVALUE_PTR:
        dmalloc_touch_svalue(from);
        dmalloc_touch_svalue(lval->u.lval);
        assign_svalue(lval->u.lval,from);
        break;
    
      case T_OBJECT:
        /* FIXME: Object subtypes! */
        if (TYPEOF(lval[1]) == T_OBJ_INDEX)
          object_low_set_index (lval->u.object, lval[1].u.identifier, from);
        else
          object_set_index(lval->u.object, SUBTYPEOF(*lval), lval+1, from);
        break;
    
      case T_ARRAY:
        simple_set_index(lval->u.array, lval+1, from);
        break;
    
      case T_MAPPING:
        mapping_insert(lval->u.mapping, lval+1, from);
        break;
    
      case T_MULTISET:
        if(UNSAFE_IS_ZERO(from))
          multiset_delete(lval->u.multiset, lval+1);
        else
          multiset_insert(lval->u.multiset, lval+1);
        break;
        
      default:
       if(SAFE_IS_ZERO(lval))
         index_error(0,0,0,lval,lval+1,"Indexing the NULL value.\n");
       else
         index_error(0,0,0,lval,lval+1,"Indexing a basic type.\n");
      }
    }
    
    /* On error callback. lvalue is followed by value to assign. */
    static void o_assign_lvalue(struct svalue *lvalue)
    {
      assign_lvalue(lvalue, lvalue+2);
    }
    
    union anything *get_pointer_if_this_type(struct svalue *lval, TYPE_T t)
    {
    #ifdef PIKE_SECURITY
      if(TYPEOF(*lval) <= MAX_COMPLEX)
        if(!CHECK_DATA_SECURITY(lval->u.array, SECURITY_BIT_SET_INDEX))
          Pike_error("Assign index permission denied.\n");
    #endif
    
      switch(TYPEOF(*lval))
      {
        case T_ARRAY_LVALUE:
          return 0;
          
        case T_SVALUE_PTR:
          dmalloc_touch_svalue(lval->u.lval);
          if(TYPEOF(*(lval->u.lval)) == t) return & ( lval->u.lval->u );
          return 0;
    
        case T_OBJECT:
          /* FIXME: What about object subtypes? */
          return object_get_item_ptr(lval->u.object, SUBTYPEOF(*lval), lval+1, t);
          
        case T_ARRAY:
          return array_get_item_ptr(lval->u.array,lval+1,t);
          
        case T_MAPPING:
          return mapping_get_item_ptr(lval->u.mapping,lval+1,t);
    
        case T_MULTISET: return 0;
          
        default:
          if(SAFE_IS_ZERO(lval))
    	index_error(0,0,0,lval,lval+1,"Indexing the NULL value.\n");
          else
    	index_error(0,0,0,lval,lval+1,"Indexing a basic type.\n");
          return 0;
      }
    }
    
    #ifdef PIKE_DEBUG
    
    INLINE void pike_trace(int level,char *fmt, ...) ATTRIBUTE((format (printf, 2, 3)));
    INLINE void pike_trace(int level,char *fmt, ...)
    {
      if(Pike_interpreter.trace_level > level)
      {
        va_list args;
        va_start(args,fmt);
        vsprintf(trace_buffer,fmt,args);
        va_end(args);
        write_to_stderr(trace_buffer,strlen(trace_buffer));
      }
    }
    
    void my_describe_inherit_structure(struct program *p)
    {
      struct inherit *in,*last=0;
      int e,i=0;
      last=p->inherits-1;
    
      fprintf(stderr,"PROGRAM[%d]: inherits=%d identifers_refs=%d ppid=%d\n",
    	  p->id,
    	  p->num_inherits,
    	  p->num_identifier_references,
    	  p->parent ? p->parent->id : -1);
      for(e=0;e<p->num_identifier_references;e++)
      {
        in=INHERIT_FROM_INT(p,e);
        while(last < in)
        {
          last++;
          fprintf(stderr,
    	      "[%ld]%*s parent{ offset=%d ident=%d id=%d } "
    	      "id{ level=%d } prog=%d\n",
    	      DO_NOT_WARN((long)(last - p->inherits)),
    	      last->inherit_level*2,"",
    	      last->parent_offset,
    	      last->parent_identifier,
    	      last->prog->parent ? last->prog->parent->id : -1,
    	      last->identifier_level,
    	      last->prog->id);
          i=0;
        }
    
        fprintf(stderr,"   %*s %d,%d: %s\n",
    	      in->inherit_level*2,"",
    	      e,i,
    	    ID_FROM_INT(p,e)->name->str);
        i++;
      }
    }
    
    #define TRACE(X) pike_trace X
    #else
    #define TRACE(X)
    #endif
    
    static struct inherit dummy_inherit
    #ifdef PIKE_DEBUG
      = {-4711, -4711, -4711, -4711, (size_t) -4711, -4711, NULL, NULL, NULL}
    #endif
    ;
    
    /* Find the lexical scope @[depth] levels out.
     *
     * @[loc]:
     *   Input:
     *     struct object *o		// object to start from.
     *     struct inherit *inherit	// inherit in o->prog.
     *    (int parent_identifier)	// identifier in o to start from.
     *                              // Only if depth == 0.
     *
     *   Output:
     *     struct object *o		// object containing the scope.
     *     struct inherit *inherit	// inherit in o->prog being the scope.
     *     int parent_identifier	// identifier in o from the inherit.
     */
    PMOD_EXPORT void find_external_context(struct external_variable_context *loc,
    				       int depth)
    {
      struct program *p;
    
      TRACE((4, "-find_external_context(%d, inherit=%ld)\n", depth,
    	 DO_NOT_WARN((long)(loc->o->prog ? loc->inherit - loc->o->prog->inherits : 0))));
    
    #ifdef PIKE_DEBUG
      if(!loc->o)
        Pike_fatal("No object\n");
    #endif
    
      if (!(p = loc->o->prog)) {
        /* magic fallback */
        p = get_program_for_object_being_destructed(loc->o);
        if(!p)
        {
          Pike_error("Cannot access parent of destructed object.\n");
        }
      }
    
    #ifdef DEBUG_MALLOC
      if (loc->o->refs == 0x55555555) {
        fprintf(stderr, "The object %p has been zapped!\n", loc->o);
        describe(p);
        Pike_fatal("Object zapping detected.\n");
      }
      if (p && p->refs == 0x55555555) {
        fprintf(stderr, "The program %p has been zapped!\n", p);
        describe(p);
        fprintf(stderr, "Which taken from the object %p\n", loc->o);
        describe(loc->o);
        Pike_fatal("Looks like the program %p has been zapped!\n", p);
      }
    #endif /* DEBUG_MALLOC */
    
      while(--depth>=0)
      {
        struct inherit *inh = loc->inherit;
    
        if (!p)
          Pike_error("Attempting to access parent of destructed object.\n");
    
    #ifdef PIKE_DEBUG  
        if(Pike_interpreter.trace_level>8)
          my_describe_inherit_structure(p);
    #endif
    
        TRACE((4,"-   i->parent_offset=%d i->parent_identifier=%d\n",
    	   inh->parent_offset,
    	   inh->parent_identifier));
    
        TRACE((4,"-   o->parent_identifier=%d inherit->identifier_level=%d\n",
    	   (p->flags & PROGRAM_USES_PARENT) ?
    	   LOW_PARENT_INFO(loc->o, p)->parent_identifier : -1,
    	   inh->identifier_level));
    
        switch(inh->parent_offset)
        {
          default:
    	{
    	  /* Find the program that inherited us. */
    	  int my_level = inh->inherit_level;
    #ifdef PIKE_DEBUG
    	  if(!my_level)
    	    Pike_fatal("Gahhh! inherit level zero in wrong place!\n");
    #endif
    	  while(loc->inherit->inherit_level >= my_level)
    	  {
    	    TRACE((5,"-   inherit-- (%d >= %d)\n",
    		   loc->inherit->inherit_level, my_level));
    	    loc->inherit--;
    	    TRACE((5, "-   identifier_level: %d\n",
    		   loc->inherit->identifier_level));
    	  }
    
    	  find_external_context(loc, inh->parent_offset);
    	  TRACE((5,
    		 "-    inh->parent_identifier: %d\n"
    		 "-    inh->identifier_level: %d\n"
    		 "-    loc->parent_identifier: %d\n"
    		 "-    loc->inherit->parent_offset: %d\n"
    		 "-    loc->inherit->identifier_level: %d\n",
    		 inh->parent_identifier,
    		 inh->identifier_level,
    		 loc->parent_identifier,
    		 loc->inherit->parent_offset,
    		 loc->inherit->identifier_level));
    
    	  loc->parent_identifier =
    	    inh->parent_identifier +
    	    loc->inherit->identifier_level;
    	  TRACE((5, "-    parent_identifier: %d\n", loc->parent_identifier));
    	}
    	break;
    
          case INHERIT_PARENT:
    	TRACE((5,"-   Following inherit->parent\n"));
    	loc->parent_identifier=inh->parent_identifier;
    	loc->o=inh->parent;
    #ifdef PIKE_DEBUG  
    	TRACE((5, "-   parent_identifier: %d\n"
    	       "-   o: %p\n"
    	       "-   inh: %"PRINTPTRDIFFT"d\n",
    	       loc->parent_identifier,
    	       loc->o,
    	       loc->inherit - loc->o->prog->inherits));
    	if(Pike_interpreter.trace_level>5) {
    	  dump_program_tables(loc->o->prog, 4);
    	}
    #endif
    	break;
    
          case OBJECT_PARENT:
    	TRACE((5,"-   Following o->parent\n"));
    
    #ifdef PIKE_DEBUG
    	/* Can this happen legitimately? Well, someone will hopefully
    	 * let me know in that case. /mast */
    	if (!(p->flags & PROGRAM_USES_PARENT))
    	  Pike_fatal ("Attempting to access parent of object without parent pointer.\n");
    #endif
    
    	loc->parent_identifier=LOW_PARENT_INFO(loc->o,p)->parent_identifier;
    	loc->o=LOW_PARENT_INFO(loc->o,p)->parent;
    #ifdef PIKE_DEBUG  
    	TRACE((5, "-   parent_identifier: %d\n"
    	       "-   o: %p\n",
    	       loc->parent_identifier,
    	       loc->o));
    	if(Pike_interpreter.trace_level>5) {
    	  dump_program_tables(loc->o->prog, 4);
    	}
    #endif
    	break;
        }
    
    #ifdef PIKE_DEBUG
        /* I don't think this should happen either. The gc doesn't zap the
         * pointer even if the object is destructed, at least. /mast */
        if (!loc->o) Pike_fatal ("No parent object.\n");
    #endif
    
        p = loc->o->prog;
    
    #ifdef DEBUG_MALLOC
        if (loc->o->refs == 0x55555555) {
          fprintf(stderr, "The object %p has been zapped!\n", loc->o);
          describe(p);
          Pike_fatal("Object zapping detected.\n");
        }
        if (p && p->refs == 0x55555555) {
          fprintf(stderr, "The program %p has been zapped!\n", p);
          describe(p);
          fprintf(stderr, "Which taken from the object %p\n", loc->o);
          describe(loc->o);
          Pike_fatal("Looks like the program %p has been zapped!\n", p);
        }
    #endif /* DEBUG_MALLOC */
    
        if (p) {
    #ifdef PIKE_DEBUG
          if(loc->parent_identifier < 0 ||
    	 loc->parent_identifier > p->num_identifier_references)
    	Pike_fatal("Identifier out of range, loc->parent_identifer=%d!\n",
    		   loc->parent_identifier);
    #endif
          loc->inherit=INHERIT_FROM_INT(p, loc->parent_identifier);
          TRACE((5, "-   loc->inherit: %"PRINTPTRDIFFT"d\n",
    	     loc->inherit - loc->o->prog->inherits));
        }
        else
          /* Return a valid pointer to a dummy inherit for the convenience
           * of the caller. Identifier offsets will be bogus but it'll
           * never get to that since the object is destructed. */
          loc->inherit = &dummy_inherit;
    
        TRACE((5,"-   Parent identifier = %d (%s), inherit # = %ld\n",
    	   loc->parent_identifier,
    	   p ? ID_FROM_INT(p, loc->parent_identifier)->name->str : "N/A",
    	   p ? DO_NOT_WARN((long)(loc->inherit - p->inherits)) : -1));
        
    #ifdef DEBUG_MALLOC
        if (p && loc->inherit->storage_offset == 0x55555555) {
          fprintf(stderr, "The inherit %p has been zapped!\n", loc->inherit);
          debug_malloc_dump_references(loc->inherit,0,2,0);
          fprintf(stderr, "It was extracted from the program %p %d\n", p, loc->parent_identifier);
          describe(p);
          fprintf(stderr, "Which was in turn taken from the object %p\n", loc->o);
          describe(loc->o);
          Pike_fatal("Looks like the program %p has been zapped!\n", p);
        }
    #endif /* DEBUG_MALLOC */
      }
    
      TRACE((4,"--find_external_context: parent_id=%d (%s)\n",
    	 loc->parent_identifier,
    	 p ? ID_FROM_INT(p,loc->parent_identifier)->name->str : "N/A"
    	 ));
    }
    
    #ifdef PIKE_DEBUG
    void print_return_value(void)
    {
      if(Pike_interpreter.trace_level>3)
      {
        char *s;
        dynamic_buffer save_buf;
    
        init_buf(&save_buf);
        safe_describe_svalue(Pike_sp-1,0,0);
        s=simple_free_buf(&save_buf);
        if((size_t)strlen(s) > (size_t)TRACE_LEN)
        {
          s[TRACE_LEN]=0;
          s[TRACE_LEN-1]='.';
          s[TRACE_LEN-2]='.';
          s[TRACE_LEN-3]='.';
        }
        fprintf(stderr,"-    value: %s\n",s);
        free(s);
      }
    }
    #else
    #define print_return_value()
    #endif
    
    struct callback_list evaluator_callbacks;
    
    
    /*
     * reset the stack machine.
     */
    void reset_evaluator(void)
    {
      Pike_fp=0;
      pop_n_elems(Pike_sp - Pike_interpreter.evaluator_stack);
    
    #ifdef PIKE_DEBUG
      if (Pike_interpreter.catch_ctx)
        Pike_fatal ("Catch context spillover.\n");
      if (Pike_interpreter.catching_eval_jmpbuf)
        Pike_fatal ("Got an active catching_eval_jmpbuf.\n");
    #endif
    }
    
    #ifdef PIKE_DEBUG
    
    #define BACKLOG 100
    struct backlog
    {
      PIKE_INSTR_T instruction;
      INT32 arg,arg2;
      INT32 program_id;
      PIKE_OPCODE_T *pc;
    #ifdef _REENTRANT
      struct thread_state *thread_state;
    #endif
      ptrdiff_t stack;
      ptrdiff_t mark_stack;
    };
    
    struct backlog backlog[BACKLOG];
    int backlogp=BACKLOG-1;
    
    static INLINE void low_debug_instr_prologue (PIKE_INSTR_T instr)
    {
      if(Pike_interpreter.trace_level > 2)
      {
        char *file = NULL, *f;
        struct pike_string *filep;
        INT_TYPE linep;
    
        filep = get_line(Pike_fp->pc,Pike_fp->context->prog,&linep);
        if (filep && !filep->size_shift) {
          file = filep->str;
          while((f=STRCHR(file,'/')))
    	file=f+1;
        }
        fprintf(stderr,"- %s:%4ld:%p(%"PRINTPTRDIFFT"d): "
    	    "%-25s %4"PRINTPTRDIFFT"d %4"PRINTPTRDIFFT"d\n",
    	    file ? file : "-",(long)linep,
    	    Pike_fp->pc, Pike_fp->pc - Pike_fp->context->prog->program,
    	    get_opcode_name(instr),
    	    Pike_sp-Pike_interpreter.evaluator_stack,
    	    Pike_mark_sp-Pike_interpreter.mark_stack);
        free_string(filep);
      }
    
    #ifdef HAVE_COMPUTED_GOTO
      if (instr) 
        ADD_RUNNED(instr);
      else
        Pike_fatal("NULL Instruction!\n");
    #else /* !HAVE_COMPUTED_GOTO */
      if(instr + F_OFFSET < F_MAX_OPCODE) 
        ADD_RUNNED(instr);
    #endif /* HAVE_COMPUTED_GOTO */
    
      if(d_flag )
      {
        backlogp++;
        if(backlogp >= BACKLOG) backlogp=0;
    
        backlog[backlogp].program_id = Pike_fp->context->prog->id;
        backlog[backlogp].instruction=instr;
        backlog[backlogp].pc = Pike_fp->pc;
        backlog[backlogp].stack = Pike_sp - Pike_interpreter.evaluator_stack;
        backlog[backlogp].mark_stack = Pike_mark_sp - Pike_interpreter.mark_stack;
    #ifdef _REENTRANT
        backlog[backlogp].thread_state=Pike_interpreter.thread_state;
    #endif
    
    #ifdef _REENTRANT
        CHECK_INTERPRETER_LOCK();
        if(d_flag>1) DEBUG_CHECK_THREAD();
    #endif
    
        INVALIDATE_SVAL(Pike_sp[0]);
        INVALIDATE_SVAL(Pike_sp[1]);
        INVALIDATE_SVAL(Pike_sp[2]);
        INVALIDATE_SVAL(Pike_sp[3]);
    
        if(Pike_sp<Pike_interpreter.evaluator_stack ||
           Pike_mark_sp < Pike_interpreter.mark_stack || Pike_fp->locals>Pike_sp)
          Pike_fatal("Stack error (generic) sp=%p/%p mark_sp=%p/%p locals=%p.\n",
    		 Pike_sp,
    		 Pike_interpreter.evaluator_stack,
    		 Pike_mark_sp,
    		 Pike_interpreter.mark_stack,
    		 Pike_fp->locals);
    
        if(Pike_mark_sp > Pike_interpreter.mark_stack+Pike_stack_size)
          Pike_fatal("Mark Stack error (overflow).\n");
    
    
        if(Pike_mark_sp < Pike_interpreter.mark_stack)
          Pike_fatal("Mark Stack error (underflow).\n");
    
        if(Pike_sp > Pike_interpreter.evaluator_stack+Pike_stack_size)
          Pike_fatal("stack error (overflow).\n");
    
    
        /* The locals will not be correct when running FILL_STACK
           (actually, they will always be incorrect before running FILL_STACK,
           but at least currently that is the first opcode run).
        */
    
        /* as it turns out, this is no longer true.. */
        /* if( instr+F_OFFSET != F_FILL_STACK ) */
        /* { */
        /*     if(/\* Pike_fp->fun>=0 && *\/ Pike_fp->current_object->prog && */
        /*        Pike_fp->locals+Pike_fp->num_locals > Pike_sp) */
        /*         Pike_fatal("Stack error (stupid! %p %p+%x).\n",Pike_sp, */
        /*                    Pike_fp->locals, Pike_fp->num_locals*sizeof(struct svalue)); */
        /* } */
    
        if(Pike_interpreter.recoveries &&
           (Pike_sp-Pike_interpreter.evaluator_stack <
    	Pike_interpreter.recoveries->stack_pointer))
          Pike_fatal("Stack error (underflow).\n");
    
        if(Pike_mark_sp > Pike_interpreter.mark_stack &&
           Pike_mark_sp[-1] > Pike_sp)
          Pike_fatal("Stack error (underflow?)\n");
          
        if(d_flag > 9) do_debug();
    
        debug_malloc_touch(Pike_fp->current_object);
        switch(d_flag)
        {
          default:
          case 3:
    	check_object(Pike_fp->current_object);
    	/*	  break; */
    
          case 2:
    	check_object_context(Pike_fp->current_object,
    			     Pike_fp->context->prog,
    			     Pike_fp->current_object->storage+
    			     Pike_fp->context->storage_offset);
          case 1:
          case 0:
    	break;
        }
      }
    }
    
    #define DEBUG_LOG_ARG(ARG)					\
      (backlog[backlogp].arg = (ARG),				\
       (Pike_interpreter.trace_level>3 ?				\
        sprintf(trace_buffer, "-    Arg = %ld\n",			\
    	    (long) backlog[backlogp].arg),			\
        write_to_stderr(trace_buffer,strlen(trace_buffer)) : 0))
    
    #define DEBUG_LOG_ARG2(ARG2)					\
      (backlog[backlogp].arg2 = (ARG2),				\
       (Pike_interpreter.trace_level>3 ?				\
        sprintf(trace_buffer, "-    Arg2 = %ld\n",			\
    	    (long) backlog[backlogp].arg2),			\
        write_to_stderr(trace_buffer,strlen(trace_buffer)) : 0))
    
    void dump_backlog(void)
    {
    #ifdef _REENTRANT
      struct thread_state *thread=0;
    #endif
    
      int e;
      if(!d_flag || backlogp<0 || backlogp>=BACKLOG)
        return;
    
      e=backlogp;
      do
      {
        struct program *p;
        e++;
        if(e>=BACKLOG) e=0;
    
        p = id_to_program (backlog[e].program_id);
        if (p)
        {
          struct pike_string *file;
          INT_TYPE line;
    
    #ifdef _REENTRANT
          if(thread != backlog[e].thread_state)
          {
    	fprintf(stderr,"[Thread swap, Pike_interpreter.thread_state=%p]\n",backlog[e].thread_state);
    	thread = backlog[e].thread_state;
          }
    #endif
    
          file = get_line(backlog[e].pc,p, &line);
    #ifdef HAVE_COMPUTED_GOTO
          fprintf(stderr,"%s:%ld:(%"PRINTPTRDIFFT"d): %s",
    	      file->str,
    	      (long)line,
    	      backlog[e].pc - p->program,
    	      get_opcode_name(backlog[e].instruction));
    #else /* !HAVE_COMPUTED_GOTO */
          if(backlog[e].instruction+F_OFFSET > F_MAX_OPCODE)
          {
    	fprintf(stderr,"%s:%ld:(%"PRINTPTRDIFFT"d): ILLEGAL INSTRUCTION %d\n",
    		file->str,
    		(long)line,
    		backlog[e].pc - p->program,
    		backlog[e].instruction + F_OFFSET);
    	free_string(file);
    	continue;
          }
    
          fprintf(stderr,"%s:%ld:(%"PRINTPTRDIFFT"d): %s",
    	      file->str,
    	      (long)line,
    	      backlog[e].pc - p->program,
    	      low_get_f_name(backlog[e].instruction + F_OFFSET, p));
          if(instrs[backlog[e].instruction].flags & I_HASARG2)
          {
    	fprintf(stderr,"(%ld,%ld)",
    		(long)backlog[e].arg,
    		(long)backlog[e].arg2);
          }
          else if(instrs[backlog[e].instruction].flags & I_POINTER)
          {
    	fprintf(stderr,"(%+ld)", (long)backlog[e].arg);
          }
          else if(instrs[backlog[e].instruction].flags & I_HASARG)
          {
    	fprintf(stderr,"(%ld)", (long)backlog[e].arg);
          }
          fprintf(stderr," %ld, %ld\n",
    	      DO_NOT_WARN((long)backlog[e].stack),
    	      DO_NOT_WARN((long)backlog[e].mark_stack));
    #endif /* HAVE_COMPUTED_GOTO */
          free_string(file);
        }
      }while(e!=backlogp);
    }
    
    #else  /* PIKE_DEBUG */
    
    #define DEBUG_LOG_ARG(arg) 0
    #define DEBUG_LOG_ARG2(arg2) 0
    
    #endif	/* !PIKE_DEBUG */
    
    
    #define POP_CATCH_CONTEXT do {                                         \
        struct catch_context *cc = Pike_interpreter.catch_ctx;             \
        DO_IF_DEBUG (                                                      \
          TRACE((3,"-   Popping catch context %p ==> %p\n",                        \
                cc, cc ? cc->prev : NULL));                                \
          if (!Pike_interpreter.catching_eval_jmpbuf)                      \
           Pike_fatal ("Not in catching eval.\n");                         \
          if (!cc)                                                         \
           Pike_fatal ("Catch context dropoff.\n");                        \
          if (cc->frame != Pike_fp)                                                \
           Pike_fatal ("Catch context doesn't belong to this frame.\n");   \
          if (Pike_mark_sp != cc->recovery.mark_sp + Pike_interpreter.mark_stack) \
           Pike_fatal ("Mark sp diff in catch context pop.\n");            \
        );                                                                 \
        debug_malloc_touch (cc);                                           \
        UNSETJMP (cc->recovery);                                           \
        Pike_fp->expendible = cc->save_expendible;                         \
        Pike_interpreter.catch_ctx = cc->prev;                             \
        really_free_catch_context (cc);                                    \
      } while (0)
    
    static struct catch_context *free_catch_context;
    static int num_catch_ctx, num_free_catch_ctx;
    
    PMOD_EXPORT void really_free_catch_context( struct catch_context *data )
    {
        if( num_free_catch_ctx > 100 && free_catch_context )
        {
          num_catch_ctx--;
          free( data );
        }
        else
        {
          data->prev = free_catch_context;
    
          num_free_catch_ctx++;
          PIKE_MEM_NA(*data);
          PIKE_MEM_RW(data->prev);
          free_catch_context = data;
        }
    }
    
    struct catch_context *alloc_catch_context(void)
    {
        struct catch_context *res;
        if( free_catch_context )
        {
            num_free_catch_ctx--;
            res = free_catch_context;
            PIKE_MEM_RW(res->prev);
            free_catch_context = res->prev;
            PIKE_MEM_WO(*res);
        }
        else
        {
            num_catch_ctx++;
            res = xalloc( sizeof( struct catch_context ) );
        }
        return res;
    }
    
    void count_memory_in_catch_contexts(size_t *num, size_t *size )
    {
      *num = (num_catch_ctx-num_free_catch_ctx);
      *size = num_catch_ctx * (sizeof(struct catch_context)+8); /* assumes 8 bytes overhead. */
    }
    
    #ifdef DO_PIKE_CLEANUP
    static void free_all_catch_context_blocks(void)
    {
        struct catch_context *x = free_catch_context, *n;
        while( x )
        {
            PIKE_MEM_RW(x->prev);
            n = x->prev;
            free( x );
            x = n;
        }
        free_catch_context = NULL;
    }
    #endif
    
    static int catching_eval_instruction (PIKE_OPCODE_T *pc);
    
    
    #ifdef PIKE_USE_MACHINE_CODE
    #ifdef OPCODE_INLINE_RETURN
    /* Catch notes:
     *
     * Typical F_CATCH use:
     *
     *   F_CATCH
     * 	F_PTR	continue_label
     *
     *   ENTRY
     *
     *   catch body
     *
     *   F_EXIT_CATCH
     *
     *   F_BRANCH
     *	F_PTR	continue_label
     *
     *   ENTRY
     *
     * continue_label:
     *
     *   rest of code.
     */
    
    /* Modified calling-conventions to simplify code-generation when
     * INTER_RETURN is inlined.
     *
     * cf interpret_functions.h:F_CATCH
     *
     * Arguments:
     *   addr:
     *     Address where the continue POINTER (INT32) is stored.
     *     Directly after the POINTER is the ENTRY for the catch block.
     *
     * Returns:
     *   (PIKE_OPCODE_T *)-1 on INTER_RETURN.
     *   jump_destination otherwise.
     */
    PIKE_OPCODE_T *inter_return_opcode_F_CATCH(PIKE_OPCODE_T *addr)
    {
    #ifdef PIKE_DEBUG
      if (d_flag || Pike_interpreter.trace_level > 2) {
        low_debug_instr_prologue (F_CATCH - F_OFFSET);
        if (Pike_interpreter.trace_level>3) {
          sprintf(trace_buffer, "-    Addr = %p\n", addr);
          write_to_stderr(trace_buffer,strlen(trace_buffer));
        }
      }
    #endif
      {
        struct catch_context *new_catch_ctx = alloc_catch_context();
    #ifdef PIKE_DEBUG
          new_catch_ctx->frame = Pike_fp;
          init_recovery (&new_catch_ctx->recovery, 0, 0, PERR_LOCATION());
    #else
          init_recovery (&new_catch_ctx->recovery, 0);
    #endif
        new_catch_ctx->save_expendible = Pike_fp->expendible;
        new_catch_ctx->continue_reladdr = (INT32)get_unaligned32(addr)
          /* We need to run the entry prologue... */
          - ENTRY_PROLOGUE_SIZE;
    
        new_catch_ctx->next_addr = addr;
        new_catch_ctx->prev = Pike_interpreter.catch_ctx;
        Pike_interpreter.catch_ctx = new_catch_ctx;
        DO_IF_DEBUG({
    	TRACE((3,"-   Pushed catch context %p\n", new_catch_ctx));
          });
      }
    
      Pike_fp->expendible = Pike_fp->locals + Pike_fp->num_locals;
    
      /* Need to adjust next_addr by sizeof(INT32) to skip past the jump
       * address to the continue position after the catch block. */
      addr = (PIKE_OPCODE_T *) ((INT32 *) addr + 1);
    
      if (Pike_interpreter.catching_eval_jmpbuf) {
        /* There's already a catching_eval_instruction around our
         * eval_instruction, so we can just continue. */
        debug_malloc_touch_named (Pike_interpreter.catch_ctx, "(1)");
        /* Skip past the entry prologue... */
        addr += ENTRY_PROLOGUE_SIZE;
        DO_IF_DEBUG({
    	TRACE((3,"-   In active catch; continuing at %p\n", addr));
          });
        return addr;
      }
      else {
        debug_malloc_touch_named (Pike_interpreter.catch_ctx, "(2)");
    
        while (1) {
          /* Loop here every time an exception is caught. Once we've
           * gotten here and set things up to run eval_instruction from
           * inside catching_eval_instruction, we keep doing it until it's
           * time to return. */
    
          int res;
    
          DO_IF_DEBUG({
    	  TRACE((3,"-   Activating catch; calling %p in context %p\n",
    		 addr, Pike_interpreter.catch_ctx));
    	});
    
          res = catching_eval_instruction (addr);
    
          DO_IF_DEBUG({
    	  TRACE((3,"-   catching_eval_instruction(%p) returned %d\n",
    		 addr, res));
    	});
    
          if (res != -3) {
    	/* There was an inter return inside the evaluated code. Just
    	 * propagate it. */
    	DO_IF_DEBUG ({
    	    TRACE((3,"-   Returning from catch.\n"));
    	    if (res != -1) Pike_fatal ("Unexpected return value from "
    				       "catching_eval_instruction: %d\n", res);
    	  });
    	break;
          }
    
          else {
    	/* Caught an exception. */
    	struct catch_context *cc = Pike_interpreter.catch_ctx;
    
    	DO_IF_DEBUG ({
    	    TRACE((3,"-   Caught exception. catch context: %p\n", cc));
    	    if (!cc) Pike_fatal ("Catch context dropoff.\n");
    	    if (cc->frame != Pike_fp)
    	      Pike_fatal ("Catch context doesn't belong to this frame.\n");
    	  });
    
    	debug_malloc_touch_named (cc, "(3)");
    	UNSETJMP (cc->recovery);
    	Pike_fp->expendible = cc->save_expendible;
    	move_svalue (Pike_sp++, &throw_value);
    	mark_free_svalue (&throw_value);
    	low_destruct_objects_to_destruct();
    
    	if (cc->continue_reladdr < 0)
    	  FAST_CHECK_THREADS_ON_BRANCH();
    	addr = cc->next_addr + cc->continue_reladdr;
    
    	DO_IF_DEBUG({
    	    TRACE((3,"-   Popping catch context %p ==> %p\n",
    		   cc, cc->prev));
    	    if (!addr) Pike_fatal ("Unexpected null continue addr.\n");
    	  });
    
    	Pike_interpreter.catch_ctx = cc->prev;
    	really_free_catch_context (cc);
          }
        }
    
        return (PIKE_OPCODE_T *)(ptrdiff_t)-1;	/* INTER_RETURN; */
      }
    }
    
    void *do_inter_return_label = (void*)(ptrdiff_t)-1;
    #else
    /* Labels to jump to to cause eval_instruction to return */
    /* FIXME: Replace these with assembler lables */
    void *do_inter_return_label = NULL;
    void *dummy_label = NULL;
    #endif
    
    #ifndef CALL_MACHINE_CODE
    #define CALL_MACHINE_CODE(pc)					\
      do {								\
        /* The test is needed to get the labels to work... */	\
        if (pc) {							\
          /* No extra setup needed!					\
           */							\
          return ((int (*)(void))(pc))();				\
        }								\
      } while(0)
    #endif /* !CALL_MACHINE_CODE */
    
    #ifndef EXIT_MACHINE_CODE
    #define EXIT_MACHINE_CODE()
    #endif
    
    /* Intended to be called from machine code before inlined function
     * calls (primarily the CALL_BUILTIN opcodes), to ensure thread
     * switching. */
    void call_check_threads_etc()
    {
      FAST_CHECK_THREADS_ON_CALL();
    }
    
    #if defined(OPCODE_INLINE_BRANCH) || defined(INS_F_JUMP) || \
        defined(INS_F_JUMP_WITH_ARG) || defined(INS_F_JUMP_WITH_TWO_ARGS)
    /* Intended to be called from machine code on backward branch jumps,
     * to ensure thread switching. */
    void branch_check_threads_etc()
    {
      FAST_CHECK_THREADS_ON_BRANCH();
    }
    #endif
    
    #ifdef PIKE_DEBUG
    
    static void debug_instr_prologue (PIKE_INSTR_T instr)
    {
      low_debug_instr_prologue (instr);
    }
    
    #define DEBUG_PROLOGUE(OPCODE, EXTRA) do {				\
        if (d_flag || Pike_interpreter.trace_level > 2) {			\
          debug_instr_prologue ((OPCODE) - F_OFFSET);			\
          EXTRA;								\
        }									\
      } while (0)
    
    /* The following are intended to be called directly from generated
     * machine code. */
    void simple_debug_instr_prologue_0 (PIKE_INSTR_T instr)
    {
      if (d_flag || Pike_interpreter.trace_level > 2)
        low_debug_instr_prologue (instr);
    }
    void simple_debug_instr_prologue_1 (PIKE_INSTR_T instr, INT32 arg)
    {
      if (d_flag || Pike_interpreter.trace_level > 2) {
        low_debug_instr_prologue (instr);
        DEBUG_LOG_ARG (arg);
      }
    }
    void simple_debug_instr_prologue_2 (PIKE_INSTR_T instr, INT32 arg1, INT32 arg2)
    {
      if (d_flag || Pike_interpreter.trace_level > 2) {
        low_debug_instr_prologue (instr);
        DEBUG_LOG_ARG (arg1);
        DEBUG_LOG_ARG2 (arg2);
      }
    }
    
    #endif	/* !PIKE_DEBUG */
    
    #endif /* PIKE_USE_MACHINE_CODE */
    
    /* These don't change when eval_instruction_without_debug is compiled. */
    #ifdef PIKE_DEBUG
    #define REAL_PIKE_DEBUG
    #define DO_IF_REAL_DEBUG(X) X
    #define DO_IF_NOT_REAL_DEBUG(X)
    #else
    #define DO_IF_REAL_DEBUG(X)
    #define DO_IF_NOT_REAL_DEBUG(X) X
    #endif
    
    #ifdef PIKE_SMALL_EVAL_INSTRUCTION
    #undef PROG_COUNTER
    #define PROG_COUNTER	Pike_fp->pc+1
    #endif /* PIKE_SMALL_EVAL_INSTRUCTION */
    
    #if defined(PIKE_USE_MACHINE_CODE) || defined(PIKE_SMALL_EVAL_INSTRUCTION)
    
    #ifndef DEF_PROG_COUNTER
    #define DEF_PROG_COUNTER
    #endif /* !DEF_PROG_COUNTER */
    
    #ifndef DEBUG_PROLOGUE
    #define DEBUG_PROLOGUE(OPCODE, EXTRA) do {} while (0)
    #endif
    
    #define OPCODE0(O,N,F,C) \
    void PIKE_CONCAT(opcode_,O)(void) { \
      DEF_PROG_COUNTER; \
      DEBUG_PROLOGUE (O, ;);						\
    C }
    
    #define OPCODE1(O,N,F,C) \
    void PIKE_CONCAT(opcode_,O)(INT32 arg1) {\
      DEF_PROG_COUNTER; \
      DEBUG_PROLOGUE (O, DEBUG_LOG_ARG (arg1));				\
    C }
    
    #define OPCODE2(O,N,F,C) \
    void PIKE_CONCAT(opcode_,O)(INT32 arg1,INT32 arg2) { \
      DEF_PROG_COUNTER; \
      DEBUG_PROLOGUE (O, DEBUG_LOG_ARG (arg1); DEBUG_LOG_ARG2 (arg2));	\
    C }
    
    #if defined(OPCODE_RETURN_JUMPADDR) || defined(PIKE_SMALL_EVAL_INSTRUCTION)
    
    #define OPCODE0_JUMP(O,N,F,C)						\
      void *PIKE_CONCAT(jump_opcode_,O)(void) {				\
        void *jumpaddr DO_IF_DEBUG(= NULL);					\
        DEF_PROG_COUNTER;							\
        DEBUG_PROLOGUE (O, ;);						\
        C;									\
        JUMP_DONE;								\
      }
    
    #define OPCODE1_JUMP(O,N,F,C)						\
      void *PIKE_CONCAT(jump_opcode_,O)(INT32 arg1) {			\
        void *jumpaddr DO_IF_DEBUG(= NULL);					\
        DEF_PROG_COUNTER;							\
        DEBUG_PROLOGUE (O, DEBUG_LOG_ARG (arg1));				\
        C;									\
        JUMP_DONE;								\
      }
    
    #define OPCODE2_JUMP(O,N,F,C)						\
      void *PIKE_CONCAT(jump_opcode_,O)(INT32 arg1, INT32 arg2) {		\
        void *jumpaddr DO_IF_DEBUG(= NULL);					\
        DEF_PROG_COUNTER;							\
        DEBUG_PROLOGUE (O, DEBUG_LOG_ARG (arg1); DEBUG_LOG_ARG2 (arg2));	\
        C;									\
        JUMP_DONE;								\
      }
    
    #define SET_PROG_COUNTER(X) (jumpaddr = (X))
    
    #ifdef PIKE_DEBUG
    #define JUMP_DONE do {							\
        if (!jumpaddr)							\
          Pike_fatal ("Instruction didn't set jump address.\n");		\
        return jumpaddr;							\
      } while (0)
    #else
    #define JUMP_DONE return jumpaddr
    #endif
    
    #else  /* !OPCODE_RETURN_JUMPADDR && !PIKE_SMALL_EVAL_INSTRUCTION */
    #define OPCODE0_JUMP OPCODE0
    #define OPCODE1_JUMP OPCODE1
    #define OPCODE2_JUMP OPCODE2
    #define JUMP_DONE DONE
    #endif	/* OPCODE_RETURN_JUMPADDR || PIKE_SMALL_EVAL_INSTRUCTION */
    
    #if defined(OPCODE_INLINE_BRANCH) || defined(PIKE_SMALL_EVAL_INSTRUCTION)
    #define TEST_OPCODE0(O,N,F,C) \
    ptrdiff_t PIKE_CONCAT(test_opcode_,O)(void) { \
        ptrdiff_t branch_taken = 0;	\
        DEF_PROG_COUNTER; \
        DEBUG_PROLOGUE (O, ;);						\
        C; \
        return branch_taken; \
      }
    
    #define TEST_OPCODE1(O,N,F,C) \
    ptrdiff_t PIKE_CONCAT(test_opcode_,O)(INT32 arg1) {\
        ptrdiff_t branch_taken = 0;	\
        DEF_PROG_COUNTER; \
        DEBUG_PROLOGUE (O, DEBUG_LOG_ARG (arg1));				\
        C; \
        return branch_taken; \
      }
    
    
    #define TEST_OPCODE2(O,N,F,C) \
    ptrdiff_t PIKE_CONCAT(test_opcode_,O)(INT32 arg1, INT32 arg2) { \
        ptrdiff_t branch_taken = 0;	\
        DEF_PROG_COUNTER; \
        DEBUG_PROLOGUE (O, DEBUG_LOG_ARG (arg1); DEBUG_LOG_ARG2 (arg2));	\
        C; \
        return branch_taken; \
      }
    
    #define DO_BRANCH()	(branch_taken = -1)
    #define DONT_BRANCH()	(branch_taken = 0)
    #else /* !OPCODE_INLINE_BRANCH && !PIKE_SMALL_EVAL_INSTRUCTION */
    #define TEST_OPCODE0(O,N,F,C) OPCODE0_PTRJUMP(O,N,F,C)
    #define TEST_OPCODE1(O,N,F,C) OPCODE1_PTRJUMP(O,N,F,C)
    #define TEST_OPCODE2(O,N,F,C) OPCODE2_PTRJUMP(O,N,F,C)
    #endif /* OPCODE_INLINE_BRANCH || PIKE_SMALL_EVAL_INSTRUCTION */
    
    #define OPCODE0_TAIL(O,N,F,C) OPCODE0(O,N,F,C)
    #define OPCODE1_TAIL(O,N,F,C) OPCODE1(O,N,F,C)
    #define OPCODE2_TAIL(O,N,F,C) OPCODE2(O,N,F,C)
    
    #define OPCODE0_PTRJUMP(O,N,F,C) OPCODE0_JUMP(O,N,F,C)
    #define OPCODE1_PTRJUMP(O,N,F,C) OPCODE1_JUMP(O,N,F,C)
    #define OPCODE2_PTRJUMP(O,N,F,C) OPCODE2_JUMP(O,N,F,C)
    #define OPCODE0_TAILPTRJUMP(O,N,F,C) OPCODE0_PTRJUMP(O,N,F,C)
    #define OPCODE1_TAILPTRJUMP(O,N,F,C) OPCODE1_PTRJUMP(O,N,F,C)
    #define OPCODE2_TAILPTRJUMP(O,N,F,C) OPCODE2_PTRJUMP(O,N,F,C)
    
    #define OPCODE0_RETURN(O,N,F,C) OPCODE0_JUMP(O,N,F | I_RETURN,C)
    #define OPCODE1_RETURN(O,N,F,C) OPCODE1_JUMP(O,N,F | I_RETURN,C)
    #define OPCODE2_RETURN(O,N,F,C) OPCODE2_JUMP(O,N,F | I_RETURN,C)
    #define OPCODE0_TAILRETURN(O,N,F,C) OPCODE0_RETURN(O,N,F,C)
    #define OPCODE1_TAILRETURN(O,N,F,C) OPCODE1_RETURN(O,N,F,C)
    #define OPCODE2_TAILRETURN(O,N,F,C) OPCODE2_RETURN(O,N,F,C)
    
    /* BRANCH opcodes only generate code for the test,
     * so that the branch instruction can be inlined.
     */
    #define OPCODE0_BRANCH(O,N,F,C) TEST_OPCODE0(O,N,F,C)
    #define OPCODE1_BRANCH(O,N,F,C) TEST_OPCODE1(O,N,F,C)
    #define OPCODE2_BRANCH(O,N,F,C) TEST_OPCODE2(O,N,F,C)
    #define OPCODE0_TAILBRANCH(O,N,F,C) TEST_OPCODE0(O,N,F,C)
    #define OPCODE1_TAILBRANCH(O,N,F,C) TEST_OPCODE1(O,N,F,C)
    #define OPCODE2_TAILBRANCH(O,N,F,C) TEST_OPCODE2(O,N,F,C)
    
    #define OPCODE0_ALIAS(O,N,F,C)
    #define OPCODE1_ALIAS(O,N,F,C)
    #define OPCODE2_ALIAS(O,N,F,C)
    
    #undef HAVE_COMPUTED_GOTO
    
    #ifdef GLOBAL_DEF_PROG_COUNTER
    GLOBAL_DEF_PROG_COUNTER;
    #endif
    
    #ifndef SET_PROG_COUNTER
    #define SET_PROG_COUNTER(X)	(PROG_COUNTER=(X))
    #endif /* SET_PROG_COUNTER */
    
    #undef DONE
    #undef FETCH
    #undef INTER_RETURN
    
    #define DONE return
    #define FETCH
    #define INTER_RETURN {SET_PROG_COUNTER(do_inter_return_label);JUMP_DONE;}
    
    #if defined(PIKE_USE_MACHINE_CODE) && defined(_M_IX86)
    /* Disable frame pointer optimization */
    #pragma optimize("y", off)
    #endif
    
    #include "interpret_functions_fixed.h"
    
    #if defined(PIKE_USE_MACHINE_CODE) && defined(_M_IX86)
    /* Restore optimization */
    #pragma optimize("", on)
    #endif
    
    #ifdef PIKE_SMALL_EVAL_INSTRUCTION
    #undef SET_PROG_COUNTER
    #undef PROG_COUNTER
    #define PROG_COUNTER	pc
    #endif
    
    #endif /* PIKE_USE_MACHINE_CODE || PIKE_SMALL_EVAL_INSTRUCTION */
    
    #ifdef PIKE_USE_MACHINE_CODE
    
    #ifdef PIKE_DEBUG
    /* Note: The debug code is extracted, to keep the frame size constant. */
    static int eval_instruction_low(PIKE_OPCODE_T *pc);
    #endif /* PIKE_DEBUG */
    
    static int eval_instruction(PIKE_OPCODE_T *pc)
    #ifdef PIKE_DEBUG
    {
      int x;
      if (Pike_interpreter.trace_level > 5 && pc) {
        int i;
        fprintf(stderr, "Calling code at %p:\n", pc);
    #ifdef PIKE_OPCODE_ALIGN
        if (((INT32)pc) % PIKE_OPCODE_ALIGN) {
          Pike_fatal("Odd offset!\n");
        }
    #endif /* PIKE_OPCODE_ALIGN */
    #ifdef DISASSEMBLE_CODE
        DISASSEMBLE_CODE(pc, 16*4);
    #else /* !DISASSEMBLE_CODE */
        for (i=0; i < 16; i+=4) {
          fprintf(stderr,
    	      "  0x%08x 0x%08x 0x%08x 0x%08x\n",
    	      ((int *)pc)[i],
    	      ((int *)pc)[i+1],
    	      ((int *)pc)[i+2],
    	      ((int *)pc)[i+3]);
        }
    #endif /* DISASSEMBLE_CODE */
      }
      x = eval_instruction_low(pc);
      pike_trace(3, "-    eval_instruction(%p) ==> %d\n", pc, x);
      return x;
    }
    
    static int eval_instruction_low(PIKE_OPCODE_T *pc)
    #endif /* PIKE_DEBUG */
    {
    #ifndef OPCODE_INLINE_RETURN
      if(pc == NULL) {
        if(do_inter_return_label != NULL)
          Pike_fatal("eval_instruction called with NULL (twice).\n");
    
    #ifdef __GNUC__
        do_inter_return_label = && inter_return_label;
    #elif defined (_M_IX86)
        /* MSVC. */
        _asm
        {
          lea eax,inter_return_label
          mov do_inter_return_label,eax
        }
    #else
    #error Machine code not supported with this compiler.
    #endif
    
    #if 0
        /* Paranoia.
         *
         * This can happen on systems with delay slots if the labels aren't
         * used explicitly.
         */
        if (do_inter_return_label == do_escape_catch_label) {
          Pike_fatal("Inter return and escape catch labels are equal: %p\n",
    		 do_inter_return_label);
        }
    #endif
    
        /* Trick optimizer */
        if(!dummy_label)
          return 0;
      }
    
      /* This else is important to avoid an overoptimization bug in (at
       * least) gcc 4.0.2 20050808 which caused the address stored in
       * do_inter_return_label to be at the CALL_MACHINE_CODE below. */
      else {
    #endif /* !OPCODE_INLINE_RETURN */
        CALL_MACHINE_CODE(pc);
    
    #ifndef OPCODE_INLINE_RETURN
        /* This code is never reached, but will
         * prevent gcc from optimizing the labels below too much
         */
    
    #ifdef PIKE_DEBUG
        fprintf(stderr,"We have reached the end of the world!\n");
    #endif
      }
    
    #ifdef __GNUC__
      goto *dummy_label;
    #endif
    
     inter_return_label:
    #endif /*!OPCODE_INLINE_RETURUN */
    #ifdef PIKE_DEBUG
      pike_trace(3, "-    Inter return\n");
    #endif
      EXIT_MACHINE_CODE();
      return -1;
    }
    
    #else /* PIKE_USE_MACHINE_CODE */
    
    
    #ifndef SET_PROG_COUNTER
    #define SET_PROG_COUNTER(X)	(PROG_COUNTER=(X))
    #endif /* SET_PROG_COUNTER */
    
    #ifdef HAVE_COMPUTED_GOTO
    int lookup_sort_fun(const void *a, const void *b)
    {
      return (int)(((ptrdiff_t)((struct op_2_f *)a)->opcode) -
    	       ((ptrdiff_t)((struct op_2_f *)b)->opcode));
    }
    #endif /* HAVE_COMPUTED_GOTO */
    
    /* NOTE: Due to the implementation of computed goto,
     *       interpreter.h may only be included once.
     */
    #if defined(PIKE_DEBUG) && !defined(HAVE_COMPUTED_GOTO)
    #define eval_instruction eval_instruction_with_debug
    #include "interpreter_debug.h"
    
    #undef eval_instruction
    #define eval_instruction eval_instruction_without_debug
    
    #undef PIKE_DEBUG
    #undef NDEBUG
    #undef DO_IF_DEBUG
    #define DO_IF_DEBUG(X)
    #define print_return_value()
    #include "interpreter.h"
    
    #define PIKE_DEBUG
    #define NDEBUG
    #undef DO_IF_DEBUG
    #define DO_IF_DEBUG(X) X
    #undef print_return_value
    
    #undef eval_instruction
    
    static INLINE int eval_instruction(unsigned char *pc)
    {
      if(d_flag || Pike_interpreter.trace_level>2)
        return eval_instruction_with_debug(pc);
      else
        return eval_instruction_without_debug(pc);
    }
    
    
    #else /* !PIKE_DEBUG || HAVE_COMPUTED_GOTO */
    #include "interpreter.h"
    #endif
    
    
    #endif /* PIKE_USE_MACHINE_CODE */
    
    #undef REAL_PIKE_DEBUG
    #undef DO_IF_REAL_DEBUG
    #undef DO_IF_NOT_REAL_DEBUG
    
    
    static void do_trace_call(INT32 args, dynamic_buffer *old_buf)
    {
      struct pike_string *filep = NULL;
      char *file, *s;
      INT_TYPE linep;
      INT32 e;
      ptrdiff_t len = 0;
    
      my_strcat("(");
      for(e=0;e<args;e++)
      {
        if(e) my_strcat(",");
        safe_describe_svalue(Pike_sp-args+e,0,0);
      }
      my_strcat(")");
    
      s=simple_free_buf(old_buf);
      if((size_t)strlen(s) > (size_t)TRACE_LEN)
      {
        s[TRACE_LEN]=0;
        s[TRACE_LEN-1]='.';
        s[TRACE_LEN-2]='.';
        s[TRACE_LEN-3]='.';
      }
    
      if(Pike_fp && Pike_fp->pc)
      {
        char *f;
        filep = get_line(Pike_fp->pc,Pike_fp->context->prog,&linep);
        if (filep->size_shift)
          file = "...";
        else {
          file = filep->str;
          while((f = STRCHR(file, '/'))
    #ifdef __NT__
    	    || (f = STRCHR(file, '\\'))
    #endif /* __NT__ */
    	    )
    	file=f+1;
          len = filep->len - (file - filep->str);
        }
      }else{
        linep=0;
        file="-";
      }
    
      if (len < 30)
      {
        char buf[40];
        if (linep)
          SNPRINTF(buf, sizeof (buf), "%s:%ld:", file, (long)linep);
        else
          SNPRINTF(buf, sizeof (buf), "%s:", file);
        fprintf(stderr, "- %-20s %s\n",buf,s);
      } else if (linep) {
        fprintf(stderr, "- %s:%ld: %s\n", file, (long)linep, s);
      } else {
        fprintf(stderr, "- %s: %s\n", file, s);
      }
    
      if (filep) {
        free_string(filep);
      }
      free(s);
    }
    
    static void do_trace_func_return (int got_retval, struct object *o, int fun)
    {
      dynamic_buffer save_buf;
      init_buf (&save_buf);
      if (o) {
        if (o->prog) {
          struct identifier *id = ID_FROM_INT (o->prog, fun);
          char buf[50];
          sprintf(buf, "%lx->", DO_NOT_WARN((long) PTR_TO_INT (o)));
          my_strcat(buf);
          if (id->name->size_shift)
    	my_strcat ("[widestring function name]");
          else
    	my_strcat(id->name->str);
          my_strcat ("() ");
        }
        else
          my_strcat ("function in destructed object ");
      }
      do_trace_return (got_retval, &save_buf);
    }
    
    static void do_trace_return (int got_retval, dynamic_buffer *old_buf)
    {
      struct pike_string *filep = NULL;
      char *file, *s;
      INT_TYPE linep;
    
      if (got_retval) {
        my_strcat ("returns: ");
        safe_describe_svalue(Pike_sp-1,0,0);
      }
      else
        my_strcat ("returns with no value");
    
      s=simple_free_buf(old_buf);
      if((size_t)strlen(s) > (size_t)TRACE_LEN)
      {
        s[TRACE_LEN]=0;
        s[TRACE_LEN-1]='.';
        s[TRACE_LEN-2]='.';
        s[TRACE_LEN-3]='.';
      }
    
      if(Pike_fp && Pike_fp->pc)
      {
        char *f;
        filep = get_line(Pike_fp->pc,Pike_fp->context->prog,&linep);
        if (filep->size_shift)
          file = "...";
        else {
          file = filep->str;
          while((f=STRCHR(file,'/')))
    	file=f+1;
        }
      }else{
        linep=0;
        file="-";
      }
    
      {
        char buf[40];
        if (linep)
          SNPRINTF(buf, sizeof (buf), "%s:%ld:", file, (long)linep);
        else
          SNPRINTF(buf, sizeof (buf), "%s:", file);
        fprintf(stderr,"- %-20s %s\n",buf,s);
      }
    
      if (filep) {
        free_string(filep);
      }
      free(s);
    }
    
    static struct pike_frame_chunk {
      struct pike_frame_chunk *next;
    } *pike_frame_chunks;
    static int num_pike_frame_chunks;
    static int num_pike_frames;
    
    PMOD_EXPORT void really_free_pike_frame( struct pike_frame *X )
    {
        free_object(X->current_object);
        if(X->current_program)
            free_program(X->current_program);
        if(X->scope)
            free_pike_scope(X->scope);
        DO_IF_SECURITY( if(X->current_creds) free_object(X->current_creds) );
        DO_IF_DEBUG(
            if(X->flags & PIKE_FRAME_MALLOCED_LOCALS)
                Pike_fatal("Pike frame is not supposed to have malloced locals here!\n"));
      DO_IF_DMALLOC(
        X->current_program=0;
        X->context=0;
        X->scope=0;
        X->current_object=0;
        X->flags=0;
        X->expendible=0;
        X->locals=0;
        DO_IF_SECURITY( X->current_creds=0; )
      );
      X->next = free_pike_frame;
      PIKE_MEMPOOL_FREE(&free_pike_frame, X, sizeof(struct pike_frame));
      free_pike_frame = X;
    }
    
    struct pike_frame *alloc_pike_frame(void)
    {
        struct pike_frame *res;
        if( free_pike_frame )
        {
          res = free_pike_frame;
          PIKE_MEMPOOL_ALLOC(&free_pike_frame, res, sizeof(struct pike_frame));
          PIKE_MEM_RW_RANGE(&res->next, sizeof(void*));
          free_pike_frame = res->next;
          PIKE_MEM_WO_RANGE(&res->next, sizeof(void*));
          res->refs=0;
          add_ref(res);	/* For DMALLOC... */
          res->flags=0;
          res->next=0;
          res->scope=0;
    
          DO_IF_SECURITY(
            if(CURRENT_CREDS) {
              add_ref(res->current_creds=CURRENT_CREDS);
            } else {
              res->current_creds = 0;
            });
    
          return res;
        }
    
        /* Need to allocate more. */
        {
          unsigned int i;
    #define FRAMES_PER_CHUNK ((4096*4-8-sizeof(struct pike_frame_chunk))/sizeof(struct pike_frame))
    #define FRAME_CHUNK_SIZE (FRAMES_PER_CHUNK*sizeof(struct pike_frame))+sizeof(struct pike_frame_chunk)
    
          void *p = xalloc( FRAME_CHUNK_SIZE );
          num_pike_frame_chunks++;
          ((struct pike_frame_chunk*)p)->next = pike_frame_chunks;
          pike_frame_chunks = p;
          free_pike_frame = res = (struct pike_frame*)((char*)p+sizeof(struct pike_frame_chunk));
          for( i=1; i<FRAMES_PER_CHUNK; i++ )
          {
            res->next = &free_pike_frame[i];
            res = res->next;
          }
          res->next = NULL;
          num_pike_frames+=FRAMES_PER_CHUNK;
        }
        return alloc_pike_frame();
    }
    
    void count_memory_in_pike_frames(size_t *num, size_t *size )
    {
      *num = num_pike_frames;
      *size = num_pike_frame_chunks * (FRAME_CHUNK_SIZE*8);
    }
    #undef FRAMES_PER_CHUNK
    #undef FRAME_CHUNK_SIZE
    
    #ifdef DO_PIKE_CLEANUP
    static void free_all_pike_frame_blocks(void)
    {
      struct pike_frame_chunk *x = pike_frame_chunks, *n;
      while( x )
      {
        n = x->next;
        free(x);
        x = n;
      }
      free_pike_frame = NULL;
      pike_frame_chunks = NULL;
      num_pike_frames=0;
      num_pike_frame_chunks=0;
    }
    #endif
    
    void really_free_pike_scope(struct pike_frame *scope)
    {
      if(scope->flags & PIKE_FRAME_MALLOCED_LOCALS)
      {
        free_mixed_svalues(scope->locals,scope->num_locals);
        free(scope->locals);
    #ifdef PIKE_DEBUG
        scope->flags&=~PIKE_FRAME_MALLOCED_LOCALS;
    #endif
      }
      really_free_pike_frame(scope);
    }
    
    void *lower_mega_apply( INT32 args, struct object *o, ptrdiff_t fun )
    {
      struct program *p;
      check_stack(256);
      check_mark_stack(256);
    
      if( (p = o->prog) )
      {
        struct svalue *save_sp = Pike_sp - args;
        struct reference *ref = p->identifier_references + fun;
        struct inherit *context = p->inherits + ref->inherit_offset;
        struct identifier *function = context->prog->identifiers + ref->identifier_offset;
        struct svalue *constant = NULL;
        struct pike_frame *new_frame = NULL;
    
        int type = (function->identifier_flags & (IDENTIFIER_TYPE_MASK|IDENTIFIER_ALIAS));
        if( o->prog != pike_trampoline_program && function->func.offset != -1 )
        {
          switch( type )
          {
            case IDENTIFIER_CONSTANT:
              constant = &context->prog->constants[function->func.const_info.offset].sval;
              if( TYPEOF(*constant) != PIKE_T_PROGRAM )
                break;
            case IDENTIFIER_C_FUNCTION:
            case IDENTIFIER_PIKE_FUNCTION:
              if( !new_frame )
              {
                new_frame=alloc_pike_frame();
                debug_malloc_touch(new_frame);
              }
    #ifdef PROFILING
              new_frame->children_base = Pike_interpreter.accounted_time;
              new_frame->start_time = get_cpu_time() - Pike_interpreter.unlocked_time;
    
              /* This is mostly for profiling, but
               * could also be used to find out the name of a function
               * in a destructed object. -hubbe
               *
               * Since it not used for anything but profiling yet, I will
               * put it here until someone needs it. -Hubbe
               */
              new_frame->ident = ref->identifier_offset;
              DO_IF_PROFILING_DEBUG({
                  fprintf(stderr, "%p{: Push at %" PRINT_CPU_TIME
                          " %" PRINT_CPU_TIME "\n",
                          Pike_interpreter.thread_state, new_frame->start_time,
                          new_frame->children_base);
                });
    #endif
              new_frame->next = Pike_fp;
              add_ref(new_frame->current_object = o);
              add_ref(new_frame->current_program = p);
              new_frame->context = context;
              new_frame->fun = DO_NOT_WARN((unsigned INT16)fun);
              new_frame->expendible = new_frame->locals = save_sp;
              new_frame->args = args;
              new_frame->save_sp = save_sp;
    
    #ifdef PIKE_DEBUG
              if (Pike_in_gc > GC_PASS_PREPARE && Pike_in_gc < GC_PASS_FREE)
                Pike_fatal("Pike code called within gc.\n");
    #endif
    
              Pike_fp = new_frame;
              debug_malloc_touch(Pike_fp);
    #ifdef PROFILING
              function->num_calls++;
              function->recur_depth++;
    #endif
    #ifdef PIKE_USE_MACHINE_CODE
              call_check_threads_etc();
    #endif
    
              if( !constant )
              {
                if (PIKE_FN_START_ENABLED())
                {
                  /* DTrace enter probe
                     arg0: function name
                     arg1: object
                  */
                  dynamic_buffer save_buf;
                  dynbuf_string obj_name;
                  struct svalue obj_sval;
                  SET_SVAL(obj_sval, T_OBJECT, 0, object, o);
                  init_buf(&save_buf);
                  safe_describe_svalue(&obj_sval, 0, NULL);
                  obj_name = complex_free_buf(&save_buf);
                  PIKE_FN_START(function->name->size_shift == 0 ?
                                function->name->str : "[widestring fn name]",
                                obj_name.str);
                }
                if(UNLIKELY(Pike_interpreter.trace_level))
                {
                  dynamic_buffer save_buf;
                  char buf[50];
    
                  init_buf(&save_buf);
                  sprintf(buf, "%lx->", DO_NOT_WARN((long) PTR_TO_INT (o)));
                  my_strcat(buf);
                  if (function->name->size_shift)
                    my_strcat ("[widestring function name]");
                  else
                    my_strcat(function->name->str);
                  do_trace_call(args, &save_buf);
                }
                if( type == IDENTIFIER_C_FUNCTION )
                {
                  new_frame->num_args = args;
                  new_frame->num_locals = args;
                  new_frame->current_storage = o->storage+context->storage_offset;
                  new_frame->pc = 0;
    #ifndef PIKE_USE_MACHINE_CODE
                  FAST_CHECK_THREADS_ON_CALL();
    #endif
                  (*function->func.c_fun)(args);
    
                  /* .. and below follows what is basically a copy of the
                   * low_return function...
                   */
                  if(save_sp+1 > Pike_sp)
                  {
                    push_int(0);
                  } else if(save_sp+1 < Pike_sp) {
                    stack_pop_n_elems_keep_top( Pike_sp-save_sp-1 );
                  }
                  if(UNLIKELY(Pike_interpreter.trace_level>1))
                    do_trace_func_return (1, o, fun);
                  goto pop;
                }
                new_frame->save_mark_sp=new_frame->mark_sp_base=Pike_mark_sp;
                new_frame->pc = new_frame->context->prog->program + function->func.offset
    #ifdef ENTRY_PROLOGUE_SIZE
                  + ENTRY_PROLOGUE_SIZE
    #endif /* ENTRY_PROLOGUE_SIZE */
                  ;
                return new_frame->pc;
              }
              else
              {
                struct object *tmp;
                new_frame->pc = 0;
                new_frame->num_args = 0;
                tmp=parent_clone_object(constant->u.program,
                                        o,
                                        fun,
                                        args);
                push_object(tmp);
              pop:
                POP_PIKE_FRAME();
                return 0;
              }
          }
        }
      }
      return low_mega_apply( APPLY_LOW, args, o, (void*)fun );
    }
    
    /* Apply a function.
     *
     * Application types:
     *
     *   APPLY_STACK:         Apply Pike_sp[-args] with args-1 arguments.
     *
     *   APPLY_SVALUE:        Apply the svalue at arg1, and adjust the stack
     *                        to leave a return value.
     *
     *   APPLY_SVALUE_STRICT: Apply the svalue at arg1, and don't adjust the
     *                        stack for functions that return void.
     *
     *   APPLY_LOW:		  Apply function #arg2 in object arg1.
     *
     * Return values:
     *
     *   Returns zero if the function was invalid or has been executed.
     *
     *   Returns one if a frame has been set up to start the function
     *   with eval_instruction(Pike_fp->pc - ENTRY_PROLOGUE_SIZE). After
     *   eval_instruction() is done the frame needs to be removed by a call
     *   to low_return() or low_return_pop().
     */
    void* low_mega_apply(enum apply_type type, INT32 args, void *arg1, void *arg2)
    {
      struct object *o = NULL;
      struct pike_frame *scope=0;
      ptrdiff_t fun=0;
      struct svalue *save_sp=Pike_sp-args;
    
    #if defined(PIKE_DEBUG) && defined(_REENTRANT)
      if(d_flag)
        {
          THREAD_T self = th_self();
    
          CHECK_INTERPRETER_LOCK();
    
          if (Pike_interpreter.thread_state) {
    	if (!th_equal(Pike_interpreter.thread_state->id, self))
    	  Pike_fatal("Current thread is wrong.\n");
    
    	DEBUG_CHECK_THREAD();
          }
        }
    #endif
    
      switch(type)
      {
      case APPLY_STACK:
        if(!args)
          PIKE_ERROR("`()", "Too few arguments (apply stack).\n", Pike_sp, 0);
        args--;
        arg1=(void *)(Pike_sp-args-1);
    
      case APPLY_SVALUE:
      case APPLY_SVALUE_STRICT:
      apply_svalue:
      {
        struct svalue *s=(struct svalue *)arg1;
        switch(TYPEOF(*s))
        {
        case T_INT:
          if (!s->u.integer) {
    	PIKE_ERROR("0", "Attempt to call the NULL-value\n", Pike_sp, args);
          } else {
    	Pike_error("Attempt to call the value %"PRINTPIKEINT"d\n", 
    		   s->u.integer);
          }
    
        case T_STRING:
          if (s->u.string->len > 20) {
    	Pike_error("Attempt to call the string \"%20S\"...\n", s->u.string);
          } else {
    	Pike_error("Attempt to call the string \"%S\"\n", s->u.string);
          }
        case T_MAPPING:
          Pike_error("Attempt to call a mapping\n");
        default:
          Pike_error("Call to non-function value type:%s.\n",
    		 get_name_of_type(TYPEOF(*s)));
    
        case T_FUNCTION:
          if(SUBTYPEOF(*s) == FUNCTION_BUILTIN)
          {
    #ifdef PIKE_DEBUG
    	struct svalue *expected_stack = Pike_sp-args;
    #endif
    	if(Pike_interpreter.trace_level>1)
    	{
    	  dynamic_buffer save_buf;
    	  init_buf(&save_buf);
    	  if (s->u.efun->name->size_shift)
    	    my_strcat ("[widestring function name]");
    	  else
    	    my_strcat (s->u.efun->name->str);
    	  do_trace_call(args, &save_buf);
    	}
    	if (PIKE_FN_START_ENABLED()) {
    	  /* DTrace enter probe
    	     arg0: function name
    	     arg1: object
    	   */
    	  PIKE_FN_START(s->u.efun->name->size_shift == 0 ?
    			s->u.efun->name->str : "[widestring fn name]",
    			"");
    	}
    	FAST_CHECK_THREADS_ON_CALL();
    	(*(s->u.efun->function))(args);
    	if (PIKE_FN_DONE_ENABLED()) {
    	  /* DTrace leave probe
    	     arg0: function name
    	  */
    	  PIKE_FN_DONE(s->u.efun->name->size_shift == 0 ?
    		       s->u.efun->name->str : "[widestring fn name]");
    	}
    
    #ifdef PIKE_DEBUG
    	s->u.efun->runs++;
    	if(Pike_sp != expected_stack + !s->u.efun->may_return_void)
    	{
    	  if(Pike_sp < expected_stack)
    	    Pike_fatal("Function popped too many arguments: %S\n",
    		       s->u.efun->name);
    	  if(Pike_sp>expected_stack+1)
    	    Pike_fatal("Function left droppings on stack: %S\n",
    		       s->u.efun->name);
    	  if(Pike_sp == expected_stack && !s->u.efun->may_return_void)
    	    Pike_fatal("Non-void function returned without return value on stack: %S %d\n",
    		       s->u.efun->name, s->u.efun->may_return_void);
    	  if(Pike_sp==expected_stack+1 && s->u.efun->may_return_void)
    	    Pike_fatal("Void function returned with a value on the stack: %S %d\n",
    		       s->u.efun->name, s->u.efun->may_return_void);
    	}
    #endif
    
    	break;
          }else{
    	type=APPLY_SVALUE;
    	o=s->u.object;
            fun = SUBTYPEOF(*s);
    	if(o->prog == pike_trampoline_program &&
    	   fun == QUICK_FIND_LFUN(pike_trampoline_program, LFUN_CALL))
    	{
    	  fun=((struct pike_trampoline *)(o->storage))->func;
    	  scope=((struct pike_trampoline *)(o->storage))->frame;
    	  o=scope->current_object;
    	}
            goto apply_low;
          }
          break;
    
        case T_ARRAY:
          if(Pike_interpreter.trace_level)
          {
    	dynamic_buffer save_buf;
    	init_buf(&save_buf);
    	safe_describe_svalue(s,0,0);
    	do_trace_call(args, &save_buf);
          }
          if (PIKE_FN_START_ENABLED()) {
    	/* DTrace enter probe
    	   arg0: function name
    	   arg1: object
    	*/
    	PIKE_FN_START("[array]", "");
          }
          apply_array(s->u.array, args, (type == APPLY_STACK));
          break;
    
        case PIKE_T_TYPE:
          if (args != 1) {
    	/* FIXME: Casts to object ought to propagate to apply program below. */
    	SIMPLE_WRONG_NUM_ARGS_ERROR("cast", 1);
          }
          o_cast(s->u.type, compile_type_to_runtime_type(s->u.type));
          break;
    
        case T_PROGRAM:
          if(Pike_interpreter.trace_level)
          {
    	dynamic_buffer save_buf;
    	init_buf(&save_buf);
    	safe_describe_svalue(s,0,0);
    	do_trace_call(args, &save_buf);
          }
          if (PIKE_FN_START_ENABLED()) {
    	/* DTrace enter probe
    	   arg0: function name
    	   arg1: object
    	*/
    	dynamic_buffer save_buf;
    	dynbuf_string prog_name;
    	init_buf(&save_buf);
    	safe_describe_svalue(s,0,0);
    	prog_name = complex_free_buf(&save_buf);
    	PIKE_FN_START("[program]", prog_name.str);
          }
          push_object(clone_object(s->u.program,args));
          break;
    
        case T_OBJECT:
          /* FIXME: Object subtypes! */
          o=s->u.object;
          if(o->prog == pike_trampoline_program)
          {
    	fun=((struct pike_trampoline *)(o->storage))->func;
    	scope=((struct pike_trampoline *)(o->storage))->frame;
    	o=scope->current_object;
    	goto apply_low;
          }
          fun=LFUN_CALL;
          type=APPLY_SVALUE;
          goto call_lfun;
        }
        break;
      }
    
      call_lfun: {
        int lfun;
    #ifdef PIKE_DEBUG
        if(fun < 0 || fun >= NUM_LFUNS)
          Pike_fatal("Apply lfun on illegal value!\n");
    #endif
        if(!o->prog)
          PIKE_ERROR("destructed object", "Apply on destructed object.\n", Pike_sp, args);
        lfun = FIND_LFUN(o->prog, fun);
        if (lfun < 0)
          Pike_error ("Cannot call undefined lfun %s.\n", lfun_names[fun]);
        fun = lfun;
        goto apply_low;
      }
    
      case APPLY_LOW:
        o = (struct object *)arg1;
        fun = PTR_TO_INT(arg2);
        if(o->prog == pike_trampoline_program &&
           fun == QUICK_FIND_LFUN(pike_trampoline_program, LFUN_CALL))
        {
          fun=((struct pike_trampoline *)(o->storage))->func;
          scope=((struct pike_trampoline *)(o->storage))->frame;
          o=scope->current_object;
        }
    
      apply_low:
    #include "apply_low.h"
        break;
      }
    
      if(save_sp+1 > Pike_sp)
      {
        if(type != APPLY_SVALUE_STRICT) {
          push_int(0);
          if(Pike_interpreter.trace_level>1)
    	do_trace_func_return (1, o, fun);
        }
        else
          if(Pike_interpreter.trace_level>1)
    	do_trace_func_return (0, o, fun);
      }else{
        if(save_sp+1 < Pike_sp)
        {
          assign_svalue(save_sp,Pike_sp-1);
          pop_n_elems(Pike_sp-save_sp-1);
          low_destruct_objects_to_destruct(); /* consider using a flag for immediate destruct instead... */
        }
        if(Pike_interpreter.trace_level>1)
          do_trace_func_return (1, o, fun);
      }
    
      if (PIKE_FN_DONE_ENABLED()) {
        /* DTrace leave probe
           arg0: function name
        */
        char *fn = "(unknown)";
        if (o && o->prog) {
          struct identifier *id = ID_FROM_INT(o->prog, fun);
          fn = id->name->size_shift == 0 ? id->name->str : "[widestring fn name]";
        }
        PIKE_FN_DONE(fn);
      }
    
      return 0;
    }
    
    
    
    #define basic_low_return(save_sp)			\
      DO_IF_DEBUG(						\
        if(Pike_mark_sp < Pike_fp->save_mark_sp)		\
          Pike_fatal("Popped below save_mark_sp!\n");	\
        if(Pike_sp<Pike_interpreter.evaluator_stack)	\
          Pike_fatal("Stack error (also simple).\n");	\
        )							\
    							\
        Pike_mark_sp=Pike_fp->save_mark_sp;			\
    							\
      POP_PIKE_FRAME()
    
    
    void low_return(void)
    {
      struct svalue *save_sp = Pike_fp->save_sp+1;
      struct object *o = Pike_fp->current_object;
      int fun = Pike_fp->fun;
    
      if (PIKE_FN_DONE_ENABLED()) {
        /* DTrace leave probe
           arg0: function name
        */
        char *fn = "(unknown)";
        if (o && o->prog) {
          struct identifier *id = ID_FROM_INT(o->prog, fun);
          fn = id->name->size_shift == 0 ? id->name->str : "[widestring fn name]";
        }
        PIKE_FN_DONE(fn);
      }
    
    #if defined (PIKE_USE_MACHINE_CODE) && defined (OPCODE_RETURN_JUMPADDR)
      /* If the function that returns is the only ref to the current
       * object and its program then the program would be freed in
       * destruct_objects_to_destruct below. However, we're still
       * executing in an opcode in its code so we need prog->program to
       * stick around for a little while more to handle the returned
       * address. We therefore add a ref to the current object so that
       * it'll live through this function. */
      add_ref (o);
    #endif
    
      basic_low_return (save_sp);
    
      stack_pop_n_elems_keep_top (Pike_sp - save_sp);
      {
          /* consider using a flag for immediate destruct instead... */
          extern struct object *objects_to_destruct;
          if( objects_to_destruct )
              destruct_objects_to_destruct();
      }
    
    #ifdef PIKE_DEBUG
      if(save_sp > Pike_sp)
          Pike_fatal("Pike function did not leave an return value\n");
    #endif
    
      if(UNLIKELY(Pike_interpreter.trace_level>1))
        do_trace_func_return (1, o, fun);
    
    #if defined (PIKE_USE_MACHINE_CODE) && defined (OPCODE_RETURN_JUMPADDR)
      free_object (o);
    #endif
    }
    
    void low_return_pop(void)
    {
      struct svalue *save_sp = Pike_fp->save_sp;
    #if defined (PIKE_USE_MACHINE_CODE) && defined (OPCODE_RETURN_JUMPADDR)
      /* See note above. */
      struct object *o = Pike_fp->current_object;
      add_ref (o);
    #endif
    
      if (PIKE_FN_DONE_ENABLED()) {
        /* DTrace leave probe
           arg0: function name
        */
        char *fn = "(unknown)";
        struct object *o = Pike_fp->current_object;
        int fun = Pike_fp->fun;
        if (o && o->prog) {
          struct identifier *id = ID_FROM_INT(o->prog, fun);
          fn = id->name->size_shift == 0 ? id->name->str : "[widestring fn name]";
        }
        PIKE_FN_DONE(fn);
      }
    
      basic_low_return (save_sp);
    
      pop_n_elems(Pike_sp-save_sp);
      /* consider using a flag for immediate destruct instead... */
      destruct_objects_to_destruct();
    
    #if defined (PIKE_USE_MACHINE_CODE) && defined (OPCODE_RETURN_JUMPADDR)
      free_object (o);
    #endif
    }
    
    
    void unlink_previous_frame(void)
    {
      struct pike_frame *current, *prev;
    
      current=Pike_interpreter.frame_pointer;
      prev=current->next;
    #ifdef PIKE_DEBUG
      {
        JMP_BUF *rec;
    
        /* Check if any recoveries belong to the frame we're
         * about to unlink.
         */
        if((rec=Pike_interpreter.recoveries))
        {
          while(rec->frame_pointer == current) rec=rec->previous;
          /* FIXME: Wouldn't a simple return be ok? */
          if(rec->frame_pointer == current->next)
    	Pike_fatal("You can't touch this!\n");
        }
      }
    #endif
      /* Save various fields from the previous frame.
       */
      current->save_sp=prev->save_sp;
      current->save_mark_sp=prev->save_mark_sp;
      current->flags = prev->flags;
    
      /* Unlink the top frame temporarily. */
      Pike_interpreter.frame_pointer=prev;
    
    #ifdef PROFILING
      {
        /* We must update the profiling info of the previous frame
         * to account for that the current frame has gone away.
         */
        cpu_time_t total_time =
          get_cpu_time() - (Pike_interpreter.unlocked_time + current->start_time);
        cpu_time_t child_time =
          Pike_interpreter.accounted_time - current->children_base;
        struct identifier *function =
          current->context->prog->identifiers + current->ident;
        if (!function->recur_depth)
          function->total_time += total_time;
        total_time -= child_time;
        function->self_time += total_time;
        Pike_interpreter.accounted_time += total_time;
    #ifdef PROFILING_DEBUG
        fprintf(stderr, "%p: Unlinking previous frame.\n"
    	    "Previous: %" PRINT_CPU_TIME " %" PRINT_CPU_TIME "\n"
    	    "Current:  %" PRINT_CPU_TIME " %" PRINT_CPU_TIME "\n",
    	    Pike_interpreter.thread_state,
    	    prev->start_time, prev->children_base,
    	    current->start_time, current->children_base);
    #endif /* PROFILING_DEBUG */
      }
    #endif /* PROFILING */
    
      /* Unlink the frame. */
      POP_PIKE_FRAME();
    
      /* Hook our frame again. */
      current->next=Pike_interpreter.frame_pointer;
      Pike_interpreter.frame_pointer=current;
    
    #ifdef PROFILING
      current->children_base = Pike_interpreter.accounted_time;
      current->start_time = get_cpu_time() - Pike_interpreter.unlocked_time;
    #endif /* PROFILING */
    }
    
    static void restore_catching_eval_jmpbuf (LOW_JMP_BUF *p)
    {
      Pike_interpreter.catching_eval_jmpbuf = p;
    }
    
    PMOD_EXPORT void mega_apply(enum apply_type type, INT32 args, void *arg1, void *arg2)
    {
      /* Save and clear Pike_interpreter.catching_eval_jmpbuf so that the
       * following eval_instruction will install a LOW_JMP_BUF of its
       * own to handle catches. */
      LOW_JMP_BUF *saved_jmpbuf = Pike_interpreter.catching_eval_jmpbuf;
      ONERROR uwp;
      Pike_interpreter.catching_eval_jmpbuf = NULL;
      SET_ONERROR (uwp, restore_catching_eval_jmpbuf, saved_jmpbuf);
    
      /* The C stack margin is normally 8 kb, but if we get here during a
       * lowered margin then don't fail just because of that, unless it's
       * practically zero. */
      check_c_stack(Pike_interpreter.c_stack_margin ?
    		Pike_interpreter.c_stack_margin : 100);
      if( low_mega_apply(type, args, arg1, arg2) )
      {
        eval_instruction(Pike_fp->pc
    #ifdef ENTRY_PROLOGUE_SIZE
    		     - ENTRY_PROLOGUE_SIZE
    #endif /* ENTRY_PROLOGUE_SIZE */
    		     );
        low_return();
      }
      CALL_AND_UNSET_ONERROR(uwp);
    }
    
    PMOD_EXPORT void mega_apply_low(INT32 args, void *arg1, ptrdiff_t arg2)
    {
      /* Save and clear Pike_interpreter.catching_eval_jmpbuf so that the
       * following eval_instruction will install a LOW_JMP_BUF of its
       * own to handle catches. */
      LOW_JMP_BUF *saved_jmpbuf = Pike_interpreter.catching_eval_jmpbuf;
      ONERROR uwp;
      Pike_interpreter.catching_eval_jmpbuf = NULL;
      SET_ONERROR (uwp, restore_catching_eval_jmpbuf, saved_jmpbuf);
    
      /* The C stack margin is normally 8 kb, but if we get here during a
       * lowered margin then don't fail just because of that, unless it's
       * practically zero. */
      check_c_stack(Pike_interpreter.c_stack_margin ?
    		Pike_interpreter.c_stack_margin : 100);
      if( lower_mega_apply( args, arg1, arg2 ) )
      {
        eval_instruction(Pike_fp->pc
    #ifdef ENTRY_PROLOGUE_SIZE
    		     - ENTRY_PROLOGUE_SIZE
    #endif /* ENTRY_PROLOGUE_SIZE */
    		     );
        low_return();
      }
      CALL_AND_UNSET_ONERROR(uwp);
    }
    
    /* Put catch outside of eval_instruction, so the setjmp won't affect
     * the optimization of eval_instruction.
     */
    static int catching_eval_instruction (PIKE_OPCODE_T *pc)
    {
      LOW_JMP_BUF jmpbuf;
    #ifdef PIKE_DEBUG
      if (Pike_interpreter.catching_eval_jmpbuf)
        Pike_fatal ("catching_eval_jmpbuf already active.\n");
    #endif
      Pike_interpreter.catching_eval_jmpbuf = &jmpbuf;
      if (LOW_SETJMP (jmpbuf))
      {
        Pike_interpreter.catching_eval_jmpbuf = NULL;
    #ifdef PIKE_DEBUG
        pike_trace(3, "-    catching_eval_instruction(%p) caught error ==> -3\n",
    	       pc);
    #endif
        return -3;
      }else{
        int x;
        check_c_stack(8192);
        x = eval_instruction(pc);
        Pike_interpreter.catching_eval_jmpbuf = NULL;
    #ifdef PIKE_DEBUG
        pike_trace(3, "-    catching_eval_instruction(%p) ==> %d\n", pc, x);
    #endif
        return x;
      }
    }
    
    /*! @decl mixed `()(function fun, mixed ... args)
     *! @decl mixed call_function(function fun, mixed ... args)
     *!
     *! Call a function.
     *!
     *! Calls the function @[fun] with the arguments specified by @[args].
     *!
     *! @seealso
     *!   @[lfun::`()()]
     */
    PMOD_EXPORT void f_call_function(INT32 args)
    {
      mega_apply(APPLY_STACK,args,0,0);
    }
    
    /*! @class MasterObject
     */
    
    /*! @decl void handle_error(mixed exception)
     *!
     *!   Called by the Pike runtime if an exception isn't caught.
     *!
     *! @param exception
     *!   Value that was @[throw()]'n.
     *!
     *! @seealso
     *!   @[describe_backtrace()]
     */
    
    /*! @endclass
     */
    
    PMOD_EXPORT void call_handle_error(void)
    {
      dmalloc_touch_svalue(&throw_value);
    
      if (Pike_interpreter.svalue_stack_margin > LOW_SVALUE_STACK_MARGIN) {
        int old_t_flag = Pike_interpreter.trace_level;
        Pike_interpreter.trace_level = 0;
        Pike_interpreter.svalue_stack_margin = LOW_SVALUE_STACK_MARGIN;
        Pike_interpreter.c_stack_margin = LOW_C_STACK_MARGIN;
        move_svalue (Pike_sp++, &throw_value);
        mark_free_svalue (&throw_value);
    
        if (get_master()) {		/* May return NULL at odd times. */
          ONERROR tmp;
          SET_ONERROR(tmp,exit_on_error,"Error in handle_error in master object!");
          APPLY_MASTER("handle_error", 1);
          UNSET_ONERROR(tmp);
        }
        else {
          dynamic_buffer save_buf;
          char *s;
          fprintf (stderr, "There's no master to handle the error. Dumping it raw:\n");
          init_buf(&save_buf);
          safe_describe_svalue (Pike_sp - 1, 0, 0);
          s=simple_free_buf(&save_buf);
          fprintf(stderr,"%s\n",s);
          free(s);
          if (TYPEOF(Pike_sp[-1]) == PIKE_T_OBJECT && Pike_sp[-1].u.object->prog) {
    	int fun = find_identifier("backtrace", Pike_sp[-1].u.object->prog);
    	if (fun != -1) {
    	  fprintf(stderr, "Attempting to extract the backtrace.\n");
    	  safe_apply_low2(Pike_sp[-1].u.object, fun, 0, 0);
    	  init_buf(&save_buf);
    	  safe_describe_svalue(Pike_sp - 1, 0, 0);
    	  pop_stack();
    	  s=simple_free_buf(&save_buf);
    	  fprintf(stderr,"%s\n",s);
    	  free(s);
    	}
          }
        }
    
        pop_stack();
        Pike_interpreter.svalue_stack_margin = SVALUE_STACK_MARGIN;
        Pike_interpreter.c_stack_margin = C_STACK_MARGIN;
        Pike_interpreter.trace_level = old_t_flag;
      }
    
      else {
        free_svalue(&throw_value);
        mark_free_svalue (&throw_value);
      }
    }
    
    /* NOTE: This function may only be called from the compiler! */
    int apply_low_safe_and_stupid(struct object *o, INT32 offset)
    {
      JMP_BUF tmp;
      struct pike_frame *new_frame=alloc_pike_frame();
      int ret;
      volatile int use_dummy_reference = 1;
      struct program *prog = o->prog;
      int p_flags = prog->flags;
      LOW_JMP_BUF *saved_jmpbuf;
      int fun = -1;
    
      /* Search for a function that belongs to the current program,
       * since this is needed for opcodes that use INHERIT_FROM_*
       * (eg F_EXTERN) to work.
       */
      for (fun = prog->num_identifier_references; fun--;) {
        if (!prog->identifier_references[fun].inherit_offset) {
          use_dummy_reference = 0;
          break;
        }
      }
    
      if (use_dummy_reference) {
        /* No suitable function was found, so add one. */
        struct identifier dummy;
        struct reference dummy_ref = {
          0, 0, ID_HIDDEN,
          PIKE_T_UNKNOWN, { 0, },
        };
        /* FIXME: Assert that o->prog == Pike_compiler->new_program */
        copy_shared_string(dummy.name, empty_pike_string);
        copy_pike_type(dummy.type, function_type_string);
        dummy.filename_strno = -1;
        dummy.linenumber = 0;
        dummy.run_time_type = PIKE_T_FUNCTION;
        dummy.identifier_flags = IDENTIFIER_PIKE_FUNCTION|IDENTIFIER_HAS_BODY;
        dummy.func.offset = offset;
        dummy.opt_flags = 0;
        dummy_ref.identifier_offset = prog->num_identifiers;
        add_to_identifiers(dummy);
        fun = prog->num_identifier_references;
        add_to_identifier_references(dummy_ref);
      }
    
      /* FIXME: Is this up-to-date with mega_apply? */
      new_frame->next = Pike_fp;
      add_ref(new_frame->current_object = o);
      add_ref(new_frame->current_program = prog);
      new_frame->context = prog->inherits;
      new_frame->locals = Pike_sp;
      new_frame->expendible=new_frame->locals;
      new_frame->args = 0;
      new_frame->num_args=0;
      new_frame->num_locals=0;
      new_frame->fun = fun;
      new_frame->pc = 0;
      new_frame->current_storage=o->storage;
    
    #ifdef PIKE_DEBUG      
      if (Pike_fp && (new_frame->locals < Pike_fp->locals)) {
        fatal("New locals below old locals: %p < %p\n",
    	  new_frame->locals, Pike_fp->locals);
      }
    #endif /* PIKE_DEBUG */
    
      Pike_fp = new_frame;
    
      saved_jmpbuf = Pike_interpreter.catching_eval_jmpbuf;
      Pike_interpreter.catching_eval_jmpbuf = NULL;
    
      if(SETJMP(tmp))
      {
        ret=1;
      }else{
        int tmp;
        new_frame->mark_sp_base=new_frame->save_mark_sp=Pike_mark_sp;
        tmp=eval_instruction(prog->program + offset);
        Pike_mark_sp=new_frame->save_mark_sp;
        
    #ifdef PIKE_DEBUG
        if (tmp != -1)
          Pike_fatal ("Unexpected return value from eval_instruction: %d\n", tmp);
        if(Pike_sp<Pike_interpreter.evaluator_stack)
          Pike_fatal("Stack error (simple).\n");
    #endif
        ret=0;
      }
      UNSETJMP(tmp);
    
      Pike_interpreter.catching_eval_jmpbuf = saved_jmpbuf;
    
      if (use_dummy_reference) {
        /* Pop the dummy identifier. */
        free_type(function_type_string);
        free_string(empty_pike_string);
        prog->num_identifier_references--;
        prog->num_identifiers--;
      }
    
      assert (new_frame == Pike_fp);
      LOW_POP_PIKE_FRAME (new_frame);
    
      return ret;
    }
    
    int safe_apply_low2(struct object *o, int fun, int args,
    				const char *fun_name)
    {
      JMP_BUF recovery;
      int ret = 0;
    
      free_svalue(& throw_value);
      mark_free_svalue (&throw_value);
      if(SETJMP_SP(recovery, args))
      {
        if(fun_name) call_handle_error();
        push_int(0);
        ret = 0;
      }else{
        if (fun >= 0) {
          apply_low(o,fun,args);
        } else if (fun_name) {
          Pike_error("Cannot call unknown function \"%s\".\n", fun_name);
        } else {
          pop_n_elems(args);
          push_int(0);
        }
        ret = 1;
      }
      UNSETJMP(recovery);
      return ret;
    }
    
    PMOD_EXPORT int safe_apply_low(struct object *o, int fun, int args)
    {
      return safe_apply_low2(o, fun, args, "Unknown function.");
    }
    
    PMOD_EXPORT int safe_apply(struct object *o, const char *fun, INT32 args)
    {
      int id;
    #ifdef PIKE_DEBUG
      if(!o->prog) Pike_fatal("Apply safe on destructed object.\n");
    #endif
      id = find_identifier(fun, o->prog);
      return safe_apply_low2(o, id, args, fun);
    }
    
    /* Returns nonzero if the function was called in some handler. */
    int low_unsafe_apply_handler(const char *fun,
    					 struct object *handler,
    					 struct object *compat,
    					 INT32 args)
    {
      int i;
    #if 0
      fprintf(stderr, "low_unsafe_apply_handler(\"%s\", 0x%08p, 0x%08p, %d)\n",
    	  fun, handler, compat, args);
    #endif /* 0 */
      if (handler && handler->prog &&
          (i = find_identifier(fun, handler->prog)) != -1) {
        apply_low(handler, i, args);
      } else if (compat && compat->prog &&
    	     (i = find_identifier(fun, compat->prog)) != -1) {
        apply_low(compat, i, args);
      } else {
        struct object *master_obj = get_master();
        if (master_obj && (i = find_identifier(fun, master_obj->prog)) != -1)
          apply_low(master_obj, i, args);
        else {
          pop_n_elems(args);
          push_undefined();
          return 0;
        }
      }
      return 1;
    }
    
    void low_safe_apply_handler(const char *fun,
    					struct object *handler,
    					struct object *compat,
    					INT32 args)
    {
      int i;
    #if 0
      fprintf(stderr, "low_safe_apply_handler(\"%s\", 0x%08p, 0x%08p, %d)\n",
    	  fun, handler, compat, args);
    #endif /* 0 */
      if (handler && handler->prog &&
          (i = find_identifier(fun, handler->prog)) != -1) {
        safe_apply_low2(handler, i, args, fun);
      } else if (compat && compat->prog &&
    	     (i = find_identifier(fun, compat->prog)) != -1) {
        safe_apply_low2(compat, i, args, fun);
      } else {
        struct object *master_obj = master();
        if ((i = find_identifier(fun, master_obj->prog)) != -1)
          safe_apply_low2(master_obj, i, args, fun);
        else {
          pop_n_elems(args);
          push_undefined();
        }
      }
    }
    
    PMOD_EXPORT void push_text( const char *x )
    {
        struct svalue *_sp_ = Pike_sp++;
        SET_SVAL_SUBTYPE(*_sp_, 0);
        _sp_->u.string=make_shared_string(x);
        debug_malloc_touch(_sp_->u.string);
        SET_SVAL_TYPE(*_sp_, PIKE_T_STRING);
    }
    
    /* NOTE: Returns 1 if result on stack, 0 otherwise. */
    PMOD_EXPORT int safe_apply_handler(const char *fun,
    				   struct object *handler,
    				   struct object *compat,
    				   INT32 args,
    				   TYPE_FIELD rettypes)
    {
      JMP_BUF recovery;
      int ret;
    
      STACK_LEVEL_START(args);
    
    #if 0
      fprintf(stderr, "safe_apply_handler(\"%s\", 0x%08p, 0x%08p, %d)\n",
    	  fun, handler, compat, args);
    #endif /* 0 */
    
      free_svalue(& throw_value);
      mark_free_svalue (&throw_value);
    
      if (SETJMP_SP(recovery, args)) {
        ret = 0;
      } else {
        if (low_unsafe_apply_handler (fun, handler, compat, args) &&
    	rettypes && !((1 << TYPEOF(Pike_sp[-1])) & rettypes)) {
          if ((rettypes & BIT_ZERO) && SAFE_IS_ZERO (Pike_sp - 1)) {
    	pop_stack();
    	push_int(0);
          }
          else {
    	Pike_error("Invalid return value from %s: %O\n",
    		   fun, Pike_sp-1);
          }
        }
    
        ret = 1;
      }
    
      UNSETJMP(recovery);
    
      STACK_LEVEL_DONE(ret);
    
      return ret;
    }
    
    PMOD_EXPORT void apply_lfun(struct object *o, int lfun, int args)
    {
      int fun;
    #ifdef PIKE_DEBUG
      if(lfun < 0 || lfun >= NUM_LFUNS)
        Pike_fatal("Apply lfun on illegal value!\n");
    #endif
      if(!o->prog)
        PIKE_ERROR("destructed object", "Apply on destructed object.\n",
    	       Pike_sp, args);
    
      if ((fun = (int)FIND_LFUN(o->prog, lfun)) < 0)
        Pike_error("Calling undefined lfun::%s.\n", lfun_names[lfun]);
    
      apply_low(o, fun, args);
    }
    
    PMOD_EXPORT void apply_shared(struct object *o,
    		  struct pike_string *fun,
    		  int args)
    {
      int id = find_shared_string_identifier(fun, o->prog);
      if (id >= 0)
        apply_low(o, id, args);
      else
        Pike_error("Cannot call unknown function \"%S\".\n", fun);
    }
    
    PMOD_EXPORT void apply(struct object *o, const char *fun, int args)
    {
      int id = find_identifier(fun, o->prog);
      if (id >= 0)
        apply_low(o, id, args);
      else
        Pike_error ("Cannot call unknown function \"%s\".\n", fun);
    }
    
    
    PMOD_EXPORT void apply_svalue(struct svalue *s, INT32 args)
    {
      if(TYPEOF(*s) == T_INT)
      {
        pop_n_elems(args);
        push_int(0);
      }else{
        ptrdiff_t expected_stack=Pike_sp-args+1 - Pike_interpreter.evaluator_stack;
    
        strict_apply_svalue(s,args);
        if(Pike_sp > (expected_stack + Pike_interpreter.evaluator_stack))
        {
          pop_n_elems(Pike_sp-(expected_stack + Pike_interpreter.evaluator_stack));
        }
        else if(Pike_sp < (expected_stack + Pike_interpreter.evaluator_stack))
        {
          push_int(0);
        }
    #ifdef PIKE_DEBUG
        if(Pike_sp < (expected_stack + Pike_interpreter.evaluator_stack))
          Pike_fatal("Stack underflow!\n");
    #endif
      }
    }
    
    PMOD_EXPORT void safe_apply_svalue(struct svalue *s, int args, int handle_errors)
    {
      JMP_BUF recovery;
      free_svalue(& throw_value);
      mark_free_svalue (&throw_value);
      if(SETJMP_SP(recovery, args))
      {
        if(handle_errors) call_handle_error();
        push_int(0);
      }else{
        apply_svalue (s, args);
      }
      UNSETJMP(recovery);
    }
    
    /* Apply function @[fun] in parent @[depth] levels up with @[args] arguments.
     */
    PMOD_EXPORT void apply_external(int depth, int fun, INT32 args)
    {
      struct external_variable_context loc;
    
      loc.o = Pike_fp->current_object;
      loc.parent_identifier = Pike_fp->fun;
      if (loc.o->prog) {
        loc.inherit = INHERIT_FROM_INT(loc.o->prog, loc.parent_identifier);
    
        find_external_context(&loc, depth);
    
        apply_low(loc.o, fun + loc.inherit->identifier_level, args);
      } else {
        PIKE_ERROR("destructed object", "Apply on parent of destructed object.\n",
    	       Pike_sp, args);
      }
    }
    
    #ifdef PIKE_DEBUG
    void slow_check_stack(void)
    {
      struct svalue *s,**m;
      struct pike_frame *f;
    
      debug_check_stack();
    
      if(Pike_sp > &(Pike_interpreter.evaluator_stack[Pike_stack_size]))
        Pike_fatal("Svalue stack overflow. "
    	  "(%ld entries on stack, stack_size is %ld entries)\n",
    	  PTRDIFF_T_TO_LONG(Pike_sp - Pike_interpreter.evaluator_stack),
    	  PTRDIFF_T_TO_LONG(Pike_stack_size));
    
      if(Pike_mark_sp > &(Pike_interpreter.mark_stack[Pike_stack_size]))
        Pike_fatal("Mark stack overflow.\n");
    
      if(Pike_mark_sp < Pike_interpreter.mark_stack)
        Pike_fatal("Mark stack underflow.\n");
    
      for(s=Pike_interpreter.evaluator_stack;s<Pike_sp;s++) {
        /* NOTE: Freed svalues are allowed on the stack. */
        if (TYPEOF(*s) != PIKE_T_FREE) check_svalue(s);
      }
    
      s=Pike_interpreter.evaluator_stack;
      for(m=Pike_interpreter.mark_stack;m<Pike_mark_sp;m++)
      {
        if(*m < s)
          Pike_fatal("Mark stack failure.\n");
    
        s=*m;
      }
    
      if(s > &(Pike_interpreter.evaluator_stack[Pike_stack_size]))
        Pike_fatal("Mark stack exceeds svalue stack\n");
    
      for(f=Pike_fp;f;f=f->next)
      {
        if(f->locals)
        {
          if(f->locals < Pike_interpreter.evaluator_stack ||
    	f->locals > &(Pike_interpreter.evaluator_stack[Pike_stack_size]))
          Pike_fatal("Local variable pointer points to Finspng.\n");
    
          if(f->args < 0 || f->args > Pike_stack_size)
    	Pike_fatal("FEL FEL FEL! HELP!! (corrupted pike_frame)\n");
        }
      }
    }
    
    
    static const char *safe_idname_from_int(struct program *prog, int func)
    {
      /* ID_FROM_INT with a thick layer of checks. */
      struct reference *ref;
      struct inherit *inher;
      struct identifier *id;
      if (!prog)
        return "<null program *>";
      if (func < 0 || func >= prog->num_identifier_references)
        return "<offset outside prog->identifier_references>";
      if (!prog->identifier_references)
        return "<null prog->identifier_references>";
      ref = prog->identifier_references + func;
      if (ref->inherit_offset >= prog->num_inherits)
        return "<offset outside prog->inherits>";
      if (!prog->inherits)
        return "<null prog->inherits>";
      inher = prog->inherits + ref->inherit_offset;
      prog = inher->prog;
      if (!prog)
        return "<null inherited prog>";
      if (ref->identifier_offset >= prog->num_identifiers)
        return "<offset outside inherited prog->identifiers>";
      if (!prog->identifiers)
        return "<null inherited prog->identifiers>";
      id = prog->identifiers + ref->identifier_offset;
      if (!id->name)
        return "<null identifier->name>";
      if (id->name->size_shift)
        return "<wide identifier->name->str>";
      /* FIXME: Convert wide string identifiers to narrow strings? */
      return id->name->str;
    }
    
    /*: Prints the Pike backtrace for the interpreter context in the given
     *: thread to stderr, without messing in the internals (doesn't even
     *: use dynamic_buffer).
     *:
     *: This function is intended only for convenient use inside a
     *: debugger session; it can't be used from inside the code.
     */
    void gdb_backtrace (
    #ifdef PIKE_THREADS
      THREAD_T thread_id
    #endif
    )
    {
      struct pike_frame *f, *of;
    
    #ifdef PIKE_THREADS
      extern struct thread_state *gdb_thread_state_for_id(THREAD_T);
      struct thread_state *ts = gdb_thread_state_for_id(thread_id);
      if (!ts) {
        fputs ("Not a Pike thread.\n", stderr);
        return;
      }
      f = ts->state.frame_pointer;
    #else
      f = Pike_fp;
    #endif
    
      for (of = 0; f; f = (of = f)->next)
        if (f->refs) {
          int args, i;
          char *file = NULL;
          INT_TYPE line;
    
          if (f->context) {
    	if (f->pc)
    	  file = low_get_line_plain (f->pc, f->context->prog, &line, 0);
    	else
    	  file = low_get_program_line_plain (f->context->prog, &line, 0);
          }
          if (file)
    	fprintf (stderr, "%s:%ld: ", file, (long)line);
          else
    	fputs ("unknown program: ", stderr);
    
          if (f->current_program) {
    	/* FIXME: Wide string identifiers. */
    	fputs (safe_idname_from_int(f->current_program, f->fun), stderr);
    	fputc ('(', stderr);
          }
          else
    	fputs ("unknown function(", stderr);
    
          if(!f->locals)
          {
    	args=0;
          }else{
    	args=f->num_args;
    	args = DO_NOT_WARN((INT32) MINIMUM(f->num_args, Pike_sp - f->locals));
    	if(of)
    	  args = DO_NOT_WARN((INT32)MINIMUM(f->num_args,of->locals - f->locals));
    	args=MAXIMUM(args,0);
          }
    
          for (i = 0; i < args; i++) {
    	struct svalue *arg = f->locals + i;
    
    	switch (TYPEOF(*arg)) {
    	  case T_INT:
    	    fprintf (stderr, "%ld", (long) arg->u.integer);
    	    break;
    
    	  case T_TYPE:
    	    /* FIXME: */
    	    fputs("type-value", stderr);
    	    break;
    
    	  case T_STRING: {
    	    int i,j=0;
    	    fputc ('"', stderr);
    	    for(i=0; i < arg->u.string->len && i < 100; i++)
    	    {
    	      switch(j=index_shared_string(arg->u.string,i))
    	      {
    		case '\n':
    		  fputc ('\\', stderr);
    		  fputc ('n', stderr);
    		  break;
    
    		case '\t':
    		  fputc ('\\', stderr);
    		  fputc ('t', stderr);
    		  break;
    
    		case '\b':
    		  fputc ('\\', stderr);
    		  fputc ('b', stderr);
    		  break;
    
    		case '\r':
    		  fputc ('\\', stderr);
    		  fputc ('r', stderr);
    		  break;
    
    
    		case '"':
    		case '\\':
    		  fputc ('\\', stderr);
    		  fputc (j, stderr);
    		  break;
    
    		default:
    		  if(j>=0 && j<256 && isprint(j))
    		  {
    		    fputc (j, stderr);
    		    break;
    		  }
    
    		  fputc ('\\', stderr);
    		  fprintf (stderr, "%o", j);
    
    		  switch(index_shared_string(arg->u.string,i+1))
    		  {
    		    case '0': case '1': case '2': case '3':
    		    case '4': case '5': case '6': case '7':
    		    case '8': case '9':
    		      fputc ('"', stderr);
    		      fputc ('"', stderr);
    		  }
    		  break;
    	      } 
    	    }
    	    fputc ('"', stderr);
    	    if (i < arg->u.string->len)
    	      fprintf (stderr, "+[%ld]", (long) (arg->u.string->len - i));
    	    break;
    	  }
    
    	  case T_FUNCTION:
    	    /* FIXME: Wide string identifiers. */
    	    if(SUBTYPEOF(*arg) == FUNCTION_BUILTIN)
    	      fputs (arg->u.efun->name->str, stderr);
    	    else if(arg->u.object->prog)
    	      fputs (safe_idname_from_int(arg->u.object->prog,
    					  SUBTYPEOF(*arg)), stderr);
    	    else
    	      fputc ('0', stderr);
    	    break;
    
    	  case T_OBJECT: {
    	    struct program *p = arg->u.object->prog;
    	    if (p && p->num_linenumbers) {
    	      file = low_get_program_line_plain (p, &line, 0);
    	      fprintf (stderr, "object(%s:%ld)", file, (long)line);
    	    }
    	    else
    	      fputs ("object", stderr);
    	    break;
    	  }
    
    	  case T_PROGRAM: {
    	    struct program *p = arg->u.program;
    	    if (p->num_linenumbers) {
    	      file = low_get_program_line_plain (p, &line, 0);
    	      fprintf (stderr, "program(%s:%ld)", file, (long)line);
    	    }
    	    else
    	      fputs ("program", stderr);
    	    break;
    	  }
    
    	  case T_FLOAT:
    	    fprintf (stderr, "%f",(double) arg->u.float_number);
    	    break;
    
    	  case T_ARRAY:
    	    fprintf (stderr, "array[%ld]", (long) arg->u.array->size);
    	    break;
    
    	  case T_MULTISET:
    	    fprintf (stderr, "multiset[%ld]", (long) multiset_sizeof (arg->u.multiset));
    	    break;
    
    	  case T_MAPPING:
    	    fprintf (stderr, "mapping[%ld]", (long) m_sizeof (arg->u.mapping));
    	    break;
    
    	  default:
    	    fprintf (stderr, "<Unknown %d>", TYPEOF(*arg));
    	}
    
    	if (i < args - 1) fputs (", ", stderr);
          }
          fputs (")\n", stderr);
        }
        else
          fputs ("frame with no references\n", stderr);
    }
    
    /*: Prints the Pike backtraces for the interpreter contexts in all
     *: Pike threads to stderr, using @[gdb_backtrace].
     *:
     *: This function is intended only for convenient use inside a
     *: debugger session; it can't be used from inside the program.
     */
    void gdb_backtraces()
    {
    #ifdef PIKE_THREADS
      extern INT32 gdb_next_thread_state(INT32, struct thread_state **);
      INT32 i = 0;
      struct thread_state *ts = 0;
      while ((i = gdb_next_thread_state (i, &ts)), ts) {
        fprintf (stderr, "\nTHREAD_ID %p (swapped %s):\n",
    	     (void *)(ptrdiff_t)ts->id, ts->swapped ? "out" : "in");
        gdb_backtrace (ts->id);
      }
    #else
      gdb_backtrace();
    #endif
    }
    #endif
    
    PMOD_EXPORT void custom_check_stack(ptrdiff_t amount, const char *fmt, ...)
    {
      if (low_stack_check(amount)) {
        va_list args;
        va_start(args, fmt);
        va_error(fmt, args);
      }
    }
    
    PMOD_EXPORT void low_cleanup_interpret(struct Pike_interpreter_struct *interpreter)
    {
    #ifdef USE_MMAP_FOR_STACK
      if(!interpreter->evaluator_stack_malloced)
      {
        munmap((char *)interpreter->evaluator_stack,
    	   Pike_stack_size*sizeof(struct svalue));
        interpreter->evaluator_stack = 0;
      }
      if(!interpreter->mark_stack_malloced)
      {
        munmap((char *)interpreter->mark_stack,
    	   Pike_stack_size*sizeof(struct svalue *));
        interpreter->mark_stack = 0;
      }
    #endif
    
      if(interpreter->evaluator_stack)
        free(interpreter->evaluator_stack);
      if(interpreter->mark_stack)
        free(interpreter->mark_stack);
    
      interpreter->mark_stack = 0;
      interpreter->evaluator_stack = 0;
      interpreter->mark_stack_malloced = 0;
      interpreter->evaluator_stack_malloced = 0;
    
      interpreter->stack_pointer = 0;
      interpreter->mark_stack_pointer = 0;
      interpreter->frame_pointer = 0;
    }
    
    PMOD_EXPORT void cleanup_interpret(void)
    {
      while(Pike_fp)
        POP_PIKE_FRAME();
    
      reset_evaluator();
    
      low_cleanup_interpret(&Pike_interpreter);
    }
    
    void really_clean_up_interpret(void)
    {
    #ifdef DO_PIKE_CLEANUP
    #if 0
      struct pike_frame_block *p;
      int e;
      for(p=pike_frame_blocks;p;p=p->next)
        for(e=0;e<128;e++)
          debug_malloc_dump_references( p->x + e);
    #endif
      free_callback_list (&evaluator_callbacks);
      free_all_pike_frame_blocks();
      free_all_catch_context_blocks();
    #endif
    }