Optimize make-stack

* libguile/continuations.h:
* libguile/continuations.c (scm_i_continuation_to_frame): Operate on
  low-level C structures instead of heap objects.

* libguile/frames.h:
* libguile/frames.c (frame_offset, frame_stack_base): Const args.
  (scm_c_frame_closure): New helper.
  (scm_frame_procedure): Use the new helper.

* libguile/stacks.c (stack_depth, narrow_stack, scm_make_stack): Rework
  to avoid allocating frames as we traverse the stack, and to avoid an
  n**2 case where there are outer cuts.

libguile/continuations.c

@@ -168,8 +168,8 @@ scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont)
 }
 #undef FUNC_NAME
 
-SCM
+int
-scm_i_continuation_to_frame (SCM continuation)
+scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame)
 {
   SCM contregs;
   scm_t_contregs *cont;
@@ -179,18 +179,17 @@ scm_i_continuation_to_frame (SCM continuation)
 
   if (scm_is_true (cont->vm_cont))
     {
-      struct scm_frame frame;
       struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
 
-      frame.stack_holder = data;
+      frame->stack_holder = data;
-      frame.fp_offset = (data->fp + data->reloc) - data->stack_base;
+      frame->fp_offset = (data->fp + data->reloc) - data->stack_base;
-      frame.sp_offset = (data->sp + data->reloc) - data->stack_base;
+      frame->sp_offset = (data->sp + data->reloc) - data->stack_base;
-      frame.ip = data->ra;
+      frame->ip = data->ra;
 
-      return scm_c_make_frame (SCM_VM_FRAME_KIND_CONT, &frame);
+      return 1;
     }
   else
-    return SCM_BOOL_F;
+    return 0;
 }
 
 struct scm_vm *

libguile/continuations.h

@@ -3,7 +3,7 @@
 #ifndef SCM_CONTINUATIONS_H
 #define SCM_CONTINUATIONS_H
 
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 2012, 2013, 2014 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -76,7 +76,10 @@ SCM_INTERNAL SCM scm_i_make_continuation (int *first,
 SCM_INTERNAL void scm_i_check_continuation (SCM cont);
 SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);
 
-SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
+struct scm_frame;
+SCM_INTERNAL int scm_i_continuation_to_frame (SCM cont,
+                                              struct scm_frame *frame);
+
 SCM_INTERNAL struct scm_vm* scm_i_contregs_vp (SCM contregs);
 SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);
 

libguile/frames.c

@@ -58,7 +58,7 @@ scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
 }
 
 static SCM*
-frame_stack_base (enum scm_vm_frame_kind kind, struct scm_frame *frame)
+frame_stack_base (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
 {
   switch (kind)
     {
@@ -74,7 +74,7 @@ frame_stack_base (enum scm_vm_frame_kind kind, struct scm_frame *frame)
 }
 
 static scm_t_ptrdiff
-frame_offset (enum scm_vm_frame_kind kind, struct scm_frame *frame)
+frame_offset (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
 {
   switch (kind)
     {
@@ -124,13 +124,27 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+/* Retrieve the local in slot 0, which may or may not actually be a
+   procedure, and may or may not actually be the procedure being
+   applied.  If you want the procedure, look it up from the IP.  */
+SCM
+scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
+{
+  SCM *fp = frame_stack_base (kind, frame) + frame->fp_offset;
+
+  return SCM_FRAME_PROGRAM (fp);
+}
+
 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
 	    (SCM frame),
 	    "")
 #define FUNC_NAME s_scm_frame_procedure
 {
   SCM_VALIDATE_VM_FRAME (1, frame);
-  return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
+
+  /* FIXME: Retrieve procedure from address?  */
+  return scm_c_frame_closure (SCM_VM_FRAME_KIND (frame),
+                              SCM_VM_FRAME_DATA (frame));
 }
 #undef FUNC_NAME
 

libguile/frames.h

@@ -167,6 +167,10 @@ enum scm_vm_frame_kind
 SCM_INTERNAL SCM* scm_i_frame_stack_base (SCM frame);
 SCM_INTERNAL scm_t_ptrdiff scm_i_frame_offset (SCM frame);
 
+/* See notes in frames.c before using this.  */
+SCM_INTERNAL SCM scm_c_frame_closure (enum scm_vm_frame_kind kind,
+                                      const struct scm_frame *frame);
+
 SCM_INTERNAL SCM scm_c_make_frame (enum scm_vm_frame_kind kind,
                                    const struct scm_frame *frame);
 

libguile/stacks.c

@@ -65,11 +65,12 @@ static SCM scm_sys_stacks;
 /* Count number of debug info frames on a stack, beginning with FRAME.
  */
 static long
-stack_depth (SCM frame)
+stack_depth (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
 {
-  long n = 0;
+  struct scm_frame tmp;
-  /* count frames, skipping boot frames */
+  long n = 1;
-  for (; scm_is_true (frame); frame = scm_frame_previous (frame))
+  memcpy (&tmp, frame, sizeof tmp);
+  while (scm_c_frame_previous (kind, &tmp))
     ++n;
   return n;
 }
@@ -108,24 +109,19 @@ find_prompt (SCM key)
   return fp_offset;
 }
 
-static void
+static long
-narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
+narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
+              SCM inner_cut, SCM outer_cut)
 {
-  unsigned long int len;
-  SCM frame;
-  
-  len = SCM_STACK_LENGTH (stack);
-  frame = SCM_STACK_FRAME (stack);
-
   /* Cut inner part. */
   if (scm_is_true (scm_procedure_p (inner_cut)))
     {
       /* Cut until the given procedure is seen. */
       for (; len ;)
         {
-          SCM proc = scm_frame_procedure (frame);
+          SCM proc = scm_c_frame_closure (kind, frame);
           len--;
-          frame = scm_frame_previous (frame);
+          scm_c_frame_previous (kind, frame);
           if (scm_is_eq (proc, inner_cut))
             break;
         }
@@ -138,32 +134,32 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
       for (; inner && len; --inner)
         {
           len--;
-          frame = scm_frame_previous (frame);
+          scm_c_frame_previous (kind, frame);
         }
     }
   else
     {
       /* Cut until the given prompt tag is seen. */
       scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
-      for (; len; len--, frame = scm_frame_previous (frame))
+      for (; len; len--, scm_c_frame_previous (kind, frame))
-        if (fp_offset == SCM_VM_FRAME_FP_OFFSET (frame))
+        if (fp_offset == frame->fp_offset)
           break;
     }
 
-  SCM_SET_STACK_LENGTH (stack, len);
-  SCM_SET_STACK_FRAME (stack, frame);
-
   /* Cut outer part. */
   if (scm_is_true (scm_procedure_p (outer_cut)))
     {
+      long i, new_len;
+      struct scm_frame tmp;
+
+      memcpy (&tmp, frame, sizeof tmp);
+
       /* Cut until the given procedure is seen. */
-      for (; len ;)
+      for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
-        {
+        if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
-          frame = scm_stack_ref (stack, scm_from_long (len - 1));
+          new_len = i;
-          len--;
+
-          if (scm_is_eq (scm_frame_procedure (frame), outer_cut))
+      len = new_len;
-            break;
-        }
     }
   else if (scm_is_integer (outer_cut))
     {
@@ -178,17 +174,23 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
   else
     {
       /* Cut until the given prompt tag is seen. */
+      long i;
+      struct scm_frame tmp;
       scm_t_ptrdiff fp_offset = find_prompt (outer_cut);
-      while (len)
+
-        {
+      memcpy (&tmp, frame, sizeof tmp);
-          frame = scm_stack_ref (stack, scm_from_long (len - 1));
+
-          len--;
+      for (i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
-          if (fp_offset == SCM_VM_FRAME_FP_OFFSET (frame))
+        if (tmp.fp_offset == fp_offset)
           break;
-        }
+
+      if (i < len)
+        len = i;
+      else
+        len = 0;
     }
 
-  SCM_SET_STACK_LENGTH (stack, len);
+  return len;
 }
 
 
@@ -244,9 +246,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 #define FUNC_NAME s_scm_make_stack
 {
   long n;
-  SCM frame;
-  SCM stack;
   SCM inner_cut, outer_cut;
+  enum scm_vm_frame_kind kind;
+  struct scm_frame frame;
 
   /* Extract a pointer to the innermost frame of whatever object
      scm_make_stack was given.  */
@@ -254,48 +256,46 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
     {
       SCM cont;
       struct scm_vm_cont *c;
-      struct scm_frame tmp;
 
       cont = scm_i_capture_current_stack ();
-
       c = SCM_VM_CONT_DATA (cont);
-      tmp.stack_holder = c;
+
-      tmp.fp_offset = (c->fp + c->reloc) - c->stack_base;
+      kind = SCM_VM_FRAME_KIND_CONT;
-      tmp.sp_offset = (c->sp + c->reloc) - c->stack_base;
+      frame.stack_holder = c;
-      tmp.ip = c->ra;
+      frame.fp_offset = (c->fp + c->reloc) - c->stack_base;
-      frame = scm_c_make_frame (SCM_VM_FRAME_KIND_CONT, &tmp);
+      frame.sp_offset = (c->sp + c->reloc) - c->stack_base;
+      frame.ip = c->ra;
     }
   else if (SCM_VM_FRAME_P (obj))
-    frame = obj;
+    {
+      kind = SCM_VM_FRAME_KIND (obj);
+      memcpy (&frame, SCM_VM_FRAME_DATA (obj), sizeof frame);
+    }
   else if (SCM_CONTINUATIONP (obj))
     /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
        that were in place when the continuation was captured. */
-    frame = scm_i_continuation_to_frame (obj);
+    {
+      kind = SCM_VM_FRAME_KIND_CONT;
+      if (!scm_i_continuation_to_frame (obj, &frame))
+        return SCM_BOOL_F;
+    }
   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
       /* not reached */
     }
 
-  /* FIXME: is this even possible? */
+  /* Skip initial boot frame, if any.  This is possible if the frame
-  if (scm_is_true (frame)
+     originates from a captured continuation.  */
-      && SCM_PROGRAM_P (scm_frame_procedure (frame))
+  if (SCM_PROGRAM_P (scm_c_frame_closure (kind, &frame))
-      && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+      && SCM_PROGRAM_IS_BOOT (scm_c_frame_closure (kind, &frame))
-    frame = scm_frame_previous (frame);
+      && !scm_c_frame_previous (kind, &frame))
-  
-  if (scm_is_false (frame))
     return SCM_BOOL_F;
 
   /* Count number of frames.  Also get stack id tag and check whether
      there are more stackframes than we want to record
      (SCM_BACKTRACE_MAXDEPTH). */
-  n = stack_depth (frame);
+  n = stack_depth (kind, &frame);
-
-  /* Make the stack object. */
-  stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
-  SCM_SET_STACK_LENGTH (stack, n);
-  SCM_SET_STACK_ID (stack, scm_stack_id (obj));
-  SCM_SET_STACK_FRAME (stack, frame);
 
   /* Narrow the stack according to the arguments given to scm_make_stack. */
   SCM_VALIDATE_REST_ARGUMENT (args);
@@ -313,15 +313,18 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 	  args = SCM_CDR (args);
 	}
       
-      narrow_stack (stack,
+      n = narrow_stack (n, kind, &frame, inner_cut, outer_cut);
-                    inner_cut,
-                    outer_cut);
-
-      n = SCM_STACK_LENGTH (stack);
     }
   
   if (n > 0)
+    {
+      /* Make the stack object. */
+      SCM stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
+      SCM_SET_STACK_LENGTH (stack, n);
+      SCM_SET_STACK_ID (stack, scm_stack_id (obj));
+      SCM_SET_STACK_FRAME (stack, scm_c_make_frame (kind, &frame));
       return stack;
+    }
   else
     return SCM_BOOL_F;
 }