Reflection support for unboxed f64 slots

* module/system/vm/assembler.scm (emit-definition): Add representation
  field.
  (write-arities): Emit representations into the arities section.

* module/system/vm/debug.scm (arity-definitions): Read representations.

* module/system/vm/frame.scm (<binding>): Add representation field and
  binding-representation getter.
  (available-bindings): Pass representation to make-binding.
  (frame-binding-set!, frame-binding-ref, frame-call-representation):
  Pass representation to frame-local-ref / frame-local-set!.

* test-suite/tests/rtl.test: Update definition instructions.

* module/language/cps/slot-allocation.scm ($allocation): Add
  representations field.
  (lookup-representation): New public function.
  (allocate-slots): Pass representations to make-$allocation.

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

* libguile/frames.h:
* libguile/frames.c (scm_frame_local_ref, scm_frame_local_set_x): Take
  representation argument.
  (scm_to_stack_item_representation): New internal helper.

9 files changed, 130 insertions, 58 deletions

diff --git a/libguile/frames.c b/libguile/frames.c
index a1c7f3e71..d522e762a 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -220,45 +220,88 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
-	    (SCM frame, SCM index),
+enum stack_item_representation
+  {
+    STACK_ITEM_SCM = 0,
+    STACK_ITEM_F64 = 1
+  };
+
+static enum stack_item_representation
+scm_to_stack_item_representation (SCM x, const char *subr, int pos)
+{
+  if (scm_is_eq (x, scm_from_latin1_symbol ("scm")))
+    return STACK_ITEM_SCM;
+  if (scm_is_eq (x, scm_from_latin1_symbol ("f64")))
+    return STACK_ITEM_F64;
+
+  scm_wrong_type_arg (subr, pos, x);
+  return 0;  /* Not reached.  */
+}
+
+SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0,
+	    (SCM frame, SCM index, SCM representation),
 	    "")
 #define FUNC_NAME s_scm_frame_local_ref
 {
   union scm_vm_stack_element *fp, *sp;
   unsigned int i;
+  enum stack_item_representation repr;
 
   SCM_VALIDATE_VM_FRAME (1, frame);
   SCM_VALIDATE_UINT_COPY (2, index, i);
+  repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
 
   fp = SCM_VM_FRAME_FP (frame);
   sp = SCM_VM_FRAME_SP (frame);
 
   if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
-    return SCM_FRAME_LOCAL (fp, i);
+    {
+      union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
+      switch (repr)
+        {
+          case STACK_ITEM_SCM:
+            return item->as_scm;
+          case STACK_ITEM_F64:
+            /* return item->as_f64; */
+          default:
+            abort();
+        }
+    }
 
   SCM_OUT_OF_RANGE (SCM_ARG2, index);
 }
 #undef FUNC_NAME
 
 /* Need same not-yet-active frame logic here as in frame-num-locals */
-SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
-	    (SCM frame, SCM index, SCM val),
+SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0,
+	    (SCM frame, SCM index, SCM val, SCM representation),
 	    "")
 #define FUNC_NAME s_scm_frame_local_set_x
 {
   union scm_vm_stack_element *fp, *sp;
   unsigned int i;
+  enum stack_item_representation repr;
 
   SCM_VALIDATE_VM_FRAME (1, frame);
   SCM_VALIDATE_UINT_COPY (2, index, i);
+  repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
 
   fp = SCM_VM_FRAME_FP (frame);
   sp = SCM_VM_FRAME_SP (frame);
 
   if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
     {
-      SCM_FRAME_LOCAL (fp, i) = val;
+      union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
+      switch (repr)
+        {
+          case STACK_ITEM_SCM:
+            item->as_scm = val;
+            break;
+          case STACK_ITEM_F64:
+            /* item->as_f64 = scm_to_double (val); */
+          default:
+            abort();
+        }
       return SCM_UNSPECIFIED;
     }
 
diff --git a/libguile/frames.h b/libguile/frames.h
index e1130e94b..c965bbfb7 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -160,8 +160,9 @@ SCM_API SCM scm_frame_call_representation (SCM frame);
 SCM_API SCM scm_frame_arguments (SCM frame);
 SCM_API SCM scm_frame_source (SCM frame);
 SCM_API SCM scm_frame_num_locals (SCM frame);
-SCM_API SCM scm_frame_local_ref (SCM frame, SCM index);
-SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_frame_local_ref (SCM frame, SCM index, SCM representation);
+SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val,
+                                   SCM representation);
 SCM_API SCM scm_frame_address (SCM frame);
 SCM_API SCM scm_frame_stack_pointer (SCM frame);
 SCM_API SCM scm_frame_instruction_pointer (SCM frame);
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 6830d753b..96200a83d 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -475,7 +475,8 @@
          (for-each (lambda (name var)
                      (let ((slot (maybe-slot var)))
                        (when slot
-                         (emit-definition asm name slot))))
+                         (let ((repr (lookup-representation var allocation)))
+                           (emit-definition asm name slot repr)))))
                    names vars)
          (when src
            (emit-source asm src))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 9189d86a0..ad4e524e7 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -35,6 +35,7 @@
   #:export (allocate-slots
             lookup-slot
             lookup-maybe-slot
+            lookup-representation
             lookup-constant-value
             lookup-maybe-constant-value
             lookup-nlocals
@@ -43,7 +44,8 @@
             lookup-slot-map))
 
 (define-record-type $allocation
-  (make-allocation slots constant-values call-allocs shuffles frame-sizes)
+  (make-allocation slots representations constant-values call-allocs
+                   shuffles frame-sizes)
   allocation?
 
   ;; A map of VAR to slot allocation.  A slot allocation is an integer,
@@ -51,6 +53,11 @@
   ;;
   (slots allocation-slots)
 
+  ;; A map of VAR to representation.  A representation is either 'scm or
+  ;; 'f64.
+  ;;
+  (representations allocation-representations)
+
   ;; A map of VAR to constant value, for variables with constant values.
   ;;
   (constant-values allocation-constant-values)
@@ -95,6 +102,9 @@
 (define (lookup-slot var allocation)
   (intmap-ref (allocation-slots allocation) var))
 
+(define (lookup-representation var allocation)
+  (intmap-ref (allocation-representations allocation) var))
+
 (define *absent* (list 'absent))
 
 (define (lookup-constant-value var allocation)
@@ -1006,4 +1016,5 @@ are comparable with eqv?.  A tmp slot may be used."
         (let* ((slots (allocate-lazy-vars cps slots calls live-in lazy))
                (shuffles (compute-shuffles cps slots calls live-in))
                (frame-sizes (compute-frame-sizes cps slots calls shuffles)))
-          (make-allocation slots constants calls shuffles frame-sizes))))))
+          (make-allocation slots representations constants calls
+                           shuffles frame-sizes))))))
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 6fff660e5..9516af622 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -113,7 +113,8 @@
       (format port "~aLocal variables:~%" per-line-prefix)
       (for-each
        (lambda (binding)
-         (let ((v (frame-local-ref frame (binding-slot binding))))
+         (let ((v (frame-local-ref frame (binding-slot binding)
+                                   (binding-representation binding))))
            (display per-line-prefix port)
            (run-hook before-print-hook v)
            (format port "~a = ~v:@y\n" (binding-name binding) width v)))
@@ -174,7 +175,8 @@
           (module-use! mod* mod)
           (for-each
            (lambda (binding)
-             (let* ((x (frame-local-ref frame (binding-slot binding)))
+             (let* ((x (frame-local-ref frame (binding-slot binding)
+                                        (binding-representation binding)))
                     (var (if (variable? x) x (make-variable x))))
                (format #t
                        "~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 379539f6a..dd96709e5 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1162,10 +1162,9 @@ returned instead."
 (define-macro-assembler (source asm source)
   (set-asm-sources! asm (acons (asm-start asm) source (asm-sources asm))))
 
-(define-macro-assembler (definition asm name slot)
+(define-macro-assembler (definition asm name slot representation)
   (let* ((arity (car (meta-arities (car (asm-meta asm)))))
-         (def (vector name
-                      slot
+         (def (vector name slot representation
                       (* (- (asm-start asm) (arity-low-pc arity)) 4))))
     (set-arity-definitions! arity (cons def (arity-definitions arity)))))
 
@@ -1876,7 +1875,7 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
       (let lp ((definitions (arity-definitions arity)))
         (match definitions
           (() relocs)
-          ((#(name slot def) . definitions)
+          ((#(name slot representation def) . definitions)
            (let ((sym (if (symbol? name)
                           (string-table-intern! strtab (symbol->string name))
                           0)))
@@ -1886,9 +1885,13 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
       (let lp ((definitions (arity-definitions arity)))
         (match definitions
           (() relocs)
-          ((#(name slot def) . definitions)
+          ((#(name slot representation def) . definitions)
            (put-uleb128 names-port def)
-           (put-uleb128 names-port slot)
+           (let ((tag (case representation
+                        ((scm) 0)
+                        ((f64) 1)
+                        (else (error "what!" representation)))))
+             (put-uleb128 names-port (logior (ash slot 2) tag)))
            (lp definitions))))))
   (let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
     (match metas
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index cd8c19e13..814472b7a 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -1,6 +1,6 @@
 ;;; Guile runtime debug information
 
-;;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 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
@@ -381,9 +381,14 @@ section of the ELF image.  Returns an ELF symbol, or @code{#f}."
            (call-with-values (lambda () (read-uleb128 bv pos))
              (lambda (def-offset pos)
                (call-with-values (lambda () (read-uleb128 bv pos))
-                 (lambda (slot pos)
-                   (cons (vector name def-offset slot)
-                         (lp pos names))))))))))
+                 (lambda (slot+representation pos)
+                   (let ((slot (ash slot+representation -2))
+                         (representation (case (logand slot+representation #x3)
+                                           ((0) 'scm)
+                                           ((1) 'f64)
+                                           (else 'unknown))))
+                     (cons (vector name def-offset slot representation)
+                           (lp pos names)))))))))))
     (define (load-symbols pos)
       (let lp ((pos pos) (n nlocals) (out '()))
         (if (zero? n)
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 7f0211da8..6e4527956 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM frame functions
 
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 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
@@ -31,6 +31,7 @@
   #:export (binding-index
             binding-name
             binding-slot
+            binding-representation
 
             frame-bindings
             frame-lookup-binding
@@ -40,11 +41,12 @@
             frame-object-binding frame-object-name))
 
 (define-record-type <binding>
-  (make-binding idx name slot)
+  (make-binding idx name slot representation)
   binding?
   (idx binding-index)
   (name binding-name)
-  (slot binding-slot))
+  (slot binding-slot)
+  (representation binding-representation))
 
 (define (parse-code code)
   (let ((len (bytevector-length code)))
@@ -134,7 +136,7 @@
     (let lp ((var 0) (pos 0) (pc-offset 0))
       (when (< var (vector-length defs))
         (match (vector-ref defs var)
-          (#(name offset slot)
+          (#(name offset slot representation)
            (when (< offset pc-offset)
              (error "mismatch between def offsets and parsed code"))
            (cond
@@ -147,7 +149,7 @@
 
 (define (compute-defs-by-slot defs)
   (let* ((nslots (match defs
-                   (#(#(_ _ slot) ...) (1+ (apply max slot)))))
+                   (#(#(_ _ slot _) ...) (1+ (apply max slot)))))
          (by-slot (make-vector nslots #f)))
     (let lp ((n 0))
       (when (< n nslots)
@@ -156,7 +158,7 @@
     (let lp ((n 0))
       (when (< n (vector-length defs))
         (match (vector-ref defs n)
-          (#(_ _ slot)
+          (#(_ _ slot _)
            (bitvector-set! (vector-ref by-slot slot) n #t)
            (lp (1+ n))))))
     by-slot))
@@ -179,7 +181,7 @@
     (let lp ((var 0) (pos 0) (pc-offset 0))
       (when (< var (vector-length defs))
         (match (vector-ref defs var)
-          (#(name offset slot)
+          (#(name offset slot representation)
            (when (< offset pc-offset)
              (error "mismatch between def offsets and parsed code"))
            (cond
@@ -274,10 +276,10 @@
               (let ((n (bit-position #t live n)))
                 (if n
                     (match (vector-ref defs n)
-                      (#(name def-offset slot)
+                      (#(name def-offset slot representation)
                        ;; Binding 0 is the closure, and is not present
                        ;; in arity-definitions.
-                       (cons (make-binding (1+ n) name slot)
+                       (cons (make-binding (1+ n) name slot representation)
                              (lp (1+ n)))))
                     '()))))
           (lp (1+ n) (- offset (vector-ref parsed n)))))))
@@ -300,17 +302,16 @@
            (lp (cdr bindings))))))
 
 (define (frame-binding-set! frame var val)
-  (frame-local-set! frame
-                    (binding-slot
-                     (or (frame-lookup-binding frame var)
-                         (error "variable not bound in frame" var frame)))
-                    val))
+  (let ((binding (or (frame-lookup-binding frame var)
+                     (error "variable not bound in frame" var frame))))
+    (frame-local-set! frame (binding-slot binding) val
+                      (binding-representation binding))))
 
 (define (frame-binding-ref frame var)
-  (frame-local-ref frame
-                   (binding-slot
-                    (or (frame-lookup-binding frame var)
-                        (error "variable not bound in frame" var frame)))))
+  (let ((binding (or (frame-lookup-binding frame var)
+                     (error "variable not bound in frame" var frame))))
+    (frame-local-ref frame (binding-slot binding)
+                     (binding-representation binding))))
 
 
 ;; This function is always called to get some sort of representation of the
@@ -347,16 +348,21 @@
          (closure (frame-procedure frame)))
     (define (find-slot i bindings)
       (match bindings
-        (#f (and (< i nlocals) i))
         (() #f)
-        ((($ <binding> idx name slot) . bindings)
+        (((and binding ($ <binding> idx name slot)) . bindings)
          (if (< idx i)
              (find-slot i bindings)
-             (and (= idx i) slot)))))
+             (and (= idx i) binding)))))
     (define (local-ref i bindings)
       (cond
+       ((not bindings)
+        ;; This case is only hit for primitives and application
+        ;; arguments.
+        (frame-local-ref frame i 'scm))
        ((find-slot i bindings)
-        => (lambda (slot) (frame-local-ref frame slot)))
+        => (lambda (binding)
+             (frame-local-ref frame (binding-slot binding)
+                              (binding-representation binding))))
        (else
         '_)))
     (define (application-arguments)
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 872c5f1ff..bae76825e 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -104,7 +104,7 @@ a procedure."
                         '((begin-program countdown
                                          ((name . countdown)))
                           (begin-standard-arity (x) 4 #f)
-                          (definition x 1)
+                          (definition x 1 scm)
                           (br fix-body)
                           (label loop-head)
                           (br-if-= 1 2 #f out)
@@ -143,7 +143,7 @@ a procedure."
                           (begin-program accum
                                          ((name . accum)))
                           (begin-standard-arity (x) 4 #f)
-                          (definition x 1)
+                          (definition x 1 scm)
                           (free-ref 1 3 0)
                           (box-ref 0 1)
                           (add 0 0 2)
@@ -164,7 +164,7 @@ a procedure."
                         '((begin-program call
                                          ((name . call)))
                           (begin-standard-arity (f) 7 #f)
-                          (definition f 1)
+                          (definition f 1 scm)
                           (mov 1 5)
                           (call 5 1)
                           (receive 1 5 7)
@@ -179,7 +179,7 @@ a procedure."
                         '((begin-program call-with-3
                                          ((name . call-with-3)))
                           (begin-standard-arity (f) 7 #f)
-                          (definition f 1)
+                          (definition f 1 scm)
                           (mov 1 5)
                           (load-constant 0 3)
                           (call 5 2)
@@ -196,7 +196,7 @@ a procedure."
                         '((begin-program call
                                          ((name . call)))
                           (begin-standard-arity (f) 2 #f)
-                          (definition f 1)
+                          (definition f 1 scm)
                           (mov 1 0)
                           (tail-call 1)
                           (end-arity)
@@ -209,7 +209,7 @@ a procedure."
                         '((begin-program call-with-3
                                          ((name . call-with-3)))
                           (begin-standard-arity (f) 2 #f)
-                          (definition f 1)
+                          (definition f 1 scm)
                           (mov 1 0) ;; R0 <- R1
                           (load-constant 0 3) ;; R1 <- 3
                           (tail-call 2)
@@ -234,7 +234,7 @@ a procedure."
                           (begin-program sqrt-trampoline
                                          ((name . sqrt-trampoline)))
                           (begin-standard-arity (x) 3 #f)
-                          (definition x 1)
+                          (definition x 1 scm)
                           (cached-toplevel-box 0 sqrt-scope sqrt #t)
                           (box-ref 2 0)
                           (tail-call 2)
@@ -287,7 +287,7 @@ a procedure."
                           (begin-program sqrt-trampoline
                                          ((name . sqrt-trampoline)))
                           (begin-standard-arity (x) 3 #f)
-                          (definition x 1)
+                          (definition x 1 scm)
                           (cached-module-box 0 (guile) sqrt #t #t)
                           (box-ref 2 0)
                           (tail-call 2)
@@ -368,8 +368,8 @@ a procedure."
        (assemble-program
         '((begin-program foo ((name . foo)))
           (begin-standard-arity (x y) 3 #f)
-          (definition x 1)
-          (definition y 2)
+          (definition x 1 scm)
+          (definition y 2 scm)
           (load-constant 1 42)
           (return-values 2)
           (end-arity)
@@ -380,9 +380,9 @@ a procedure."
        (assemble-program
         '((begin-program foo ((name . foo)))
           (begin-opt-arity (x) (y) z 4 #f)
-          (definition x 1)
-          (definition y 2)
-          (definition z 3)
+          (definition x 1 scm)
+          (definition y 2 scm)
+          (definition z 3 scm)
           (load-constant 2 42)
           (return-values 2)
           (end-arity)