guile/libguile/stacks.c

/* Representation of stack frame debug information
 * Copyright (C) 1996 Mikael Djurfeldt
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.
 *
 * The author can be reached at djurfeldt@nada.kth.se
 * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
 */


#include <stdio.h>
#include "_scm.h"
#include "debug.h"
#include "continuations.h"
#include "struct.h"

#include "stacks.h"


/* {Frames and stacks}
 *
 * The debugging evaluator creates debug frames on the stack.  These
 * are linked from the innermost frame and outwards.  The last frame
 * created can always be accessed as SCM_LAST_DEBUG_FRAME.
 * Continuations contain a pointer to the innermost debug frame on the
 * continuation stack.
 *
 * Each debug frame contains a set of flags and information about one
 * or more stack frames.  The case of multiple frames occurs due to
 * tail recursion.  The maximal number of stack frames which can be
 * recorded in one debug frame can be set dynamically with the debug
 * option FRAMES.
 *
 * Stack frame information is of two types: eval information (the
 * expression being evaluated and its environment) and apply
 * information (the procedure being applied and its arguments).  A
 * stack frame normally corresponds to an eval/apply pair, but macros
 * and special forms (which are implemented as macros in Guile) only
 * have eval information and apply calls leads to apply only frames.
 *
 * Since we want to record the total stack information and later
 * manipulate this data at the scheme level in the debugger, we need
 * to transform it into a new representation.  In the following code
 * section you'll find the functions implementing this data type.
 *
 * Representation:
 *
 * The stack is represented as a struct with an id slot and a tail
 * array of scm_info_frame structs.
 *
 * A frame is represented as a pair where the car contains a stack and
 * the cdr an inum.  The inum is an index to the first SCM value of
 * the scm_info_frame struct.
 *
 * Stacks
 *   Constructor
 *     make-stack
 *   Selectors
 *     stack-id
 *     stack-ref
 *   Inspector
 *     stack-length
 *
 * Frames
 *   Constructor
 *     last-stack-frame
 *   Selectors
 *     frame-number
 *     frame-source
 *     frame-procedure
 *     frame-arguments
 *     frame-previous
 *     frame-next
 *   Predicates
 *     frame-real?
 *     frame-procedure?
 *     frame-evaluating-args?
 *     frame-overflow?  */



/* Some auxiliary functions for reading debug frames off the stack.
 */

/* Count number of debug info frames on a stack, beginning with
 * DFRAME.  OFFSET is used for relocation of pointers when the stack
 * is read from a continuation.
 */
static int stack_depth SCM_P ((scm_debug_frame *dframe, long offset, SCM *id, int *maxp));
static int
stack_depth (dframe, offset, id, maxp)
     scm_debug_frame *dframe;
     long offset;
     SCM *id;
     int *maxp;
{
  int n, size;
  int max_depth = SCM_BACKTRACE_MAXDEPTH;
  scm_debug_info *info;
  for (n = 0;
       dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
       dframe = (scm_debug_frame *) ((SCM_STACKITEM *) dframe->prev + offset))
    {
      if (SCM_EVALFRAMEP (*dframe))
	{
	  size = dframe->status & SCM_MAX_FRAME_SIZE;
	  info = (scm_debug_info *) (*((SCM_STACKITEM **) &dframe->vect[size])
				     + offset);
	  n += (info - dframe->vect) / 2 + 1;
	  /* Data in the apply part of an eval info frame comes from previous
	     stack frame if the scm_debug_info vector is overflowed. */
	  if ((((info - dframe->vect) & 1) == 0)
	      && SCM_OVERFLOWP (*dframe)
	      && !SCM_UNBNDP (info[1].a.proc))
	    ++n;
	}
      else
	++n;
    }
  if (dframe && SCM_VOIDFRAMEP (*dframe))
    *id = dframe->vect[0].id;
  else if (dframe)
    *maxp = 1;
  return n;
}

/* Read debug info from DFRAME into IFRAME.
 */
static void read_frame SCM_P ((scm_debug_frame *dframe, long offset, scm_info_frame *iframe));
static void
read_frame (dframe, offset, iframe)
     scm_debug_frame *dframe;
     long offset;
     scm_info_frame *iframe;
{
  SCM flags = SCM_INUM0;
  int size;
  scm_debug_info *info;
  if (SCM_EVALFRAMEP (*dframe))
    {
      size = dframe->status & SCM_MAX_FRAME_SIZE;
      info = (scm_debug_info *) (*((SCM_STACKITEM **) &dframe->vect[size])
				 + offset);
      if ((info - dframe->vect) & 1)
	{
	  /* Debug.vect ends with apply info. */
	  --info;
	  if (info[1].a.proc != SCM_UNDEFINED)
	    {
	      flags |= SCM_FRAMEF_PROC;
	      iframe->proc = info[1].a.proc;
	      iframe->args = info[1].a.args;
	      if (!SCM_ARGS_READY_P (*dframe))
		flags |= SCM_FRAMEF_EVAL_ARGS;
	    }
	}
      iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
    }
  else
    {
      flags |= SCM_FRAMEF_PROC;
      iframe->proc = dframe->vect[0].a.proc;
      iframe->args = dframe->vect[0].a.args;
    }
  iframe->flags = flags;
}

/* Fill the scm_info_frame vector IFRAME with data from N stack frames
 * starting with the first stack frame represented by debug frame
 * DFRAME.
 */

#define NEXT_FRAME(iframe, n, quit) \
{ \
  ++iframe; \
  if (--n == 0) \
    goto quit; \
} \


static void read_frames SCM_P ((scm_debug_frame *dframe, long offset, int nframes, scm_info_frame *iframes));
static void
read_frames (dframe, offset, n, iframes)
     scm_debug_frame *dframe;
     long offset;
     int n;
     scm_info_frame *iframes;
{
  int size;
  scm_info_frame *iframe = iframes;
  scm_debug_info *info;
  
  for (;
       dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
       dframe = (scm_debug_frame *) ((SCM_STACKITEM *) dframe->prev + offset))
    {
      read_frame (dframe, offset, iframe);
      if (SCM_EVALFRAMEP (*dframe))
	{
	  size = dframe->status & SCM_MAX_FRAME_SIZE;
	  info = (scm_debug_info *) (*((SCM_STACKITEM **) &dframe->vect[size])
				     + offset);
	  if ((info - dframe->vect) & 1)
	    --info;
	  /* Data in the apply part of an eval info frame comes from
	     previous stack frame if the scm_debug_info vector is overflowed. */
	  else if (SCM_OVERFLOWP (*dframe)
		   && !SCM_UNBNDP (info[1].a.proc))
	    {
	      NEXT_FRAME (iframe, n, quit);
	      iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC;
	      iframe->proc = info[1].a.proc;
	      iframe->args = info[1].a.args;
	    }
	  if (SCM_OVERFLOWP (*dframe))
	    iframe->flags |= SCM_FRAMEF_OVERFLOW;
	  info -= 2;
	  NEXT_FRAME (iframe, n, quit);
	  while (info >= dframe->vect)
	    {
	      if (!SCM_UNBNDP (info[1].a.proc))
		{
		  iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC;
		  iframe->proc = info[1].a.proc;
		  iframe->args = info[1].a.args;
		}
	      else
		iframe->flags = SCM_INUM0;
	      iframe->source = scm_make_memoized (info[0].e.exp,
						  info[0].e.env);
	      info -= 2;
	      NEXT_FRAME (iframe, n, quit);
	    }
	}
      else
	{
	  NEXT_FRAME (iframe, n, quit);
	}
    quit:
      if (iframe > iframes)
	(iframe - 1) -> flags |= SCM_FRAMEF_REAL;
    }
}

static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer, SCM outer_key));

static void
narrow_stack (stack, inner, inner_key, outer, outer_key)
     SCM stack;
     int inner;
     SCM inner_key;
     int outer;
     SCM outer_key;
{
  scm_stack *s = SCM_STACK (stack);
  int i;
  int n = s->length;
  
  /* Cut inner part. */
  for (i = 0; inner; --inner)
    if (s->frames[i++].proc == inner_key)
      break;
  s->frames = &s->frames[i];
  n -= i;

  /* Cut outer part. */
  for (; n && outer; --outer)
    if (s->frames[--n].proc == outer_key)
      break;

  s->length = n;
}



/* Stacks
 */

SCM scm_stack_type;

SCM_PROC (s_stack_p, "stack?", 1, 0, 0, scm_stack_p);
SCM
scm_stack_p (obj)
     SCM obj;
{
  return SCM_NIMP (obj) && SCM_STACKP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC (s_make_stack, "make-stack", 0, 3, 0, scm_make_stack);
SCM
scm_make_stack (obj, inner_cut, outer_cut)
     SCM obj;
     SCM inner_cut;
     SCM outer_cut;
{
  int n, maxp, size;
  scm_debug_frame *dframe;
  scm_info_frame *iframe;
  long offset = 0;
  SCM stack, id;

  if (SCM_UNBNDP (inner_cut))
    inner_cut = SCM_INUM0;
  if (SCM_UNBNDP (outer_cut))
    outer_cut = SCM_INUM0;
  
  if (obj == SCM_BOOL_T)
    dframe = scm_last_debug_frame;
  else
    {
      SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_make_stack);
      if (SCM_DEBUGOBJP (obj))
	dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
      else if (scm_tc7_contin == SCM_TYP7 (obj))
	{
	  offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs))
		    - SCM_BASE (obj));
#ifndef STACK_GROWS_UP
	  offset += SCM_LENGTH (obj);
#endif
	  dframe = (scm_debug_frame *) ((SCM_STACKITEM *) SCM_DFRAME (obj)
				       + offset);
	}
      else scm_wta (obj, (char *) SCM_ARG1, s_make_stack);
    }

  id = SCM_BOOL_F;
  maxp = 0;
  n = stack_depth (dframe, offset, &id, &maxp);
  size = n * SCM_FRAME_N_SLOTS;

  stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (size), SCM_EOL);
  SCM_STACK (stack) -> id = id;
  SCM_STACK (stack) -> length = n;
  iframe = &SCM_STACK (stack) -> tail[0];
  SCM_STACK (stack) -> frames = iframe;
  
  read_frames ((scm_debug_frame *) ((SCM_STACKITEM *) dframe + offset), offset, n, iframe);

  narrow_stack (stack,
		SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n,
		SCM_INUMP (inner_cut) ? 0 : inner_cut,
		SCM_INUMP (outer_cut) ? SCM_INUM (outer_cut) : n,
		SCM_INUMP (outer_cut) ? 0 : outer_cut);

  n = SCM_STACK (stack) -> length;
  if (n > 0)
  {
    if (maxp)
      iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
    return stack;
  }
  else
    return SCM_BOOL_F;
}

SCM_PROC (s_stack_id, "stack-id", 1, 0, 0, scm_stack_id);
SCM
scm_stack_id (stack)
     SCM stack;
{
  scm_debug_frame *dframe;
  long offset = 0;
  if (stack == SCM_BOOL_T)
    dframe = scm_last_debug_frame;
  else
    {
      SCM_ASSERT (SCM_NIMP (stack), stack, SCM_ARG1, s_make_stack);
      if (SCM_DEBUGOBJP (stack))
	dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack);
      else if (scm_tc7_contin == SCM_TYP7 (stack))
	{
	  offset = ((SCM_STACKITEM *) (SCM_CHARS (stack) + sizeof (scm_contregs))
		    - SCM_BASE (stack));
#ifndef STACK_GROWS_UP
	  offset += SCM_LENGTH (stack);
#endif
	  dframe = (scm_debug_frame *) ((SCM_STACKITEM *) SCM_DFRAME (stack)
				       + offset);
	}
      else if (SCM_STACKP (stack))
	return SCM_STACK (stack) -> id;
      else scm_wrong_type_arg (s_stack_id, SCM_ARG1, stack);
    }
  while (dframe && !SCM_VOIDFRAMEP (*dframe))
    dframe = (scm_debug_frame *) ((SCM_STACKITEM *) dframe->prev + offset);
  if (dframe && SCM_VOIDFRAMEP (*dframe))
    return dframe->vect[0].id;
  return SCM_BOOL_F;
}

SCM_PROC (s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref);
SCM
scm_stack_ref (stack, i)
     SCM stack;
     SCM i;
{
  SCM_ASSERT (SCM_NIMP (stack)
	      && SCM_STACKP (stack),
	      stack,
	      SCM_ARG1,
	      s_stack_ref);
  SCM_ASSERT (SCM_INUMP (i), i, SCM_ARG2, s_stack_ref);
  SCM_ASSERT (SCM_INUM (i) >= 0
	      && SCM_INUM (i) < SCM_STACK_LENGTH (stack),
	      i,
	      SCM_OUTOFRANGE,
	      s_stack_ref);
  return scm_cons (stack, i);
}

SCM_PROC(s_stack_length, "stack-length", 1, 0, 0, scm_stack_length);
SCM
scm_stack_length (stack)
     SCM stack;
{
  SCM_ASSERT (SCM_NIMP (stack)
	      && SCM_STACKP (stack),
	      stack,
	      SCM_ARG1,
	      s_stack_length);
  return SCM_MAKINUM (SCM_STACK_LENGTH (stack));
}

/* Frames
 */

SCM_PROC (s_frame_p, "frame?", 1, 0, 0, scm_frame_p);
SCM
scm_frame_p (obj)
     SCM obj;
{
  return SCM_NIMP (obj) && SCM_FRAMEP (obj);
}

SCM_PROC(s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame);
SCM
scm_last_stack_frame (obj)
     SCM obj;
{
  scm_debug_frame *dframe;
  long offset = 0;
  SCM stack;
  
  SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame);
  if (SCM_DEBUGOBJP (obj))
    dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj);
  else if (scm_tc7_contin == SCM_TYP7 (obj))
    {
      offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs))
		- SCM_BASE (obj));
#ifndef STACK_GROWS_UP
      offset += SCM_LENGTH (obj);
#endif
      dframe = (scm_debug_frame *) ((SCM_STACKITEM *) SCM_DFRAME (obj) + offset);
    }
  else scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame);
  
  if (!dframe || SCM_VOIDFRAMEP (*dframe))
    return SCM_BOOL_F;

  stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS), SCM_EOL);
  SCM_STACK (stack) -> length = 1;
  SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
  read_frame (dframe, offset, (scm_info_frame *) &SCM_STACK (stack) -> frames[0]);
  
  return scm_cons (stack, SCM_INUM0);;
}

SCM_PROC(s_frame_number, "frame-number", 1, 0, 0, scm_frame_number);
SCM
scm_frame_number (frame)
     SCM frame;
{
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_number);
  return SCM_MAKINUM (SCM_FRAME_NUMBER (frame));
}

SCM_PROC(s_frame_source, "frame-source", 1, 0, 0, scm_frame_source);
SCM
scm_frame_source (frame)
     SCM frame;
{
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_source);
  return SCM_FRAME_SOURCE (frame);
}

SCM_PROC(s_frame_procedure, "frame-procedure", 1, 0, 0, scm_frame_procedure);
SCM
scm_frame_procedure (frame)
     SCM frame;
{
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_procedure);
  return (SCM_FRAME_PROC_P (frame)
	  ? SCM_BOOL_F
	  : SCM_FRAME_PROC (frame));
}

SCM_PROC(s_frame_arguments, "frame-arguments", 1, 0, 0, scm_frame_arguments);
SCM
scm_frame_arguments (frame)
     SCM frame;
{
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_arguments);
  return SCM_FRAME_ARGS (frame);
}

SCM_PROC(s_frame_previous, "frame-previous", 1, 0, 0, scm_frame_previous);
SCM
scm_frame_previous (frame)
     SCM frame;
{
  int n;
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_previous);
  n = SCM_INUM (SCM_CDR (frame)) + 1;
  if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
    return SCM_BOOL_F;
  else
    return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n));
}

SCM_PROC(s_frame_next, "frame-next", 1, 0, 0, scm_frame_next);
SCM
scm_frame_next (frame)
     SCM frame;
{
  int n;
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_next);
  n = SCM_INUM (SCM_CDR (frame)) - 1;
  if (n < 0)
    return SCM_BOOL_F;
  else
    return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n));
}

SCM_PROC(s_frame_real_p, "frame-real?", 1, 0, 0, scm_frame_real_p);
SCM
scm_frame_real_p (frame)
     SCM frame;
{
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_real_p);
  return SCM_FRAME_REAL_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC(s_frame_procedure_p, "frame-procedure?", 1, 0, 0, scm_frame_procedure_p);
SCM
scm_frame_procedure_p (frame)
     SCM frame;
{
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_procedure_p);
  return SCM_FRAME_PROC_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC(s_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, scm_frame_evaluating_args_p);
SCM
scm_frame_evaluating_args_p (frame)
     SCM frame;
{
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_evaluating_args_p);
  return SCM_FRAME_EVAL_ARGS_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC(s_frame_overflow_p, "frame-overflow?", 1, 0, 0, scm_frame_overflow_p);
SCM
scm_frame_overflow_p (frame)
     SCM frame;
{
  SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame),
	      frame,
	      SCM_ARG1,
	      s_frame_overflow_p);
  return SCM_FRAME_OVERFLOW_P (frame) ? SCM_BOOL_T : SCM_BOOL_F;
}



void
scm_init_stacks ()
{
  SCM vtable;
  SCM vtable_layout = scm_make_struct_layout (scm_nullstr);
  SCM stack_layout = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT));
  vtable = scm_make_vtable_vtable (vtable_layout, SCM_INUM0, SCM_EOL);
  scm_stack_type = scm_permanent_object (scm_make_struct (vtable,
							  SCM_INUM0,
							  scm_cons (stack_layout, SCM_EOL)));
#include "stacks.x"
}