RTL compiler supports static bitvectors

* libguile/arrays.c (scm_from_contiguous_typed_array):
* libguile/bytevectors.c (scm_uniform_array_to_bytevector): For
  bitvectors, round up the length to 32-bit units, as they are stored
  internally.  Otherwise I think this probably does the wrong thing for
  the last word on big-endian systems.
* libguile/bitvectors.c (BITVECTOR_LENGTH, BITVECTOR_BITS):
  (scm_c_make_bitvector): Reorder the length and pointer words to match
  the layout of bytevectors.

* module/language/cps/primitives.scm (*branching-primcall-arities*):
* module/system/vm/assembler.scm (br-if-bitvector):
* module/system/vm/disassembler.scm (code-annotation): Add bitvector
  test support.

* module/system/vm/assembler.scm (<uniform-vector-backing-store>): Add
  an element-size field.
  (intern-constant): Adapt make-uniform-vector-backing-store call.  Use
  uniform-array->bytevector, as the old compiler did.
  (link-data): Add bitvector cases.

libguile/arrays.c

@@ -1,5 +1,5 @@
 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
- *   2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *   2006, 2009, 2010, 2011, 2012, 2013 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
@@ -242,8 +242,9 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
     }
   else if (sz < 8)
     {
-      /* byte_len ?= ceil (rlen * sz / 8) */
+      /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
-      if (byte_len != (rlen * sz + 7) / 8)
+         units.  */
+      if (byte_len != ((rlen * sz + 31) / 32) * 4)
         SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
     }
   else

libguile/bitvectors.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012, 2013 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
@@ -39,8 +39,8 @@
  */
 
 #define IS_BITVECTOR(obj)       SCM_TYP16_PREDICATE(scm_tc7_bitvector,(obj))
-#define BITVECTOR_BITS(obj)     ((scm_t_uint32 *)SCM_CELL_WORD_1(obj))
+#define BITVECTOR_LENGTH(obj)   ((size_t)SCM_CELL_WORD_1(obj))
-#define BITVECTOR_LENGTH(obj)   ((size_t)SCM_CELL_WORD_2(obj))
+#define BITVECTOR_BITS(obj)     ((scm_t_uint32 *)SCM_CELL_WORD_2(obj))
 
 int
 scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate)
@@ -110,7 +110,7 @@ scm_c_make_bitvector (size_t len, SCM fill)
 
   bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len,
 				    "bitvector");
-  res = scm_double_cell (scm_tc7_bitvector, (scm_t_bits)bits, len, 0);
+  res = scm_double_cell (scm_tc7_bitvector, len, (scm_t_bits)bits, 0);
 
   if (!SCM_UNBNDP (fill))
     scm_bitvector_fill_x (res, fill);

libguile/bytevectors.c

@@ -649,8 +649,9 @@ SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
   if (sz >= 8 && ((sz % 8) == 0))
     byte_len = len * (sz / 8);
   else if (sz < 8)
-    /* byte_len = ceil (len * sz / 8) */
+    /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
-    byte_len = (len * sz + 7) / 8;
+       units.  */
+    byte_len = ((len * sz + 31) / 32) * 4;
   else
     /* an internal guile error, really */
     SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);

module/language/cps/primitives.scm

@@ -75,6 +75,7 @@
     (vector? . (1 . 1))
     (symbol? . (1 . 1))
     (variable? . (1 . 1))
+    (bitvector? . (1 . 1))
     (bytevector? . (1 . 1))
     (char? . (1 . 1))
     (eq? . (1 . 2))

module/system/vm/assembler.scm

@@ -531,9 +531,10 @@ list of lists.  This procedure can be called many times before calling
   (code static-procedure-code))
 
 (define-record-type <uniform-vector-backing-store>
-  (make-uniform-vector-backing-store bytes)
+  (make-uniform-vector-backing-store bytes element-size)
   uniform-vector-backing-store?
-  (bytes uniform-vector-backing-store-bytes))
+  (bytes uniform-vector-backing-store-bytes)
+  (element-size uniform-vector-backing-store-element-size))
 
 (define-record-type <cache-cell>
   (make-cache-cell scope key)
@@ -603,7 +604,13 @@ table, its existing label is used directly."
      ((uniform-vector-backing-store? obj) '())
      ((simple-uniform-vector? obj)
       `((static-patch! ,label 2
-                       ,(recur (make-uniform-vector-backing-store obj)))))
+                       ,(recur (make-uniform-vector-backing-store
+                                (uniform-array->bytevector obj)
+                                (if (bitvector? obj)
+                                    ;; Bitvectors are addressed in
+                                    ;; 32-bit units.
+                                    4
+                                    (uniform-vector-element-size obj)))))))
      (else
       (error "don't know how to intern" obj))))
   (cond
@@ -709,7 +716,7 @@ returned instead."
 ;(define-tc7-macro-assembler br-if-weak-set 85)
 ;(define-tc7-macro-assembler br-if-weak-table 87)
 ;(define-tc7-macro-assembler br-if-array 93)
-;(define-tc7-macro-assembler br-if-bitvector 95)
+(define-tc7-macro-assembler br-if-bitvector 95)
 ;(define-tc7-macro-assembler br-if-port 125)
 ;(define-tc7-macro-assembler br-if-smob 127)
 
@@ -901,6 +908,7 @@ should be .data or .rodata), and return the resulting linker object.
   (define tc7-ro-string (+ 21 #x200))
   (define tc7-rtl-program 69)
   (define tc7-bytevector 77)
+  (define tc7-bitvector 95)
 
   (let ((word-size (asm-word-size asm))
         (endianness (asm-endianness asm)))
@@ -1023,18 +1031,26 @@ should be .data or .rodata), and return the resulting linker object.
         (write-immediate asm buf pos #f))
 
        ((simple-uniform-vector? obj)
-        (let ((tag (logior tc7-bytevector
+        (let ((tag (if (bitvector? obj)
-                           (ash (uniform-vector-element-type-code obj) 7))))
+                       tc7-bitvector
+                       (let ((type-code (uniform-vector-element-type-code obj)))
+                         (logior tc7-bytevector (ash type-code 7))))))
           (case word-size
             ((4)
              (bytevector-u32-set! buf pos tag endianness)
-             (bytevector-u32-set! buf (+ pos 4) (bytevector-length obj)
+             (bytevector-u32-set! buf (+ pos 4)
+                                  (if (bitvector? obj)
+                                      (bitvector-length obj)
+                                      (bytevector-length obj))
                                   endianness)                 ; length
              (bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer
              (write-immediate asm buf (+ pos 12) #f))         ; owner
             ((8)
              (bytevector-u64-set! buf pos tag endianness)
-             (bytevector-u64-set! buf (+ pos 8) (bytevector-length obj)
+             (bytevector-u64-set! buf (+ pos 8)
+                                  (if (bitvector? obj)
+                                      (bitvector-length obj)
+                                      (bytevector-length obj))
                                   endianness)                  ; length
              (bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer
              (write-immediate asm buf (+ pos 24) #f))          ; owner
@@ -1043,7 +1059,7 @@ should be .data or .rodata), and return the resulting linker object.
        ((uniform-vector-backing-store? obj)
         (let ((bv (uniform-vector-backing-store-bytes obj)))
           (bytevector-copy! bv 0 buf pos (bytevector-length bv))
-          (unless (or (= 1 (uniform-vector-element-size bv))
+          (unless (or (= 1 (uniform-vector-backing-store-element-size obj))
                       (eq? endianness (native-endianness)))
             ;; Need to swap units of element-size bytes
             (error "FIXME: Implement byte order swap"))))

module/system/vm/disassembler.scm

@@ -225,6 +225,7 @@ address of that offset."
                         ((13) "vector?")
                         ((15) "string?")
                         ((77) "bytevector?")
+                        ((95) "bitvector?")
                         (else (number->string tc7)))))
              (if invert? (string-append "not " tag) tag))
            (vector-ref labels (- (+ offset target) start))))