summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-06-05 16:31:38 +0200
committerAndy Wingo <wingo@pobox.com>2009-06-05 16:31:38 +0200
commit782a82eed13abb64393f7acad92758ae191ce509 (patch)
tree517a209c703d8810789dbdf3cfc23a835e21e5b1
parenta9b0f876c12bbbca9bdf1890eb014a30f004d9f8 (diff)
downloadguile-782a82eed13abb64393f7acad92758ae191ce509.tar.gz
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 :)
-rw-r--r--libguile/bytevectors.c33
-rw-r--r--libguile/bytevectors.h2
-rw-r--r--libguile/unif.c47
-rw-r--r--libguile/unif.h3
-rw-r--r--libguile/vm-i-loader.c14
-rw-r--r--module/language/assembly.scm20
-rw-r--r--module/language/assembly/compile-bytecode.scm6
-rw-r--r--module/language/glil/compile-assembly.scm11
-rw-r--r--module/rnrs/bytevector.scm5
9 files changed, 132 insertions, 9 deletions
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 4c3a353a1..ced1b082f 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 98c38aca2..b01116ce6 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 daf085007..4013f29b8 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 a09bfc921..1d01f807d 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 b231d392f..50569e01a 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 28dde1e1a..3ffbf11f1 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 00a324c31..e4458a992 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 1fb10c146..dcdbc5133 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 793cbc020..7728a1581 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!