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

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!