mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-18 01:30:27 +02:00
All literal constants are read-only
* libguile/array-handle.c (initialize_vector_handle): Add mutable_p argument. Unless the vector handle is mutable, null out its writable_elements member. (scm_array_get_handle): Adapt to determine mutability of the various arrays. (scm_array_handle_elements, scm_array_handle_writable_elements): Reverse the sense: instead of implementing read-only in terms of read-write, go the other way around, adding an assertion in the read-write case that the array handle is mutable. * libguile/array-map.c (racp): Assert that the destination is mutable. * libguile/bitvectors.c (SCM_F_BITVECTOR_IMMUTABLE, IS_BITVECTOR): (IS_MUTABLE_BITVECTOR): Add a flag to indicate immutability. (scm_i_bitvector_bits): Fix indentation. (scm_i_is_mutable_bitvector): New helper. (scm_array_handle_bit_elements) ((scm_array_handle_bit_writable_elements): Build writable_elements in terms of elements. (scm_bitvector_elements, scm_bitvector_writable_elements): Likewise. (scm_c_bitvector_set_x): Require a mutable bitvector for the fast-path. (scm_bitvector_to_list, scm_bit_count): Use read-only elements() function. * libguile/bitvectors.h (scm_i_is_mutable_bitvector): New decl. * libguile/bytevectors.c (INTEGER_ACCESSOR_PROLOGUE): (INTEGER_GETTER_PROLOGUE, INTEGER_SETTER_PROLOGUE): (INTEGER_REF, INTEGER_NATIVE_REF, INTEGER_SET, INTEGER_NATIVE_SET): (GENERIC_INTEGER_ACCESSOR_PROLOGUE): (GENERIC_INTEGER_GETTER_PROLOGUE, GENERIC_INTEGER_SETTER_PROLOGUE): (LARGE_INTEGER_NATIVE_REF, LARGE_INTEGER_NATIVE_SET): (IEEE754_GETTER_PROLOGUE, IEEE754_SETTER_PROLOGUE): (IEEE754_REF, IEEE754_NATIVE_REF, IEEE754_SET, IEEE754_NATIVE_SET): Setters require a mutable bytevector. (SCM_BYTEVECTOR_SET_FLAG): New helper. (SCM_BYTEVECTOR_SET_CONTIGUOUS_P, SCM_BYTEVECTOR_SET_ELEMENT_TYPE): Remove helpers. (SCM_VALIDATE_MUTABLE_BYTEVECTOR): New helper. (make_bytevector, make_bytevector_from_buffer): Use SCM_SET_BYTEVECTOR_FLAGS. (scm_c_bytevector_set_x, scm_bytevector_fill_x) (scm_bytevector_copy_x): Require a mutable bytevector. * libguile/bytevectors.h (SCM_F_BYTEVECTOR_CONTIGUOUS) (SCM_F_BYTEVECTOR_IMMUTABLE, SCM_MUTABLE_BYTEVECTOR_P): New definitions. * libguile/bytevectors.h (SCM_BYTEVECTOR_CONTIGUOUS_P): Just access one bit. * libguile/srfi-4.c (DEFINE_SRFI_4_C_FUNCS): Implement writable_elements() in terms of elements(). * libguile/strings.c (scm_i_string_is_mutable): New helper. * libguile/uniform.c (scm_array_handle_uniform_elements): (scm_array_handle_uniform_writable_elements): Implement writable_elements in terms of elements. * libguile/vectors.c (SCM_VALIDATE_MUTABLE_VECTOR): New helper. (scm_vector_elements, scm_vector_writable_elements): Implement writable_elements in terms of elements. (scm_c_vector_set_x): Require a mutable vector. * libguile/vectors.h (SCM_F_VECTOR_IMMUTABLE, SCM_I_IS_MUTABLE_VECTOR): New definitions. * libguile/vm-engine.c (VM_VALIDATE_MUTABLE_BYTEVECTOR): (VM_VALIDATE_MUTABLE_VECTOR, vector-set!, vector-set!/immediate) (BV_BOUNDED_SET, BV_SET): Require mutable bytevector/vector. * libguile/vm.c (vm_error_not_a_mutable_bytevector): (vm_error_not_a_mutable_vector): New definitions. * module/system/vm/assembler.scm (link-data): Mark residualized vectors, bytevectors, and bitvectors as being read-only.
This commit is contained in:
parent
6e573a0885
commit
7ed54fd36d
15 changed files with 237 additions and 131 deletions
|
@ -1392,17 +1392,27 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
(+ address
|
||||
(modulo (- alignment (modulo address alignment)) alignment)))
|
||||
|
||||
(define tc7-vector 13)
|
||||
(define tc7-vector #x0d)
|
||||
(define vector-immutable-flag #x80)
|
||||
|
||||
(define tc7-string #x15)
|
||||
(define string-read-only-flag #x200)
|
||||
|
||||
(define tc7-stringbuf #x27)
|
||||
(define stringbuf-wide-flag #x400)
|
||||
(define tc7-stringbuf 39)
|
||||
(define tc7-narrow-stringbuf tc7-stringbuf)
|
||||
(define tc7-wide-stringbuf (+ tc7-stringbuf stringbuf-wide-flag))
|
||||
(define tc7-ro-string (+ 21 #x200))
|
||||
|
||||
(define tc7-syntax #x3d)
|
||||
(define tc7-program 69)
|
||||
(define tc7-bytevector 77)
|
||||
(define tc7-bitvector 95)
|
||||
(define tc7-array 93)
|
||||
|
||||
(define tc7-program #x45)
|
||||
|
||||
(define tc7-bytevector #x4d)
|
||||
;; This flag is intended to be left-shifted by 7 bits.
|
||||
(define bytevector-immutable-flag #x200)
|
||||
|
||||
(define tc7-array #x5d)
|
||||
|
||||
(define tc7-bitvector #x5f)
|
||||
(define bitvector-immutable-flag #x80)
|
||||
|
||||
(let ((word-size (asm-word-size asm))
|
||||
(endianness (asm-endianness asm)))
|
||||
|
@ -1447,9 +1457,10 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
((stringbuf? obj)
|
||||
(let* ((x (stringbuf-string obj))
|
||||
(len (string-length x))
|
||||
(tag (if (= (string-bytes-per-char x) 1)
|
||||
tc7-narrow-stringbuf
|
||||
tc7-wide-stringbuf)))
|
||||
(tag (logior tc7-stringbuf
|
||||
(if (= (string-bytes-per-char x) 1)
|
||||
0
|
||||
stringbuf-wide-flag))))
|
||||
(case word-size
|
||||
((4)
|
||||
(bytevector-u32-set! buf pos tag endianness)
|
||||
|
@ -1491,15 +1502,15 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
(write-placeholder asm buf pos))
|
||||
|
||||
((string? obj)
|
||||
(let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused?
|
||||
(let ((tag (logior tc7-string string-read-only-flag)))
|
||||
(case word-size
|
||||
((4)
|
||||
(bytevector-u32-set! buf pos tc7-ro-string endianness)
|
||||
(bytevector-u32-set! buf pos tag endianness)
|
||||
(write-placeholder asm buf (+ pos 4)) ; stringbuf
|
||||
(bytevector-u32-set! buf (+ pos 8) 0 endianness)
|
||||
(bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness))
|
||||
((8)
|
||||
(bytevector-u64-set! buf pos tc7-ro-string endianness)
|
||||
(bytevector-u64-set! buf pos tag endianness)
|
||||
(write-placeholder asm buf (+ pos 8)) ; stringbuf
|
||||
(bytevector-u64-set! buf (+ pos 16) 0 endianness)
|
||||
(bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness))
|
||||
|
@ -1511,7 +1522,7 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
|
||||
((simple-vector? obj)
|
||||
(let* ((len (vector-length obj))
|
||||
(tag (logior tc7-vector (ash len 8))))
|
||||
(tag (logior tc7-vector vector-immutable-flag (ash len 8))))
|
||||
(case word-size
|
||||
((4) (bytevector-u32-set! buf pos tag endianness))
|
||||
((8) (bytevector-u64-set! buf pos tag endianness))
|
||||
|
@ -1546,9 +1557,14 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
|
||||
((simple-uniform-vector? obj)
|
||||
(let ((tag (if (bitvector? obj)
|
||||
tc7-bitvector
|
||||
(let ((type-code (array-type-code obj)))
|
||||
(logior tc7-bytevector (ash type-code 7))))))
|
||||
(logior tc7-bitvector
|
||||
bitvector-immutable-flag)
|
||||
(logior tc7-bytevector
|
||||
;; Bytevector immutable flag also shifted
|
||||
;; left.
|
||||
(ash (logior bytevector-immutable-flag
|
||||
(array-type-code obj))
|
||||
7)))))
|
||||
(case word-size
|
||||
((4)
|
||||
(bytevector-u32-set! buf pos tag endianness)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue