[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-34-gc4c098e
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-34-gc4c098e |
|
Date: |
Sun, 09 Jun 2013 22:00:51 +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=c4c098e355bd2edcd3bc66eb7041c5f9cdeefef0
The branch, master has been updated
via c4c098e355bd2edcd3bc66eb7041c5f9cdeefef0 (commit)
via bf8328ec16cbe76b7af9703bb41e964865034561 (commit)
via 9128b1a19fe89de1aacafe5ccffd06e193f531bc (commit)
via eb2bc00fb3863986927f0bade97487209b6d6a5b (commit)
via f88e574d58aa3e64b6f1ed0bc6ea918d20a67d88 (commit)
via b2006c19aff23f73aea0aa9fa5e211c7fa4f4df3 (commit)
via 3185c9071c93c4c7322f4f4484f20e038de4fdf1 (commit)
via 07c052796d6fcf056d172b311a87519996937fd0 (commit)
via 2a4daafd303f9b70d0680a4cadf42ef5c3fcfabc (commit)
from 82e299f3864c663c45ddb960112a12b4f17d68c9 (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 c4c098e355bd2edcd3bc66eb7041c5f9cdeefef0
Author: Andy Wingo <address@hidden>
Date: Fri May 17 22:10:16 2013 +0200
procedure-properties for RTL functions
* module/system/vm/assembler.scm (link-procprops, link-objects): Arrange
to write procedure property links out to a separate section.
* libguile/procprop.c (scm_procedure_properties):
* libguile/programs.h:
* libguile/programs.c (scm_i_rtl_program_properties):
* module/system/vm/debug.scm (find-program-properties): Wire up
procedure-properties for RTL procedures. Yeah! Fistpumps! :)
* module/system/vm/debug.scm (find-program-debug-info): Return #f if the
string is "", as it is if we don't have a name. Perhaps
elf-symbol-name should return #f in that case...
* test-suite/tests/rtl.test: Add some tests.
commit bf8328ec16cbe76b7af9703bb41e964865034561
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 9128b1a19fe89de1aacafe5ccffd06e193f531bc
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.
commit eb2bc00fb3863986927f0bade97487209b6d6a5b
Author: Andy Wingo <address@hidden>
Date: Thu May 16 20:58:54 2013 +0200
Wire up ability to print RTL program arities
* libguile/procprop.c (scm_i_procedure_arity): Allow RTL programs to
dispatch to scm_i_program_arity.
* libguile/programs.c (scm_i_program_print): Refactor reference to
write-program.
(scm_i_rtl_program_minimum_arity): New procedure, dispatches to
Scheme.
(scm_i_program_arity): Dispatch to scm_i_rtl_program_minimum_arity if
appropriate.
* module/system/vm/debug.scm (program-minimum-arity): New export.
* module/system/vm/program.scm (rtl-program-minimum-arity): New internal
function.
(program-arguments-alists): New helper, implemented also for RTL
procedures.
(write-program): Refactor a bit, and call program-arguments-alists.
* 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 f88e574d58aa3e64b6f1ed0bc6ea918d20a67d88
Author: Andy Wingo <address@hidden>
Date: Thu May 16 18:56:22 2013 +0200
(system vm debug) can read arity information
* module/system/vm/debug.scm (<arity>): New object, for reading
arities. Unlike <arity> in the assembler, this one only holds on to a
couple of pointers, and doesn't even load in argument names. Unlike
the arity lists in (system vm program), it can load in names. Very
early days but it does seem to work.
(find-program-arities, arity-arguments-alist): New higher-level
interfaces.
commit b2006c19aff23f73aea0aa9fa5e211c7fa4f4df3
Author: Andy Wingo <address@hidden>
Date: Thu May 16 14:06:10 2013 +0200
RTL assembler writes arities information into separate section.
* module/system/vm/assembler.scm: Write arities into a .guile.arities
section and associated .guile.arities.strtab.
commit 3185c9071c93c4c7322f4f4484f20e038de4fdf1
Author: Andy Wingo <address@hidden>
Date: Tue May 14 11:18:05 2013 +0200
Beginnings of tracking of procedure arities in assembler
* module/system/vm/assembler.scm (<meta>, <arity>): Assembler now tracks
arities of a function.
(begin-standard-arity, begin-opt-arity, begin-kw-arity, end-arity):
New macro-assemblers.
* test-suite/tests/rtl.test: Adapt all tests to use begin-standard-arity
and end-arity.
commit 07c052796d6fcf056d172b311a87519996937fd0
Author: Andy Wingo <address@hidden>
Date: Tue May 14 10:33:43 2013 +0200
add procedure prelude macro-instructions
* module/system/vm/assembler.scm (pack-flags): New helper.
(standard-prelude, opt-prelude, kw-prelude): New macro-instructions.
* test-suite/tests/rtl.test: Update tests to use standard-prelude.
commit 2a4daafd303f9b70d0680a4cadf42ef5c3fcfabc
Author: Andy Wingo <address@hidden>
Date: Tue May 14 10:25:38 2013 +0200
begin-program takes properties alist
* module/system/vm/assembler.scm (assert-match): New helper macro to
check argument types.
(<meta>): Add properties field. Rename name field to "label" to
indicate that it should be unique.
(make-meta, meta-name): New helpers.
(begin-program): Take additional properties argument.
(emit-init-constants): Adapt to begin-program change.
(link-symtab): Allow for anonymous procedures.
* test-suite/tests/rtl.test: Adapt tests.
-----------------------------------------------------------------------
Summary of changes:
libguile/procprop.c | 45 ++++-
libguile/procprop.h | 2 +
libguile/procs.c | 15 --
libguile/procs.h | 5 +-
libguile/programs.c | 55 +++++-
libguile/programs.h | 2 +
module/system/vm/assembler.scm | 443 +++++++++++++++++++++++++++++++++++++++-
module/system/vm/debug.scm | 250 ++++++++++++++++++++++-
module/system/vm/program.scm | 67 ++++--
test-suite/tests/rtl.test | 211 ++++++++++++++++----
10 files changed, 992 insertions(+), 103 deletions(-)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 4809702..2d9e655 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -60,7 +60,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest)
return 1;
}
- while (!SCM_PROGRAM_P (proc))
+ while (!SCM_PROGRAM_P (proc) && !SCM_RTL_PROGRAM_P (proc))
{
if (SCM_STRUCTP (proc))
{
@@ -82,14 +82,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest)
return 1;
}
- else if (SCM_RTL_PROGRAM_P (proc))
- {
- *req = 0;
- *opt = 0;
- *rest = 1;
-
- return 1;
- }
else
return 0;
}
@@ -154,6 +146,8 @@ SCM_DEFINE (scm_procedure_properties,
"procedure-properties", 1, 0, 0,
{
if (SCM_PROGRAM_P (proc))
ret = scm_i_program_properties (proc);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_properties (proc);
else
ret = SCM_EOL;
}
@@ -246,6 +240,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 d356915..d8dd378 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -123,15 +123,39 @@ 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);
+}
+
+SCM
+scm_i_rtl_program_properties (SCM program)
+{
+ static SCM rtl_program_properties = SCM_BOOL_F;
+
+ if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p)
+ rtl_program_properties =
+ scm_c_private_variable ("system vm program", "rtl-program-properties");
+
+ return scm_call_1 (scm_variable_ref (rtl_program_properties), program);
+}
+
void
scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
{
static int print_error = 0;
if (scm_is_false (write_program) && scm_module_system_booted_p)
- write_program = scm_module_local_variable
- (scm_c_resolve_module ("system vm program"),
- scm_from_latin1_symbol ("write-program"));
+ write_program = scm_c_private_variable ("system vm program",
+ "write-program");
if (SCM_PROGRAM_IS_CONTINUATION (program))
{
@@ -450,11 +474,36 @@ parse_arity (SCM arity, int *req, int *opt, int *rest)
*req = *opt = *rest = 0;
}
+static int
+scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
+{
+ static SCM rtl_program_minimum_arity = SCM_BOOL_F;
+ SCM l;
+
+ if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
+ rtl_program_minimum_arity =
+ scm_c_private_variable ("system vm debug",
+ "rtl-program-minimum-arity");
+
+ l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program);
+ if (scm_is_false (l))
+ return 0;
+
+ *req = scm_to_int (scm_car (l));
+ *opt = scm_to_int (scm_cadr (l));
+ *rest = scm_is_true (scm_caddr (l));
+
+ return 1;
+}
+
int
scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
{
SCM arities;
+ if (SCM_RTL_PROGRAM_P (program))
+ return scm_i_rtl_program_minimum_arity (program, req, opt, rest);
+
arities = scm_program_arities (program);
if (!scm_is_pair (arities))
return 0;
diff --git a/libguile/programs.h b/libguile/programs.h
index fa46135..e42a76e 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -45,6 +45,8 @@ 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);
+SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);
/*
* Programs
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 0a35bdc..556f589 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -90,6 +90,12 @@
(define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
(logior x (ash y 8) (ash z 16) (ash w 24)))
+(define-syntax pack-flags
+ (syntax-rules ()
+ ;; Add clauses as needed.
+ ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
+ (if f2 (ash 2 0) 0)))))
+
;;; Helpers to read and write 32-bit units in a buffer.
(define-syntax-rule (u32-ref buf n)
@@ -110,12 +116,40 @@
;;; A <meta> entry collects metadata for one procedure. Procedures are
;;; written as contiguous ranges of RTL code.
;;;
+(define-syntax-rule (assert-match arg pattern kind)
+ (let ((x arg))
+ (unless (match x (pattern #t) (_ #f))
+ (error (string-append "expected " kind) x))))
+
(define-record-type <meta>
- (make-meta name low-pc high-pc)
+ (%make-meta label properties low-pc high-pc arities)
meta?
- (name meta-name)
+ (label meta-label)
+ (properties meta-properties set-meta-properties!)
(low-pc meta-low-pc)
- (high-pc meta-high-pc set-meta-high-pc!))
+ (high-pc meta-high-pc set-meta-high-pc!)
+ (arities meta-arities set-meta-arities!))
+
+(define (make-meta label properties low-pc)
+ (assert-match label (? symbol?) "symbol")
+ (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
+ (%make-meta label properties low-pc #f '()))
+
+(define (meta-name meta)
+ (assq-ref (meta-properties meta) 'name))
+
+;; Metadata for one <lambda-case>.
+(define-record-type <arity>
+ (make-arity req opt rest kw-indices allow-other-keys?
+ low-pc high-pc)
+ arity?
+ (req arity-req)
+ (opt arity-opt)
+ (rest arity-rest)
+ (kw-indices arity-kw-indices)
+ (allow-other-keys? arity-allow-other-keys?)
+ (low-pc arity-low-pc)
+ (high-pc arity-high-pc set-arity-high-pc!))
(define-syntax *block-size* (identifier-syntax 32))
@@ -597,13 +631,93 @@ returned instead."
(let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc)))
-(define-macro-assembler (begin-program asm label)
+(define-macro-assembler (begin-program asm label properties)
(emit-label asm label)
- (let ((meta (make-meta label (asm-start asm) #f)))
+ (let ((meta (make-meta label properties (asm-start asm))))
(set-asm-meta! asm (cons meta (asm-meta asm)))))
(define-macro-assembler (end-program asm)
- (set-meta-high-pc! (car (asm-meta asm)) (asm-start asm)))
+ (let ((meta (car (asm-meta asm))))
+ (set-meta-high-pc! meta (asm-start asm))
+ (set-meta-arities! meta (reverse (meta-arities meta)))))
+
+(define-macro-assembler (begin-standard-arity asm req nlocals alternate)
+ (emit-begin-opt-arity asm req '() #f nlocals alternate))
+
+(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
+ (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
+
+(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (assert-match req ((? symbol?) ...) "list of symbols")
+ (assert-match opt ((? symbol?) ...) "list of symbols")
+ (assert-match rest (or #f (? symbol?)) "#f or symbol")
+ (assert-match kw-indices (((? symbol?) . (? integer?)) ...)
+ "alist of symbol -> integer")
+ (assert-match allow-other-keys? (? boolean?) "boolean")
+ (assert-match nlocals (? integer?) "integer")
+ (assert-match alternate (or #f (? symbol?)) "#f or symbol")
+ (let* ((meta (car (asm-meta asm)))
+ (arity (make-arity req opt rest kw-indices allow-other-keys?
+ (asm-start asm) #f))
+ (nreq (length req))
+ (nopt (length opt))
+ (rest? (->bool rest)))
+ (set-meta-arities! meta (cons arity (meta-arities meta)))
+ (cond
+ ((or allow-other-keys? (pair? kw-indices))
+ (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys?
+ nlocals alternate))
+ ((or rest? (pair? opt))
+ (emit-opt-prelude asm nreq nopt rest? nlocals alternate))
+ (else
+ (emit-standard-prelude asm nreq nlocals alternate)))))
+
+(define-macro-assembler (end-arity asm)
+ (let ((arity (car (meta-arities (car (asm-meta asm))))))
+ (set-arity-high-pc! arity (asm-start asm))))
+
+(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
+ (cond
+ (alternate
+ (emit-br-if-nargs-ne asm nreq alternate)
+ (emit-reserve-locals asm nlocals))
+ ((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12)))
+ (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
+ (else
+ (emit-assert-nargs-ee asm nreq)
+ (emit-reserve-locals asm nlocals))))
+
+(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (cond
+ (rest?
+ (emit-bind-rest asm (+ nreq nopt)))
+ (alternate
+ (emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
+ (else
+ (emit-assert-nargs-le asm (+ nreq nopt))))
+ (emit-reserve-locals asm nlocals))
+
+(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
+ allow-other-keys? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (let ((ntotal (fold (lambda (kw ntotal)
+ (match kw
+ (((? keyword?) . idx)
+ (max (1+ idx) ntotal))))
+ (+ nreq nopt) kw-indices)))
+ ;; FIXME: port 581f410f
+ (emit-bind-kwargs asm nreq
+ (pack-flags allow-other-keys? rest?)
+ (+ nreq nopt)
+ ntotal
+ kw-indices)
+ (emit-reserve-locals asm nlocals)))
(define-macro-assembler (label asm sym)
(set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
@@ -686,7 +800,7 @@ a procedure to do that and return its label. Otherwise
return
(and (not (null? inits))
(let ((label (gensym "init-constants")))
(emit-text asm
- `((begin-program ,label)
+ `((begin-program ,label ())
(assert-nargs-ee/locals 0 1)
,@(reverse inits)
(load-constant 0 ,*unspecified*)
@@ -1025,7 +1139,7 @@ it will be added to the GC roots at runtime."
(strtab (make-string-table))
(bv (make-bytevector (* n size) 0)))
(define (intern-string! name)
- (string-table-intern! strtab (symbol->string name)))
+ (string-table-intern! strtab (if name (symbol->string name) "")))
(for-each
(lambda (meta n)
(let ((name (intern-string! (meta-name meta))))
@@ -1053,17 +1167,326 @@ it will be added to the GC roots at runtime."
(linker-object-section strtab)))
strtab))))
+;;; The .guile.arities section describes the arities that a function can
+;;; have. It is in two parts: a sorted array of headers describing
+;;; basic arities, and an array of links out to a string table (and in
+;;; the case of keyword arguments, to the data section) for argument
+;;; names. The whole thing is prefixed by a uint32 indicating the
+;;; offset of the end of the headers array.
+;;;
+;;; The arity headers array is a packed array of structures of the form:
+;;;
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+;;;
+;;; All of the offsets and addresses are 32 bits. We can expand in the
+;;; future to use 64-bit offsets if appropriate, but there are other
+;;; aspects of RTL that constrain us to a total image that fits in 32
+;;; bits, so for the moment we'll simplify the problem space.
+;;;
+;;; The following flags values are defined:
+;;;
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+;;;
+;;; Functions with a single arity specify their number of required and
+;;; optional arguments in nreq and nopt, and do not have the
+;;; is-case-lambda? flag set. Their "offset" member links to an array
+;;; of pointers into the associated .guile.arities.strtab string table,
+;;; identifying the argument names. This offset is relative to the
+;;; start of the .guile.arities section. Links for required arguments
+;;; are first, in order, as uint32 values. Next follow the optionals,
+;;; then the rest link if has-rest? is set, then a link to the "keyword
+;;; indices" literal if has-keyword-args? is set. Unlike the other
+;;; links, the kw-indices link points into the data section, and is
+;;; relative to the ELF image as a whole.
+;;;
+;;; Functions with no arities have no arities information present in the
+;;; .guile.arities section.
+;;;
+;;; Functions with multiple arities are preceded by a header with
+;;; is-case-lambda? set. All other fields are 0, except low-pc and
+;;; high-pc which should be the bounds of the whole function. Headers
+;;; for the individual arities follow. In this way the whole headers
+;;; array is sorted in increasing low-pc order, and case-lambda clauses
+;;; are contained within the [low-pc, high-pc] of the case-lambda
+;;; header.
+
+;; Length of the prefix to the arities section, in bytes.
+(define arities-prefix-len 4)
+
+;; Length of an arity header, in bytes.
+(define arity-header-len (* 6 4))
+
+;; The offset of "offset" within arity header, in bytes.
+(define arity-header-offset-offset (* 2 4))
+
+(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
+ has-keyword-args? is-case-lambda?)
+ (logior (if has-rest? (ash 1 0) 0)
+ (if allow-other-keys? (ash 1 1) 0)
+ (if has-keyword-args? (ash 1 2) 0)
+ (if is-case-lambda? (ash 1 3) 0)))
+
+(define (meta-arities-size meta)
+ (define (lambda-size arity)
+ (+ arity-header-len
+ (* 4 ;; name pointers
+ (+ (length (arity-req arity))
+ (length (arity-opt arity))
+ (if (arity-rest arity) 1 0)
+ (if (pair? (arity-kw-indices arity)) 1 0)))))
+ (define (case-lambda-size arities)
+ (fold +
+ arity-header-len ;; case-lambda header
+ (map lambda-size arities))) ;; the cases
+ (match (meta-arities meta)
+ (() 0)
+ ((arity) (lambda-size arity))
+ (arities (case-lambda-size arities))))
+
+(define (write-arity-headers metas bv endianness)
+ (define (write-arity-header* pos low-pc high-pc flags nreq nopt)
+ (bytevector-u32-set! bv pos low-pc endianness)
+ (bytevector-u32-set! bv (+ pos 4) high-pc endianness)
+ (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
+ (bytevector-u32-set! bv (+ pos 12) flags endianness)
+ (bytevector-u32-set! bv (+ pos 16) nreq endianness)
+ (bytevector-u32-set! bv (+ pos 20) nopt endianness))
+ (define (write-arity-header pos arity)
+ (write-arity-header* pos (arity-low-pc arity)
+ (arity-high-pc arity)
+ (pack-arity-flags (arity-rest arity)
+ (arity-allow-other-keys? arity)
+ (pair? (arity-kw-indices arity))
+ #f)
+ (length (arity-req arity))
+ (length (arity-opt arity))))
+ (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
+ (match metas
+ (()
+ ;; Fill in the prefix.
+ (bytevector-u32-set! bv 0 pos endianness)
+ (values pos (reverse offsets)))
+ ((meta . metas)
+ (match (meta-arities meta)
+ (() (lp metas pos offsets))
+ ((arity)
+ (write-arity-header pos arity)
+ (lp metas
+ (+ pos arity-header-len)
+ (acons arity (+ pos arity-header-offset-offset) offsets)))
+ (arities
+ ;; Write a case-lambda header, then individual arities.
+ ;; The case-lambda header's offset link is 0.
+ (write-arity-header* pos (meta-low-pc meta) (meta-high-pc meta)
+ (pack-arity-flags #f #f #f #t) 0 0)
+ (let lp* ((arities arities) (pos (+ pos arity-header-len))
+ (offsets offsets))
+ (match arities
+ (() (lp metas pos offsets))
+ ((arity . arities)
+ (write-arity-header pos arity)
+ (lp* arities
+ (+ pos arity-header-len)
+ (acons arity
+ (+ pos arity-header-offset-offset)
+ offsets)))))))))))
+
+(define (write-arity-links asm bv pos arity-offset-pairs strtab)
+ (define (write-symbol sym pos)
+ (bytevector-u32-set! bv pos
+ (string-table-intern! strtab (symbol->string sym))
+ (asm-endianness asm))
+ (+ pos 4))
+ (define (write-kw-indices pos kw-indices)
+ ;; FIXME: Assert that kw-indices is already interned.
+ (make-linker-reloc 'abs32/1 pos 0
+ (intern-constant asm kw-indices)))
+ (let lp ((pos pos) (pairs arity-offset-pairs) (relocs '()))
+ (match pairs
+ (()
+ (unless (= pos (bytevector-length bv))
+ (error "expected to fully fill the bytevector"
+ pos (bytevector-length bv)))
+ relocs)
+ (((arity . offset) . pairs)
+ (bytevector-u32-set! bv offset pos (asm-endianness asm))
+ (let ((pos (fold write-symbol
+ pos
+ (append (arity-req arity)
+ (arity-opt arity)
+ (cond
+ ((arity-rest arity) => list)
+ (else '()))))))
+ (match (arity-kw-indices arity)
+ (() (lp pos pairs relocs))
+ (kw-indices
+ (lp (+ pos 4)
+ pairs
+ (cons (write-kw-indices pos kw-indices) relocs)))))))))
+
+(define (link-arities asm)
+ (let* ((endianness (asm-endianness asm))
+ (metas (reverse (asm-meta asm)))
+ (size (fold (lambda (meta size)
+ (+ size (meta-arities-size meta)))
+ arities-prefix-len
+ metas))
+ (strtab (make-string-table))
+ (bv (make-bytevector size 0)))
+ (let ((kw-indices-relocs
+ (call-with-values
+ (lambda ()
+ (write-arity-headers metas bv endianness))
+ (lambda (pos arity-offset-pairs)
+ (write-arity-links asm bv pos arity-offset-pairs strtab)))))
+ (let ((strtab (make-object asm '.guile.arities.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.arities
+ bv
+ kw-indices-relocs '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (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)))
+ (fold (lambda (pair pos)
+ (match pair
+ ((pc . string)
+ (bytevector-u32-set! bv pos pc endianness)
+ (bytevector-u32-set! bv (+ pos 4)
+ (string-table-intern! strtab 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))))
+
+;;;
+;;; The .guile.procprops section is a packed, sorted array of (pc, addr)
+;;; values. Pc and addr 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
+;;; addr is the address of the associated properties alist, relative to
+;;; the start of the ELF image.
+;;;
+;;; Since procedure properties are stored in the data sections, we need
+;;; to link the procedures property section first. (Note that this
+;;; constraint does not apply to the arities section, which may
+;;; reference the data sections via the kw-indices literal, because
+;;; assembling the text section already makes sure that the kw-indices
+;;; are interned.)
+;;;
+
+;; The size of a procprops entry, in bytes.
+(define procprops-size 8)
+
+(define (link-procprops asm)
+ (define (assoc-remove-one alist key value-pred)
+ (match alist
+ (() '())
+ ((((? (lambda (x) (eq? x key))) . value) . alist)
+ (if (value-pred value)
+ alist
+ (acons key value alist)))
+ (((k . v) . alist)
+ (acons k v (assoc-remove-one alist key value-pred)))))
+ (define (props-without-name-or-docstring meta)
+ (assoc-remove-one
+ (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t))
+ 'documentation
+ string?))
+ (define (find-procprops)
+ (filter-map (lambda (meta)
+ (let ((props (props-without-name-or-docstring meta)))
+ (and (pair? props)
+ (cons (meta-low-pc meta) props))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (procprops (find-procprops))
+ (bv (make-bytevector (* (length procprops) procprops-size) 0)))
+ (let lp ((procprops procprops) (pos 0) (relocs '()))
+ (match procprops
+ (()
+ (make-object asm '.guile.procprops
+ bv
+ relocs '()
+ #:type SHT_PROGBITS #:flags 0))
+ (((pc . props) . procprops)
+ (bytevector-u32-set! bv pos pc endianness)
+ (lp procprops
+ (+ pos procprops-size)
+ (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
+ (intern-constant asm props))
+ relocs)))))))
+
(define (link-objects asm)
- (let*-values (((ro rw rw-init) (link-constants asm))
+ (let*-values (;; Link procprops before constants, because it probably
+ ;; interns more constants.
+ ((procprops) (link-procprops asm))
+ ((ro rw rw-init) (link-constants asm))
;; Link text object after constants, so that the
;; constants initializer gets included.
((text) (link-text-object asm))
((dt) (link-dynamic-section asm text 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 shstrtab))))
+ (filter identity
+ (list text ro rw dt symtab strtab arities arities-strtab
+ docstrs docstrs-strtab procprops shstrtab))))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 9522d62..c70f7c5 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -42,8 +42,25 @@
program-debug-info-u32-offset
program-debug-info-u32-offset-end
+ arity?
+ arity-low-pc
+ arity-high-pc
+ arity-nreq
+ arity-nopt
+ arity-has-rest?
+ arity-allow-other-keys?
+ arity-has-keyword-args?
+ arity-is-case-lambda?
+
find-debug-context
- find-program-debug-info))
+ find-program-debug-info
+ arity-arguments-alist
+ find-program-arities
+ program-minimum-arity
+
+ find-program-docstring
+
+ find-program-properties))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@@ -159,3 +176,234 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(elf-symbol-value sym)
(elf-symbol-size sym))))
(else #f)))
+
+(define-record-type <arity>
+ (make-arity context base header-offset)
+ arity?
+ (context arity-context)
+ (base arity-base)
+ (header-offset arity-header-offset))
+
+(define arities-prefix-len 4)
+(define arity-header-len (* 6 4))
+
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+
+(define (arity-low-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
+(define (arity-high-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
+(define (arity-offset* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
+(define (arity-flags* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
+(define (arity-nreq* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
+(define (arity-nopt* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
+
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+
+(define (has-rest? flags) (not (zero? (logand flags (ash 1 0)))))
+(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
+(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
+(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3)))))
+
+(define (arity-nreq arity)
+ (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-nopt arity)
+ (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-flags arity)
+ (arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
+(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags
arity)))
+(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags
arity)))
+(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
+
+(define (arity-load-symbol arity)
+ (let ((elf (debug-context-elf (arity-context arity))))
+ (cond
+ ((elf-section-by-name elf ".guile.arities")
+ =>
+ (lambda (sec)
+ (let* ((strtab (elf-section elf (elf-section-link sec)))
+ (bv (elf-bytes elf))
+ (strtab-offset (elf-section-offset strtab)))
+ (lambda (n)
+ (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
+ (else (error "couldn't find arities section")))))
+
+(define (arity-arguments-alist arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (%load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity) link-offset))
+ (flags (arity-flags* bv header))
+ (nreq (arity-nreq* bv header))
+ (nopt (arity-nopt* bv header)))
+ (define (load-symbol idx)
+ (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (define (load-symbols skip n)
+ (let lp ((n n) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n)
+ (cons (load-symbol (+ skip (1- n))) out)))))
+ (define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+ (define (load-non-immediate idx)
+ (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
+ (and (not (is-case-lambda? flags))
+ `((required . ,(load-symbols 0 nreq))
+ (optional . ,(load-symbols nreq nopt))
+ (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))
+ (keyword . ,(if (has-keyword-args? flags)
+ (load-non-immediate
+ (+ nreq nopt (if (has-rest? flags) 1 0)))
+ '()))
+ (allow-other-keys? . ,(allow-other-keys? flags))))))
+
+(define (find-first-arity context base addr)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context)))
+ (headers-start (+ base arities-prefix-len))
+ (headers-end (+ base (bytevector-u32-native-ref bv base))))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos headers-start))
+ (cond
+ ((>= pos headers-end) #f)
+ ((< text-offset (arity-low-pc* bv pos))
+ (lp (+ pos arity-header-len)))
+ ((< (arity-high-pc* bv pos) text-offset)
+ #f)
+ (else
+ (make-arity context base pos))))))
+
+(define (read-sub-arities context base outer-header-offset)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (headers-end (+ base (bytevector-u32-native-ref bv base)))
+ (low-pc (arity-low-pc* bv outer-header-offset))
+ (high-pc (arity-high-pc* bv outer-header-offset)))
+ (let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
+ (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
+ (lp (+ pos arity-header-len)
+ (cons (make-arity context base pos) out))
+ (reverse out)))))
+
+(define* (find-program-arities addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ ;; FIXME: Handle case-lambda arities.
+ (cond
+ ((not first) '())
+ ((arity-is-case-lambda? first)
+ (read-sub-arities context base (arity-header-offset first)))
+ (else (list first)))))))
+
+(define* (program-minimum-arity addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ (if (arity-is-case-lambda? first)
+ (list 0 0 #t) ;; FIXME: be more precise.
+ (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 docstr-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))))))))))
+
+(define* (find-program-properties addr #:optional
+ (context (find-debug-context addr)))
+ (define (add-name-and-docstring props)
+ (define (maybe-acons k v tail)
+ (if v (acons k v tail) tail))
+ (let ((name (and=> (find-program-debug-info addr context)
+ program-debug-info-name))
+ (docstring (find-program-docstring addr context)))
+ (maybe-acons 'name name
+ (maybe-acons 'documentation docstring props))))
+ (add-name-and-docstring
+ (cond
+ ((elf-section-by-name (debug-context-elf context) ".guile.procprops")
+ => (lambda (sec)
+ ;; struct procprop {
+ ;; uint32_t pc;
+ ;; uint32_t offset;
+ ;; }
+ (define procprop-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))))
+ (define (unpack-scm addr)
+ (pointer->scm (make-pointer addr)))
+ (define (load-non-immediate offset)
+ (unpack-scm (+ (debug-context-base context) offset)))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos start))
+ (cond
+ ((>= pos end) '())
+ ((< text-offset (bytevector-u32-native-ref bv pos))
+ (lp (+ pos procprop-len)))
+ ((> text-offset (bytevector-u32-native-ref bv pos))
+ '())
+ (else
+ (load-non-immediate
+ (bytevector-u32-native-ref bv (+ pos 4))))))))))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index fdfc9a8..267e373 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -54,12 +54,24 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_programs")
-;; This procedure is called by programs.c.
+;; These procedures are called by programs.c.
(define (rtl-program-name program)
(unless (rtl-program? program)
(error "shouldn't get here"))
(and=> (find-program-debug-info (rtl-program-code program))
program-debug-info-name))
+(define (rtl-program-documentation program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (find-program-docstring (rtl-program-code program)))
+(define (rtl-program-minimum-arity program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (program-minimum-arity (rtl-program-code program)))
+(define (rtl-program-properties program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (find-program-properties (rtl-program-code program)))
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
@@ -276,25 +288,38 @@
1+
0)))
+(define (program-arguments-alists prog)
+ (cond
+ ((rtl-program? prog)
+ (map arity-arguments-alist
+ (find-program-arities (rtl-program-code prog))))
+ ((program? prog)
+ (map (lambda (arity) (arity->arguments-alist prog arity))
+ (or (program-arities prog) '())))
+ (else (error "expected a program" prog))))
+
(define (write-program prog port)
- (format port "#<procedure ~a~a>"
- (or (procedure-name prog)
- (and=> (and (program? prog) (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))
- (let ((arities (and (program? prog) (program-arities prog))))
- (if (or (not arities) (null? arities))
- ""
- (string-append
- " " (string-join (map (lambda (a)
- (object->string
- (arguments-alist->lambda-list
- (arity->arguments-alist prog a))))
- arities)
- " | "))))))
+ (define (program-identity-string)
+ (or (procedure-name prog)
+ (and=> (and (program? prog) (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 (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)
+ " | ")))))
+
+ (format port "#<procedure ~a~a>"
+ (program-identity-string) (program-formals-string)))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 8429512..0e38a8e 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -27,10 +27,12 @@
(pass-if (object->string x) (equal? expr x))))
(define (return-constant val)
- (assemble-program `((begin-program foo)
- (assert-nargs-ee/locals 0 1)
+ (assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 1 #f)
(load-constant 0 ,val)
(return 0)
+ (end-arity)
(end-program))))
(define-syntax-rule (assert-constants val ...)
@@ -63,15 +65,19 @@
(with-test-prefix "static procedure"
(assert-equal 42
- (((assemble-program `((begin-program foo)
- (assert-nargs-ee/locals 0 1)
+ (((assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 bar)
(return 0)
+ (end-arity)
(end-program)
- (begin-program bar)
- (assert-nargs-ee/locals 0 1)
+ (begin-program bar
+ ((name . bar)))
+ (begin-standard-arity () 1 #f)
(load-constant 0 42)
(return 0)
+ (end-arity)
(end-program)))))))
(with-test-prefix "loop"
@@ -81,8 +87,9 @@
;; 0: limit
;; 1: n
;; 2: accum
- '((begin-program countdown)
- (assert-nargs-ee/locals 1 2)
+ '((begin-program countdown
+ ((name . countdown)))
+ (begin-standard-arity (x) 3 #f)
(br fix-body)
(label loop-head)
(br-if-= 1 0 out)
@@ -95,6 +102,7 @@
(br loop-head)
(label out)
(return 2)
+ (end-arity)
(end-program)))))
(sumto 1000))))
@@ -105,20 +113,24 @@
;; 0: elt
;; 1: tail
;; 2: head
- '((begin-program make-accum)
- (assert-nargs-ee/locals 0 2)
+ '((begin-program make-accum
+ ((name . make-accum)))
+ (begin-standard-arity () 2 #f)
(load-constant 0 0)
(box 0 0)
(make-closure 1 accum (0))
(return 1)
+ (end-arity)
(end-program)
- (begin-program accum)
- (assert-nargs-ee/locals 1 2)
+ (begin-program accum
+ ((name . accum)))
+ (begin-standard-arity (x) 3 #f)
(free-ref 1 0)
(box-ref 2 1)
(add 2 2 0)
(box-set! 1 2)
(return 2)
+ (end-arity)
(end-program)))))
(let ((accum (make-accum)))
(accum 1)
@@ -129,23 +141,27 @@
(assert-equal 42
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
- (assert-nargs-ee/locals 1 0)
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 1 #f)
(call 1 0 ())
(return 1) ;; MVRA from call
(return 1) ;; RA from call
+ (end-arity)
(end-program)))))
(call (lambda () 42))))
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
- (assert-nargs-ee/locals 1 1)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 2 #f)
(load-constant 1 3)
(call 2 0 (1))
(return 2) ;; MVRA from call
(return 2) ;; RA from call
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -153,20 +169,24 @@
(assert-equal 3
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
- (assert-nargs-ee/locals 1 0)
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 1 #f)
(tail-call 0 0)
+ (end-arity)
(end-program)))))
(call (lambda () 3))))
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
- (assert-nargs-ee/locals 1 1)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 2 #f)
(mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3
(tail-call 1 1)
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -174,17 +194,21 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 1 #f)
(cache-current-module! 0 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
+ (end-arity)
(end-program)
- (begin-program sqrt-trampoline)
- (assert-nargs-ee/locals 1 1)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 2 #f)
(cached-toplevel-ref 1 sqrt-scope sqrt)
(tail-call 1 1)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -195,19 +219,23 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 1 #f)
(cache-current-module! 0 top-incrementor)
(load-static-procedure 0 top-incrementor)
(return 0)
+ (end-arity)
(end-program)
- (begin-program top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 1 #f)
(cached-toplevel-ref 0 top-incrementor *top-val*)
(add1 0 0)
(cached-toplevel-set! 0 top-incrementor *top-val*)
(return/values 0)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
@@ -216,16 +244,20 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
+ (end-arity)
(end-program)
- (begin-program sqrt-trampoline)
- (assert-nargs-ee/locals 1 1)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 2 #f)
(cached-module-ref 1 (guile) #t sqrt)
(tail-call 1 1)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -234,28 +266,33 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 top-incrementor)
(return 0)
+ (end-arity)
(end-program)
- (begin-program top-incrementor)
- (assert-nargs-ee/locals 0 1)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 1 #f)
(cached-module-ref 0 (tests rtl) #f *top-val*)
(add1 0 0)
(cached-module-set! 0 (tests rtl) #f *top-val*)
(return 0)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
(with-test-prefix "debug contexts"
(let ((return-3 (assemble-program
- '((begin-program return-3)
- (assert-nargs-ee/locals 0 1)
+ '((begin-program return-3 ((name . return-3)))
+ (begin-standard-arity () 1 #f)
(load-constant 0 3)
(return 0)
+ (end-arity)
(end-program)))))
(pass-if "program name"
(and=> (find-program-debug-info (rtl-program-code return-3))
@@ -273,8 +310,102 @@
(pass-if-equal 'foo
(procedure-name
(assemble-program
- '((begin-program foo)
- (assert-nargs-ee/locals 0 1)
+ '((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))))))
+
+(with-test-prefix "procedure properties"
+ ;; No properties.
+ (pass-if-equal '()
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ())
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ ;; Name and docstring (which actually don't go out to procprops).
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux"))
+ (procedure-properties
+ (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)))))
+
+ ;; A property that actually needs serialization.
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ ;; Procedure-name still works in this case.
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (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, master, updated. v2.1.0-34-gc4c098e,
Andy Wingo <=