[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-930-g16dcce9
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-930-g16dcce9 |
|
Date: |
Sun, 05 May 2013 16:40:47 +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=16dcce93ab67afe84d3c7d1fc4d85aa1341599d7
The branch, wip-rtl has been updated
via 16dcce93ab67afe84d3c7d1fc4d85aa1341599d7 (commit)
via db39349d9d74bbd4631b19698bee3d6c7b58b7e3 (commit)
via e5749d89dad52943eb22d15b31ebfe90c1e12c1a (commit)
from 1dc0d7b0068d1a313ea4d89a75f80f0786eb9e2e (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 16dcce93ab67afe84d3c7d1fc4d85aa1341599d7
Author: Andy Wingo <address@hidden>
Date: Sun May 5 18:35:56 2013 +0200
Fix program-debug-info-addr; remove FIXMEs in disassembler.scm
* module/system/vm/debug.scm (program-debug-info-offset): Rename from
program-debug-info-addr to reflect reality.
(program-debug-info-addr): New function.
* module/system/vm/disassembler.scm (disassembler): Remove FIXMEs.
(disassemble-program): Rely on the RTL program to print its name.
commit db39349d9d74bbd4631b19698bee3d6c7b58b7e3
Author: Andy Wingo <address@hidden>
Date: Sun May 5 18:26:53 2013 +0200
RTL programs print with their name
* libguile/print.c (iprin1): Use scm_i_program_print for RTL programs
too.
* libguile/procprop.c (scm_procedure_name): For RTL programs, call
scm_i_rtl_program_name if there is no override.
* libguile/programs.h:
* libguile/programs.c (scm_i_rtl_program_name): New helper, dispatches
to (system vm program).
(scm_i_program_print): For RTL programs, the fallback prints the code
pointer too.
* module/system/vm/program.scm (rtl-program-name): Use the debug info to
get an RTL program name.
(write-program): Work with RTL programs too.
commit e5749d89dad52943eb22d15b31ebfe90c1e12c1a
Author: Andy Wingo <address@hidden>
Date: Sun May 5 17:52:59 2013 +0200
move procedure-name and procedure-source to procprop.c
* libguile/procprop.h:
* libguile/procprop.c (scm_procedure_name, scm_procedure_source): Move
these functions here, from debug.[ch].
-----------------------------------------------------------------------
Summary of changes:
libguile/debug.c | 41 +------------------------
libguile/debug.h | 4 +--
libguile/print.c | 4 +--
libguile/procprop.c | 60 ++++++++++++++++++++++++++++++++++++-
libguile/procprop.h | 4 ++-
libguile/programs.c | 33 ++++++++++++++------
libguile/programs.h | 3 +-
module/system/vm/debug.scm | 18 +++++++----
module/system/vm/disassembler.scm | 21 +-----------
module/system/vm/program.scm | 12 ++++++-
10 files changed, 113 insertions(+), 87 deletions(-)
diff --git a/libguile/debug.c b/libguile/debug.c
index 87513bf..53bebff 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -1,5 +1,5 @@
/* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010, 2011, 2012 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 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
@@ -115,45 +115,6 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface",
0, 1, 0,
}
#undef FUNC_NAME
-
-SCM_SYMBOL (scm_sym_source, "source");
-
-SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
- (SCM proc),
- "Return the name of the procedure @var{proc}")
-#define FUNC_NAME s_scm_procedure_name
-{
- SCM_VALIDATE_PROC (1, proc);
- while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
- proc = SCM_STRUCT_PROCEDURE (proc);
- return scm_procedure_property (proc, scm_sym_name);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
- (SCM proc),
- "Return the source of the procedure @var{proc}.")
-#define FUNC_NAME s_scm_procedure_source
-{
- SCM src;
- SCM_VALIDATE_PROC (1, proc);
-
- do
- {
- src = scm_procedure_property (proc, scm_sym_source);
- if (scm_is_true (src))
- return src;
-
- if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
- && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
- continue;
- }
- while (0);
-
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
diff --git a/libguile/debug.h b/libguile/debug.h
index 362d9b7..e535a6a 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -3,7 +3,7 @@
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H
-/* Copyright (C)
1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012
+/* Copyright (C)
1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -44,8 +44,6 @@ typedef union scm_t_debug_info
SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
-SCM_API SCM scm_procedure_source (SCM proc);
-SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_debug_options (SCM setting);
SCM_INTERNAL void scm_init_debug (void);
diff --git a/libguile/print.c b/libguile/print.c
index 26e4dfc..d65f247 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
- * 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2009, 2010, 2011, 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 License
@@ -656,8 +656,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_i_variable_print (exp, port, pstate);
break;
case scm_tc7_rtl_program:
- scm_i_rtl_program_print (exp, port, pstate);
- break;
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;
diff --git a/libguile/procprop.c b/libguile/procprop.c
index d37495b..4809702 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010,
2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010,
2011, 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 License
@@ -212,8 +212,66 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
}
#undef FUNC_NAME
+
+SCM_SYMBOL (scm_sym_source, "source");
+
+
+SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
+ (SCM proc),
+ "Return the name of the procedure @var{proc}")
+#define FUNC_NAME s_scm_procedure_name
+{
+ SCM props, ret;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ proc = SCM_STRUCT_PROCEDURE (proc);
+
+ props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+
+ if (scm_is_pair (props))
+ ret = scm_assq_ref (props, scm_sym_name);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_name (proc);
+ else if (SCM_PROGRAM_P (proc))
+ ret = scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
+ else
+ ret = SCM_BOOL_F;
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
+ (SCM proc),
+ "Return the source of the procedure @var{proc}.")
+#define FUNC_NAME s_scm_procedure_source
+{
+ SCM src;
+ SCM_VALIDATE_PROC (1, proc);
+
+ do
+ {
+ src = scm_procedure_property (proc, scm_sym_source);
+ if (scm_is_true (src))
+ return src;
+
+ if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
+ && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
+ continue;
+ }
+ while (0);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+
void
scm_init_procprop ()
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 88e44ec..13fbe46 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -3,7 +3,7 @@
#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010, 2011 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010, 2011, 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 License
@@ -40,6 +40,8 @@ SCM_API SCM scm_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
SCM_API SCM scm_procedure_property (SCM proc, SCM key);
SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val);
+SCM_API SCM scm_procedure_source (SCM proc);
+SCM_API SCM scm_procedure_name (SCM proc);
SCM_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
diff --git a/libguile/programs.c b/libguile/programs.c
index eb5972a..d356915 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -111,14 +111,16 @@ SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1,
0, 0,
}
#undef FUNC_NAME
-void
-scm_i_rtl_program_print (SCM program, SCM port, scm_print_state *pstate)
+SCM
+scm_i_rtl_program_name (SCM program)
{
- scm_puts_unlocked ("#<rtl-program ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc_unlocked (' ', port);
- scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port);
- scm_putc_unlocked ('>', port);
+ static SCM rtl_program_name = SCM_BOOL_F;
+
+ if (scm_is_false (rtl_program_name) && scm_module_system_booted_p)
+ rtl_program_name =
+ scm_c_private_variable ("system vm program", "rtl-program-name");
+
+ return scm_call_1 (scm_variable_ref (rtl_program_name), program);
}
void
@@ -147,9 +149,20 @@ scm_i_program_print (SCM program, SCM port,
scm_print_state *pstate)
}
else if (scm_is_false (write_program) || print_error)
{
- scm_puts_unlocked ("#<program ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc_unlocked ('>', port);
+ if (SCM_RTL_PROGRAM_P (program))
+ {
+ scm_puts_unlocked ("#<rtl-program ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked (' ', port);
+ scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16,
port);
+ scm_putc_unlocked ('>', port);
+ }
+ else
+ {
+ scm_puts_unlocked ("#<program ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked ('>', port);
+ }
}
else
{
diff --git a/libguile/programs.h b/libguile/programs.h
index 732594c..fa46135 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -44,8 +44,7 @@ SCM_INTERNAL SCM scm_make_rtl_program (SCM bytevector, SCM
byte_offset, SCM free
SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
-SCM_INTERNAL void scm_i_rtl_program_print (SCM program, SCM port,
- scm_print_state *pstate);
+SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
/*
* Programs
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index bd8a0d6..58cb977 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -35,6 +35,7 @@
program-debug-info-name
program-debug-info-context
program-debug-info-image
+ program-debug-info-offset
program-debug-info-addr
program-debug-info-u32-offset
program-debug-info-u32-offset-end
@@ -55,28 +56,33 @@
(+ (debug-context-base context) (* offset 4)))
(define-record-type <program-debug-info>
- (make-program-debug-info context name addr size)
+ (make-program-debug-info context name offset size)
program-debug-info?
(context program-debug-info-context)
(name program-debug-info-name)
- (addr program-debug-info-addr)
+ (offset program-debug-info-offset)
(size program-debug-info-size))
+(define (program-debug-info-addr pdi)
+ (+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi))
+ (debug-context-base (program-debug-info-context pdi))))
+
(define (program-debug-info-image pdi)
(debug-context-image (program-debug-info-context pdi)))
(define (program-debug-info-u32-offset pdi)
- ;; ADDR is in bytes from the beginning of the text section. TEXT-BASE
- ;; is in bytes from the beginning of the image. Return ADDR as a u32
+ ;; OFFSET is in bytes from the beginning of the text section. TEXT-BASE
+ ;; is in bytes from the beginning of the image. Return OFFSET as a u32
;; index from the start of the image.
- (/ (+ (program-debug-info-addr pdi)
+ (/ (+ (program-debug-info-offset pdi)
(debug-context-text-base (program-debug-info-context pdi)))
4))
(define (program-debug-info-u32-offset-end pdi)
;; Return the end position as a u32 index from the start of the image.
(/ (+ (program-debug-info-size pdi)
- (program-debug-info-addr pdi)
+ (program-debug-info-offset pdi)
(debug-context-text-base (program-debug-info-context pdi)))
4))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 1db44aa..7e949e0 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -73,10 +73,8 @@
((U8_U24)
#'((ash word -8)))
((U8_L24)
- ;; Fixme: translate back to label
#'((unpack-s24 (ash word -8))))
((U8_R24)
- ;; FIXME: parse rest instructions correctly
#'(#:rest (ash word -8)))
((U8_U8_I16)
#'((logand (ash word -8) #xff)
@@ -100,15 +98,12 @@
#'((logand word #xff)
(ash word -8)))
((U8_L24)
- ;; Fixme: translate back to label
#'((logand word #xff)
(unpack-s24 (ash word -8))))
((U8_R24)
- ;; FIXME: parse rest instructions correctly
#'((logand word #xff)
#:rest (ash word -8)))
((U8_U8_I16)
- ;; FIXME: immediates
#'((logand word #xff)
(logand (ash word -8) #xff)
(ash word -16)))
@@ -124,25 +119,18 @@
((U32)
#'(word))
((I32)
- ;; FIXME: immediates
#'(word))
((A32)
- ;; FIXME: long immediates
#'(word))
((B32)
- ;; FIXME: long immediates
#'(word))
((N32)
- ;; FIXME: non-immediate
#'((unpack-s32 word)))
((S32)
- ;; FIXME: indirect access
#'((unpack-s32 word)))
((L32)
- ;; FIXME: offset
#'((unpack-s32 word)))
((LO32)
- ;; FIXME: offset
#'((unpack-s32 word)))
((X8_U24)
#'((ash word -8)))
@@ -150,17 +138,13 @@
#'((logand (ash word -8) #xfff)
(ash word -20)))
((X8_R24)
- ;; FIXME: rest
#'(#:rest (ash word -8)))
((X8_L24)
- ;; FIXME: label
#'((unpack-s24 (ash word -8))))
((U1_X7_L24)
- ;; FIXME: label
#'((logand word #x1)
(unpack-s24 (ash word -8))))
((U1_U7_L24)
- ;; FIXME: label
#'((logand word #x1)
(logand (ash word -1) #x7f)
(unpack-s24 (ash word -8))))
@@ -345,9 +329,8 @@
(cond
((find-program-debug-info #:program program)
=> (lambda (pdi)
- ;; FIXME: RTL programs should print with their names.
- (format port "Disassembly of ~A at ~S:\n\n"
- (program-debug-info-name pdi) program)
+ (format port "Disassembly of ~S at #x~X:\n\n" program
+ (program-debug-info-addr pdi))
(disassemble-buffer port
(program-debug-info-image pdi)
(program-debug-info-u32-offset pdi)
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 1875093..2fc3b53 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -22,6 +22,7 @@
#:use-module (system base pmatch)
#:use-module (system vm instruction)
#:use-module (system vm objcode)
+ #:use-module (system vm debug)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -53,6 +54,13 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_programs")
+;; This procedure is called by programs.c.
+(define (rtl-program-name program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (and=> (find-program-debug-info #:program program)
+ program-debug-info-name))
+
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
@@ -271,7 +279,7 @@
(define (write-program prog port)
(format port "#<procedure ~a~a>"
(or (procedure-name prog)
- (and=> (program-source prog 0)
+ (and=> (and (program? prog) (program-source prog 0))
(lambda (s)
(format #f "~a at ~a:~a:~a"
(number->string (object-address prog) 16)
@@ -279,7 +287,7 @@
(if s "<current input>" "<unknown port>"))
(source:line-for-user s) (source:column s))))
(number->string (object-address prog) 16))
- (let ((arities (program-arities prog)))
+ (let ((arities (and (program? prog) (program-arities prog))))
(if (or (not arities) (null? arities))
""
(string-append
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-930-g16dcce9,
Andy Wingo <=