[Guile-commits] GNU Guile branch, master, updated. 782a82eed13abb64393f7acad92758ae191ce509

[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=782a82eed13abb64393f7acad92758ae191ce509

The branch, master has been updated
       via  782a82eed13abb64393f7acad92758ae191ce509 (commit)
      from  a9b0f876c12bbbca9bdf1890eb014a30f004d9f8 (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 782a82eed13abb64393f7acad92758ae191ce509
Author: Andy Wingo <address@hidden>
Date:   Fri Jun 5 16:31:38 2009 +0200

    add ability to compile uniform arrays
    
    * module/rnrs/bytevector.scm (rnrs):
    * libguile/bytevectors.h:
    * libguile/bytevectors.c (scm_uniform_array_to_bytevector): New function.
    
    * libguile/unif.h:
    * libguile/unif.c (scm_from_contiguous_typed_array): New function.
    
    * libguile/vm-i-loader.c (load-array): New instruction, for loading byte
      data into uniform vectors. Currently it copies out the data, though in
      the future we could avoid that.
    
    * module/language/assembly.scm (align-code): New exported function,
      aligns code on some boundary.
      (align-program): Use align-code.
    
    * module/language/assembly/compile-bytecode.scm (write-bytecode): Support
      the load-array instruction.
    
    * module/language/glil/compile-assembly.scm (dump-object): Dump uniform
      arrays. Neat :)

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

Summary of changes:
 libguile/bytevectors.c                        |   33 +++++++++++++++++
 libguile/bytevectors.h                        |    2 +
 libguile/unif.c                               |   47 +++++++++++++++++++++++++
 libguile/unif.h                               |    3 ++
 libguile/vm-i-loader.c                        |   14 +++++++
 module/language/assembly.scm                  |   20 +++++++----
 module/language/assembly/compile-bytecode.scm |    6 +++
 module/language/glil/compile-assembly.scm     |   11 ++++++
 module/rnrs/bytevector.scm                    |    5 ++-
 9 files changed, 132 insertions(+), 9 deletions(-)

diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 4c3a353..ced1b08 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -29,6 +29,8 @@
 #include "libguile/strings.h"
 #include "libguile/validate.h"
 #include "libguile/ieee-754.h"
+#include "libguile/unif.h"
+#include "libguile/srfi-4.h"
 
 #include <byteswap.h>
 #include <striconveh.h>
@@ -511,6 +513,37 @@ SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 
0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
+            1, 0, 0, (SCM array),
+           "Return a newly allocated bytevector whose contents\n"
+            "will be copied from the uniform array @var{array}.")
+#define FUNC_NAME s_scm_uniform_array_to_bytevector
+{
+  SCM contents, ret;
+  size_t len;
+  scm_t_array_handle h;
+  const void *base;
+  size_t sz;
+  
+  contents = scm_array_contents (array, SCM_BOOL_T);
+  if (scm_is_false (contents))
+    scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
+
+  scm_array_get_handle (contents, &h);
+
+  base = scm_array_handle_uniform_elements (&h);
+  len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
+  sz = scm_array_handle_uniform_element_size (&h);
+
+  ret = make_bytevector (len * sz);
+  memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz);
+
+  scm_array_handle_release (&h);
+
+  return ret;
+}
+#undef FUNC_NAME
+
 
 /* Operations on bytes and octets.  */
 
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 98c38ac..b01116c 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -46,6 +46,8 @@ SCM_API SCM scm_bytevector_fill_x (SCM, SCM);
 SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM);
 SCM_API SCM scm_bytevector_copy (SCM);
 
+SCM_API SCM scm_uniform_array_to_bytevector (SCM);
+
 SCM_API SCM scm_bytevector_to_u8_list (SCM);
 SCM_API SCM scm_u8_list_to_bytevector (SCM);
 SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM);
diff --git a/libguile/unif.c b/libguile/unif.c
index daf0850..4013f29 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -770,6 +770,53 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 
0, 1,
 }
 #undef FUNC_NAME
 
+SCM
+scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
+                                 size_t byte_len)
+#define FUNC_NAME "scm_from_contiguous_typed_array"
+{
+  size_t k, rlen = 1;
+  scm_t_array_dim *s;
+  creator_proc *creator;
+  SCM ra;
+  scm_t_array_handle h;
+  void *base;
+  size_t sz;
+  
+  creator = type_to_creator (type);
+  ra = scm_i_shap2ra (bounds);
+  SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
+  s = SCM_I_ARRAY_DIMS (ra);
+  k = SCM_I_ARRAY_NDIM (ra);
+
+  while (k--)
+    {
+      s[k].inc = rlen;
+      SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
+      rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
+    }
+  SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), SCM_UNDEFINED);
+
+
+  scm_array_get_handle (ra, &h);
+  base = scm_array_handle_uniform_writable_elements (&h);
+  sz = scm_array_handle_uniform_element_size (&h);
+  scm_array_handle_release (&h);
+
+  if (byte_len % sz)
+    SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
+  if (byte_len / sz != rlen)
+    SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+
+  memcpy (base, bytes, byte_len);
+
+  if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+    if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+      return SCM_I_ARRAY_V (ra);
+  return ra;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
            (SCM fill, SCM bounds),
            "Create and return an array.")
diff --git a/libguile/unif.h b/libguile/unif.h
index a09bfc9..1d01f80 100644
--- a/libguile/unif.h
+++ b/libguile/unif.h
@@ -45,6 +45,9 @@ SCM_API SCM scm_array_p (SCM v, SCM prot);
 SCM_API SCM scm_typed_array_p (SCM v, SCM type);
 SCM_API SCM scm_make_array (SCM fill, SCM bounds);
 SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
+SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
+                                             const void *bytes,
+                                             size_t byte_len);
 SCM_API SCM scm_array_rank (SCM ra);
 SCM_API size_t scm_c_array_rank (SCM ra);
 SCM_API SCM scm_array_dimensions (SCM ra);
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index b231d39..50569e0 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -15,6 +15,7 @@
  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  */
 
+/* FIXME! Need to check that the fetch is within the current program */
 
 /* This file is included in vm_engine.c */
 
@@ -143,6 +144,19 @@ VM_DEFINE_LOADER (67, define, "define")
   NEXT;
 }
 
+VM_DEFINE_LOADER (68, load_array, "load-array")
+{
+  SCM type, shape;
+  size_t len;
+  FETCH_LENGTH (len);
+  POP (shape);
+  POP (type);
+  SYNC_REGISTER ();
+  PUSH (scm_from_contiguous_typed_array (type, shape, ip, len));
+  ip += len;
+  NEXT;
+}
+
 /*
 (defun renumber-ops ()
   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 28dde1e..3ffbf11 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -20,11 +20,12 @@
 ;;; Code:
 
 (define-module (language assembly)
+  #:use-module (rnrs bytevector)
   #:use-module (system base pmatch)
   #:use-module (system vm instruction)
   #:use-module ((srfi srfi-1) #:select (fold))
   #:export (byte-length
-            addr+ align-program
+            addr+ align-program align-code
             assembly-pack assembly-unpack
             object->assembly assembly->object))
 
@@ -50,6 +51,8 @@
      (+ 1 *len-len* (string-length str)))
     ((load-keyword ,str)
      (+ 1 *len-len* (string-length str)))
+    ((load-array ,bv)
+     (+ 1 *len-len* (bytevector-length bv)))
     ((define ,str)
      (+ 1 *len-len* (string-length str)))
     ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
@@ -66,13 +69,16 @@
         addr
         code))
 
-(define (align-program prog addr)
-  `(,@(make-list (modulo (- *program-alignment*
-                            (modulo (1+ addr) *program-alignment*))
-                         ;; plus the one for the load-program inst itself
-                         *program-alignment*)
+
+(define (align-code code addr alignment header-len)
+  `(,@(make-list (modulo (- alignment
+                            (modulo (+ addr header-len) alignment))
+                         alignment)
                  '(nop))
-    ,prog))
+    ,code))
+
+(define (align-program prog addr)
+  (align-code prog addr *program-alignment* 1))
 
 ;;;
 ;;; Code compress/decompression
diff --git a/module/language/assembly/compile-bytecode.scm 
b/module/language/assembly/compile-bytecode.scm
index 00a324c..e4458a9 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -24,6 +24,7 @@
   #:use-module (language assembly)
   #:use-module (system vm instruction)
   #:use-module (srfi srfi-4)
+  #:use-module (rnrs bytevector)
   #:use-module ((srfi srfi-1) #:select (fold))
   #:use-module ((system vm objcode) #:select (byte-order))
   #:export (compile-bytecode write-bytecode))
@@ -72,6 +73,10 @@
   (define (write-loader str)
     (write-loader-len (string-length str))
     (write-string str))
+  (define (write-bytevector bv)
+    (write-loader-len (bytevector-length bv))
+    ;; Ew!
+    (for-each write-byte (bytevector->u8-list bv)))
   (define (write-break label)
     (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2))))
   
@@ -113,6 +118,7 @@
         ((load-string ,str) (write-loader str))
         ((load-symbol ,str) (write-loader str))
         ((load-keyword ,str) (write-loader str))
+        ((load-array ,bv) (write-bytevector bv))
         ((define ,str) (write-loader str))
         ((br ,l) (write-break l))
         ((br-if ,l) (write-break l))
diff --git a/module/language/glil/compile-assembly.scm 
b/module/language/glil/compile-assembly.scm
index 1fb10c1..dcdbc51 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -28,6 +28,7 @@
   #:use-module ((system vm program) #:select (make-binding))
   #:use-module (ice-9 receive)
   #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (rnrs bytevector)
   #:export (compile-assembly))
 
 ;; Variable cache cells go in the object table, and serialize as their
@@ -393,6 +394,16 @@
             (let ((code (dump-object (vector-ref x i) addr)))
               (dump-objects (1+ i) (cons code codes)
                             (addr+ addr code)))))))
+   ((and (array? x) (symbol? (array-type x)))
+    (let* ((type (dump-object (array-type x) addr))
+           (shape (dump-object (array-shape x) (addr+ addr type))))
+      `(,@type
+        ,@shape
+        ,@(align-code
+           `(load-array ,(uniform-array->bytevector x))
+           (addr+ (addr+ addr type) shape)
+           8
+           4))))
    (else
     (error "assemble: unrecognized object" x))))
 
diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm
index 793cbc0..7728a15 100644
--- a/module/rnrs/bytevector.scm
+++ b/module/rnrs/bytevector.scm
@@ -32,8 +32,9 @@
   :export-syntax (endianness)
   :export (native-endianness bytevector?
            make-bytevector bytevector-length bytevector=? bytevector-fill!
-           bytevector-copy! bytevector-copy bytevector-u8-ref
-           bytevector-s8-ref
+           bytevector-copy! bytevector-copy
+           uniform-array->bytevector
+           bytevector-u8-ref bytevector-s8-ref
            bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
            u8-list->bytevector
            bytevector-uint-ref bytevector-uint-set!


hooks/post-receive
-- 
GNU Guile