[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl-vm, updated. v2.1.0-17-g083ea2
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl-vm, updated. v2.1.0-17-g083ea26 |
|
Date: |
Thu, 23 May 2013 14:08:45 +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=083ea264cbeec5367a7cc584db43dc4757593f90
The branch, wip-rtl-vm has been updated
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 083ea264cbeec5367a7cc584db43dc4757593f90 (commit)
via 6ea7e853008cfbf4fba1cb270532c306792e632c (commit)
via 3c2c607d14082d637cc2ad7f6038845c2b6cd8ab (commit)
via 9612d840b801be4ab2582728db400a56e391b210 (commit)
via 4bdbdef523a5714052d1d7cac9a6fd6d58b40312 (commit)
via 00fe4a658ffe53a59696ddaeea15b186d5ccb68c (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 (afef28b93e5c9032950806fd17c29e5d4e23772c)
\
N -- N -- N (083ea264cbeec5367a7cc584db43dc4757593f90)
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 083ea264cbeec5367a7cc584db43dc4757593f90
Author: Andy Wingo <address@hidden>
Date: Thu May 23 14:52:29 2013 +0200
add new rtl vm
* libguile/vm-engine.c (rtl_vm_engine): Add new VM.
(vm_engine): Add support for calling RTL programs.
* libguile/tags.h (scm_tc7_rtl_program): New type for procedures that
run on the new VM.
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/goops.c (scm_class_of):
* libguile/print.c (iprin1):
* libguile/procprop.c (scm_i_procedure_arity):
* libguile/procs.c (scm_procedure_p): Add hooks for the new tc7.
* libguile/programs.h:
* libguile/programs.c (scm_make_rtl_program, scm_i_rtl_program_print)
(scm_rtl_program_p, scm_rtl_program_code):
* module/system/vm/program.scm: Add constructors and accessors for the
new "RTL programs".
* libguile/vm.c (rtl_boot_continuation): Define a boot program.
(rtl_apply, rtl_values): New static RTL programs.
* libguile/frames.c (scm_frame_num_locals): Adapt for frames of RTL
programs.
* libguile/frames.h: Add description of RTL frames.
* libguile/Makefile.am: Add rules to generate vm-operations.h.
* .gitignore: Ignore vm-operations.h.
* module/system/vm/instruction.scm:
* libguile/instructions.c:
* libguile/instructions.h: Use vm-operations.h to define enumerated
values for the new RTL opcodes. Define some helper macros to pack and
unpack 32-bit instruction words.
(rtl-instruction-list): New function, exported by (system vm
instruction).
* libguile/objcodes.c: Wire up the bits needed to detect the new RTL
bytecode and load it, as appropriate.
commit 6ea7e853008cfbf4fba1cb270532c306792e632c
Author: Andy Wingo <address@hidden>
Date: Mon May 28 12:25:43 2012 +0200
refactor to resolve_variable
* libguile/vm.c (resolve_variable): Slight refactor.
commit 3c2c607d14082d637cc2ad7f6038845c2b6cd8ab
Author: Andy Wingo <address@hidden>
Date: Thu May 17 18:35:05 2012 +0200
cpp hygiene in the vm
* libguile/vm-engine.c:
* libguile/vm-i-scheme.c:
* libguile/vm-i-system.c: CPP hygiene: the code that #defines, #undefs.
Makes things cleaner given the multiple inclusion dance we do.
commit 9612d840b801be4ab2582728db400a56e391b210
Author: Andy Wingo <address@hidden>
Date: Thu May 23 15:07:37 2013 +0200
pop-continuation abort-continuation hooks pass return vals directly
* doc/ref/api-debug.texi (VM Hooks): Update documentation.
* libguile/vm.c (vm_dispatch_hook):
* libguile/vm-engine.c: Rework the hook machinery so that they can
receive an arbitrary number of arguments. The return and abort
hooks will pass the values that they return to their continuations.
(vm_engine): Adapt to ABORT_CONTINUATION_HOOK change.
* libguile/vm-i-system.c (return, return/values): Adapt to
POP_CONTINUATION_HOOK change.
* module/system/vm/frame.scm (frame-return-values): Remove. The
pop-continuation-hook will pass the values directly.
* module/system/vm/trace.scm (print-return):
(trace-calls-to-procedure):
(trace-calls-in-procedure): Update to receive return values
directly.
* module/system/vm/traps.scm (trap-in-procedure)
(trap-in-dynamic-extent): Ignore return values.
(trap-frame-finish, trap-calls-in-dynamic-extent)
(trap-calls-to-procedure): Pass return values to the handlers.
commit 4bdbdef523a5714052d1d7cac9a6fd6d58b40312
Author: Andy Wingo <address@hidden>
Date: Thu May 23 15:16:20 2013 +0200
Allow vm_engine caller to pass arguments on the stack.
* libguile/vm-engine.c (vm_engine): Allow the caller to pass arguments
on the stack.
commit 00fe4a658ffe53a59696ddaeea15b186d5ccb68c
Author: Andy Wingo <address@hidden>
Date: Fri May 18 12:21:33 2012 +0200
vm-engine: remove register assignments
* libguile/vm-engine.c: Remove the register assignments inherited from
the 1990s. GCC does seem to allocate reasonably on systems with
enough registers (e.g. x86-64), and on system with too few (x86-32) we
disabled manual allocation. Anyway this code was never tested, so
it's better to leave the compiler to do its own thing, until proven
otherwise. Also in the RTL VM we don't need to allocate a register to
the SP, because it isn't accessed as much.
commit ff3968c22d84529666487c2706d904c96440a33d
Author: Andy Wingo <address@hidden>
Date: Fri May 18 12:21:08 2012 +0200
remove some configurability in vm-engine
* libguile/vm-engine.c: Remove the ability for the VM to check object
access, free variable access, and the ip. They were off by default.
Since they will be different in the RTL VM, their presence is just
making things confusing.
* libguile/vm.c: Remove corresponding error helpers.
commit 27c7c630a1f2b3499311c092673f3b131fc5e6e7
Author: Andy Wingo <address@hidden>
Date: Fri May 18 11:57:51 2012 +0200
minor vm-engine cleanups
* libguile/vm-engine.c: Some very minor cleanups: indenting, use of
VM_ASSERT, commenting.
commit 52182d5280cefe18e605b6c40f690badb174ec27
Author: Andy Wingo <address@hidden>
Date: Thu May 17 11:39:35 2012 +0200
remove CONS macro in VM; use scm_cons instead
* libguile/vm-engine.c (CONS): Remove. Callers should use scm_cons
instead, syncing registers beforehand.
(POP_LIST): Adapt, only synchronizing once.
(POP_LIST_MARK, POP_CONS_MARK): Remove unused macros.
* libguile/vm-i-scheme.c (cons):
* libguile/vm-i-system.c (push-rest, bind-rest): Adapt.
commit eac12024830736409112634d3b16ddaaa2bff05b
Author: Andy Wingo <address@hidden>
Date: Fri May 18 11:52:12 2012 +0200
inline vm-engine.h into vm-engine.c
* libguile/vm-engine.h:
* libguile/vm-engine.c: Fold vm-engine.h into vm-engine.c.
* libguile/Makefile.am: Adapt.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-debug.texi | 2 +-
libguile/foreign.c | 16 +--
libguile/numbers.h | 28 ++++
libguile/objcodes.c | 13 +-
libguile/vm-engine.c | 18 +--
libguile/vm.c | 32 ----
module/system/vm/linker.scm | 328 +++++++++++++++++++++++++++----------------
7 files changed, 255 insertions(+), 182 deletions(-)
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 7f936fe..9a592d0 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -850,7 +850,7 @@ 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
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/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)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl-vm, updated. v2.1.0-17-g083ea26,
Andy Wingo <=