From 8e653625fb56a1810174fba407d90000c5ec43de Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 26 Apr 2014 08:00:13 -0700 Subject: [PATCH] Fix string-head! to hide the unused (non-marked) words. This quiets 3 of the 17 complaints from verify_heap during `make check'. The remaining 14 appear to be caused by SIGFPE recovery. --- src/runtime/string.scm | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/src/runtime/string.scm b/src/runtime/string.scm index f7279c8fe..04b2d5f9e 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -173,19 +173,31 @@ USA. (define %string-head! (let ((reuse - (lambda (string end) + (named-lambda (%string-head! string end) (declare (no-type-checks) (no-range-checks)) (let ((mask (set-interrupt-enables! interrupt-mask/none))) (if (fix:< end (string-length string)) (begin (string-set! string end #\nul) (set-string-length! string end))) - ((ucode-primitive primitive-object-set! 3) - string - 0 - ((ucode-primitive primitive-object-set-type 2) - (ucode-type manifest-nm-vector) - (fix:+ 2 (fix:lsh end %octets->words-shift)))) + (string-set! string end #\nul) + (set-string-length! string end) + (let ((new-gc-length (fix:+ 2 (fix:lsh end %octets->words-shift))) + (old-gc-length (system-vector-length string))) + (let ((delta (fix:- old-gc-length new-gc-length))) + (cond ((fix:= delta 1) + (system-vector-set! string new-gc-length #f)) + ((fix:> delta 1) + (system-vector-set! + string new-gc-length + ((ucode-primitive primitive-object-set-type 2) + (ucode-type manifest-nm-vector) (fix:-1+ delta))))) + (if (fix:> delta 0) + ((ucode-primitive primitive-object-set! 3) + string + 0 + ((ucode-primitive primitive-object-set-type 2) + (ucode-type manifest-nm-vector) new-gc-length))))) (set-interrupt-enables! mask) string)))) (if (compiled-procedure? reuse) -- 2.25.1