guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-952-gf5765cc


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-952-gf5765cc
Date: Wed, 16 Apr 2014 17:24:50 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=f5765cc25eb56ab2e11a25066c0d8e2b9d292324

The branch, master has been updated
       via  f5765cc25eb56ab2e11a25066c0d8e2b9d292324 (commit)
       via  18aa6da21e4f644878021e920bf88644f2bcc6f2 (commit)
       via  73fc4e73e40d555431156ea486dd7fcff63bcad6 (commit)
       via  a2ebdba7acefdc62ae8be378415f70a0aed68b2e (commit)
       via  deb2df53233e44a097741a824330a8e5a82d8053 (commit)
       via  4cfa92d60f0f2e8d7443617288e1a6530ab059ce (commit)
       via  a285f38fda53f580686566613f827d5585f283df (commit)
       via  37d574b378d2093a71475edda1cef51edb363c87 (commit)
       via  3f71590f20ae205e9c6c786d5f6a047aac6bdeab (commit)
       via  6eae3141bf70a21b762d2be4700ebc8ea542c7d1 (commit)
       via  4819276185a35001d56af93177fc29a6a7700000 (commit)
       via  d856931d8dedf3aeea2f5e8d530f43162b9dfaa5 (commit)
      from  1a2711a84865462fe3f3c4c08aa79dcefa661719 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit f5765cc25eb56ab2e11a25066c0d8e2b9d292324
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 19:21:50 2014 +0200

    Slot allocation can re-use closure and argument slots
    
    * module/language/cps/slot-allocation.scm (allocate-slots): Allow slot
      allocation to re-use the closure and argument slots.

commit 18aa6da21e4f644878021e920bf88644f2bcc6f2
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 19:20:42 2014 +0200

    Remove SCM_FRAME_PROGRAM
    
    * libguile/frames.h: Remove SCM_FRAME_PROGRAM, now unused.

commit 73fc4e73e40d555431156ea486dd7fcff63bcad6
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 19:20:23 2014 +0200

    VM robustness for optimized closures
    
    * libguile/vm.c (vm_error_unbound, vm_error_unbound_fluid): Remove proc
      argument.  The value in slot 0 is not necessarily the procedure being
      applied, after the prelude is done.
    
    * libguile/vm-engine.c (vm_engine): Use LOCAL_REF (0) instead of
      SCM_FRAME_PROGRAM, and adapt to above changes.

commit a2ebdba7acefdc62ae8be378415f70a0aed68b2e
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 19:18:29 2014 +0200

    Fix rewinding continuations when outermost frame has zero locals
    
    * libguile/vm.c (vm_reinstate_partial_continuation_inner): Fix boundary
      condition when the outermost frame has zero locals.

commit deb2df53233e44a097741a824330a8e5a82d8053
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 19:17:38 2014 +0200

    frame-previous, frame-procedure robustness
    
    * libguile/frames.c (scm_c_frame_closure): Don't use SCM_FRAME_PROGRAM,
      as we don't know if the frame actually has any locals.
      (scm_c_frame_previous): More robustly detect end-of-stack.  Allows
      scm_c_frame_previous to work on partial continuations.

commit 4cfa92d60f0f2e8d7443617288e1a6530ab059ce
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 19:16:10 2014 +0200

    make-stack works on delimited continuations
    
    * libguile/stacks.c (scm_make_stack, scm_stack_id):
    * libguile/vm.c (scm_i_vm_cont_to_frame): Allow delimited continuations
      as the argument to make-stack.

commit a285f38fda53f580686566613f827d5585f283df
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 19:13:49 2014 +0200

    More robust coverage tests
    
    * test-suite/tests/coverage.test ("line-execution-counts"): Allow zero
      or one count on the loop head.

commit 37d574b378d2093a71475edda1cef51edb363c87
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 19:13:09 2014 +0200

    Change some make-stack tests to use frame-call-representation
    
    * test-suite/tests/eval.test ("stacks"): Use frame-call-representation.

commit 3f71590f20ae205e9c6c786d5f6a047aac6bdeab
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 19:12:43 2014 +0200

    Fix statprof for optimizations
    
    * module/statprof.scm (profile-signal-handler): Bind in a letrec.
      Otherwise the compiler may see the closure slot as dead, and the inner
      stack cut won't work.

commit 6eae3141bf70a21b762d2be4700ebc8ea542c7d1
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 14:54:46 2014 +0200

    Fix a frame-call-representation bug
    
    * module/system/vm/frame.scm (frame-call-representation): Fix logic for
      displaying names of non-procedures and procedures out of arities.

commit 4819276185a35001d56af93177fc29a6a7700000
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 14:33:20 2014 +0200

    Better backtraces from C, especially for optimized closures
    
    * libguile/frames.h:
    * libguile/frames.c (scm_frame_call_representation): New interface;
      dispatches to Scheme.
    
    * libguile/backtrace.c (display_application): Use
      scm_frame_call_representation.  This should be monotonically better,
      given that scm_frame_arguments (which was previously called) also
      dispatched to Scheme and actually ended up calling
      frame-call-representation.

commit d856931d8dedf3aeea2f5e8d530f43162b9dfaa5
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 16 14:19:18 2014 +0200

    frame-call-representation checks available-bindings, as appropriate
    
    * module/system/vm/frame.scm (available-bindings): Map indexes in such a
      way that the first argument is index 1.
      (frame-call-representation): Update to search the bindings for live
      bindings.

-----------------------------------------------------------------------

Summary of changes:
 libguile/backtrace.c                    |   11 +----
 libguile/frames.c                       |   76 ++++++++++++++++++++++---------
 libguile/frames.h                       |   22 +---------
 libguile/stacks.c                       |   10 ++++
 libguile/vm-engine.c                    |   52 ++++++++++-----------
 libguile/vm.c                           |   27 ++++++++---
 libguile/vm.h                           |    1 +
 module/language/cps/slot-allocation.scm |   12 +++---
 module/statprof.scm                     |   45 +++++++++++--------
 module/system/vm/frame.scm              |   56 +++++++++++++++--------
 test-suite/tests/coverage.test          |   11 ++++-
 test-suite/tests/eval.test              |   14 +++---
 12 files changed, 198 insertions(+), 139 deletions(-)

diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index e247aa7..fa12a5d 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -1,5 +1,5 @@
 /* Printing of backtraces and error messages
- * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 
2011 Free Software Foundation
+ * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 
2011, 2014 Free Software Foundation
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -262,14 +262,7 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int 
indentation, SCM sport, S
 static void
 display_application (SCM frame, int indentation, SCM sport, SCM port, 
scm_print_state *pstate)
 {
-  SCM proc = scm_frame_procedure (frame);
-  SCM name = (scm_is_true (scm_procedure_p (proc))
-             ? scm_procedure_name (proc)
-             : SCM_BOOL_F);
-  display_frame_expr ("[",
-                     scm_cons (scm_is_true (name) ? name : proc,
-                               scm_frame_arguments (frame)),
-                     "]",
+  display_frame_expr ("[", scm_frame_call_representation (frame), "]",
                      indentation,
                      sport,
                      port,
diff --git a/libguile/frames.c b/libguile/frames.c
index 6096824..cf9648d 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -130,9 +130,15 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
 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;
+  SCM *fp, *sp;
+
+  fp = frame_stack_base (kind, frame) + frame->fp_offset;
+  sp = frame_stack_base (kind, frame) + frame->sp_offset;
 
-  return SCM_FRAME_PROGRAM (fp);
+  if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0)
+    return SCM_FRAME_LOCAL (fp, 0);
+
+  return SCM_BOOL_F;
 }
 
 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
@@ -171,6 +177,27 @@ SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 
0,
 }
 #undef FUNC_NAME
 
+static SCM frame_call_representation_var;
+
+static void
+init_frame_call_representation_var (void)
+{
+  frame_call_representation_var
+    = scm_c_private_lookup ("system vm frame", "frame-call-representation");
+}
+
+SCM scm_frame_call_representation (SCM frame)
+#define FUNC_NAME "frame-call-representation"
+{
+  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+  scm_i_pthread_once (&once, init_frame_call_representation_var);
+
+  SCM_VALIDATE_VM_FRAME (1, frame);
+
+  return scm_call_1 (scm_variable_ref (frame_call_representation_var), frame);
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
            (SCM frame),
            "")
@@ -308,29 +335,36 @@ int
 scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
 {
   SCM *this_fp, *new_fp, *new_sp;
-  SCM proc;
+  SCM *stack_base = frame_stack_base (kind, frame);
 
  again:
-  this_fp = frame->fp_offset + frame_stack_base (kind, frame);
+  this_fp = frame->fp_offset + stack_base;
+
+  if (this_fp == stack_base)
+    return 0;
+
   new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
-  if (new_fp) 
-    {
-      SCM *stack_base = frame_stack_base (kind, frame);
-      new_fp = RELOC (kind, frame, new_fp);
-      new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
-      frame->fp_offset = new_fp - stack_base;
-      frame->sp_offset = new_sp - stack_base;
-      frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
-
-      proc = SCM_FRAME_PROGRAM (new_fp);
-
-      if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
-        goto again;
-      else
-        return 1;
-    }
-  else
+
+  if (!new_fp)
+    return 0;
+
+  new_fp = RELOC (kind, frame, new_fp);
+
+  if (new_fp < stack_base)
     return 0;
+
+  new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
+  frame->fp_offset = new_fp - stack_base;
+  frame->sp_offset = new_sp - stack_base;
+  frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
+
+  {
+    SCM proc = scm_c_frame_closure (kind, frame);
+    if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
+      goto again;
+  }
+
+  return 1;
 }
 
 SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
diff --git a/libguile/frames.h b/libguile/frames.h
index 6defff5..31f8634 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -110,27 +110,6 @@ struct scm_vm_frame
 #define SCM_FRAME_NUM_LOCALS(fp, sp)            \
   ((sp) + 1 - &SCM_FRAME_LOCAL (fp, 0))
 
-/* Currently (November 2013) we keep the procedure and arguments in
-   their slots for the duration of the procedure call, regardless of
-   whether the values are live or not.  This allows for backtraces that
-   show the closure and arguments.  We may allow the compiler to relax
-   this restriction in the future, if the user so desires.  This would
-   conserve stack space and make GC more precise.  We would need better
-   debugging information to do that, however.
-
-   Even now there is an exception to the rule that slot 0 holds the
-   procedure, which is in the case of tail calls.  The compiler will
-   emit code that shuffles the new procedure and arguments into position
-   before performing the tail call, so there is a window in which
-   SCM_FRAME_PROGRAM does not correspond to the program being executed.
-
-   The moral of the story is to use the IP in a frame to determine what
-   procedure is being called.  It is only appropriate to use
-   SCM_FRAME_PROGRAM in the prologue of a procedure call, when you know
-   it must be there.  */
-
-#define SCM_FRAME_PROGRAM(fp) (SCM_FRAME_LOCAL (fp, 0))
-
 
 /*
  * Heap frames
@@ -181,6 +160,7 @@ SCM_INTERNAL int scm_c_frame_previous (enum 
scm_vm_frame_kind kind,
 
 SCM_API SCM scm_frame_p (SCM obj);
 SCM_API SCM scm_frame_procedure (SCM frame);
+SCM_API SCM scm_frame_call_representation (SCM frame);
 SCM_API SCM scm_frame_arguments (SCM frame);
 SCM_API SCM scm_frame_source (SCM frame);
 SCM_API SCM scm_frame_num_locals (SCM frame);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 182d357..7531908 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -279,6 +279,13 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
       if (!scm_i_continuation_to_frame (obj, &frame))
         return SCM_BOOL_F;
     }
+  else if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (obj))
+    {
+      kind = SCM_VM_FRAME_KIND_CONT;
+      if (!scm_i_vm_cont_to_frame (SCM_PROGRAM_FREE_VARIABLE_REF (obj, 0),
+                                   &frame))
+        return SCM_BOOL_F;
+    }
   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
@@ -347,6 +354,9 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
   else if (SCM_CONTINUATIONP (stack))
     /* FIXME: implement me */
     return SCM_BOOL_F;
+  else if (SCM_PROGRAM_P (stack) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION 
(stack))
+    /* FIXME: implement me */
+    return SCM_BOOL_F;
   else
     {
       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 96e6721..e574eac 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -457,9 +457,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
     NEXT (0);
 
  apply:
-  while (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))
+  while (!SCM_PROGRAM_P (LOCAL_REF (0)))
     {
-      SCM proc = SCM_FRAME_PROGRAM (fp);
+      SCM proc = LOCAL_REF (0);
 
       if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
         {
@@ -484,7 +484,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
     }
 
   /* Let's go! */
-  ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+  ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
   NEXT (0);
 
   BEGIN_DISPATCH_SWITCH;
@@ -558,10 +558,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       PUSH_CONTINUATION_HOOK ();
       APPLY_HOOK ();
 
-      if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+      if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
         goto apply;
 
-      ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+      ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
       NEXT (0);
     }
 
@@ -618,10 +618,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       APPLY_HOOK ();
 
-      if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+      if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
         goto apply;
 
-      ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+      ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
       NEXT (0);
     }
 
@@ -672,10 +672,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       APPLY_HOOK ();
 
-      if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+      if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
         goto apply;
 
-      ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+      ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
       NEXT (0);
     }
 
@@ -961,10 +961,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       APPLY_HOOK ();
 
-      if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+      if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
         goto apply;
 
-      ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+      ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
       NEXT (0);
     }
 
@@ -1005,10 +1005,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
           APPLY_HOOK ();
 
-          if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+          if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
             goto apply;
 
-          ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+          ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
           NEXT (0);
         }
       else
@@ -1096,7 +1096,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       scm_t_uint32 expected;
       UNPACK_24 (op, expected);
       VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
-                 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
+                 vm_error_wrong_num_args (LOCAL_REF (0)));
       NEXT (1);
     }
   VM_DEFINE_OP (22, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
@@ -1104,7 +1104,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       scm_t_uint32 expected;
       UNPACK_24 (op, expected);
       VM_ASSERT (FRAME_LOCALS_COUNT () >= expected,
-                 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
+                 vm_error_wrong_num_args (LOCAL_REF (0)));
       NEXT (1);
     }
   VM_DEFINE_OP (23, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
@@ -1112,7 +1112,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       scm_t_uint32 expected;
       UNPACK_24 (op, expected);
       VM_ASSERT (FRAME_LOCALS_COUNT () <= expected,
-                 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
+                 vm_error_wrong_num_args (LOCAL_REF (0)));
       NEXT (1);
     }
 
@@ -1159,7 +1159,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       scm_t_uint16 expected, nlocals;
       UNPACK_12_12 (op, expected, nlocals);
       VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
-                 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
+                 vm_error_wrong_num_args (LOCAL_REF (0)));
       ALLOC_FRAME (expected + nlocals);
       while (nlocals--)
         LOCAL_SET (expected + nlocals, SCM_UNDEFINED);
@@ -1258,7 +1258,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
         LOCAL_SET (n++, SCM_UNDEFINED);
 
       VM_ASSERT (has_rest || (nkw % 2) == 0,
-                 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp)));
+                 vm_error_kwargs_length_not_even (LOCAL_REF (0)));
 
       /* Now bind keywords, in the order given.  */
       for (n = 0; n < nkw; n++)
@@ -1274,12 +1274,12 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
                   break;
                 }
             VM_ASSERT (scm_is_pair (walk) || allow_other_keys,
-                       vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM 
(fp),
+                       vm_error_kwargs_unrecognized_keyword (LOCAL_REF (0),
                                                              LOCAL_REF (ntotal 
+ n)));
             n++;
           }
         else
-          VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword 
(SCM_FRAME_PROGRAM (fp),
+          VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (LOCAL_REF (0),
                                                                 LOCAL_REF 
(ntotal + n)));
 
       if (has_rest)
@@ -1555,8 +1555,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       var = LOCAL_REF (src);
       VM_ASSERT (SCM_VARIABLEP (var),
                  vm_error_not_a_variable ("variable-ref", var));
-      VM_ASSERT (VARIABLE_BOUNDP (var),
-                 vm_error_unbound (SCM_FRAME_PROGRAM (fp), var));
+      VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (var));
       LOCAL_SET (dst, VARIABLE_REF (var));
       NEXT (1);
     }
@@ -1870,8 +1869,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       var = scm_lookup (LOCAL_REF (sym));
       CACHE_FP ();
       if (ip[1] & 0x1)
-        VM_ASSERT (VARIABLE_BOUNDP (var),
-                   vm_error_unbound (fp[0], LOCAL_REF (sym)));
+        VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (LOCAL_REF (sym)));
       LOCAL_SET (dst, var);
 
       NEXT (2);
@@ -1950,7 +1948,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
           var = scm_module_lookup (mod, sym);
           CACHE_FP ();
           if (ip[4] & 0x1)
-            VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[0], sym));
+            VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (sym));
 
           *var_loc = var;
         }
@@ -2012,7 +2010,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
           CACHE_FP ();
 
           if (ip[4] & 0x1)
-            VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[0], sym));
+            VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (sym));
 
           *var_loc = var;
         }
@@ -2141,7 +2139,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
           if (scm_is_eq (val, SCM_UNDEFINED))
             val = SCM_I_FLUID_DEFAULT (fluid);
           VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
-                     vm_error_unbound_fluid (SCM_FRAME_PROGRAM (fp), fluid));
+                     vm_error_unbound_fluid (fluid));
           LOCAL_SET (dst, val);
         }
 
diff --git a/libguile/vm.c b/libguile/vm.c
index b4ebbc7..4516a68 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -112,6 +112,19 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state 
*pstate)
   scm_puts_unlocked (">", port);
 }
 
+int
+scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame)
+{
+  struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont);
+
+  frame->stack_holder = data;
+  frame->fp_offset = (data->fp + data->reloc) - data->stack_base;
+  frame->sp_offset = (data->sp + data->reloc) - data->stack_base;
+  frame->ip = data->ra;
+
+  return 1;
+}
+
 /* Ideally we could avoid copying the C stack if the continuation root
    is inside VM code, and call/cc was invoked within that same call to
    vm_run.  That's currently not implemented.  */
@@ -384,7 +397,7 @@ vm_reinstate_partial_continuation_inner (void *data_ptr)
   {
     SCM *fp;
     for (fp = vp->fp;
-         SCM_FRAME_LOWER_ADDRESS (fp) > base;
+         SCM_FRAME_LOWER_ADDRESS (fp) >= base;
          fp = SCM_FRAME_DYNAMIC_LINK (fp))
       SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc);
   }
@@ -449,8 +462,8 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM 
cont,
 
 static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
 static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN 
SCM_NOINLINE;
-static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN 
SCM_NOINLINE;
+static void vm_error_unbound (SCM sym) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_unbound_fluid (SCM fluid) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_variable (const char *func_name, SCM x) 
SCM_NORETURN SCM_NOINLINE;
 static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN 
SCM_NOINLINE;
@@ -488,17 +501,17 @@ vm_error_bad_instruction (scm_t_uint32 inst)
 }
 
 static void
-vm_error_unbound (SCM proc, SCM sym)
+vm_error_unbound (SCM sym)
 {
-  scm_error_scm (scm_misc_error_key, proc,
+  scm_error_scm (scm_misc_error_key, SCM_BOOL_F,
                  scm_from_latin1_string ("Unbound variable: ~s"),
                  scm_list_1 (sym), SCM_BOOL_F);
 }
 
 static void
-vm_error_unbound_fluid (SCM proc, SCM fluid)
+vm_error_unbound_fluid (SCM fluid)
 {
-  scm_error_scm (scm_misc_error_key, proc,
+  scm_error_scm (scm_misc_error_key, SCM_BOOL_F,
                  scm_from_latin1_string ("Unbound fluid: ~s"),
                  scm_list_1 (fluid), SCM_BOOL_F);
 }
diff --git a/libguile/vm.h b/libguile/vm.h
index 4029c5c..8f88d0c 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -101,6 +101,7 @@ SCM_INTERNAL SCM scm_i_vm_capture_stack (SCM *stack_base, 
SCM *fp, SCM *sp,
                                          scm_t_uint32 *ra,
                                          scm_t_dynstack *dynstack,
                                          scm_t_uint32 flags);
+SCM_INTERNAL int scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame);
 SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
                                        scm_print_state *pstate);
 SCM_INTERNAL void scm_bootstrap_vm (void);
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 3d5183e..1cb0fa7 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -270,11 +270,13 @@ are comparable with eqv?.  A tmp slot may be used."
       (+ 2 (find-first-trailing-zero live-slots)))
 
     (define (compute-prompt-handler-proc-slot live-slots)
-      (1- (find-first-trailing-zero live-slots)))
+      (if (zero? live-slots)
+          0
+          (1- (find-first-trailing-zero live-slots))))
 
     (define (recompute-live-slots k nargs)
       (let ((in (dfa-k-in dfa (label->idx k))))
-        (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs)))))
+        (let lp ((v 0) (live-slots 0))
           (let ((v (bit-position #t in v)))
             (if v
                 (let ((slot (vector-ref slots v)))
@@ -596,13 +598,11 @@ are comparable with eqv?.  A tmp slot may be used."
     ;; definitions dominate uses and a block's dominator will appear
     ;; before it, in reverse post-order.
     (define (visit-clause n nargs live)
-      (let lp ((n n) (live live))
+      (let lp ((n n) (live (recompute-live-slots (idx->label n) nargs)))
         (define (kill-dead live vars-by-label-idx pred)
           (fold (lambda (v live)
                   (let ((slot (vector-ref slots v)))
-                    (if (and slot
-                             (> slot nargs)
-                             (pred n v dfa))
+                    (if (and slot (pred n v dfa))
                         (kill-dead-slot slot live)
                         live)))
                 live
diff --git a/module/statprof.scm b/module/statprof.scm
index b9d4702..76dfbea 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -337,29 +337,36 @@
   (let ((prev (setitimer ITIMER_PROF 0 0 0 usecs)))
     (+ (* (caadr prev) #e1e6) (cdadr prev))))
 
-(define (profile-signal-handler sig)
-  (define state (existing-profiler-state))
+(define profile-signal-handler
+  (let ()
+    (define (profile-signal-handler sig)
+      (define state (existing-profiler-state))
+
+      (set-inside-profiler?! state #t)
+
+      (when (positive? (profile-level state))
+        (let* ((stop-time (get-internal-run-time))
+               ;; Cut down to the signal handler.  Note that this will
+               ;; only work if statprof.scm is compiled; otherwise we
+               ;; get `eval' on the stack instead, because if it's not
+               ;; compiled, profile-signal-handler is a thunk that
+               ;; tail-calls eval.  For the same reason we define the
+               ;; handler in an inner letrec, so that the compiler sees
+               ;; the inner reference to profile-signal-handler as the
+               ;; same as the procedure, and therefore keeps slot 0
+               ;; alive.  Nastiness, that.
+               (stack
+                (or (make-stack #t profile-signal-handler (outer-cut state))
+                    (pk 'what! (make-stack #t)))))
+
+          (sample-stack-procs state stack)
+          (accumulate-time state stop-time)
+          (set-last-start-time! state (get-internal-run-time))
 
-  (set-inside-profiler?! state #t)
-
-  (when (positive? (profile-level state))
-    (let* ((stop-time (get-internal-run-time))
-           ;; Cut down to the signal handler.  Note that this will only
-           ;; work if statprof.scm is compiled; otherwise we get `eval'
-           ;; on the stack instead, because if it's not compiled,
-           ;; profile-signal-handler is a thunk that tail-calls eval.
-           ;; Perhaps we should always compile the signal handler
-           ;; instead.
-           (stack (or (make-stack #t profile-signal-handler (outer-cut state))
-                      (pk 'what! (make-stack #t)))))
-
-      (sample-stack-procs state stack)
-      (accumulate-time state stop-time)
-      (set-last-start-time! state (get-internal-run-time))
+          (reset-sigprof-timer (sampling-period state))))
 
-      (reset-sigprof-timer (sampling-period state))))
-  
-  (set-inside-profiler?! state #f))
+      (set-inside-profiler?! state #f))
+    profile-signal-handler))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Count total calls.
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 4477c97..e0965ff 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -224,7 +224,10 @@
                 (if n
                     (match (vector-ref defs n)
                       (#(name def-offset slot)
-                       (cons (make-binding n name slot) (lp (1+ n)))))
+                       ;; Binding 0 is the closure, and is not present
+                       ;; in arity-definitions.
+                       (cons (make-binding (1+ n) name slot)
+                             (lp (1+ n)))))
                     '()))))
           (lp (1+ n) (- offset (vector-ref parsed n)))))))
 
@@ -286,46 +289,58 @@
 ;;      the types don't match. In that case the arguments are all on the
 ;;      stack, and nothing else is on the stack.
 
-(define (frame-call-representation frame)
+(define* (frame-call-representation frame #:optional top-frame?)
   (let* ((ip (frame-instruction-pointer frame))
          (info (find-program-debug-info ip))
          (nlocals (frame-num-locals frame))
          (closure (frame-procedure frame)))
-    (define (local-ref i)
-      (if (< i nlocals)
-          (frame-local-ref frame i)
-          ;; Let's not error here, as we are called during backtraces.
-          '???))
-    (define (reconstruct-arguments nreq nopt kw has-rest? local)
+    (define (find-slot i bindings)
+      (match bindings
+        (#f (and (< i nlocals) i))
+        (() #f)
+        ((($ <binding> idx name slot) . bindings)
+         (if (< idx i)
+             (find-slot i bindings)
+             (and (= idx i) slot)))))
+    (define (local-ref i bindings)
+      (cond
+       ((find-slot i bindings)
+        => (lambda (slot) (frame-local-ref frame slot)))
+       (else
+        '_)))
+    (define (reconstruct-arguments bindings nreq nopt kw has-rest? local)
       (cond
        ((positive? nreq)
-        (cons (local-ref local)
-              (reconstruct-arguments (1- nreq) nopt kw has-rest? (1+ local))))
+        (cons (local-ref local bindings)
+              (reconstruct-arguments bindings
+                                     (1- nreq) nopt kw has-rest? (1+ local))))
        ((positive? nopt)
-        (cons (local-ref local)
-              (reconstruct-arguments nreq (1- nopt) kw has-rest? (1+ local))))
+        (cons (local-ref local bindings)
+              (reconstruct-arguments bindings
+                                     nreq (1- nopt) kw has-rest? (1+ local))))
        ((pair? kw)
-        (cons* (caar kw) (local-ref (cdar kw))
-               (reconstruct-arguments nreq nopt (cdr kw) has-rest? (1+ 
local))))
+        (cons* (caar kw) (local-ref (cdar kw) bindings)
+               (reconstruct-arguments bindings
+                                      nreq nopt (cdr kw) has-rest? (1+ 
local))))
        (has-rest?
-        (local-ref local))
+        (local-ref local bindings))
        (else
         '())))
     (cons
      (or (and=> info program-debug-info-name)
-         (procedure-name closure)
+         (and (procedure? closure) (procedure-name closure))
          (and info
               ;; No need to give source info, as backtraces will already
               ;; take care of that.
               (format #f "#<procedure ~a>"
                       (number->string (program-debug-info-addr info) 16)))
-         (procedure-name closure)
          closure)
      (cond
       ((find-program-arity ip)
        => (lambda (arity)
             ;; case 1
-            (reconstruct-arguments (arity-nreq arity)
+            (reconstruct-arguments (available-bindings arity ip top-frame?)
+                                   (arity-nreq arity)
                                    (arity-nopt arity)
                                    (arity-keyword-args arity)
                                    (arity-has-rest? arity)
@@ -340,10 +355,11 @@
                 ('allow-other-keys? . _)
                 ('rest . rest))
                ;; case 1
-               (reconstruct-arguments (length req) (length opt) kw rest 1)))))
+               (reconstruct-arguments #f
+                                      (length req) (length opt) kw rest 1)))))
       (else
        ;; case 2
-       (map local-ref
+       (map (lambda (local) (local-ref local #f))
             ;; Cdr past the 0th local, which is the procedure.
             (cdr (iota nlocals))))))))
 
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 822d06e..1a63353 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -106,8 +106,17 @@
                (every (lambda (line+count)
                         (let ((line  (car line+count))
                               (count (cdr line+count)))
+                          ;; The actual line counts for aliasing
+                          ;; operations, like the loop header that
+                          ;; initializes "x" to "x", are sensitive to
+                          ;; whether there is an associated "mov"
+                          ;; instruction, or whether the value is left
+                          ;; in place.  Currently there are no
+                          ;; instructions for line 2, but we allow 1 as
+                          ;; well.
                           (case line
-                            ((0 1 2) (= count 1))
+                            ((0 1)   (= count 1))
+                            ((2)     (<= 0 count 1))
                             ((3)     (= count 78))
                             ((4 5 6) (= count 77))
                             ((7)     (= count 1))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index fca3852..e1837fd 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -384,8 +384,8 @@
            (frames (stack->frames stack)))
       ;; the top frame on the stack is the lambda inside the 'catch, and the
       ;; next frame is the (catch 'result ...)
-      (and (eq? (frame-procedure (cadr frames))
-                catch)
+      (and (eq? (car (frame-call-representation (cadr frames)))
+                'catch)
            (eq? (car (frame-arguments (cadr frames)))
                 'result))))
 
@@ -394,12 +394,10 @@
            (frames (stack->frames stack)))
       ;; the top frame on the stack is the make-stack call, and the last
       ;; frame is the (with-throw-handler 'wrong-type-arg ...)
-      (and (eq? (frame-procedure (car frames))
-                make-stack)
-           (eq? (frame-procedure (car (last-pair frames)))
-                with-throw-handler)
-           (eq? (car (frame-arguments (car (last-pair frames))))
-                'wrong-type-arg)))))
+      (and (eq? (car (frame-call-representation (car frames)))
+                'make-stack)
+           (eq? (car (frame-call-representation (car (last-pair frames))))
+                'with-throw-handler)))))
 
 ;;;
 ;;; letrec init evaluation


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]