More precise stack marking via .guile.frame-maps section

* module/language/cps/slot-allocation.scm (lookup-dead-slot-map)
  (allocate-slots): For each non-tail call in a function, compute the
  set of slots that are dead after the function has begun the call.

* module/language/cps/compile-bytecode.scm (compile-fun): Emit the
  `dead-slot-map' macro instruction for non-tail calls.

* module/system/vm/assembler.scm (<asm>): Add `dead-slot-maps' member.
  (dead-slot-map): New macro-instruction.
  (link-frame-maps, link-dynamic-section, link-objects): Write dead
  slots information into .guile.frame-maps sections of ELF files.
* module/system/vm/elf.scm (DT_GUILE_FRAME_MAPS): New definition.

* libguile/loader.h:
* libguile/loader.c (DT_GUILE_FRAME_MAPS, process_dynamic_segment):
  (load_thunk_from_memory, register_elf): Arrange to parse
  DT_GUILE_FRAME_MAPS out of the dynamic section.
  (find_mapped_elf_image_unlocked, find_mapped_elf_image): New helpers.
  (scm_find_mapped_elf_image): Refactor.
  (scm_find_dead_slot_map_unlocked): New interface.

* libguile/vm.c (scm_i_vm_mark_stack): Mark the hottest frame
  conservatively, as before.  Otherwise use the dead slots map, if
  available, to avoid marking data that isn't live.

7 files changed, 291 insertions, 74 deletions

diff --git a/libguile/loader.c b/libguile/loader.c
index ce5699167..83c5bb56c 100644
--- a/libguile/loader.c
+++ b/libguile/loader.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 2001, 2009, 2010, 2011, 2012
- *    2013 Free Software Foundation, Inc.
+ *    2013, 2014 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
@@ -34,6 +34,7 @@
 #include <assert.h>
 #include <alignof.h>
 #include <byteswap.h>
+#include <verify.h>
 
 #include <full-read.h>
 
@@ -69,6 +70,7 @@
                                            roots */
 #define DT_GUILE_ENTRY      0x37146002  /* Address of entry thunk */
 #define DT_GUILE_VM_VERSION 0x37146003  /* Bytecode version */
+#define DT_GUILE_FRAME_MAPS 0x37146004  /* Frame maps */
 #define DT_HIGUILE          0x37146fff  /* End of Guile-specific */
 
 #ifdef WORDS_BIGENDIAN
@@ -77,7 +79,7 @@
 #define ELFDATA ELFDATA2LSB
 #endif
 
-static void register_elf (char *data, size_t len);
+static void register_elf (char *data, size_t len, char *frame_maps);
 
 enum bytecode_kind
   {
@@ -244,12 +246,12 @@ segment_flags_to_prot (Elf_Word flags)
 
 static char*
 process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
-                         SCM *init_out, SCM *entry_out)
+                         SCM *init_out, SCM *entry_out, char **frame_maps_out)
 {
   char *dyn_addr = base + dyn_phdr->p_vaddr;
   Elf_Dyn *dyn = (Elf_Dyn *) dyn_addr;
   size_t i, dyn_size = dyn_phdr->p_memsz / sizeof (Elf_Dyn);
-  char *init = 0, *gc_root = 0, *entry = 0;
+  char *init = 0, *gc_root = 0, *entry = 0, *frame_maps = 0;
   scm_t_ptrdiff gc_root_size = 0;
   enum bytecode_kind bytecode_kind = BYTECODE_KIND_NONE;
 
@@ -303,6 +305,11 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
               }
             break;
           }
+        case DT_GUILE_FRAME_MAPS:
+          if (frame_maps)
+            return "duplicate DT_GUILE_FRAME_MAPS";
+          frame_maps = base + dyn[i].d_un.d_val;
+          break;
         }
     }
 
@@ -327,6 +334,8 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
 
   *init_out = init ? pointer_to_procedure (bytecode_kind, init) : SCM_BOOL_F;
   *entry_out = pointer_to_procedure (bytecode_kind, entry);
+  *frame_maps_out = frame_maps;
+
   return NULL;
 }
 
@@ -343,6 +352,7 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only)
   int i;
   int dynamic_segment = -1;
   SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
+  char *frame_maps = 0;
 
   if (len < sizeof *header)
     ABORT ("object file too small");
@@ -427,13 +437,13 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only)
     }
 
   if ((err_msg = process_dynamic_segment (data, &ph[dynamic_segment],
-                                          &init, &entry)))
+                                          &init, &entry, &frame_maps)))
     goto cleanup;
 
   if (scm_is_true (init))
     scm_call_0 (init);
 
-  register_elf (data, len);
+  register_elf (data, len, frame_maps);
 
   /* Finally!  Return the thunk.  */
   return entry;
@@ -568,6 +578,7 @@ struct mapped_elf_image
 {
   char *start;
   char *end;
+  char *frame_maps;
 };
 
 static struct mapped_elf_image *mapped_elf_images = NULL;
@@ -594,7 +605,7 @@ find_mapped_elf_insertion_index (char *ptr)
 }
 
 static void
-register_elf (char *data, size_t len)
+register_elf (char *data, size_t len, char *frame_maps)
 {
   scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
   {
@@ -619,6 +630,7 @@ register_elf (char *data, size_t len)
           {
             mapped_elf_images[n].start = prev[n].start;
             mapped_elf_images[n].end = prev[n].end;
+            mapped_elf_images[n].frame_maps = prev[n].frame_maps;
           }
       }
 
@@ -628,37 +640,49 @@ register_elf (char *data, size_t len)
 
       for (end = mapped_elf_images_count; n < end; end--)
         {
-          mapped_elf_images[end].start = mapped_elf_images[end - 1].start;
-          mapped_elf_images[end].end = mapped_elf_images[end - 1].end;
+          const struct mapped_elf_image *prev = &mapped_elf_images[end - 1];
+          mapped_elf_images[end].start = prev->start;
+          mapped_elf_images[end].end = prev->end;
+          mapped_elf_images[end].frame_maps = prev->frame_maps;
         }
       mapped_elf_images_count++;
 
       mapped_elf_images[n].start = data;
       mapped_elf_images[n].end = data + len;
+      mapped_elf_images[n].frame_maps = frame_maps;
     }
   }
   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 }
 
-static SCM
-scm_find_mapped_elf_image (SCM ip)
+static struct mapped_elf_image *
+find_mapped_elf_image_unlocked (char *ptr)
 {
-  char *ptr = (char *) scm_to_uintptr_t (ip);
-  SCM result;
+  size_t n = find_mapped_elf_insertion_index ((char *) ptr);
+
+  if (n < mapped_elf_images_count
+      && mapped_elf_images[n].start <= ptr
+      && ptr < mapped_elf_images[n].end)
+    return &mapped_elf_images[n];
+
+  return NULL;
+}
+
+static int
+find_mapped_elf_image (char *ptr, struct mapped_elf_image *image)
+{
+  int result;
 
   scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
   {
-    size_t n = find_mapped_elf_insertion_index ((char *) ptr);
-    if (n < mapped_elf_images_count
-        && mapped_elf_images[n].start <= ptr
-        && ptr < mapped_elf_images[n].end)
+    struct mapped_elf_image *img = find_mapped_elf_image_unlocked (ptr);
+    if (img)
       {
-        signed char *data = (signed char *) mapped_elf_images[n].start;
-        size_t len = mapped_elf_images[n].end - mapped_elf_images[n].start;
-        result = scm_c_take_gc_bytevector (data, len, SCM_BOOL_F);
+        memcpy (image, img, sizeof (*image));
+        result = 1;
       }
     else
-      result = SCM_BOOL_F;
+      result = 0;
   }
   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 
@@ -666,6 +690,22 @@ scm_find_mapped_elf_image (SCM ip)
 }
 
 static SCM
+scm_find_mapped_elf_image (SCM ip)
+{
+  struct mapped_elf_image image;
+
+  if (find_mapped_elf_image ((char *) scm_to_uintptr_t (ip), &image))
+    {
+      signed char *data = (signed char *) image.start;
+      size_t len = image.end - image.start;
+
+      return scm_c_take_gc_bytevector (data, len, SCM_BOOL_F);
+    }
+
+  return SCM_BOOL_F;
+}
+
+static SCM
 scm_all_mapped_elf_images (void)
 {
   SCM result = SCM_EOL;
@@ -686,6 +726,64 @@ scm_all_mapped_elf_images (void)
   return result;
 }
 
+struct frame_map_prefix
+{
+  scm_t_uint32 text_offset;
+  scm_t_uint32 maps_offset;
+};
+
+struct frame_map_header
+{
+  scm_t_uint32 addr;
+  scm_t_uint32 map_offset;
+};
+
+verify (sizeof (struct frame_map_prefix) == 8);
+verify (sizeof (struct frame_map_header) == 8);
+
+const scm_t_uint8 *
+scm_find_dead_slot_map_unlocked (const scm_t_uint32 *ip)
+{
+  struct mapped_elf_image *image;
+  char *base;
+  struct frame_map_prefix *prefix;
+  struct frame_map_header *headers;
+  scm_t_uintptr addr = (scm_t_uintptr) ip;
+  size_t start, end;
+
+  image = find_mapped_elf_image_unlocked ((char *) ip);
+  if (!image || !image->frame_maps)
+    return NULL;
+
+  base = image->frame_maps;
+  prefix = (struct frame_map_prefix *) base;
+  headers = (struct frame_map_header *) (base + sizeof (*prefix));
+
+  if (addr < ((scm_t_uintptr) image->start) + prefix->text_offset)
+    return NULL;
+  addr -= ((scm_t_uintptr) image->start) + prefix->text_offset;
+
+  start = 0;
+  end = (prefix->maps_offset - sizeof (*prefix)) / sizeof (*headers);
+
+  if (end == 0 || addr > headers[end - 1].addr)
+    return NULL;
+
+  while (start < end)
+    {
+      size_t n = start + (end - start) / 2;
+
+      if (addr == headers[n].addr)
+        return (const scm_t_uint8*) (base + headers[n].map_offset);
+      else if (addr < headers[n].addr)
+        end = n;
+      else
+        start = n + 1;
+    }
+
+  return NULL;
+}
+
 
 void
 scm_bootstrap_loader (void)
diff --git a/libguile/loader.h b/libguile/loader.h
index 194faff22..6fd950279 100644
--- a/libguile/loader.h
+++ b/libguile/loader.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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
@@ -24,6 +24,9 @@
 SCM_API SCM scm_load_thunk_from_file (SCM filename);
 SCM_API SCM scm_load_thunk_from_memory (SCM bv);
 
+SCM_INTERNAL const scm_t_uint8 *
+scm_find_dead_slot_map_unlocked (const scm_t_uint32 *ip);
+
 SCM_INTERNAL void scm_bootstrap_loader (void);
 SCM_INTERNAL void scm_init_loader (void);
 
diff --git a/libguile/vm.c b/libguile/vm.c
index 5a6958900..43ade82f3 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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
@@ -794,6 +794,12 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
                      struct GC_ms_entry *mark_stack_limit)
 {
   SCM *sp, *fp;
+  /* The first frame will be marked conservatively (without a dead
+     slot map).  This is because GC can happen at any point within the
+     hottest activation, due to multiple threads or per-instruction
+     hooks, and providing dead slot maps for all points in a program
+     would take a prohibitive amount of space.  */
+  const scm_t_uint8 *dead_slots = NULL;
 
   for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp))
     {
@@ -801,11 +807,32 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
         {
           SCM elt = *sp;
           if (SCM_NIMP (elt))
-            mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word *) elt,
-                                               mark_stack_ptr, mark_stack_limit,
-                                               NULL);
+            {
+              if (dead_slots)
+                {
+                  size_t slot = sp - &SCM_FRAME_LOCAL (fp, 0);
+                  if (dead_slots[slot / 8U] & (1U << (slot % 8U)))
+                    {
+                      /* This value may become dead as a result of GC,
+                         so we can't just leave it on the stack.  */
+                      *sp = SCM_UNBOUND;
+                      continue;
+                    }
+                }
+
+              mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word *) elt,
+                                                 mark_stack_ptr,
+                                                 mark_stack_limit,
+                                                 NULL);
+            }
         }
       sp = SCM_FRAME_PREVIOUS_SP (fp);
+      /* Inner frames may have a dead slots map for precise marking.
+         Note that there may be other reasons to not have a dead slots
+         map, e.g. if all of the frame's slots below the callee frame
+         are live.  */
+      dead_slots =
+        scm_find_dead_slot_map_unlocked (SCM_FRAME_RETURN_ADDRESS (fp));
     }
 
   return mark_stack_ptr;
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index e5c6ef86b..adc51594e 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -452,6 +452,8 @@
                      (lookup-parallel-moves label allocation))
            (for-each maybe-load-constant arg-slots (cons proc args))
            (emit-call asm proc-slot nargs)
+           (emit-dead-slot-map asm proc-slot
+                               (lookup-dead-slot-map label allocation))
            (cond
             ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
                   (match (lookup-parallel-moves k allocation)
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 946257b13..a4e5129f4 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -36,7 +36,8 @@
             lookup-maybe-constant-value
             lookup-nlocals
             lookup-call-proc-slot
-            lookup-parallel-moves))
+            lookup-parallel-moves
+            lookup-dead-slot-map))
 
 (define-record-type $allocation
   (make-allocation dfa slots
@@ -68,32 +69,34 @@
   ;; record the way that functions are passed values, and how their
   ;; return values are rebound to local variables.
   ;;
-  ;; A call allocation contains two pieces of information: the call's
-  ;; /proc slot/, and a set of /parallel moves/.  The proc slot
-  ;; indicates the slot of a procedure in a procedure call, or where the
-  ;; procedure would be in a multiple-value return.  The parallel moves
-  ;; shuffle locals into position for a call, or shuffle returned values
-  ;; back into place.  Though they use the same slot, moves for a call
-  ;; are called "call moves", and moves to handle a return are "return
-  ;; moves".
+  ;; A call allocation contains three pieces of information: the call's
+  ;; /proc slot/, a set of /parallel moves/, and a /dead slot map/.  The
+  ;; proc slot indicates the slot of a procedure in a procedure call, or
+  ;; where the procedure would be in a multiple-value return.  The
+  ;; parallel moves shuffle locals into position for a call, or shuffle
+  ;; returned values back into place.  Though they use the same slot,
+  ;; moves for a call are called "call moves", and moves to handle a
+  ;; return are "return moves".  The dead slot map indicates, for a
+  ;; call, what slots should be ignored by GC when marking the frame.
   ;;
   ;; $kreceive continuations record a proc slot and a set of return moves
   ;; to adapt multiple values from the stack to local variables.
   ;;
   ;; Tail calls record arg moves, but no proc slot.
   ;;
-  ;; Non-tail calls record arg moves and a call slot.  Multiple-valued
-  ;; returns will have an associated $kreceive continuation, which records
-  ;; the same proc slot, but has return moves.
+  ;; Non-tail calls record arg moves, a call slot, and a dead slot map.
+  ;; Multiple-valued returns will have an associated $kreceive
+  ;; continuation, which records the same proc slot, but has return
+  ;; moves and no dead slot map.
   ;;
   ;; $prompt handlers are $kreceive continuations like any other.
   ;;
   ;; $values expressions with more than 1 value record moves but have no
-  ;; proc slot.
+  ;; proc slot or dead slot map.
   ;;
   ;; A set of moves is expressed as an ordered list of (SRC . DST)
   ;; moves, where SRC and DST are slots.  This may involve a temporary
-  ;; variable.
+  ;; variable.  A dead slot map is a bitfield, as an integer.
   ;;
   (call-allocations allocation-call-allocations)
 
@@ -102,10 +105,11 @@
   (nlocals allocation-nlocals))
 
 (define-record-type $call-allocation
-  (make-call-allocation proc-slot moves)
+  (make-call-allocation proc-slot moves dead-slot-map)
   call-allocation?
   (proc-slot call-allocation-proc-slot)
-  (moves call-allocation-moves))
+  (moves call-allocation-moves)
+  (dead-slot-map call-allocation-dead-slot-map))
 
 (define (find-first-zero n)
   ;; Naive implementation.
@@ -162,6 +166,10 @@
   (or (call-allocation-moves (lookup-call-allocation k allocation))
       (error "Call has no use parallel moves slot" k)))
 
+(define (lookup-dead-slot-map k allocation)
+  (or (call-allocation-dead-slot-map (lookup-call-allocation k allocation))
+      (error "Call has no dead slot map" k)))
+
 (define (lookup-nlocals k allocation)
   (or (hashq-ref (allocation-nlocals allocation) k)
       (error "Not a clause continuation" k)))
@@ -485,7 +493,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                       (compute-tmp-slot pre-live tail-slots))))
            (bump-nlocals! tail-nlocals)
            (hashq-set! call-allocations label
-                       (make-call-allocation #f moves))))
+                       (make-call-allocation #f moves #f))))
         (($ $kreceive arity kargs)
          (let* ((proc-slot (compute-call-proc-slot post-live))
                 (call-slots (map (cut + proc-slot <>) (iota (length uses))))
@@ -516,12 +524,14 @@ are comparable with eqv?.  A tmp slot may be used."
                 (result-moves (parallel-move value-slots
                                              result-slots
                                              (compute-tmp-slot result-live
-                                                               value-slots))))
+                                                               value-slots)))
+                (dead-slot-map (logand (1- (ash 1 (- proc-slot 2)))
+                                       (lognot post-live))))
            (bump-nlocals! (+ proc-slot (length uses)))
            (hashq-set! call-allocations label
-                       (make-call-allocation proc-slot arg-moves))
+                       (make-call-allocation proc-slot arg-moves dead-slot-map))
            (hashq-set! call-allocations k
-                       (make-call-allocation proc-slot result-moves))))
+                       (make-call-allocation proc-slot result-moves #f))))
 
         (_
          (let* ((proc-slot (compute-call-proc-slot post-live))
@@ -533,7 +543,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                                             call-slots))))
            (bump-nlocals! (+ proc-slot (length uses)))
            (hashq-set! call-allocations label
-                       (make-call-allocation proc-slot arg-moves))))))
+                       (make-call-allocation proc-slot arg-moves #f))))))
                          
     (define (allocate-values label k uses pre-live post-live)
       (match (vector-ref contv (cfa-k-idx cfa k))
@@ -545,7 +555,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                       (compute-tmp-slot pre-live dst-slots))))
            (bump-nlocals! tail-nlocals)
            (hashq-set! call-allocations label
-                       (make-call-allocation #f moves))))
+                       (make-call-allocation #f moves #f))))
         (($ $kargs (_) (_))
          ;; When there is only one value in play, we allow the dst to be
          ;; hinted (see scan-for-hints).  If the src doesn't have a
@@ -566,7 +576,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                       (compute-tmp-slot (logior pre-live result-live)
                                                         '()))))
            (hashq-set! call-allocations label
-                       (make-call-allocation #f moves))))
+                       (make-call-allocation #f moves #f))))
         (($ $kif) #f)))
 
     (define (allocate-prompt label k handler nargs)
@@ -590,7 +600,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                                         value-slots))))
            (bump-nlocals! (+ proc-slot 1 (length result-vars)))
            (hashq-set! call-allocations handler
-                       (make-call-allocation proc-slot moves))))))
+                       (make-call-allocation proc-slot moves #f))))))
 
     (define (allocate-defs! n live)
       (fold (cut allocate! <> #f <>) live (vector-ref defv n)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index e8eba306f..e040314c3 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1,6 +1,6 @@
 ;;; Guile bytecode assembler
 
-;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014 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
@@ -189,7 +189,8 @@
             word-size endianness
             constants inits
             shstrtab next-section-number
-            meta sources)
+            meta sources
+            dead-slot-maps)
   asm?
 
   ;; We write bytecode into what is logically a growable vector,
@@ -265,7 +266,14 @@
   ;; is relative to the beginning of the text section, and SOURCE is in
   ;; the same format that source-properties returns.
   ;;
-  (sources asm-sources set-asm-sources!))
+  (sources asm-sources set-asm-sources!)
+
+  ;; A list of (pos . dead-slot-map) pairs, indicating dead slot maps.
+  ;; POS is relative to the beginning of the text section.
+  ;; DEAD-SLOT-MAP is a bitfield of slots that are dead at call sites,
+  ;; as an integer.
+  ;;
+  (dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!))
 
 (define-inlinable (fresh-block)
   (make-u32vector *block-size*))
@@ -280,7 +288,7 @@ target."
             word-size endianness
             vlist-null '()
             (make-string-table) 1
-            '() '()))
+            '() '() '()))
 
 (define (intern-section-name! asm string)
   "Add a string to the section name table (shstrtab)."
@@ -828,6 +836,12 @@ returned instead."
          (cell-label (intern-cache-cell asm key sym)))
     (emit-module-box asm dst cell-label mod-name-label sym-label bound?)))
 
+(define-macro-assembler (dead-slot-map asm proc-slot dead-slot-map)
+  (unless (zero? dead-slot-map)
+    (set-asm-dead-slot-maps! asm
+                             (cons
+                              (cons* (asm-start asm) proc-slot dead-slot-map)
+                              (asm-dead-slot-maps asm)))))
 
 
 
@@ -1194,6 +1208,67 @@ needed."
 
 
 ;;;
+;;; Create the frame maps.  These maps are used by GC to identify dead
+;;; slots in pending call frames, to avoid marking them.  We only do
+;;; this when frame makes a non-tail call, as that is the common case.
+;;; Only the topmost frame will see a GC at any other point, but we mark
+;;; top frames conservatively as serializing live slot maps at every
+;;; instruction would take up too much space in the object file.
+;;;
+
+;; The .guile.frame-maps section starts with two packed u32 values: one
+;; indicating the offset of the first byte of the .rtl-text section, and
+;; another indicating the relative offset in bytes of the slots data.
+(define frame-maps-prefix-len 8)
+
+;; Each header is 8 bytes: 4 for the offset from .rtl_text, and 4 for
+;; the offset of the slot map from the beginning of the
+;; .guile.frame-maps section.  The length of a frame map depends on the
+;; frame size at the call site, and is not encoded into this section as
+;; it is available at run-time.
+(define frame-map-header-len 8)
+
+(define (link-frame-maps asm)
+  (define (map-byte-length proc-slot)
+    (ceiling-quotient (- proc-slot 2) 8))
+  (define (make-frame-maps maps count map-len)
+    (let* ((endianness (asm-endianness asm))
+           (header-pos frame-maps-prefix-len)
+           (map-pos (+ header-pos (* count frame-map-header-len)))
+           (bv (make-bytevector (+ map-pos map-len) 0)))
+      (bytevector-u32-set! bv 4 map-pos endianness)
+      (let lp ((maps maps) (header-pos header-pos) (map-pos map-pos))
+        (match maps
+          (()
+           (make-object asm '.guile.frame-maps bv
+                        (list (make-linker-reloc 'abs32/1 0 0 '.rtl-text))
+                        '() #:type SHT_PROGBITS #:flags SHF_ALLOC))
+          (((pos proc-slot . map) . maps)
+           (bytevector-u32-set! bv header-pos (* pos 4) endianness)
+           (bytevector-u32-set! bv (+ header-pos 4) map-pos endianness)
+           (let write-bytes ((map-pos map-pos)
+                             (map map)
+                             (byte-length (map-byte-length proc-slot)))
+             (if (zero? byte-length)
+                 (lp maps (+ header-pos frame-map-header-len) map-pos)
+                 (begin
+                   (bytevector-u8-set! bv map-pos (logand map #xff))
+                   (write-bytes (1+ map-pos) (ash map -8)
+                                (1- byte-length))))))))))
+  (match (asm-dead-slot-maps asm)
+    (() #f)
+    (in
+     (let lp ((in in) (out '()) (count 0) (map-len 0))
+       (match in
+         (() (make-frame-maps out count map-len))
+         (((and head (pos proc-slot . map)) . in)
+          (lp in (cons head out)
+              (1+ count)
+              (+ (map-byte-length proc-slot) map-len))))))))
+
+
+
+;;;
 ;;; Linking other sections of the ELF file, like the dynamic segment,
 ;;; the symbol table, etc.
 ;;;
@@ -1202,14 +1277,18 @@ needed."
 (define *bytecode-major-version* #x0202)
 (define *bytecode-minor-version* 3)
 
-(define (link-dynamic-section asm text rw rw-init)
+(define (link-dynamic-section asm text rw rw-init frame-maps)
   "Link the dynamic section for an ELF image with bytecode @var{text},
 given the writable data section @var{rw} needing fixup from the
 procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
 @var{rw} is true, it will be added to the GC roots at runtime."
   (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
     (let* ((endianness (asm-endianness asm))
-           (bv (make-bytevector (* word-size (if rw (if rw-init 12 10) 6)) 0))
+           (words 6)
+           (words (if rw (+ words 4) words))
+           (words (if rw-init (+ words 2) words))
+           (words (if frame-maps (+ words 2) words))
+           (bv (make-bytevector (* word-size words) 0))
            (set-uword!
             (lambda (i uword)
               (%set-uword! bv (* i word-size) uword endianness)))
@@ -1225,25 +1304,20 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
                             *bytecode-minor-version*))
       (set-uword! 2 DT_GUILE_ENTRY)
       (set-label! 3 '.rtl-text)
-      (cond
-       (rw
+      (when rw
         ;; Add roots to GC.
         (set-uword! 4 DT_GUILE_GC_ROOT)
         (set-label! 5 '.data)
         (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
         (set-uword! 7 (bytevector-length (linker-object-bv rw)))
-        (cond
-         (rw-init
+        (when rw-init
           (set-uword! 8 DT_INIT)        ; constants
-          (set-label! 9 rw-init)
-          (set-uword! 10 DT_NULL)
-          (set-uword! 11 0))
-         (else
-          (set-uword! 8 DT_NULL)
-          (set-uword! 9 0))))
-       (else
-        (set-uword! 4 DT_NULL)
-        (set-uword! 5 0)))
+          (set-label! 9 rw-init)))
+      (when frame-maps
+        (set-uword! (- words 4) DT_GUILE_FRAME_MAPS)
+        (set-label! (- words 3) '.guile.frame-maps))
+      (set-uword! (- words 2) DT_NULL)
+      (set-uword! (- words 1) 0)
       (make-object asm '.dynamic bv relocs '()
                    #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
   (case (asm-word-size asm)
@@ -1969,7 +2043,8 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
                 ;; 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))
+                ((frame-maps) (link-frame-maps asm))
+                ((dt) (link-dynamic-section asm text rw rw-init frame-maps))
                 ((symtab strtab) (link-symtab (linker-object-section text) asm))
                 ((arities arities-strtab) (link-arities asm))
                 ((docstrs docstrs-strtab) (link-docstrs asm))
@@ -1978,7 +2053,8 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
                 ;; sections adds entries to the string table.
                 ((shstrtab) (link-shstrtab asm)))
     (filter identity
-            (list text ro rw dt symtab strtab arities arities-strtab
+            (list text ro frame-maps rw dt symtab strtab
+                  arities arities-strtab
                   docstrs docstrs-strtab procprops
                   dinfo dabbrev dstrtab dloc dline
                   shstrtab))))
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index 2fe99bada..ec89d4f27 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -1,6 +1,6 @@
 ;;; Guile ELF reader and writer
 
-;; Copyright (C)  2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C)  2011, 2012, 2013, 2014 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
@@ -105,8 +105,8 @@
             DT_FINI_ARRAYSZ DT_RUNPATH DT_FLAGS DT_ENCODING
             DT_PREINIT_ARRAY DT_PREINIT_ARRAYSZ DT_NUM DT_LOGUILE
             DT_GUILE_GC_ROOT DT_GUILE_GC_ROOT_SZ DT_GUILE_ENTRY
-            DT_GUILE_VM_VERSION DT_HIGUILE DT_LOOS DT_HIOS DT_LOPROC
-            DT_HIPROC
+            DT_GUILE_VM_VERSION DT_GUILE_FRAME_MAPS DT_HIGUILE
+            DT_LOOS DT_HIOS DT_LOPROC DT_HIPROC
 
             string-table-ref
 
@@ -781,6 +781,7 @@
 (define DT_GUILE_GC_ROOT_SZ #x37146001) ; Size in machine words of GC roots
 (define DT_GUILE_ENTRY      #x37146002) ; Address of entry thunk
 (define DT_GUILE_VM_VERSION #x37146003) ; Bytecode version
+(define DT_GUILE_FRAME_MAPS #x37146004) ; Offset of .guile.frame-maps
 (define DT_HIGUILE      #x37146fff)     ; End of Guile-specific
 (define DT_LOOS		#x6000000d)	; Start of OS-specific
 (define DT_HIOS		#x6ffff000)	; End of OS-specific