diff options
author | Andy Wingo <wingo@pobox.com> | 2009-06-05 16:31:38 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-06-05 16:31:38 +0200 |
commit | 782a82eed13abb64393f7acad92758ae191ce509 (patch) | |
tree | 517a209c703d8810789dbdf3cfc23a835e21e5b1 | |
parent | a9b0f876c12bbbca9bdf1890eb014a30f004d9f8 (diff) | |
download | guile-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.c | 33 | ||||
-rw-r--r-- | libguile/bytevectors.h | 2 | ||||
-rw-r--r-- | libguile/unif.c | 47 | ||||
-rw-r--r-- | libguile/unif.h | 3 | ||||
-rw-r--r-- | libguile/vm-i-loader.c | 14 | ||||
-rw-r--r-- | module/language/assembly.scm | 20 | ||||
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 6 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 11 | ||||
-rw-r--r-- | module/rnrs/bytevector.scm | 5 |
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! |