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"