VM support for raw slots

* libguile/loader.c (scm_find_slot_map_unlocked): Rename from
  scm_find_dead_slot_map_unlocked.

* libguile/vm.c (struct slot_map_cache_entry, struct slot_map_cache)
  (find_slot_map): Rename, changing "dead_slot" to "slot".
  (enum slot_desc): New type.
  (scm_i_vm_mark_stack): Interpret slot maps as having two bits per
  slot, allowing us to indicate that a slot is live but not a pointer.

* module/language/cps/compile-bytecode.scm (compile-function): Adapt to
  emit-slot-map name change.

* module/system/vm/assembler.scm (<asm>): Rename dead-slot-maps field to
  slot-maps.
  (emit-slot-map): Rename from emit-dead-slot-map.
  (link-frame-maps): 2 bits per slot.

* module/language/cps/slot-allocation.scm (lookup-slot-map): Rename from
  lookup-dead-slot-map.
  (compute-var-representations): New function.
  (allocate-slots): Adapt to encode two-bit slot representations.

7 files changed, 139 insertions, 64 deletions

diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 420671adc..f97a009b5 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -427,6 +427,10 @@ A table mapping addresses in the @code{.rtl-text} to procedure names.
 @itemx .guile.docstrs
 @itemx .guile.docstrs.strtab
 Side tables of procedure properties, arities, and docstrings.
+@item .guile.docstrs.strtab
+Side table of frame maps, describing the set of live slots for ever
+return point in the program text, and whether those slots are pointers
+are not.  Used by the garbage collector.
 @item .debug_info
 @itemx .debug_abbrev
 @itemx .debug_str
diff --git a/libguile/loader.c b/libguile/loader.c
index a55bd15b0..97effb30d 100644
--- a/libguile/loader.c
+++ b/libguile/loader.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 2001, 2009, 2010, 2011, 2012
- *    2013, 2014 Free Software Foundation, Inc.
+ *    2013, 2014, 2015 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
@@ -748,7 +748,7 @@ 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)
+scm_find_slot_map_unlocked (const scm_t_uint32 *ip)
 {
   struct mapped_elf_image *image;
   char *base;
diff --git a/libguile/loader.h b/libguile/loader.h
index 6fd950279..5c719cbce 100644
--- a/libguile/loader.h
+++ b/libguile/loader.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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
@@ -25,7 +25,7 @@ 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_find_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 9d9cc3129..5ea6b2bd4 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -895,31 +895,31 @@ return_unused_stack_to_os (struct scm_vm *vp)
 #endif
 }
 
-#define DEAD_SLOT_MAP_CACHE_SIZE 32U
-struct dead_slot_map_cache_entry
+#define SLOT_MAP_CACHE_SIZE 32U
+struct slot_map_cache_entry
 {
   scm_t_uint32 *ip;
   const scm_t_uint8 *map;
 };
 
-struct dead_slot_map_cache
+struct slot_map_cache
 {
-  struct dead_slot_map_cache_entry entries[DEAD_SLOT_MAP_CACHE_SIZE];
+  struct slot_map_cache_entry entries[SLOT_MAP_CACHE_SIZE];
 };
 
 static const scm_t_uint8 *
-find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache)
+find_slot_map (scm_t_uint32 *ip, struct slot_map_cache *cache)
 {
   /* The lower two bits should be zero.  FIXME: Use a better hash
      function; we don't expose scm_raw_hashq currently.  */
-  size_t slot = (((scm_t_uintptr) ip) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE;
+  size_t slot = (((scm_t_uintptr) ip) >> 2) % SLOT_MAP_CACHE_SIZE;
   const scm_t_uint8 *map;
 
   if (cache->entries[slot].ip == ip)
     map = cache->entries[slot].map;
   else
     {
-      map = scm_find_dead_slot_map_unlocked (ip);
+      map = scm_find_slot_map_unlocked (ip);
       cache->entries[slot].ip = ip;
       cache->entries[slot].map = map;
     }
@@ -927,21 +927,29 @@ find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache)
   return map;
 }
 
+enum slot_desc
+  {
+    SLOT_DESC_DEAD = 0,
+    SLOT_DESC_LIVE_RAW = 1,
+    SLOT_DESC_LIVE_SCM = 2,
+    SLOT_DESC_UNUSED = 3
+  };
+
 /* Mark the active VM stack region.  */
 struct GC_ms_entry *
 scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
                      struct GC_ms_entry *mark_stack_limit)
 {
   union scm_vm_stack_element *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;
+  /* The first frame will be marked conservatively (without a 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 slot maps for all points in a program would take a
+     prohibitive amount of space.  */
+  const scm_t_uint8 *slot_map = NULL;
   void *upper = (void *) GC_greatest_plausible_heap_addr;
   void *lower = (void *) GC_least_plausible_heap_addr;
-  struct dead_slot_map_cache cache;
+  struct slot_map_cache cache;
 
   memset (&cache, 0, sizeof (cache));
 
@@ -953,24 +961,29 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
       size_t slot = nlocals - 1;
       for (slot = nlocals - 1; sp < fp; sp++, slot--)
         {
-          if (SCM_NIMP (sp->as_scm) &&
-              sp->as_ptr >= lower && sp->as_ptr <= upper)
+          enum slot_desc desc = SLOT_DESC_LIVE_SCM;
+
+          if (slot_map)
+            desc = (slot_map[slot / 4U] >> ((slot % 4U) * 2)) & 3U;
+
+          switch (desc)
             {
-              if (dead_slots)
-                {
-                  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->as_scm = SCM_UNSPECIFIED;
-                      continue;
-                    }
-                }
-
-              mark_stack_ptr = GC_mark_and_push (sp->as_ptr,
-                                                 mark_stack_ptr,
-                                                 mark_stack_limit,
-                                                 NULL);
+            case SLOT_DESC_LIVE_RAW:
+              break;
+            case SLOT_DESC_UNUSED:
+            case SLOT_DESC_LIVE_SCM:
+              if (SCM_NIMP (sp->as_scm) &&
+                  sp->as_ptr >= lower && sp->as_ptr <= upper)
+                mark_stack_ptr = GC_mark_and_push (sp->as_ptr,
+                                                   mark_stack_ptr,
+                                                   mark_stack_limit,
+                                                   NULL);
+              break;
+            case SLOT_DESC_DEAD:
+              /* This value may become dead as a result of GC,
+                 so we can't just leave it on the stack.  */
+              sp->as_scm = SCM_UNSPECIFIED;
+              break;
             }
         }
       sp = SCM_FRAME_PREVIOUS_SP (fp);
@@ -978,7 +991,7 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
          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 = find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache);
+      slot_map = find_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache);
     }
 
   return_unused_stack_to_os (vp);
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 1f7c66422..6830d753b 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -379,8 +379,7 @@
                      ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
                     (lookup-parallel-moves label allocation))
           (emit-call asm proc-slot nargs)
-          (emit-dead-slot-map asm proc-slot
-                              (lookup-dead-slot-map label allocation))
+          (emit-slot-map asm proc-slot (lookup-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 1e349eea2..9189d86a0 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -40,7 +40,7 @@
             lookup-nlocals
             lookup-call-proc-slot
             lookup-parallel-moves
-            lookup-dead-slot-map))
+            lookup-slot-map))
 
 (define-record-type $allocation
   (make-allocation slots constant-values call-allocs shuffles frame-sizes)
@@ -84,10 +84,10 @@
   (frame-sizes allocation-frame-sizes))
 
 (define-record-type $call-alloc
-  (make-call-alloc proc-slot dead-slot-map)
+  (make-call-alloc proc-slot slot-map)
   call-alloc?
   (proc-slot call-alloc-proc-slot)
-  (dead-slot-map call-alloc-dead-slot-map))
+  (slot-map call-alloc-slot-map))
 
 (define (lookup-maybe-slot var allocation)
   (intmap-ref (allocation-slots allocation) var (lambda (_) #f)))
@@ -121,9 +121,9 @@
 (define (lookup-parallel-moves k allocation)
   (intmap-ref (allocation-shuffles allocation) k))
 
-(define (lookup-dead-slot-map k allocation)
-  (or (call-alloc-dead-slot-map (lookup-call-alloc k allocation))
-      (error "Call has no dead slot map" k)))
+(define (lookup-slot-map k allocation)
+  (or (call-alloc-slot-map (lookup-call-alloc k allocation))
+      (error "Call has no slot map" k)))
 
 (define (lookup-nlocals k allocation)
   (intmap-ref (allocation-frame-sizes allocation) k))
@@ -764,8 +764,52 @@ are comparable with eqv?.  A tmp slot may be used."
   (persistent-intmap
    (intmap-fold-right allocate-lazy cps slots)))
 
+(define (compute-var-representations cps)
+  (define (get-defs k)
+    (match (intmap-ref cps k)
+      (($ $kargs names vars) vars)
+      (_ '())))
+  (intmap-fold
+   (lambda (label cont representations)
+     (match cont
+       (($ $kargs _ _ ($ $continue k _ exp))
+        (match (get-defs k)
+          (() representations)
+          ((var)
+           (match exp
+             (($ $values (arg))
+              (intmap-add representations var
+                          (intmap-ref representations arg)))
+             ;; FIXME: Placeholder for as-yet-unwritten primitive
+             ;; operations that define unboxed f64 values.
+             (($ $primcall 'scm->f64)
+              (intmap-add representations var 'f64))
+             (_
+              (intmap-add representations var 'scm))))
+          (vars
+           (match exp
+             (($ $values args)
+              (fold (lambda (arg var representations)
+                      (intmap-add representations var
+                                  (intmap-ref representations arg)))
+                    representations args vars))))))
+       (($ $kfun src meta self)
+        (intmap-add representations self 'scm))
+       (($ $kclause arity body alt)
+        (fold1 (lambda (var representations)
+                 (intmap-add representations var 'scm))
+               (get-defs body) representations))
+       (($ $kreceive arity kargs)
+        (fold1 (lambda (var representations)
+                 (intmap-add representations var 'scm))
+               (get-defs kargs) representations))
+       (($ $ktail) representations)))
+   cps
+   empty-intmap))
+
 (define (allocate-slots cps)
   (let*-values (((defs uses) (compute-defs-and-uses cps))
+                ((representations) (compute-var-representations cps))
                 ((live-in live-out) (compute-live-variables cps defs uses))
                 ((constants) (compute-constant-values cps))
                 ((needs-slot) (compute-needs-slot cps defs uses))
@@ -809,6 +853,23 @@ are comparable with eqv?.  A tmp slot may be used."
     (define (compute-live-out-slots slots label)
       (compute-live-slots* slots label live-out))
 
+    (define slot-desc-dead 0)
+    (define slot-desc-live-raw 1)
+    (define slot-desc-live-scm 2)
+    (define slot-desc-unused 3)
+
+    (define (compute-slot-map slots live-vars nslots)
+      (intset-fold
+       (lambda (var slot-map)
+         (match (get-slot slots var)
+           (#f slot-map)
+           (slot
+            (let ((desc (match (intmap-ref representations var)
+                          ('f64 slot-desc-live-raw)
+                          ('scm slot-desc-live-scm))))
+              (logior slot-map (ash desc (* 2 slot)))))))
+       live-vars 0))
+
     (define (allocate var hint slots live)
       (cond
        ((not (intset-ref needs-slot var))
@@ -874,9 +935,9 @@ are comparable with eqv?.  A tmp slot may be used."
                   (let ((result-slots (integers (+ proc-slot 2)
                                                 (length results))))
                     (allocate* results result-slots slots post-live)))))
-              ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
-                                       (lognot post-live)))
-              ((call) (make-call-alloc proc-slot dead-slot-map)))
+              ((slot-map) (compute-slot-map slots (intmap-ref live-out label)
+                                            (- proc-slot 2)))
+              ((call) (make-call-alloc proc-slot slot-map)))
            (values slots
                    (intmap-add! call-allocs label call))))))
     
@@ -909,8 +970,8 @@ are comparable with eqv?.  A tmp slot may be used."
          (let*-values
              (((handler-live) (compute-live-in-slots slots handler))
               ((proc-slot) (compute-prompt-handler-proc-slot handler-live))
-              ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
-                                       (lognot handler-live)))
+              ((slot-map)  (compute-slot-map slots (intmap-ref live-in handler)
+                                             (- proc-slot 2)))
               ((result-vars) (match (get-cont kargs)
                                (($ $kargs names vars) vars)))
               ((value-slots) (integers (1+ proc-slot) (length result-vars)))
@@ -918,7 +979,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                               slots handler-live)))
            (values slots
                    (intmap-add! call-allocs label
-                                (make-call-alloc proc-slot dead-slot-map)))))))
+                                (make-call-alloc proc-slot slot-map)))))))
 
     (define (allocate-cont label cont slots call-allocs)
       (match cont
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index c989ec6b7..379539f6a 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -326,7 +326,7 @@
             constants inits
             shstrtab next-section-number
             meta sources
-            dead-slot-maps)
+            slot-maps)
   asm?
 
   ;; We write bytecode into what is logically a growable vector,
@@ -404,12 +404,11 @@
   ;;
   (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.
+  ;; A list of (pos . slot-map) pairs, indicating slot maps.  POS is
+  ;; relative to the beginning of the text section.  SLOT-MAP is a
+  ;; bitfield describing the stack at call sites, as an integer.
   ;;
-  (dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!))
+  (slot-maps asm-slot-maps set-asm-slot-maps!))
 
 (define-inline (fresh-block)
   (make-u32vector *block-size*))
@@ -1187,12 +1186,11 @@ 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)))))
+(define-macro-assembler (slot-map asm proc-slot slot-map)
+  (unless (zero? slot-map)
+    (set-asm-slot-maps! asm (cons
+                             (cons* (asm-start asm) proc-slot slot-map)
+                             (asm-slot-maps asm)))))
 
 
 
@@ -1605,7 +1603,7 @@ needed."
 
 (define (link-frame-maps asm)
   (define (map-byte-length proc-slot)
-    (ceiling-quotient (- proc-slot 2) 8))
+    (ceiling-quotient (* 2 (- proc-slot 2)) 8))
   (define (make-frame-maps maps count map-len)
     (let* ((endianness (asm-endianness asm))
            (header-pos frame-maps-prefix-len)
@@ -1630,7 +1628,7 @@ needed."
                    (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)
+  (match (asm-slot-maps asm)
     (() #f)
     (in
      (let lp ((in in) (out '()) (count 0) (map-len 0))