[Guile-commits] GNU Guile branch, master, updated. v2.1.0-24-g7af8115

[Andy Wingo]

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=7af81156754f8be7d7661879f7d0c13bb00e5728

The branch, master has been updated
       via  7af81156754f8be7d7661879f7d0c13bb00e5728 (commit)
       via  423164efa6dbfa5ef056ba592f636421a3f8b2fa (commit)
       via  f5cb70e94a37a069e04244312937ca2868de5135 (commit)
       via  7c080187bc55e84159b99faa9b7ae9f0a8ae90d2 (commit)
       via  18f8fd0211714f4d18ebab4dc4b85950c97483f4 (commit)
      from  40b36bbf941f1670d8665b1d5d43c842b2aea561 (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 7af81156754f8be7d7661879f7d0c13bb00e5728
Author: Andy Wingo <address@hidden>
Date:   Sun May 4 22:51:34 2014 +0200

    Fix frame-call-representation for frames from apply-hook
    
    * module/system/vm/frame.scm (frame-call-representation): Fix when
      called on frames that are created from the apply hook.

commit 423164efa6dbfa5ef056ba592f636421a3f8b2fa
Author: Andy Wingo <address@hidden>
Date:   Sun May 4 22:41:48 2014 +0200

    Program printing tweaks
    
    * module/system/vm/program.scm (print-program): New public interface --
      the guts of write-program, but refactored to be able to work when only
      given an addr.
      (write-program): Use print-program.
    
    * module/system/vm/frame.scm (frame-call-representation): Remove attempt
      to abbreviate procedure representations; was confusing because the
      result would write as a string, quotes and all.

commit f5cb70e94a37a069e04244312937ca2868de5135
Author: Andy Wingo <address@hidden>
Date:   Sun May 4 14:09:42 2014 +0200

    Refactorings to apply-hook and push-continuation-hook
    
    * libguile/vm-engine.c (vm_engine): Always invoke the apply hook after
      the ip has been reset.  Avoids problems in frame-bindings, which
      builds its bindings map based on the IP.  Invoke push-continuation
      before linking the new frame, so that more locals are available to the
      frame inspector.
    
    * module/system/vm/traps.scm (trap-in-procedure): No need for a
      push-cont handler, as the apply handler will exit the frame.

commit 7c080187bc55e84159b99faa9b7ae9f0a8ae90d2
Author: Andy Wingo <address@hidden>
Date:   Sun May 4 11:46:18 2014 +0200

    frame-address, frame-stack-pointer return offsets
    
    * libguile/frames.c (scm_frame_address, scm_frame_stack_pointer): Return
      offsets instead of absolute pointers.  This is robust in the presence
      of stack relocation.
    
    * module/system/repl/debug.scm (print-registers): Adapt to print sp and
      fp as integers.

commit 18f8fd0211714f4d18ebab4dc4b85950c97483f4
Author: Andy Wingo <address@hidden>
Date:   Sun May 4 11:18:54 2014 +0200

    frame-call-representation has #:top-frame? as keyword argument
    
    * module/system/vm/frame.scm (frame-call-representation): Change
      top-frame? argument to be a keyword instead of an optional argument.
    
    * module/system/vm/trace.scm (print-application): Adapt caller.

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

Summary of changes:
 libguile/frames.c            |    4 +-
 libguile/vm-engine.c         |   42 +++++++++++++++--------
 module/system/repl/debug.scm |    4 +-
 module/system/vm/frame.scm   |   34 +++++++++----------
 module/system/vm/program.scm |   77 +++++++++++++++++++++++++++++------------
 module/system/vm/trace.scm   |    2 +-
 module/system/vm/traps.scm   |    6 ---
 7 files changed, 103 insertions(+), 66 deletions(-)

diff --git a/libguile/frames.c b/libguile/frames.c
index cf9648d..2162f49 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -277,7 +277,7 @@ SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
 #define FUNC_NAME s_scm_frame_address
 {
   SCM_VALIDATE_VM_FRAME (1, frame);
-  return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_FP (frame));
+  return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame));
 }
 #undef FUNC_NAME
 
@@ -288,7 +288,7 @@ SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 
1, 0, 0,
 {
   SCM_VALIDATE_VM_FRAME (1, frame);
 
-  return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_SP (frame));
+  return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame));
 }
 #undef FUNC_NAME
 
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 3c09df2..c405b2b 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -486,6 +486,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
   /* Let's go! */
   ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+  APPLY_HOOK ();
+
   NEXT (0);
 
   BEGIN_DISPATCH_SWITCH;
@@ -549,6 +552,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       VM_HANDLE_INTERRUPTS;
 
+      PUSH_CONTINUATION_HOOK ();
+
       old_fp = fp;
       fp = vp->fp = old_fp + proc;
       SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
@@ -556,13 +561,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       RESET_FRAME (nlocals);
 
-      PUSH_CONTINUATION_HOOK ();
-      APPLY_HOOK ();
-
       if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
         goto apply;
 
       ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+      APPLY_HOOK ();
+
       NEXT (0);
     }
 
@@ -588,6 +593,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       VM_HANDLE_INTERRUPTS;
 
+      PUSH_CONTINUATION_HOOK ();
+
       old_fp = fp;
       fp = vp->fp = old_fp + proc;
       SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
@@ -595,10 +602,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       RESET_FRAME (nlocals);
 
-      PUSH_CONTINUATION_HOOK ();
+      ip += label;
+
       APPLY_HOOK ();
 
-      NEXT (label);
+      NEXT (0);
     }
 
   /* tail-call nlocals:24
@@ -617,12 +625,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       RESET_FRAME (nlocals);
 
-      APPLY_HOOK ();
-
       if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
         goto apply;
 
       ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+      APPLY_HOOK ();
+
       NEXT (0);
     }
 
@@ -643,9 +652,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       RESET_FRAME (nlocals);
 
+      ip += label;
+
       APPLY_HOOK ();
 
-      NEXT (label);
+      NEXT (0);
     }
 
   /* tail-call/shuffle from:24
@@ -671,12 +682,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
 
       RESET_FRAME (n + 1);
 
-      APPLY_HOOK ();
-
       if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
         goto apply;
 
       ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+      APPLY_HOOK ();
+
       NEXT (0);
     }
 
@@ -960,12 +972,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       for (i = 0; i < list_len; i++, list = SCM_CDR (list))
         LOCAL_SET (list_idx - 1 + i, SCM_CAR (list));
 
-      APPLY_HOOK ();
-
       if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
         goto apply;
 
       ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+      APPLY_HOOK ();
+
       NEXT (0);
     }
 
@@ -1004,12 +1017,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
           LOCAL_SET (1, cont);
           RESET_FRAME (2);
 
-          APPLY_HOOK ();
-
           if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
             goto apply;
 
           ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+          APPLY_HOOK ();
+
           NEXT (0);
         }
       else
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index a15defc..300145d 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -100,8 +100,8 @@
       (format port " (address@hidden)" code
               (- (frame-instruction-pointer frame) code))))
   (newline port)
-  (print "sp = #x~x\n" (frame-stack-pointer frame))
-  (print "fp = #x~x\n" (frame-address frame)))
+  (print "sp = ~a\n" (frame-stack-pointer frame))
+  (print "fp = ~a\n" (frame-address frame)))
 
 (define* (print-locals frame #:optional (port (current-output-port))
                        #:key (width (terminal-width)) (per-line-prefix "  "))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index e0965ff..776109f 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -289,7 +289,7 @@
 ;;      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 #:optional top-frame?)
+(define* (frame-call-representation frame #:key top-frame?)
   (let* ((ip (frame-instruction-pointer frame))
          (info (find-program-debug-info ip))
          (nlocals (frame-num-locals frame))
@@ -308,7 +308,13 @@
         => (lambda (slot) (frame-local-ref frame slot)))
        (else
         '_)))
+    (define (application-arguments)
+      ;; Case 1.
+      (map (lambda (local) (local-ref local #f))
+           ;; Cdr past the 0th local, which is the procedure.
+           (cdr (iota nlocals))))
     (define (reconstruct-arguments bindings nreq nopt kw has-rest? local)
+      ;; Case 2.
       (cond
        ((positive? nreq)
         (cons (local-ref local bindings)
@@ -329,22 +335,18 @@
     (cons
      (or (and=> info program-debug-info-name)
          (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)))
          closure)
      (cond
       ((find-program-arity ip)
        => (lambda (arity)
-            ;; case 1
-            (reconstruct-arguments (available-bindings arity ip top-frame?)
-                                   (arity-nreq arity)
-                                   (arity-nopt arity)
-                                   (arity-keyword-args arity)
-                                   (arity-has-rest? arity)
-                                   1)))
+            (if (and top-frame? (eqv? ip (arity-low-pc arity)))
+                (application-arguments)
+                (reconstruct-arguments (available-bindings arity ip top-frame?)
+                                       (arity-nreq arity)
+                                       (arity-nopt arity)
+                                       (arity-keyword-args arity)
+                                       (arity-has-rest? arity)
+                                       1))))
       ((and (primitive? closure)
             (program-arguments-alist closure ip))
        => (lambda (args)
@@ -354,14 +356,10 @@
                 ('keyword . kw)
                 ('allow-other-keys? . _)
                 ('rest . rest))
-               ;; case 1
                (reconstruct-arguments #f
                                       (length req) (length opt) kw rest 1)))))
       (else
-       ;; case 2
-       (map (lambda (local) (local-ref local #f))
-            ;; Cdr past the 0th local, which is the procedure.
-            (cdr (iota nlocals))))))))
+       (application-arguments))))))
 
 
 
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 8f19c54..59cb8c0 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -42,6 +42,8 @@
             program-num-free-variables
             program-free-variable-ref program-free-variable-set!
 
+            print-program
+
             primitive?))
 
 (load-extension (string-append "libguile-" (effective-version))
@@ -259,28 +261,57 @@ lists."
           (fallback))))
    (else (error "expected a program" prog))))
 
-(define (write-program prog port)
-  (define (program-identity-string)
-    (or (procedure-name prog)
-        (and=> (program-source prog 0)
-               (lambda (s)
-                 (format #f "~a at ~a:~a:~a"
-                         (number->string (object-address prog) 16)
-                         (or (source:file s)
-                             (if s "<current input>" "<unknown port>"))
-                         (source:line-for-user s) (source:column s))))
-        (number->string (object-address prog) 16)))
+(define* (print-program #:optional program (port (current-output-port))
+                        #:key (addr (program-code program))
+                        (always-print-addr? #f) (never-print-addr? #f)
+                        (always-print-source? #f) (never-print-source? #f)
+                        (name-only? #f) (print-formals? #t))
+  (let* ((pdi (find-program-debug-info addr))
+         ;; It could be the procedure had its name property set via the
+         ;; procedure property interface.
+         (name (or (and program (procedure-name program))
+                   (program-debug-info-name pdi)))
+         (source (match (find-program-sources addr)
+                   (() #f)
+                   ((source . _) source)))
+         (formals (if program
+                      (program-arguments-alists program)
+                      (let ((arities (find-program-arities addr)))
+                        (if arities
+                            (map arity-arguments-alist arities)
+                            '())))))
+    (define (hex n)
+      (number->string n 16))
 
-  (define (program-formals-string)
-    (let ((arguments (program-arguments-alists prog)))
-      (if (null? arguments)
-          ""
-          (string-append
-           " " (string-join (map (lambda (a)
-                                   (object->string
-                                    (arguments-alist->lambda-list a)))
-                                 arguments)
-                            " | ")))))
+    (cond
+     ((and name-only? name)
+      (format port "~a" name))
+     (else
+      (format port "#<procedure")
+      (format port " ~a"
+              (or name
+                  (and program (hex (object-address program)))
+                  (if never-print-addr?
+                      ""
+                      (string-append "@" (hex addr)))))
+      (when (and always-print-addr? (not never-print-addr?))
+        (unless (and (not name) (not program))
+          (format port " @~a" (hex addr))))
+      (when (and source (not never-print-source?)
+                 (or always-print-source? (not name)))
+        (format port " at ~a:~a:~a"
+                (or (source-file source) "<unknown port>")
+                (source-line-for-user source)
+                (source-column source)))
+      (unless (or (null? formals) (not print-formals?))
+        (format port "~a"
+                (string-append
+                 " " (string-join (map (lambda (a)
+                                         (object->string
+                                          (arguments-alist->lambda-list a)))
+                                       formals)
+                                  " | "))))
+      (format port ">")))))
 
-  (format port "#<procedure ~a~a>"
-          (program-identity-string) (program-formals-string)))
+(define (write-program prog port)
+  (print-program prog port))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 77191b7..36fbe92 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -46,7 +46,7 @@
     (format (current-error-port) "~a~v:@y\n"
             prefix
             width
-            (frame-call-representation frame))))
+            (frame-call-representation frame #:top-frame? #t))))
 
 (define (print-return depth width prefix max-indent values)
   (let ((prefix (build-prefix prefix depth "|  " "~d< "max-indent)))
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 77823e1..ca6acdd 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -186,10 +186,6 @@
       (if (our-frame? frame)
           (enter-proc frame)))
 
-    (define (push-cont-hook frame)
-      (if in-proc?
-          (exit-proc frame)))
-    
     (define (pop-cont-hook frame . values)
       (if in-proc?
           (exit-proc frame))
@@ -206,7 +202,6 @@
      current-frame
      (lambda (frame)
        (add-hook! (vm-apply-hook) apply-hook)
-       (add-hook! (vm-push-continuation-hook) push-cont-hook)
        (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
        (add-hook! (vm-abort-continuation-hook) abort-hook)
        (if (and frame (our-frame? frame))
@@ -215,7 +210,6 @@
        (if in-proc?
            (exit-proc frame))
        (remove-hook! (vm-apply-hook) apply-hook)
-       (remove-hook! (vm-push-continuation-hook) push-cont-hook)
        (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
        (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
 


hooks/post-receive
-- 
GNU Guile