From d65514a2de2ef922d3613f0e35dea27a88313392 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Nov 2013 21:45:34 +0100 Subject: [PATCH] RTL compiler supports static bitvectors * libguile/arrays.c (scm_from_contiguous_typed_array): * libguile/bytevectors.c (scm_uniform_array_to_bytevector): For bitvectors, round up the length to 32-bit units, as they are stored internally. Otherwise I think this probably does the wrong thing for the last word on big-endian systems. * libguile/bitvectors.c (BITVECTOR_LENGTH, BITVECTOR_BITS): (scm_c_make_bitvector): Reorder the length and pointer words to match the layout of bytevectors. * module/language/cps/primitives.scm (*branching-primcall-arities*): * module/system/vm/assembler.scm (br-if-bitvector): * module/system/vm/disassembler.scm (code-annotation): Add bitvector test support. * module/system/vm/assembler.scm (): Add an element-size field. (intern-constant): Adapt make-uniform-vector-backing-store call. Use uniform-array->bytevector, as the old compiler did. (link-data): Add bitvector cases. --- libguile/arrays.c | 7 +++--- libguile/bitvectors.c | 8 +++---- libguile/bytevectors.c | 5 +++-- module/language/cps/primitives.scm | 1 + module/system/vm/assembler.scm | 34 ++++++++++++++++++++++-------- module/system/vm/disassembler.scm | 1 + 6 files changed, 38 insertions(+), 18 deletions(-) diff --git a/libguile/arrays.c b/libguile/arrays.c index 83d7db2b9..98c8075e9 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005, - * 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -242,8 +242,9 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, } else if (sz < 8) { - /* byte_len ?= ceil (rlen * sz / 8) */ - if (byte_len != (rlen * sz + 7) / 8) + /* Elements of sub-byte size (bitvectors) are addressed in 32-bit + units. */ + if (byte_len != ((rlen * sz + 31) / 32) * 4) SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); } else diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index ffea6d182..2eef1dc56 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -39,8 +39,8 @@ */ #define IS_BITVECTOR(obj) SCM_TYP16_PREDICATE(scm_tc7_bitvector,(obj)) -#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_1(obj)) -#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_2(obj)) +#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj)) +#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_2(obj)) int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate) @@ -110,7 +110,7 @@ scm_c_make_bitvector (size_t len, SCM fill) bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len, "bitvector"); - res = scm_double_cell (scm_tc7_bitvector, (scm_t_bits)bits, len, 0); + res = scm_double_cell (scm_tc7_bitvector, len, (scm_t_bits)bits, 0); if (!SCM_UNBNDP (fill)) scm_bitvector_fill_x (res, fill); diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index f91b8451c..064c427ed 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -649,8 +649,9 @@ SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector", if (sz >= 8 && ((sz % 8) == 0)) byte_len = len * (sz / 8); else if (sz < 8) - /* byte_len = ceil (len * sz / 8) */ - byte_len = (len * sz + 7) / 8; + /* Elements of sub-byte size (bitvectors) are addressed in 32-bit + units. */ + byte_len = ((len * sz + 31) / 32) * 4; else /* an internal guile error, really */ SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL); diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index ac0d336a1..323f62371 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -75,6 +75,7 @@ (vector? . (1 . 1)) (symbol? . (1 . 1)) (variable? . (1 . 1)) + (bitvector? . (1 . 1)) (bytevector? . (1 . 1)) (char? . (1 . 1)) (eq? . (1 . 2)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index abfd5fbc2..0e3c3cd47 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -531,9 +531,10 @@ list of lists. This procedure can be called many times before calling (code static-procedure-code)) (define-record-type - (make-uniform-vector-backing-store bytes) + (make-uniform-vector-backing-store bytes element-size) uniform-vector-backing-store? - (bytes uniform-vector-backing-store-bytes)) + (bytes uniform-vector-backing-store-bytes) + (element-size uniform-vector-backing-store-element-size)) (define-record-type (make-cache-cell scope key) @@ -603,7 +604,13 @@ table, its existing label is used directly." ((uniform-vector-backing-store? obj) '()) ((simple-uniform-vector? obj) `((static-patch! ,label 2 - ,(recur (make-uniform-vector-backing-store obj))))) + ,(recur (make-uniform-vector-backing-store + (uniform-array->bytevector obj) + (if (bitvector? obj) + ;; Bitvectors are addressed in + ;; 32-bit units. + 4 + (uniform-vector-element-size obj))))))) (else (error "don't know how to intern" obj)))) (cond @@ -709,7 +716,7 @@ returned instead." ;(define-tc7-macro-assembler br-if-weak-set 85) ;(define-tc7-macro-assembler br-if-weak-table 87) ;(define-tc7-macro-assembler br-if-array 93) -;(define-tc7-macro-assembler br-if-bitvector 95) +(define-tc7-macro-assembler br-if-bitvector 95) ;(define-tc7-macro-assembler br-if-port 125) ;(define-tc7-macro-assembler br-if-smob 127) @@ -901,6 +908,7 @@ should be .data or .rodata), and return the resulting linker object. (define tc7-ro-string (+ 21 #x200)) (define tc7-rtl-program 69) (define tc7-bytevector 77) + (define tc7-bitvector 95) (let ((word-size (asm-word-size asm)) (endianness (asm-endianness asm))) @@ -1023,18 +1031,26 @@ should be .data or .rodata), and return the resulting linker object. (write-immediate asm buf pos #f)) ((simple-uniform-vector? obj) - (let ((tag (logior tc7-bytevector - (ash (uniform-vector-element-type-code obj) 7)))) + (let ((tag (if (bitvector? obj) + tc7-bitvector + (let ((type-code (uniform-vector-element-type-code obj))) + (logior tc7-bytevector (ash type-code 7)))))) (case word-size ((4) (bytevector-u32-set! buf pos tag endianness) - (bytevector-u32-set! buf (+ pos 4) (bytevector-length obj) + (bytevector-u32-set! buf (+ pos 4) + (if (bitvector? obj) + (bitvector-length obj) + (bytevector-length obj)) endianness) ; length (bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer (write-immediate asm buf (+ pos 12) #f)) ; owner ((8) (bytevector-u64-set! buf pos tag endianness) - (bytevector-u64-set! buf (+ pos 8) (bytevector-length obj) + (bytevector-u64-set! buf (+ pos 8) + (if (bitvector? obj) + (bitvector-length obj) + (bytevector-length obj)) endianness) ; length (bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer (write-immediate asm buf (+ pos 24) #f)) ; owner @@ -1043,7 +1059,7 @@ should be .data or .rodata), and return the resulting linker object. ((uniform-vector-backing-store? obj) (let ((bv (uniform-vector-backing-store-bytes obj))) (bytevector-copy! bv 0 buf pos (bytevector-length bv)) - (unless (or (= 1 (uniform-vector-element-size bv)) + (unless (or (= 1 (uniform-vector-backing-store-element-size obj)) (eq? endianness (native-endianness))) ;; Need to swap units of element-size bytes (error "FIXME: Implement byte order swap")))) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 82e0f4dc1..1683b685d 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -225,6 +225,7 @@ address of that offset." ((13) "vector?") ((15) "string?") ((77) "bytevector?") + ((95) "bitvector?") (else (number->string tc7))))) (if invert? (string-append "not " tag) tag)) (vector-ref labels (- (+ offset target) start))))