[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-950-ge2e2f14
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-950-ge2e2f14 |
|
Date: |
Thu, 16 May 2013 21:38: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=e2e2f14736d9d6a1c6b385426edffd4e76a8cff9
The branch, wip-rtl has been updated
via e2e2f14736d9d6a1c6b385426edffd4e76a8cff9 (commit)
via 468833e0f68b088e3155509d985e021bd8e1fcab (commit)
via a2a10db24751de653047ba07aea7b4ef0d9b2847 (commit)
via 19615bcd3148e957ecfe29803ef27959546b7dab (commit)
from 98451a38295b6f6bc5cd9764d3c5256f6cf2b0a9 (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 e2e2f14736d9d6a1c6b385426edffd4e76a8cff9
Author: Andy Wingo <address@hidden>
Date: Thu May 16 23:38:29 2013 +0200
procedure-documentation works on RTL procedures
* libguile/procprop.h:
* libguile/procprop.c (scm_procedure_documentation): Move here from
procs.c, and to make the logic more similar to that of procedure-name,
which allows RTL programs to dispatch to rtl-program-documentation.
* libguile/programs.c (scm_i_rtl_program_documentation):
* libguile/programs.h:
* module/system/vm/program.scm (rtl-program-documentation): New
plumbing.
* module/system/vm/debug.scm (find-program-docstring): New interface to
grovel ELF for a docstring.
commit 468833e0f68b088e3155509d985e021bd8e1fcab
Author: Andy Wingo <address@hidden>
Date: Thu May 16 23:35:35 2013 +0200
add rtl arity tests
* test-suite/tests/rtl.test ("simply procedure arity"): Add tests that
arities make it all the way to cold ELF and back to warm Guile.
commit a2a10db24751de653047ba07aea7b4ef0d9b2847
Author: Andy Wingo <address@hidden>
Date: Thu May 16 23:32:09 2013 +0200
add procedure name test
* module/system/vm/debug.scm (find-program-debug-info): Load procedure
names as symbols.
* test-suite/tests/rtl.test ("procedure name"): Add test.
commit 19615bcd3148e957ecfe29803ef27959546b7dab
Author: Andy Wingo <address@hidden>
Date: Thu May 16 22:30:51 2013 +0200
Write docstrings into RTL ELF images
* module/system/vm/assembler.scm (link-docstrs): Write docstrings.
(link-objects): Link docstrings into the ELF.
-----------------------------------------------------------------------
Summary of changes:
libguile/procprop.c | 33 ++++++++++++++++++++++
libguile/procprop.h | 2 +
libguile/procs.c | 15 ----------
libguile/procs.h | 5 +---
libguile/programs.c | 13 +++++++++
libguile/programs.h | 1 +
module/system/vm/assembler.scm | 58 +++++++++++++++++++++++++++++++++++++++-
module/system/vm/debug.scm | 37 ++++++++++++++++++++++++-
module/system/vm/program.scm | 6 ++++
test-suite/tests/rtl.test | 52 +++++++++++++++++++++++++++++++++++
10 files changed, 200 insertions(+), 22 deletions(-)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 62476c0..d7ce09b 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -238,6 +238,39 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
#undef FUNC_NAME
+SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
+
+SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
+ (SCM proc),
+ "Return the documentation string associated with @code{proc}. By\n"
+ "convention, if a procedure contains more than one expression and
the\n"
+ "first expression is a string constant, that string is assumed to
contain\n"
+ "documentation for that procedure.")
+#define FUNC_NAME s_scm_procedure_documentation
+{
+ 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_documentation);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_documentation (proc);
+ else if (SCM_PROGRAM_P (proc))
+ ret = scm_assq_ref (scm_i_program_properties (proc),
scm_sym_documentation);
+ 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}.")
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 13fbe46..41d0753 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -29,6 +29,7 @@
SCM_API SCM scm_sym_name;
SCM_API SCM scm_sym_system_procedure;
+SCM_INTERNAL SCM scm_sym_documentation;
@@ -42,6 +43,7 @@ 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_API SCM scm_procedure_documentation (SCM proc);
SCM_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
diff --git a/libguile/procs.c b/libguile/procs.c
index bda6d34..8d9ef15 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -66,21 +66,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
-
-SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
- (SCM proc),
- "Return the documentation string associated with @code{proc}. By\n"
- "convention, if a procedure contains more than one expression and
the\n"
- "first expression is a string constant, that string is assumed to
contain\n"
- "documentation for that procedure.")
-#define FUNC_NAME s_scm_procedure_documentation
-{
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
- return scm_procedure_property (proc, scm_sym_documentation);
-}
-#undef FUNC_NAME
-
/* Procedure-with-setter
*/
diff --git a/libguile/procs.h b/libguile/procs.h
index a35872e..c4c78f2 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -4,7 +4,7 @@
#define SCM_PROCS_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
- * 2012 Free Software Foundation, Inc.
+ * 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
@@ -30,15 +30,12 @@
SCM_API SCM scm_procedure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
-SCM_API SCM scm_procedure_documentation (SCM proc);
SCM_API SCM scm_procedure_with_setter_p (SCM obj);
SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc);
SCM_INTERNAL void scm_init_procs (void);
-SCM_INTERNAL SCM scm_sym_documentation;
-
#endif /* SCM_PROCS_H */
/*
diff --git a/libguile/programs.c b/libguile/programs.c
index 12561b3..567708a 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -123,6 +123,19 @@ scm_i_rtl_program_name (SCM program)
return scm_call_1 (scm_variable_ref (rtl_program_name), program);
}
+SCM
+scm_i_rtl_program_documentation (SCM program)
+{
+ static SCM rtl_program_documentation = SCM_BOOL_F;
+
+ if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p)
+ rtl_program_documentation =
+ scm_c_private_variable ("system vm program",
+ "rtl-program-documentation");
+
+ return scm_call_1 (scm_variable_ref (rtl_program_documentation), program);
+}
+
void
scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
{
diff --git a/libguile/programs.h b/libguile/programs.h
index fa46135..175059f 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -45,6 +45,7 @@ SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
+SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
/*
* Programs
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index f39491d..12aa24d 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1167,6 +1167,61 @@
(linker-object-section strtab)))
strtab)))))
+;;;
+;;; The .guile.docstrs section is a packed, sorted array of (pc, str)
+;;; values. Pc and str are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, and
+;;; str is an index into the associated .guile.docstrs.strtab string
+;;; table section.
+;;;
+
+;; The size of a docstrs entry, in bytes.
+(define docstr-size 8)
+
+(define (link-docstrs asm)
+ (define (find-docstrings)
+ (filter-map (lambda (meta)
+ (define (is-documentation? pair)
+ (eq? (car pair) 'documentation))
+ (let* ((props (meta-properties meta))
+ (tail (find-tail is-documentation? props)))
+ (and tail
+ (not (find-tail is-documentation? (cdr tail)))
+ (string? (cdar tail))
+ (cons (meta-low-pc meta) (cdar tail)))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (docstrings (find-docstrings))
+ (strtab (make-string-table))
+ (bv (make-bytevector (* (length docstrings) docstr-size) 0)))
+ (define (intern-string! name)
+ (call-with-values
+ (lambda () (string-table-intern strtab name))
+ (lambda (table idx)
+ (set! strtab table)
+ idx)))
+ (fold (lambda (pair pos)
+ (match pair
+ ((pc . string)
+ (bytevector-u32-set! bv pos pc endianness)
+ (bytevector-u32-set! bv (+ pos 4) (intern-string! string)
+ endianness)
+ (+ pos docstr-size))))
+ 0
+ docstrings)
+ (let ((strtab (make-object asm '.guile.docstrs.strtab
+ (link-string-table strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.docstrs
+ bv
+ '() '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab))))
+
(define (link-objects asm)
(let*-values (((ro rw rw-init) (link-constants asm))
;; Link text object after constants, so that the
@@ -1175,12 +1230,13 @@
((dt) (link-dynamic-section asm text ro rw rw-init))
((symtab strtab) (link-symtab (linker-object-section text)
asm))
((arities arities-strtab) (link-arities asm))
+ ((docstrs docstrs-strtab) (link-docstrs asm))
;; This needs to be linked last, because linking other
;; sections adds entries to the string table.
((shstrtab) (link-shstrtab asm)))
(filter identity
(list text ro rw dt symtab strtab arities arities-strtab
- shstrtab))))
+ docstrs docstrs-strtab shstrtab))))
(define (link-assembly asm)
(link-elf (link-objects asm)))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 0e87648..c6b5359 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -51,7 +51,9 @@
arity-is-case-lambda?
arity-arguments-alist
find-program-arities
- program-minimum-arity))
+ program-minimum-arity
+
+ find-program-docstring))
(define-record-type <debug-context>
(make-debug-context elf base text-base)
@@ -143,7 +145,8 @@
;; the string table was
;; stripped somehow.
(lambda (x)
- (and (string? x) x)))
+ (and (string? x)
+ (string->symbol x))))
(elf-symbol-value sym)
(elf-symbol-size sym))))
(else #f)))
@@ -307,3 +310,33 @@
(list (arity-nreq first)
(arity-nopt first)
(arity-has-rest? first)))))))
+
+(define* (find-program-docstring addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.docstrs")
+ (lambda (sec)
+ ;; struct docstr {
+ ;; uint32_t pc;
+ ;; uint32_t str;
+ ;; }
+ (define docstr-len 8)
+ (let* ((start (elf-section-offset sec))
+ (end (+ start (elf-section-size sec)))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos start))
+ (cond
+ ((>= pos end) #f)
+ ((< text-offset (bytevector-u32-native-ref bv pos))
+ (lp (+ pos arity-header-len)))
+ ((> text-offset (bytevector-u32-native-ref bv pos))
+ #f)
+ (else
+ (let ((strtab (elf-section (debug-context-elf context)
+ (elf-section-link sec)))
+ (idx (bytevector-u32-native-ref bv (+ pos 4))))
+ (string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index a4bd64e..d719e95 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -62,6 +62,12 @@
program-debug-info-name))
;; This procedure is called by programs.c.
+(define (rtl-program-documentation program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (find-program-docstring (rtl-program-code program)))
+
+;; This procedure is called by programs.c.
(define (rtl-program-minimum-arity program)
(unless (rtl-program? program)
(error "shouldn't get here"))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 5e7191b..6b8ce25 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -283,3 +283,55 @@
(end-program)))))
((make-top-incrementor))
*top-val*))))
+
+(with-test-prefix "procedure name"
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "simply procedure arity"
+ (pass-if-equal "#<procedure foo ()>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+ (pass-if-equal "#<procedure foo (x y)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity (x y) 2 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ (pass-if-equal "#<procedure foo (x #:optional y . z)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-opt-arity (x) (y) z 3 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "procedure docstrings"
+ (pass-if-equal "qux qux"
+ (procedure-documentation
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-950-ge2e2f14,
Andy Wingo <=