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-249-g361d0de


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-249-g361d0de
Date: Thu, 17 Oct 2013 21:29:03 +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=361d0de285587ef4c9f19b9e07c1175424520aa5

The branch, master has been updated
       via  361d0de285587ef4c9f19b9e07c1175424520aa5 (commit)
       via  9d87158fdb1c3159db90911e96d833392a02ff58 (commit)
       via  8d23c43641345c9a93cbe173c67c4f12d812770b (commit)
       via  e93c0430faf34cc881d4d87750bd2cdad2dd9813 (commit)
       via  73c3db666926aa4a0307ea0ed4b38608a31ecd82 (commit)
       via  ac371963218c757172e3f8322322853254097d7f (commit)
       via  342370bd56469925f7a5dbd608bb469d3c0ef2e4 (commit)
       via  1d94a35d69994bdbfd5dcb2c5f2af951152735a5 (commit)
       via  0bd6b1cae194ccc5b698b67257154e42933c43e5 (commit)
       via  234155e3364f5c09abca3ab82409187d3d9418c5 (commit)
       via  99511cd0abfa0bde4440b2781740f18f49248a99 (commit)
      from  5bd4b6585b3733077d0a36265ce057611836e163 (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 361d0de285587ef4c9f19b9e07c1175424520aa5
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 17 23:25:01 2013 +0200

    Stack traces skip RTL boot frames
    
    * libguile/frames.c (frame-previous)
    * libguile/stacks.c (make-stack): Skip RTL boot frames.

commit 9d87158fdb1c3159db90911e96d833392a02ff58
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 17 23:24:16 2013 +0200

    RTL engine can apply smobs and applicable structs w/o stack VM
    
    * libguile/vm-engine.c (rtl_vm_engine): Allow the RTL VM to handle the
      dispatch for SMOBs and applicable structs.

commit 8d23c43641345c9a93cbe173c67c4f12d812770b
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 17 23:21:29 2013 +0200

    Fix subr-call
    
    * libguile/vm-engine.c (subr-call): Fix for locals count including the
      procedure.

commit e93c0430faf34cc881d4d87750bd2cdad2dd9813
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 17 23:19:57 2013 +0200

    Fix tail-apply bugs
    
    * libguile/vm-engine.c (tail-apply): Fix for old change that made
      the procedure indexed 0 instead of -1.

commit 73c3db666926aa4a0307ea0ed4b38608a31ecd82
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 17 23:16:32 2013 +0200

    Better vm.c support for RTL programs
    
    * libguile/vm.c (scm_c_vm_run): Directly dispatch to the RTL VM for RTL
      programs.
      (scm_bootstrap_vm): Initialize the RTL program stubs early, and mark
      the RTL boot program with the boot flag.

commit ac371963218c757172e3f8322322853254097d7f
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 17 23:14:56 2013 +0200

    Procedure traps work with RTL programs.
    
    * module/system/vm/traps.scm (frame-matcher): Work with RTL programs.

commit 342370bd56469925f7a5dbd608bb469d3c0ef2e4
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 17 23:14:26 2013 +0200

    minimal RTL program support in (system xref)
    
    * module/system/xref.scm (procedure-sources*): Work with RTL programs.

commit 1d94a35d69994bdbfd5dcb2c5f2af951152735a5
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 17 23:13:56 2013 +0200

    (system vm coverage) works with RTL programs
    
    * module/system/vm/coverage.scm (hashq-proc, assq-proc)
      (program-sources*, closed-over-procedures, coverage-data->lcov): Work
      with RTl procedures.

commit 0bd6b1cae194ccc5b698b67257154e42933c43e5
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 17 23:12:23 2013 +0200

    Statprof works better with RTL programs
    
    * module/statprof.scm (get-call-data, procedure=?): Work with RTL
      programs.

commit 234155e3364f5c09abca3ab82409187d3d9418c5
Author: Andy Wingo <address@hidden>
Date:   Mon Oct 14 21:45:48 2013 +0200

    bind-rest works in the optional-and-rest-arg case.
    
    * libguile/vm-engine.c (bind-rest): If the sp is below the dst reg,
      alloc the frame to ensure there is enough space, and to fill in
      intermediate values with SCM_UNDEFINED.

commit 99511cd0abfa0bde4440b2781740f18f49248a99
Author: Andy Wingo <address@hidden>
Date:   Mon Oct 14 17:32:16 2013 +0200

    Refactor vm_abort
    
    * libguile/vm.c (vm_abort):
    * libguile/vm-i-system.c (abort): Refactor abort interface so that it is
      more amenable to the RTL VM.

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

Summary of changes:
 libguile/frames.c             |    3 +-
 libguile/stacks.c             |    5 ++-
 libguile/vm-engine.c          |   63 ++++++++++++++++++++++++-----------------
 libguile/vm-i-system.c        |   10 ++++--
 libguile/vm.c                 |   48 +++++++++++++++++++------------
 module/statprof.scm           |   16 ++++++----
 module/system/vm/coverage.scm |   35 ++++++++++++++++------
 module/system/vm/traps.scm    |   24 +++++++++++----
 module/system/xref.scm        |    5 ++-
 9 files changed, 132 insertions(+), 77 deletions(-)

diff --git a/libguile/frames.c b/libguile/frames.c
index 448a0cb..b2973bf 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -334,7 +334,8 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
                                 SCM_VM_FRAME_OFFSET (frame));
       proc = scm_frame_procedure (frame);
 
-      if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
+      if ((SCM_PROGRAM_P (proc) || SCM_RTL_PROGRAM_P (proc))
+          && SCM_PROGRAM_IS_BOOT (proc))
         goto again;
       else
         return frame;
diff --git a/libguile/stacks.c b/libguile/stacks.c
index c3ea624..fd19a49 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -1,5 +1,5 @@
 /* A stack holds a frame chain
- * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012 
Free Software Foundation
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 
2012, 2013 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
@@ -276,7 +276,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 
   /* FIXME: is this even possible? */
   if (scm_is_true (frame)
-      && SCM_PROGRAM_P (scm_frame_procedure (frame))
+      && (SCM_PROGRAM_P (scm_frame_procedure (frame))
+          || SCM_RTL_PROGRAM_P (scm_frame_procedure (frame)))
       && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
     frame = scm_frame_previous (frame);
   
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 2723702..095f0bc 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -898,7 +898,6 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
  apply:
   while (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))
     {
-#if 0
       SCM proc = SCM_FRAME_PROGRAM (fp);
 
       if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
@@ -910,28 +909,30 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t 
nargs_)
         {
           scm_t_uint32 n = FRAME_LOCALS_COUNT();
 
-          /* Shuffle args up, place smob in local 0. */
-          CHECK_OVERFLOW (vp->sp + 1);
-          vp->sp++;
+          /* Shuffle args up. */
+          RESET_FRAME (n + 1);
           while (n--)
             LOCAL_SET (n + 1, LOCAL_REF (n));
 
-          fp[-1] = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
+          LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc).apply_trampoline);
           continue;
         }
 
+#if 0
       SYNC_IP();
       vm_error_wrong_type_apply (proc);
 #else
-      SCM ret;
-      SYNC_ALL ();
+      {
+        SCM ret;
+        SYNC_ALL ();
 
-      ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1);
+        ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1);
 
-      if (SCM_UNLIKELY (SCM_VALUESP (ret)))
-        RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
-      else
-        RETURN_ONE_VALUE (ret);
+        if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+          RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
+        else
+          RETURN_ONE_VALUE (ret);
+      }
 #endif
     }
 
@@ -1147,7 +1148,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t 
nargs_)
       VM_HANDLE_INTERRUPTS;
       SYNC_IP ();
 
-      switch (FRAME_LOCALS_COUNT ())
+      switch (FRAME_LOCALS_COUNT () - 1)
         {
         case 0:
           ret = subr ();
@@ -1292,24 +1293,25 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t 
nargs_)
    */
   VM_DEFINE_OP (11, tail_apply, "tail-apply", OP1 (U8_X24))
     {
-      int i, list_idx, list_len, nargs;
+      int i, list_idx, list_len, nlocals;
       SCM list;
 
       VM_HANDLE_INTERRUPTS;
 
-      VM_ASSERT (FRAME_LOCALS_COUNT () >= 2, abort ());
-      nargs = FRAME_LOCALS_COUNT ();
-      list_idx = nargs - 1;
+      nlocals = FRAME_LOCALS_COUNT ();
+      // At a minimum, there should be apply, f, and the list.
+      VM_ASSERT (nlocals >= 3, abort ());
+      list_idx = nlocals - 1;
       list = LOCAL_REF (list_idx);
       list_len = scm_ilength (list);
 
       VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list));
 
-      nargs = nargs - 2 + list_len;
-      ALLOC_FRAME (nargs);
+      nlocals = nlocals - 2 + list_len;
+      ALLOC_FRAME (nlocals);
 
-      for (i = 0; i < list_idx; i++)
-        LOCAL_SET(i - 1, LOCAL_REF (i));
+      for (i = 1; i < list_idx; i++)
+        LOCAL_SET (i - 1, LOCAL_REF (i));
 
       /* Null out these slots, just in case there are less than 2 elements
          in the list. */
@@ -1586,16 +1588,25 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t 
nargs_)
       SCM_UNPACK_RTL_24 (op, dst);
       nargs = FRAME_LOCALS_COUNT ();
 
-      while (nargs-- > dst)
+      if (nargs <= dst)
+        {
+          ALLOC_FRAME (dst + 1);
+          while (nargs < dst)
+            LOCAL_SET (nargs++, SCM_UNDEFINED);
+        }
+      else
         {
-          rest = scm_cons (LOCAL_REF (nargs), rest);
-          LOCAL_SET (nargs, SCM_UNDEFINED);
+          while (nargs-- > dst)
+            {
+              rest = scm_cons (LOCAL_REF (nargs), rest);
+              LOCAL_SET (nargs, SCM_UNDEFINED);
+            }
+
+          RESET_FRAME (dst + 1);
         }
 
       LOCAL_SET (dst, rest);
 
-      RESET_FRAME (dst + 1);
-
       NEXT (1);
     }
 
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 83e07f1..8df56de 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1475,10 +1475,14 @@ VM_DEFINE_INSTRUCTION (88, wind, "wind", 0, 2, 0)
 
 VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1)
 {
-  unsigned n = FETCH ();
-  SYNC_REGISTER ();
+  ptrdiff_t n = FETCH ();
+  SCM tag, *stack_args, tail;
   PRE_CHECK_UNDERFLOW (n + 2);
-  vm_abort (vm, n, &registers);
+  SYNC_REGISTER ();
+  tail = sp[0];
+  stack_args = sp - n;
+  tag = sp[-(n + 1)];
+  vm_abort (vm, tag, n, stack_args, tail, sp - (n + 2), &registers);
   /* vm_abort should not return */
   abort ();
 }
diff --git a/libguile/vm.c b/libguile/vm.c
index 3a2795b..ff9ea35 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -273,33 +273,32 @@ vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
 }
 
 static void
-vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers) SCM_NORETURN;
+vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+          scm_i_jmp_buf *current_registers) SCM_NORETURN;
 
 static void
-vm_abort (SCM vm, size_t n, scm_i_jmp_buf *current_registers)
+vm_abort (SCM vm, SCM tag, size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+          scm_i_jmp_buf *current_registers)
 {
   size_t i;
   ssize_t tail_len;
-  SCM tag, tail, *argv;
+  SCM *argv;
   
-  /* FIXME: VM_ENABLE_STACK_NULLING */
-  tail = *(SCM_VM_DATA (vm)->sp--);
-  /* NULLSTACK (1) */
   tail_len = scm_ilength (tail);
   if (tail_len < 0)
     scm_misc_error ("vm-engine", "tail values to abort should be a list",
                     scm_list_1 (tail));
 
-  tag = SCM_VM_DATA (vm)->sp[-n];
-  argv = alloca ((n + tail_len) * sizeof (SCM));
-  for (i = 0; i < n; i++)
-    argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
-  for (; i < n + tail_len; i++, tail = scm_cdr (tail))
+  argv = alloca ((nstack + tail_len) * sizeof (SCM));
+  for (i = 0; i < nstack; i++)
+    argv[i] = stack_args[i];
+  for (; i < nstack + tail_len; i++, tail = scm_cdr (tail))
     argv[i] = scm_car (tail);
-  /* NULLSTACK (n + 1) */
-  SCM_VM_DATA (vm)->sp -= n + 1;
 
-  scm_c_abort (vm, tag, n + tail_len, argv, current_registers);
+  /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
+  SCM_VM_DATA (vm)->sp = sp;
+
+  scm_c_abort (vm, tag, nstack + tail_len, argv, current_registers);
 }
 
 static void
@@ -684,6 +683,11 @@ initialize_default_stack_size (void)
 static const scm_t_vm_engine vm_engines[] = 
   { vm_regular_engine, vm_debug_engine };
 
+typedef SCM (*scm_t_rtl_vm_engine) (SCM vm, SCM program, SCM *argv, size_t 
nargs);
+
+static const scm_t_rtl_vm_engine rtl_vm_engines[] =
+  { rtl_vm_regular_engine, rtl_vm_debug_engine };
+
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
 
 /* The GC "kind" for the VM stack.  */
@@ -767,7 +771,10 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 {
   struct scm_vm *vp = SCM_VM_DATA (vm);
   SCM_CHECK_STACK;
-  return vm_engines[vp->engine](vm, program, argv, nargs);
+  if (SCM_RTL_PROGRAM_P (program))
+    return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
+  else
+    return vm_engines[vp->engine](vm, program, argv, nargs);
 }
 
 /* Scheme interface */
@@ -1124,6 +1131,13 @@ scm_bootstrap_vm (void)
 
   boot_continuation = make_boot_program ();
 
+  rtl_boot_continuation = scm_i_make_rtl_program (rtl_boot_continuation_code);
+  SCM_SET_CELL_WORD_0 (rtl_boot_continuation,
+                       (SCM_CELL_WORD_0 (rtl_boot_continuation)
+                        | SCM_F_PROGRAM_IS_BOOT));
+  rtl_apply = scm_i_make_rtl_program (rtl_apply_code);
+  rtl_values = scm_i_make_rtl_program (rtl_values_code);
+
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
   vm_stack_gc_kind =
     GC_new_kind (GC_new_free_list (),
@@ -1139,10 +1153,6 @@ scm_init_vm (void)
 #ifndef SCM_MAGIC_SNARFER
 #include "libguile/vm.x"
 #endif
-
-  rtl_boot_continuation = scm_i_make_rtl_program (rtl_boot_continuation_code);
-  rtl_apply = scm_i_make_rtl_program (rtl_apply_code);
-  rtl_values = scm_i_make_rtl_program (rtl_values_code);
 }
 
 /*
diff --git a/module/statprof.scm b/module/statprof.scm
index 33246e5..c4483a2 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -1,7 +1,7 @@
 ;;;; (statprof) -- a statistical profiler for Guile
 ;;;; -*-scheme-*-
 ;;;;
-;;;;   Copyright (C) 2009, 2010, 2011  Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009, 2010, 2011, 2013  Free Software Foundation, Inc.
 ;;;;    Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
 ;;;;    Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
 ;;;; 
@@ -216,13 +216,13 @@
          (+ accumulated-time 0.0 (- ,stop-time last-start-time))))
 
 (define (get-call-data proc)
-  (let ((k (if (or (not (program? proc))
-                   (zero? (program-num-free-variables proc)))
-               proc
-               (program-objcode proc))))
-    (or (hashq-ref procedure-data k)
+  (let ((k (cond
+            ((program? proc) (program-objcode proc))
+            ((rtl-program? proc) (rtl-program-code proc))
+            (else proc))))
+    (or (hashv-ref procedure-data k)
         (let ((call-data (make-call-data proc 0 0 0)))
-          (hashq-set! procedure-data k call-data)
+          (hashv-set! procedure-data k call-data)
           call-data))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -583,6 +583,8 @@ to @code{statprof-reset} is true."
      ((eq? a b))
      ((and (program? a) (program? b))
       (eq? (program-objcode a) (program-objcode b)))
+     ((and (rtl-program? a) (rtl-program? b))
+      (eq? (rtl-program-code a) (rtl-program-code b)))
      (else
       #f))))
 
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
index 268d211..1ca8fee 100644
--- a/module/system/vm/coverage.scm
+++ b/module/system/vm/coverage.scm
@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 ;;;
-;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2013 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
@@ -48,17 +48,28 @@
 
 (define (hashq-proc proc n)
   ;; Return the hash of PROC's objcode.
-  (hashq (program-objcode proc) n))
+  (if (rtl-program? proc)
+      (hashq (rtl-program-code proc) n)
+      (hashq (program-objcode proc) n)))
 
 (define (assq-proc proc alist)
   ;; Instead of really looking for PROC in ALIST, look for the objcode of PROC.
   ;; IOW the alist is indexed by procedures, not objcodes, but those procedures
   ;; are taken as an arbitrary representative of all the procedures (closures)
   ;; sharing that objcode.  This can significantly reduce memory consumption.
-  (let ((code (program-objcode proc)))
-    (find (lambda (pair)
-            (eq? code (program-objcode (car pair))))
-          alist)))
+  (if (rtl-program? proc)
+      (let ((code (rtl-program-code proc)))
+        (find (lambda (pair)
+                (let ((proc (car pair)))
+                  (and (rtl-program? proc)
+                       (eqv? code (rtl-program-code proc)))))
+              alist))
+      (let ((code (program-objcode proc)))
+        (find (lambda (pair)
+                (let ((proc (car pair)))
+                  (and (program? proc)
+                       (eq? code (program-objcode proc)))))
+              alist))))
 
 (define (with-code-coverage vm thunk)
   "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect 
code
@@ -211,7 +222,7 @@ particular closure was executed."
 (define (program-sources* data proc)
   ;; A memoizing version of `program-sources'.
   (or (hashq-ref (data-procedure->sources data) proc)
-      (and (program? proc)
+      (and (or (program? proc) (rtl-program? proc))
            (let ((sources (program-sources proc))
                  (p->s    (data-procedure->sources data))
                  (f->p    (data-file->procedures data)))
@@ -310,9 +321,13 @@ was loaded at the time DATA was collected."
   ;; Return the list of procedures PROC closes over, PROC included.
   (let loop ((proc   proc)
              (result '()))
-    (if (and (program? proc) (not (memq proc result)))
+    (if (and (or (program? proc) (rtl-program? proc)) (not (memq proc result)))
         (fold loop (cons proc result)
-              (append (vector->list (or (program-objects proc) #()))
+              ;; FIXME: Include statically nested procedures for RTL
+              ;; programs.
+              (append (if (program? proc)
+                          (vector->list (or (program-objects proc) #()))
+                          '())
                       (program-free-variables proc)))
         result)))
 
@@ -329,7 +344,7 @@ gathered, even if their code was not executed."
 
   (define (dump-function proc)
     ;; Dump source location and basic coverage data for PROC.
-    (and (program? proc)
+    (and (or (program? proc) (rtl-program? proc))
          (let ((sources (program-sources* data proc)))
            (and (pair? sources)
                 (let* ((line (source:line-for-user (car sources)))
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 14aee55..af74433 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -1,6 +1,6 @@
 ;;; Traps: stepping, breakpoints, and such.
 
-;; Copyright (C)  2010, 2012 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2012, 2013 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
@@ -110,12 +110,22 @@
 
 (define (frame-matcher proc match-objcode?)
   (if match-objcode?
-      (lambda (frame)
-        (let ((frame-proc (frame-procedure frame)))
-          (or (eq? frame-proc proc)
-              (and (program? frame-proc)
-                   (eq? (program-objcode frame-proc)
-                        (program-objcode proc))))))
+      (cond
+       ((program? proc)
+        (lambda (frame)
+          (let ((frame-proc (frame-procedure frame)))
+            (or (eq? frame-proc proc)
+                (and (program? frame-proc)
+                     (eq? (program-objcode frame-proc)
+                          (program-objcode proc)))))))
+       ((rtl-program? proc)
+        (lambda (frame)
+          (let ((frame-proc (frame-procedure frame)))
+            (or (eq? frame-proc proc)
+                (and (rtl-program? frame-proc)
+                     (eqv? (rtl-program-code frame-proc)
+                           (rtl-program-code proc)))))))
+       (else (lambda (frame) #f)))
       (lambda (frame)
         (eq? (frame-procedure frame) proc))))
 
diff --git a/module/system/xref.scm b/module/system/xref.scm
index 922d17f..b6211d8 100644
--- a/module/system/xref.scm
+++ b/module/system/xref.scm
@@ -1,4 +1,4 @@
-;;;;   Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009, 2010, 2013 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
@@ -205,7 +205,8 @@ pair of the form (module-name . variable-name), "
 ;; ((ip file line . col) ...)
 (define (procedure-sources proc)
   (cond
-   ((program? proc) (program-sources proc))
+   ((or (rtl-program? proc) (program? proc))
+    (program-sources proc))
    (else '())))
 
 ;; file -> line -> (proc ...)


hooks/post-receive
-- 
GNU Guile



reply via email to

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