[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-328-gd65514a

[Andy Wingo]

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=d65514a2de2ef922d3613f0e35dea27a88313392

The branch, wip-rtl-halloween has been updated
       via  d65514a2de2ef922d3613f0e35dea27a88313392 (commit)
       via  9ae9debbd35505ef4040c1a876f7bd64434d6d14 (commit)
      from  92afe25d5c162c29d971c2c36bd04a5b9d0b29c5 (commit)

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 d65514a2de2ef922d3613f0e35dea27a88313392
Author: Andy Wingo <address@hidden>
Date:   Sun Nov 3 21:45:34 2013 +0100

    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.

commit 9ae9debbd35505ef4040c1a876f7bd64434d6d14
Author: Andy Wingo <address@hidden>
Date:   Sun Nov 3 20:24:54 2013 +0100

    struct-set! returns a value, yuck
    
    * module/language/cps/arities.scm (fix-clause-arities): Add a hack to
      ensure that (struct-set! OBJ POS VAL) evaluates to VAL.  Yuck.

-----------------------------------------------------------------------

Summary of changes:
 libguile/arrays.c                  |    7 ++++---
 libguile/bitvectors.c              |    8 ++++----
 libguile/bytevectors.c             |    5 +++--
 module/language/cps/arities.scm    |   30 ++++++++++++++++++++++++++++++
 module/language/cps/primitives.scm |    1 +
 module/system/vm/assembler.scm     |   34 +++++++++++++++++++++++++---------
 module/system/vm/disassembler.scm  |    1 +
 7 files changed, 68 insertions(+), 18 deletions(-)

diff --git a/libguile/arrays.c b/libguile/arrays.c
index 83d7db2..98c8075 100644
--- a/libguile/arrays.c
+++ b/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) */
-      if (byte_len != (rlen * sz + 7) / 8)
+      /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+         units.  */
+      if (byte_len != ((rlen * sz + 31) / 32) * 4)
         SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
     }
   else
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index ffea6d1..2eef1dc 100644
--- a/libguile/bitvectors.c
+++ b/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_2(obj))
+#define BITVECTOR_LENGTH(obj)   ((size_t)SCM_CELL_WORD_1(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);
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index f91b845..064c427 100644
--- a/libguile/bytevectors.c
+++ b/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) */
-    byte_len = (len * sz + 7) / 8;
+    /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+       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);
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 51b1892..fb888fd 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -134,6 +134,36 @@
                            (and (not (prim-rtl-instruction name))
                                 (not (branching-primitive? name))))))
          ($continue k ,exp))
+        (($ $primcall 'struct-set! (obj pos val))
+         ;; Unhappily, and undocumentedly, struct-set! returns the value
+         ;; that was set.  There is code that relies on this.  Hackety
+         ;; hack...
+         ,(rewrite-cps-term (lookup-cont k conts)
+            (($ $ktail)
+             ,(let-gensyms (kvoid)
+                (build-cps-term
+                  ($letk* ((kvoid #f ($kargs () ()
+                                       ($continue ktail
+                                         ($primcall 'return (val))))))
+                    ($continue kvoid ,exp)))))
+            (($ $ktrunc arity kargs)
+             ,(rewrite-cps-term arity
+                (($ $arity () () #f () #f)
+                 ($continue kargs ,exp))
+                (_
+                 ,(let-gensyms (kvoid)
+                    (build-cps-term
+                      ($letk* ((kvoid #f ($kargs () ()
+                                           ($continue k
+                                             ($primcall 'values (val))))))
+                        ($continue kvoid ,exp)))))))
+            (($ $kargs () () _)
+             ($continue k ,exp))
+            (_
+             ,(let-gensyms (k*)
+                (build-cps-term
+                  ($letk ((k* #f ($kargs () () ($continue k ($var val)))))
+                    ($continue k* ,exp)))))))
         (($ $primcall name args)
          ,(match (prim-arity name)
             ((out . in)
diff --git a/module/language/cps/primitives.scm 
b/module/language/cps/primitives.scm
index ac0d336..323f623 100644
--- a/module/language/cps/primitives.scm
+++ b/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))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index abfd5fb..0e3c3cd 100644
--- a/module/system/vm/assembler.scm
+++ b/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
-                           (ash (uniform-vector-element-type-code obj) 7))))
+        (let ((tag (if (bitvector? obj)
+                       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"))))
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index 82e0f4d..1683b68 100644
--- a/module/system/vm/disassembler.scm
+++ b/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))))


hooks/post-receive
-- 
GNU Guile