[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl-metadata, updated. v2.1.0-31-g
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl-metadata, updated. v2.1.0-31-g3e28111 |
|
Date: |
Mon, 27 May 2013 06:03: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=3e28111698d13a28eb9d6980aafa28fc1dc8de40
The branch, wip-rtl-metadata has been updated
discards 5ee036dd1b5678241110fc3d2f89dcc9d9a2bddf (commit)
discards 1af9d365df254c53d7fa460a1de2f90ca87f4c62 (commit)
discards 98d3ec44cd9fed907b2b3338dded5ebfef055d8c (commit)
discards 6d7e72e84cbf1fd34233fa24e08efcce6266c69b (commit)
discards dcd44cb4f86676ad2b11f1958cb86947e41ee7d6 (commit)
discards f040fb2fdca523634aa3eae9606e7c253200ad59 (commit)
discards 9ca8b770e228fd96d137ac25166df30f93418a0f (commit)
discards 98bc2904868c4698ff88569737e7db98d4c419e5 (commit)
discards e99849d74bd2f8ffc45e42ecfee18fc0428cbc15 (commit)
discards 07d2ec5ed1f197de88d9bc0d438fd9db54714458 (commit)
discards 4b288b514b47a0fad495e940aabfd073a3fc4a56 (commit)
discards 42a0c608f7663988cb96496d655f87dd1777be8d (commit)
discards bc9a144bf570b45e0bb72b2cebe990b62b41b8a4 (commit)
discards af92044544e874febf2a6e967ff27c5b0f1abbc5 (commit)
discards afef28b93e5c9032950806fd17c29e5d4e23772c (commit)
discards 59bce5abd14dde04c5271b2927f0beb7bc9df876 (commit)
discards 98c106fcd4776feb325126367b2dcd60ac7e5a94 (commit)
discards 4dc1be2932b5e739643b157714affdff7f9f0112 (commit)
discards e56d6b6ec3a90d690ade7d9d5a31c953a22add49 (commit)
discards b2b410e1504e9c7c75bfd3ac18bb1c22df43f84f (commit)
discards ae8ae3959a70dbf904edeed84decbf23e7225a4d (commit)
discards f138dc9f282a64be4c1196ed41f761f308f8dc7b (commit)
discards b5545044b1d5653964fc31347bf966a643543352 (commit)
discards 0fd66aac925f0555b7105bef49399d3640d2303a (commit)
discards 2984900f8c9eb8c643e182fdfc61f4b0e3057081 (commit)
discards e70b1e0a4617a6f2c3bd96db4632bce666b3f418 (commit)
discards 8aa1a3173446d53c6a8e0f13f2a015bb963efbd1 (commit)
discards 67123b63fe47a0b18475506e19d4ffaf3e4139df (commit)
discards 62a968d8198e37ef2c834b6fbef42c01cdef25a1 (commit)
via 3e28111698d13a28eb9d6980aafa28fc1dc8de40 (commit)
via 1138086edbbe26faa7eda1e203177b2e7aeed078 (commit)
via 945e121ab6b1cb8f554dece705018aa215150c2b (commit)
via ac7ec77eb5d4cff2b45089e953b6171219211d40 (commit)
via 20c7387bc221a68b977617d5f930e01565b254eb (commit)
via 51b9ebeae5a3550034b909ec1b3c9b4e90dc083c (commit)
via 84402e1b0739ead78370f990b216716812d5b353 (commit)
via 88a8774068c72bd9c53f2ba38ad1d85122223c98 (commit)
via 5ed69f6577f550d0e783a530944a73ada2a75edc (commit)
via f6afe96ba3af91da8b1133fd85aba7600b2e7510 (commit)
via bc258d5fc8ac5d0cda51b8fcf3d15b04adf7cc87 (commit)
via b13043a60cb4909d2c6e443627857f320d86dd1f (commit)
via c70f82d85863005d38de107b7254fd6481f9fba9 (commit)
via 8651d4b3664375e5616d300cb012648ab807cfb3 (commit)
via 50d6c9c8927d28b5248ecbabfd90984bcb5d8521 (commit)
via b782ed0137e93f3bcfcffdbfe2785e6425ef9e32 (commit)
via a0ec1ca11650ad7c16cf1c3261ec1b8665d46ac8 (commit)
via c850a0ff4d0073364612ff5785bda8217ea9ae7f (commit)
via 27319ffaa90dc5789843d8b80842b9a6d36120e1 (commit)
via 8dd6bfa7bb786e802be49fb72ff4f526244d341d (commit)
via ff3968c22d84529666487c2706d904c96440a33d (commit)
via 27c7c630a1f2b3499311c092673f3b131fc5e6e7 (commit)
via 52182d5280cefe18e605b6c40f690badb174ec27 (commit)
via eac12024830736409112634d3b16ddaaa2bff05b (commit)
via fb9600debcb3c754a312818101d8186f2e987d06 (commit)
via e1aee492d7e419b590d627bd70459b90700187ae (commit)
via 0b3b73698c92081ad3c24f40203d8f34e82778a3 (commit)
via d4da9ba9c0ff7013b00c40c18c9dc0c3a409624c (commit)
via 51611a92f42e240cd842cb26efe6c4d5a1282c00 (commit)
via 6756d265ed53d7b107d31746e8455f10e2ecebdd (commit)
via 45037e75277b622334f347ef261ea347eec6e28d (commit)
This update added new revisions after undoing existing revisions. That is
to say, the old revision is not a strict subset of the new revision. This
situation occurs when you --force push a change and generate a repository
containing something like this:
* -- * -- B -- O -- O -- O (5ee036dd1b5678241110fc3d2f89dcc9d9a2bddf)
\
N -- N -- N (3e28111698d13a28eb9d6980aafa28fc1dc8de40)
When this happens we assume that you've already had alert emails for all
of the O revisions, and so we here report only the revisions in the N
branch from the common base, B.
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 3e28111698d13a28eb9d6980aafa28fc1dc8de40
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...
(find-program-docstring): Bugfix: increment by docstr-len.
* test-suite/tests/rtl.test: Add some tests.
commit 1138086edbbe26faa7eda1e203177b2e7aeed078
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 945e121ab6b1cb8f554dece705018aa215150c2b
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 ac7ec77eb5d4cff2b45089e953b6171219211d40
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 20c7387bc221a68b977617d5f930e01565b254eb
Author: Andy Wingo <address@hidden>
Date: Thu May 16 18:56:22 2013 +0200
(system vm debug) can read arity information
* module/system/vm/assembler.scm (write-arity-headers): Fill in the
prefix.
* 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 51b9ebeae5a3550034b909ec1b3c9b4e90dc083c
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 84402e1b0739ead78370f990b216716812d5b353
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 88a8774068c72bd9c53f2ba38ad1d85122223c98
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 5ed69f6577f550d0e783a530944a73ada2a75edc
Author: Andy Wingo <address@hidden>
Date: Tue May 14 10:25:38 2013 +0200
begin-program takes properties alist
* module/system/vm/assembler.scm (check): 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:
doc/ref/api-debug.texi | 6 +-
libguile/foreign.c | 16 +--
libguile/numbers.h | 28 ++++
libguile/objcodes.c | 13 +-
libguile/vm-engine.c | 18 +--
libguile/vm.c | 32 ----
module/system/vm/debug.scm | 9 +-
module/system/vm/linker.scm | 328 +++++++++++++++++++++++++++----------------
test-suite/tests/rtl.test | 24 +++-
9 files changed, 284 insertions(+), 190 deletions(-)
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 7f936fe..4e1b822 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -830,7 +830,7 @@ before applying a procedure in a non-tail context, just
before the
corresponding apply-hook.
@end deffn
address@hidden {Scheme Procedure} vm-pop-continuation-hook vm value ...
address@hidden {Scheme Procedure} vm-pop-continuation-hook vm
The hook that will be fired before returning from a frame.
This hook fires with a variable number of arguments, corresponding to
@@ -850,10 +850,10 @@ hook.
@deffn {Scheme Procedure} vm-abort-continuation-hook vm
The hook that will be called after aborting to a
-prompt. @xref{Prompts}.
+prompt. @xref{Prompts}.
Like the pop-continuation hook, this hook fires with a variable number
-of arguments, corresponding to the values that the returned to the
+of arguments, corresponding to the values that returned to the
continuation.
@end deffn
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 4f5aa58..db8e131 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -65,16 +65,6 @@ SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
/* The cell representing the null pointer. */
static SCM null_pointer;
-#if SIZEOF_VOID_P == 4
-# define scm_to_uintptr scm_to_uint32
-# define scm_from_uintptr scm_from_uint32
-#elif SIZEOF_VOID_P == 8
-# define scm_to_uintptr scm_to_uint64
-# define scm_from_uintptr scm_from_uint64
-#else
-# error unsupported pointer size
-#endif
-
/* Raise a null pointer dereference error. */
static void
@@ -125,7 +115,7 @@ SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
void *c_finalizer;
scm_t_uintptr c_address;
- c_address = scm_to_uintptr (address);
+ c_address = scm_to_uintptr_t (address);
if (SCM_UNBNDP (finalizer))
c_finalizer = NULL;
else
@@ -173,7 +163,7 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0,
{
SCM_VALIDATE_POINTER (1, pointer);
- return scm_from_uintptr ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
}
#undef FUNC_NAME
@@ -324,7 +314,7 @@ void
scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<pointer 0x", port);
- scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
+ scm_uintprint (scm_to_uintptr_t (scm_pointer_address (pointer)), 16, port);
scm_putc_unlocked ('>', port);
}
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 01eb2cf..5cdfbac 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -514,6 +514,34 @@ SCM_API SCM scm_from_mpz (mpz_t rop);
#endif
#endif
+#if SCM_SIZEOF_INTPTR_T == 0
+/* No intptr_t; use size_t functions. */
+#define scm_to_intptr_t scm_to_ssize_t
+#define scm_from_intptr_t scm_from_ssize_t
+#elif SCM_SIZEOF_INTPTR_T == 4
+#define scm_to_intptr_t scm_to_int32
+#define scm_from_intptr_t scm_from_int32
+#elif SCM_SIZEOF_INTPTR_T == 8
+#define scm_to_intptr_t scm_to_int64
+#define scm_from_intptr_t scm_from_int64
+#else
+#error sizeof(intptr_t) is not 4 or 8.
+#endif
+
+#if SCM_SIZEOF_UINTPTR_T == 0
+/* No uintptr_t; use size_t functions. */
+#define scm_to_uintptr_t scm_to_size_t
+#define scm_from_uintptr_t scm_from_size_t
+#elif SCM_SIZEOF_UINTPTR_T == 4
+#define scm_to_uintptr_t scm_to_uint32
+#define scm_from_uintptr_t scm_from_uint32
+#elif SCM_SIZEOF_UINTPTR_T == 8
+#define scm_to_uintptr_t scm_to_uint64
+#define scm_from_uintptr_t scm_from_uint64
+#else
+#error sizeof(uintptr_t) is not 4 or 8.
+#endif
+
/* conversion functions for double */
SCM_API int scm_is_real (SCM val);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 4177c34..734bdde 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -168,12 +168,13 @@ check_elf_header (const Elf_Ehdr *header)
#define ALIGN(offset, alignment) \
((offset + (alignment - 1)) & ~(alignment - 1))
-static unsigned
-sniff_elf_alignment (const char *data, size_t len)
+/* Return the alignment required by the ELF at DATA, of LEN bytes. */
+static size_t
+elf_alignment (const char *data, size_t len)
{
Elf_Ehdr *header;
int i;
- unsigned alignment = 8;
+ size_t alignment = 8;
if (len < sizeof(Elf_Ehdr))
return alignment;
@@ -235,10 +236,10 @@ alloc_aligned (size_t len, unsigned alignment)
static char*
copy_and_align_elf_data (const char *data, size_t len)
{
- unsigned alignment;
+ size_t alignment;
char *copy;
- alignment = sniff_elf_alignment (data, len);
+ alignment = elf_alignment (data, len);
copy = alloc_aligned (len, alignment);
memcpy(copy, data, len);
@@ -718,7 +719,7 @@ register_elf (char *data, size_t len)
static SCM
scm_find_mapped_elf_image (SCM ip)
{
- char *ptr = (char *) scm_to_unsigned_integer (ip, 0, SCM_T_UINTPTR_MAX);
+ char *ptr = (char *) scm_to_uintptr_t (ip);
SCM result;
scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 5af8c00..d070823 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -128,8 +128,6 @@ static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t);
-/* Now we start with the macros that are specific to the old VM. */
-
/* Cache the VM's instruction, stack, and frame pointer in local variables. */
#define CACHE_REGISTER() \
{ \
@@ -318,9 +316,6 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* Cache variables */
struct scm_objcode *bp = NULL; /* program base pointer */
SCM *objects = NULL; /* constant objects */
-#if VM_CHECK_OBJECT
- size_t object_count = 0; /* length of OBJECTS */
-#endif
SCM *stack_limit = vp->stack_limit; /* stack limit address */
scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
@@ -512,11 +507,6 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
#undef VARIABLE_BOUNDP
#undef VARIABLE_REF
#undef VARIABLE_SET
-#undef VM_CHECK_FREE_VARIABLE
-#undef VM_CHECK_OBJECT
-#undef VM_CHECK_FREE_VARIABLE
-#undef VM_CHECK_OBJECT
-#undef VM_CHECK_UNDERFLOW
#undef VM_DEFINE_OP
#undef VM_INSTRUCTION_TO_LABEL
@@ -3569,7 +3559,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
}
+#undef ABORT_CONTINUATION_HOOK
#undef ALIGNED_P
+#undef APPLY_HOOK
#undef ARGS1
#undef ARGS2
#undef BEGIN_DISPATCH_SWITCH
@@ -3591,15 +3583,19 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t
nargs_)
#undef INIT
#undef INUM_MAX
#undef INUM_MIN
-#undef jump_table
#undef LOCAL_REF
#undef LOCAL_SET
#undef NEXT
+#undef NEXT_HOOK
#undef NEXT_JUMP
+#undef POP_CONTINUATION_HOOK
+#undef PUSH_CONTINUATION_HOOK
+#undef RESTORE_CONTINUATION_HOOK
#undef RETURN
#undef RETURN_ONE_VALUE
#undef RETURN_VALUE_LIST
#undef RUN_HOOK
+#undef RUN_HOOK0
#undef SYNC_ALL
#undef SYNC_BEFORE_GC
#undef SYNC_IP
diff --git a/libguile/vm.c b/libguile/vm.c
index ed18108..f431912 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -431,15 +431,6 @@ static void vm_error_no_values (void) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN
SCM_NOINLINE;
static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN
SCM_NOINLINE;
-#if VM_CHECK_IP
-static void vm_error_invalid_address (void) SCM_NORETURN SCM_NOINLINE;
-#endif
-#if VM_CHECK_OBJECT
-static void vm_error_object (void) SCM_NORETURN SCM_NOINLINE;
-#endif
-#if VM_CHECK_FREE_VARIABLES
-static void vm_error_free_variable (void) SCM_NORETURN SCM_NOINLINE;
-#endif
static void
vm_error (const char *msg, SCM arg)
@@ -598,29 +589,6 @@ vm_error_bad_wide_string_length (size_t len)
vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
}
-#ifdef VM_CHECK_IP
-static void
-vm_error_invalid_address (void)
-{
- vm_error ("VM: Invalid program address", SCM_UNDEFINED);
-}
-#endif
-
-#if VM_CHECK_OBJECT
-static void
-vm_error_object ()
-{
- vm_error ("VM: Invalid object table access", SCM_UNDEFINED);
-}
-#endif
-
-#if VM_CHECK_FREE_VARIABLES
-static void
-vm_error_free_variable ()
-{
- vm_error ("VM: Invalid free variable access", SCM_UNDEFINED);
-}
-#endif
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index f48f2cf..15c37f4 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -25,12 +25,9 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
- #:export (<debug-context>
- debug-context-image
- find-debug-context
+ #:export (debug-context-image
u32-offset->addr
- <program-debug-info>
program-debug-info-name
program-debug-info-context
program-debug-info-image
@@ -38,7 +35,6 @@
program-debug-info-addr
program-debug-info-u32-offset
program-debug-info-u32-offset-end
- find-program-debug-info
arity?
arity-low-pc
@@ -49,6 +45,9 @@
arity-allow-other-keys?
arity-has-keyword-args?
arity-is-case-lambda?
+
+ find-debug-context
+ find-program-debug-info
arity-arguments-alist
find-program-arities
program-minimum-arity
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
index 2baddb0..a5d43f2 100644
--- a/module/system/vm/linker.scm
+++ b/module/system/vm/linker.scm
@@ -90,6 +90,19 @@
link-elf))
+(define-syntax fold-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ proc list seed ...)
+ (with-syntax (((s ...) (generate-temporaries #'(seed ...))))
+ #'(let ((p proc))
+ (let lp ((l list) (s seed) ...)
+ (match l
+ (() (values s ...))
+ ((elt . l)
+ (call-with-values (lambda () (p elt s ...))
+ (lambda (s ...) (lp l s ...))))))))))))
+
;; A relocation records a reference to a symbol. When the symbol is
;; resolved to an address, the reloc location will be updated to point
;; to the address.
@@ -127,25 +140,36 @@
(relocs linker-object-relocs)
(symbols linker-object-symbols))
-;; Hide a symbol to the beginning of the section in the symbols.
(define (make-linker-object section bv relocs symbols)
+ "Create a linker object with the @code{<elf-section>} header
address@hidden, bytevector contents @var{bv}, list of linker relocations
address@hidden, and list of linker symbols @var{symbols}."
(%make-linker-object section bv relocs
+ ;; Hide a symbol to the beginning of the section
+ ;; in the symbols.
(cons (make-linker-symbol (gensym "*section*") 0)
symbols)))
(define (linker-object-section-symbol object)
+ "Return the linker symbol corresponding to the start of this section."
(car (linker-object-symbols object)))
(define (linker-object-symbols* object)
+ "Return the linker symbols defined by the user for this this section."
(cdr (linker-object-symbols object)))
(define (make-string-table)
+ "Return a functional string table with one entry: the empty string."
'(("" 0 #vu8())))
(define (string-table-length table)
+ "Return the number of bytes needed for the string table @var{table}."
(let ((last (car table)))
;; The + 1 is for the trailing NUL byte.
(+ (cadr last) (bytevector-length (caddr last)) 1)))
(define (string-table-intern table str)
+ "Add @var{str} to the string table @var{table}. Yields two values: a
+possibly newly allocated string table, and the byte index of the string
+in that table."
(cond
((assoc str table)
=> (lambda (ent)
@@ -157,6 +181,8 @@
next)))))
(define (link-string-table table)
+ "Link the functional string table @var{table} into a sequence of
+bytes, suitable for use as the contents of an ELF string table section."
(let ((out (make-bytevector (string-table-length table) 0)))
(for-each
(lambda (ent)
@@ -166,6 +192,10 @@
out))
(define (segment-kind section)
+ "Return the type of segment needed to store @var{section}, as a pair.
+The car is the @code{PT_} segment type, or @code{#f} if the section
+doesn't need to be present in a loadable segment. The cdr is a bitfield
+of associated @code{PF_} permissions."
(let ((flags (elf-section-flags section)))
(cons (cond
((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
@@ -183,34 +213,42 @@
PF_W)))))
(define (count-segments objects)
+ "Return the total number of segments needed to represent the linker
+objects in @var{objects}, including the segment needed for the ELF
+header and segment table."
(length
- (fold1 (lambda (object kinds)
- (let ((kind (segment-kind (linker-object-section object))))
- (if (and (car kind) (not (member kind kinds)))
- (cons kind kinds)
- kinds)))
- objects
- ;; We know there will be at least one segment, containing at
- ;; least the header and segment table.
- (list (cons PT_LOAD PF_R)))))
+ (fold-values (lambda (object kinds)
+ (let ((kind (segment-kind (linker-object-section object))))
+ (if (and (car kind) (not (member kind kinds)))
+ (cons kind kinds)
+ kinds)))
+ objects
+ ;; We know there will be at least one segment,
+ ;; containing at least the header and segment table.
+ (list (cons PT_LOAD PF_R)))))
(define (group-by-cars ls)
- (let lp ((in ls) (k #f) (group #f) (out '()))
- (cond
- ((null? in)
- (reverse!
- (if group
- (cons (cons k (reverse! group)) out)
- out)))
- ((and group (equal? k (caar in)))
- (lp (cdr in) k (cons (cdar in) group) out))
- (else
- (lp (cdr in) (caar in) (list (cdar in))
- (if group
- (cons (cons k (reverse! group)) out)
- out))))))
+ (let lp ((ls ls) (k #f) (group #f) (out '()))
+ (match ls
+ (()
+ (reverse!
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))
+ (((k* . v) . ls)
+ (if (and group (equal? k k*))
+ (lp ls k (cons v group) out)
+ (lp ls k* (list v)
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))))))
(define (collate-objects-into-segments objects)
+ "Given the list of linker objects @var{objects}, group them into
+contiguous ELF segments of the same type and flags. The result is an
+alist that maps segment types to lists of linker objects. See
address@hidden for a description of segment types. Within a
+segment, the order of the linker objects is preserved."
(group-by-cars
(stable-sort!
(map (lambda (o)
@@ -251,20 +289,9 @@
(+ address
(modulo (- alignment (modulo address alignment)) alignment))))
-(define (fold1 proc ls s0)
- (let lp ((ls ls) (s0 s0))
- (if (null? ls)
- s0
- (lp (cdr ls) (proc (car ls) s0)))))
-
-(define (fold3 proc ls s0 s1 s2)
- (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2))
- (if (null? ls)
- (values s0 s1 s2)
- (receive (s0 s1 s2) (proc (car ls) s0 s1 s2)
- (lp (cdr ls) s0 s1 s2)))))
-
(define (relocate-section-header sec addr)
+ "Return a new section header, just like @var{sec} but with its
address@hidden and @code{offset} set to @var{addr}."
(make-elf-section #:index (elf-section-index sec)
#:name (elf-section-name sec)
#:type (elf-section-type sec)
@@ -279,42 +306,57 @@
(define *page-size* 4096)
-;; Adds object symbols to global table, relocating them from object
-;; address space to memory address space.
(define (add-symbols symbols offset symtab)
- (fold1 (lambda (symbol symtab)
- (let ((name (linker-symbol-name symbol))
- (addr (linker-symbol-address symbol)))
- (when (vhash-assq name symtab)
- (error "duplicate symbol" name))
- (vhash-consq name (make-linker-symbol name (+ addr offset))
symtab)))
- symbols
- symtab))
-
-(define (alloc-objects write-segment-header!
- phidx type flags objects addr symtab alignment)
- (let* ((alignment (fold1 (lambda (o alignment)
- (lcm (elf-section-addralign
- (linker-object-section o))
- alignment))
- objects
- alignment))
+ "Add @var{symbols} to the symbol table @var{symtab}, relocating them
+from object address space to memory address space. Returns a new symbol
+table."
+ (fold-values
+ (lambda (symbol symtab)
+ (let ((name (linker-symbol-name symbol))
+ (addr (linker-symbol-address symbol)))
+ (when (vhash-assq name symtab)
+ (error "duplicate symbol" name))
+ (vhash-consq name (make-linker-symbol name (+ addr offset)) symtab)))
+ symbols
+ symtab))
+
+(define (allocate-segment write-segment-header!
+ phidx type flags objects addr symtab alignment)
+ "Given a list of linker objects that should go in a segment, the type
+and flags that the segment should have, and the address at which the
+segment should start, compute the positions that each object should have
+in the segment.
+
+Returns three values: the address of the next byte after the segment, a
+list of relocated objects, and the symbol table. The symbol table is
+the same as @var{symtab}, augmented with the symbols defined in
address@hidden, relocated to their positions in the image.
+
+In what is something of a quirky interface, this routine also patches up
+the segment table using @code{write-segment-header!}."
+ (let* ((alignment (fold-values (lambda (o alignment)
+ (lcm (elf-section-addralign
+ (linker-object-section o))
+ alignment))
+ objects
+ alignment))
(addr (align addr alignment)))
(receive (objects endaddr symtab)
- (fold3 (lambda (o out addr symtab)
- (let* ((section (linker-object-section o))
- (addr (align addr (elf-section-addralign section))))
- (values
- (cons (make-linker-object
- (relocate-section-header section addr)
- (linker-object-bv o)
- (linker-object-relocs o)
- (linker-object-symbols o))
- out)
- (+ addr (elf-section-size section))
- (add-symbols (linker-object-symbols o) addr symtab))))
- objects
- '() addr symtab)
+ (fold-values
+ (lambda (o out addr symtab)
+ (let* ((section (linker-object-section o))
+ (addr (align addr (elf-section-addralign section))))
+ (values
+ (cons (make-linker-object
+ (relocate-section-header section addr)
+ (linker-object-bv o)
+ (linker-object-relocs o)
+ (linker-object-symbols o))
+ out)
+ (+ addr (elf-section-size section))
+ (add-symbols (linker-object-symbols o) addr symtab))))
+ objects
+ '() addr symtab)
(when type
(write-segment-header!
(make-elf-segment #:index phidx #:type type
@@ -325,45 +367,58 @@
(reverse objects)
symtab))))
-(define (process-reloc reloc bv file-offset mem-offset symtab endianness)
- (let ((ent (vhash-assq (linker-reloc-symbol reloc) symtab)))
- (unless ent
- (error "Undefined symbol" (linker-reloc-symbol reloc)))
- (let* ((file-loc (+ (linker-reloc-loc reloc) file-offset))
- (mem-loc (+ (linker-reloc-loc reloc) mem-offset))
- (addr (linker-symbol-address (cdr ent))))
- (case (linker-reloc-type reloc)
- ((rel32/4)
- (let ((diff (- addr mem-loc)))
- (unless (zero? (modulo diff 4))
- (error "Bad offset" reloc symbol mem-offset))
- (bytevector-s32-set! bv file-loc
- (+ (/ diff 4) (linker-reloc-addend reloc))
- endianness)))
- ((abs32/1)
- (bytevector-u32-set! bv file-loc addr endianness))
- ((abs64/1)
- (bytevector-u64-set! bv file-loc addr endianness))
- (else
- (error "bad reloc type" reloc))))))
+(define (process-reloc reloc bv section-offset symtab endianness)
+ "Process a relocation. Given that a section containing @var{reloc}
+was just written into the image @var{bv} at offset @var{section-offset},
+fix it up so that its reference points to the correct position of its
+symbol, as present in @var{symtab}."
+ (match (vhash-assq (linker-reloc-symbol reloc) symtab)
+ (#f
+ (error "Undefined symbol" (linker-reloc-symbol reloc)))
+ ((name . symbol)
+ ;; The reloc was written at LOC bytes after SECTION-OFFSET.
+ (let* ((offset (+ (linker-reloc-loc reloc) section-offset))
+ (target (linker-symbol-address symbol)))
+ (case (linker-reloc-type reloc)
+ ((rel32/4)
+ (let ((diff (- target offset)))
+ (unless (zero? (modulo diff 4))
+ (error "Bad offset" reloc symbol offset))
+ (bytevector-s32-set! bv offset
+ (+ (/ diff 4) (linker-reloc-addend reloc))
+ endianness)))
+ ((abs32/1)
+ (bytevector-u32-set! bv offset target endianness))
+ ((abs64/1)
+ (bytevector-u64-set! bv offset target endianness))
+ (else
+ (error "bad reloc type" reloc)))))))
(define (write-linker-object bv o symtab endianness)
+ "Write the bytevector for the section wrapped by the linker object
address@hidden into the image @var{bv}. The section header in @var{o} should
+already be relocated its final position in the image. Any relocations
+in the section will be processed to point to the correct symbol
+locations, as given in @var{symtab}."
(let* ((section (linker-object-section o))
(offset (elf-section-offset section))
- (addr (elf-section-addr section))
(len (elf-section-size section))
(bytes (linker-object-bv o))
(relocs (linker-object-relocs o)))
+ (unless (= offset (elf-section-addr section))
+ (error "offset != addr" section))
(if (not (= (elf-section-type section) SHT_NOBITS))
(begin
(if (not (= len (bytevector-length bytes)))
(error "unexpected length" section bytes))
(bytevector-copy! bytes 0 bv offset len)
(for-each (lambda (reloc)
- (process-reloc reloc bv offset addr symtab endianness))
+ (process-reloc reloc bv offset symtab endianness))
relocs)))))
(define (find-shstrndx objects)
+ "Find the section name string table in @var{objects}, and return its
+section index."
(or-map (lambda (object)
(let* ((section (linker-object-section object))
(bv (linker-object-bv object))
@@ -375,6 +430,21 @@
objects))
(define (add-elf-objects objects endianness word-size)
+ "Given the list of linker objects supplied by the user, add linker
+objects corresponding to parts of the ELF file: the null object, the ELF
+header, and the section table.
+
+Both of these internal objects include relocs, allowing their
+inter-object references to be patched up when the final image allocation
+is known. There is special support for patching up the segment table,
+however. Because the segment table needs to know the segment sizes,
+which is the difference between two symbols in image space, and there is
+no reloc kind that is the difference between two symbols, we make a hack
+and return a closure that patches up segment table entries. It seems to
+work.
+
+Returns two values: the procedure to patch the segment table, and the
+list of objects, augmented with objects for the special ELF sections."
(define phoff (elf-header-len word-size))
(define phentsize (elf-program-header-len word-size))
(define shentsize (elf-section-header-len word-size))
@@ -440,14 +510,15 @@
0
section-label)
relocs))))
- (let ((relocs (fold1 (lambda (object relocs)
- (write-and-reloc
- (linker-symbol-name
- (linker-object-section-symbol object))
- (linker-object-section object)
- relocs))
- objects
- (write-and-reloc shoff-label section-table '()))))
+ (let ((relocs (fold-values
+ (lambda (object relocs)
+ (write-and-reloc
+ (linker-symbol-name
+ (linker-object-section-symbol object))
+ (linker-object-section object)
+ relocs))
+ objects
+ (write-and-reloc shoff-label section-table '()))))
(%make-linker-object section-table bv relocs
(list (make-linker-symbol shoff-label 0))))))
@@ -479,14 +550,19 @@
(values write-segment-header! objects)))
-;; objects ::= list of <linker-object>
-;;
-;; => 3 values:
-;; file size
-;; objects with allocated memory address and file offset
-;; symbol table
-;;
(define (allocate-elf objects page-aligned? endianness word-size)
+ "Lay out @var{objects} into an ELF image, computing the size of the
+file, the positions of the objects, and the global symbol table.
+
+If @var{page-aligned?} is true, read-only and writable data are
+separated so that only those writable parts of the image need be mapped
+with writable permissions. This makes the resulting image larger. It
+is more suitable to situations where you would write a file out to disk
+and read it in with mmap. Otherwise if @var{page-aligned?} is false,
+sections default to 8-byte alignment.
+
+Returns three values: the total image size, a list of objects with
+relocated headers, and the global symbol table."
(receive (write-segment-header! objects)
(add-elf-objects objects endianness word-size)
(let lp ((seglists (collate-objects-into-segments objects))
@@ -498,18 +574,19 @@
(match seglists
((((type . flags) objs-in ...) seglists ...)
(receive (addr objs-out symtab)
- (alloc-objects write-segment-header!
- phidx type flags objs-in addr symtab
- (if (and page-aligned?
- (not (= flags prev-flags))
- ;; Allow sections that are not in
- ;; loadable segments to share pages
- ;; with PF_R segments.
- (not (and (not type) (= PF_R
prev-flags))))
- *page-size*
- 8))
+ (allocate-segment
+ write-segment-header!
+ phidx type flags objs-in addr symtab
+ (if (and page-aligned?
+ (not (= flags prev-flags))
+ ;; Allow sections that are not in
+ ;; loadable segments to share pages
+ ;; with PF_R segments.
+ (not (and (not type) (= PF_R prev-flags))))
+ *page-size*
+ 8))
(lp seglists
- (fold1 cons objs-out objects)
+ (fold-values cons objs-out objects)
(if type (1+ phidx) phidx)
addr
symtab
@@ -520,6 +597,9 @@
symtab))))))
(define (check-section-numbers objects)
+ "Verify that taken as a whole, that all objects have distinct,
+contiguous section numbers, starting from 1. (Section 0 is the null
+section.)"
(let* ((nsections (1+ (length objects))) ; 1+ for initial NULL section.
(sections (make-vector nsections #f)))
(for-each (lambda (object)
@@ -543,6 +623,16 @@
(page-aligned? #t)
(endianness (target-endianness))
(word-size (target-word-size)))
+ "Create an ELF image from the linker objects, @var{objects}.
+
+If @var{page-aligned?} is true, read-only and writable data are
+separated so that only those writable parts of the image need be mapped
+with writable permissions. This is suitable for situations where you
+would write a file out to disk and read it in with @code{mmap}.
+Otherwise if @var{page-aligned?} is false, sections default to 8-byte
+alignment.
+
+Returns a bytevector."
(check-section-numbers objects)
(receive (size objects symtab)
(allocate-elf objects page-aligned? endianness word-size)
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 6e377ba..0e38a8e 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -18,7 +18,9 @@
(define-module (tests rtl)
#:use-module (test-suite lib)
- #:use-module (system vm assembler))
+ #:use-module (system vm assembler)
+ #:use-module (system vm program)
+ #:use-module (system vm debug))
(define-syntax-rule (assert-equal val expr)
(let ((x val))
@@ -284,6 +286,26 @@
((make-top-incrementor))
*top-val*))))
+(with-test-prefix "debug contexts"
+ (let ((return-3 (assemble-program
+ '((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))
+ (lambda (pdi)
+ (equal? (program-debug-info-name pdi)
+ 'return-3))))
+
+ (pass-if "program address"
+ (and=> (find-program-debug-info (rtl-program-code return-3))
+ (lambda (pdi)
+ (equal? (program-debug-info-addr pdi)
+ (rtl-program-code return-3)))))))
+
(with-test-prefix "procedure name"
(pass-if-equal 'foo
(procedure-name
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl-metadata, updated. v2.1.0-31-g3e28111,
Andy Wingo <=