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 :)

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.  */
 

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);

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.")

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);

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"

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

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))

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))))
 

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!