diff --git a/contrib/sb-md5/md5.lisp b/contrib/sb-md5/md5.lisp index c8a0f1c2c..fc6679937 100644 --- a/contrib/sb-md5/md5.lisp +++ b/contrib/sb-md5/md5.lisp @@ -124,7 +124,10 @@ where a is the intended low-order byte and d the high-order byte." (defmacro make-ub32-vector (length &rest args) #+lw-int32 `(sys:make-simple-int32-vector ,length ,@args) - #-lw-int32 `(make-array ,length :element-type 'ub32 ,@args)) + #-lw-int32 `(make-array ,length :element-type 'ub32 + ,@(unless (member :initial-element args) + '(:initial-element 0)) + ,@args)) (defmacro ub32-aref (vector index) #+lw-int32 diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index 7c94a430d..0dd5cc3e1 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -517,7 +517,10 @@ (write-string "foo" ouf)) (let ((fd (sb-posix:open (merge-pathnames "read-test.txt" *test-directory*) sb-posix:o-rdonly))) (unwind-protect - (let ((buf (make-array 10 :element-type '(unsigned-byte 8)))) + ;; There is no way to know which lisp array to unpoison in the READ + ;; function because it only has a SAP, not the tagged pointer. + (let ((buf (make-array 10 :element-type '(unsigned-byte 8) + #+ubsan :initial-element #+ubsan 0))) (values (sb-posix:read fd (sb-sys:vector-sap buf) 10) (code-char (aref buf 0)) diff --git a/contrib/sb-posix/strtod.lisp b/contrib/sb-posix/strtod.lisp index 232ce5a3d..53976c618 100644 --- a/contrib/sb-posix/strtod.lisp +++ b/contrib/sb-posix/strtod.lisp @@ -6,7 +6,8 @@ and a secondary value, the number of characters consumed." (flet ((strtod/base-string (chars offset) (declare (simple-base-string chars)) ;; On x86, dx arrays are quicker to make than aliens. - (sb-int:dx-let ((end (make-array 1 :element-type 'sb-ext:word))) + (sb-int:dx-let ((end (make-array 1 :element-type 'sb-ext:word + #+ubsan :initial-element #+ubsan 0))) (sb-sys:with-pinned-objects (chars) (let* ((base (sb-sys:sap+ (sb-sys:vector-sap chars) offset)) (answer diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index fa6b8f066..2b298fca1 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1273,6 +1273,7 @@ possibly temporarily, because it might be used internally." "DEFPRINTER" "*PRINT-IR-NODES-PRETTY*" "AVER" + "AVER-UNPOISONED" "DX-FLET" "DX-LET" "AWHEN" "ACOND" "IT" "BINDING*" "EXTRACT-VAR-DECLS" @@ -3246,6 +3247,7 @@ structure representations" "INSTANCE-LENGTH-SHIFT" "UNBOUND-MARKER-WIDETAG" "UNDEFINED-FUNCTION-TRAP" + "%UNPOISON" "NO-TLS-VALUE-MARKER-WIDETAG" "UNSIGNED-REG-SC-NUMBER" "UNSIGNED-STACK-SC-NUMBER" "UNWIND-BLOCK-CODE-SLOT" "UNWIND-BLOCK-CFP-SLOT" diff --git a/src/code/array.lisp b/src/code/array.lisp index e4bdd5d59..d107811a7 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -493,10 +493,16 @@ (t ;; store the function which bears responsibility for creation of this ;; array in case we need to blame it for not initializing. - (set-vector-extra-data (if (= widetag simple-vector-widetag) ; no shadow bits. - vector ; use the LENGTH slot directly - (vector-extra-data vector)) - (ash (sap-ref-word (current-fp) n-word-bytes) 3)) ; XXX: magic + (let* ((return-pc (sap-ref-word (current-fp) n-word-bytes)) + (code (sb-di::code-header-from-pc return-pc)) + (loc (if code + (cons (- return-pc (get-lisp-obj-address code)) code) + '(0 . :unknown)))) + (when (plusp dimension-0) + (set-vector-extra-data (if (= widetag simple-vector-widetag) ; no shadow bits. + vector ; use the LENGTH slot directly + (vector-extra-data vector)) + loc))) (cond ((= widetag simple-vector-widetag) (fill vector (%make-lisp-obj no-tls-value-marker-widetag))) ((array-may-contain-random-bits-p widetag) diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 3a76b5ba0..f0ae68ba4 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -217,6 +217,7 @@ ;; for LENGTH bytes (however bytes are defined). (defun ,constant-bash-name (dst dst-offset length value) (declare (type word value) (type index dst-offset length)) + #+ubsan (unpoison-range dst dst-offset (+ dst-offset length)) (multiple-value-bind (dst-word-offset dst-byte-offset) (floor dst-offset ,bytes-per-word) (declare (type ,word-offset dst-word-offset) @@ -562,6 +563,22 @@ ;; common uses for unary-byte-bashing (defun ,array-copy-name (src src-offset dst dst-offset length) (declare (type index src-offset dst-offset length)) + #+ubsan + (let ((src-bits-per-element + (ash 1 (aref %%simple-array-n-bits-shifts%% (%other-pointer-widetag src)))) + (dst-bits-per-element + (ash 1 (aref %%simple-array-n-bits-shifts%% (%other-pointer-widetag dst))))) + (if (= src-bits-per-element ,bitsize) + (aver-unpoisoned src src-offset (+ src-offset length)) + (error "unhandled bit-bash: bitsize ~d and src ~s" ,bitsize src)) + (cond ((= dst-bits-per-element ,bitsize) + (unpoison-range dst dst-offset (+ dst-offset length))) + ((< ,bitsize dst-bits-per-element) + (aver (zerop dst-offset)) + (aver (zerop (mod (* ,bitsize length) dst-bits-per-element))) + (unpoison-range dst 0 (floor (* ,bitsize length) dst-bits-per-element))) + (t + (error "unhandled bit-bash: bitsize ~d and dst ~s" ,bitsize dst)))) (locally (declare (optimize (speed 3) (safety 1))) (,unary-bash-name src src-offset dst dst-offset length)))))))) @@ -823,3 +840,40 @@ (clear-info :function :inlinep '%bit-position/1) (run-bit-position-assertions) + +;;; If a sanitizer error happens, we can disable it while backtracing +;;; which avoids an infinite cycle of false positives. +(defparameter sb-vm::*ubsan-enable* 0) +(defun aver-unpoisoned (seq &optional (start 0) (end nil)) + (unless (or (typep seq '(or list simple-vector)) ; simple-vector uses a distinct value in the cell + (= sb-vm::*ubsan-enable* 0)) + (aver (typep seq '(simple-array * (*)))) + (let* ((data (truly-the (simple-array * (*)) seq)) + (bits (sb-vm::vector-extra-data data))) + (when (typep bits 'simple-bit-vector) + (when (null end) (setq end (length data))) + (unless (<= 0 start end (length bits)) + (error "Poison check: bad indices")) + (let ((i (position 0 bits :start start :end end))) + (when i + (setq sb-vm::*ubsan-enable* 0) + (error "Sequence operation can't read element ~D of ~S created by ~S" + i data + (vector-extra-data (vector-extra-data seq))))))))) + +(defun unpoison-range (vector start end) + (unless (typep vector '(array t (*))) + (with-array-data ((data vector) (start start) (end end)) + (let ((shadow (vector-extra-data data))) + (when (simple-bit-vector-p shadow) + (if (and (= start 0) (= end (sb-c::vector-length shadow))) + (%unpoison data) + (fill shadow 1 :start start :end end))))))) + +(defun any-poison (vector start end) + (if (typep vector '(array t (*))) + (break "not done yet") + (with-array-data ((data vector) (start start) (end end)) + (let ((shadow (vector-extra-data data))) + (and (simple-bit-vector-p shadow) + (find 0 shadow :start start :end end)))))) diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index 6f1ec7476..63bac4a87 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -17,11 +17,16 @@ ,@(when explicit-check `((declare (explicit-check)))) (do* ((index 0 (1+ index)) (length (length object)) - (result ,constructor) + ;; there's currently no good way advise make-sequence + ;; never to allocate poison bits, so they have to + ;; be removed after-the-fact. + (result #+ubsan (sb-vm:%unpoison ,constructor) + #-ubsan ,constructor) (in-object object)) ((>= index length) result) (declare (fixnum length index)) (declare (type vector result)) + ;; FIXME: use optimized setter for vectors (setf (,access result index) ,(ecase src-type (list '(pop in-object)) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 8cd77fcb5..16dd1a9d8 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1185,28 +1185,27 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition uninitialized-element-error (cell-error) () (:report - (lambda (condition stream) + (lambda (condition stream &aux (*print-array* nil)) ;; NAME is a cons of the array and index (destructuring-bind (array . index) (cell-error-name condition) (declare (ignorable index)) #+ubsan - (let* ((origin-pc - (ash (sb-vm::vector-extra-data - (if (simple-vector-p array) - array - (sb-vm::vector-extra-data array))) - -3)) ; XXX: ubsan magic - (origin-code (sb-di::code-header-from-pc (int-sap origin-pc)))) - (let ((*print-array* nil)) - (format stream "Element ~D of array ~_~S ~_was not assigned a value.~%Origin=~X" - index array (or origin-code origin-pc)))) + (let ((data (sb-vm::vector-extra-data + (if (simple-vector-p array) ; origin is in the extra slot + array + (sb-vm::vector-extra-data array))))) ; else the extra slot of the shadow array + (if (consp data) + (destructuring-bind (pc-offset . codeblob) data + (format stream "Element ~D of array ~_~S ~_was not assigned a value.~%Origin=~A + #x~x" + index array codeblob pc-offset)) + (format stream "Element ~D of array ~_~S ~_was not assigned a value." + index array))) #-ubsan ;; FOLD-INDEX-ADDRESSING could render INDEX wrong. There's no way to know. (let ((*print-array* nil)) (format stream "Uninitialized element accessed in array ~S" array)))))) - ;;; We signal this one for SEQUENCE operations, but INVALID-ARRAY-INDEX-ERROR ;;; for arrays. Might it be better to use the above condition for operations ;;; on SEQUENCEs that happen to be arrays? diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp index f29fa2249..bd4dd9bfa 100644 --- a/src/code/cross-float.lisp +++ b/src/code/cross-float.lisp @@ -450,7 +450,8 @@ ;; floats do NOT satisfy "our" NUMBERP. But we want this to fail, not succeed. (validate-args object) (when (or (arrayp object) (listp object)) - (when (or (member type '(vector simple-vector simple-string simple-base-string list)) + (when (or (member type '(vector simple-vector string simple-string + simple-base-string list)) (equal type '(simple-array character (*)))) (return-from coerce (cl:coerce object type))) ; string or unspecialized array (let ((et (ecase (car type) diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 333330e51..9ddd3094e 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1841,7 +1841,8 @@ register." (setf prev-live (sb-c:read-packed-bit-vector live-set-len blocks i))) (t - (make-array (* live-set-len 8) :element-type 'bit)))) + (make-array (* live-set-len 8) :element-type 'bit + :initial-element 0)))) (step-info (if (logtest sb-c::compiled-code-location-stepping flags) (sb-c:read-var-string blocks i) diff --git a/src/code/debug-var-io.lisp b/src/code/debug-var-io.lisp index 58e11935f..36dcda434 100644 --- a/src/code/debug-var-io.lisp +++ b/src/code/debug-var-io.lisp @@ -310,8 +310,10 @@ ;; Uncompressed (let ((result (make-array (length input) :element-type '(unsigned-byte 8)))) (ub8-bash-copy input 0 result 0 (length input)) + (sb-vm::aver-unpoisoned result) result)) ((> (length input) +max-lz-size+) + (sb-vm::aver-unpoisoned input) input) (t (let* ((length (length input)) @@ -348,4 +350,5 @@ (copy offset 3)))) (t (vector-push-extend byte output)))))) + (sb-vm::aver-unpoisoned (%array-data output) 0 (fill-pointer output)) (%shrink-vector (%array-data output) (fill-pointer output))))))) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 391794435..0e90db6be 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -823,6 +823,8 @@ the current thread are replaced with dummy objects which can safely escape." (*current-level-in-print* 0) (*package* original-package) (*print-pretty* original-print-pretty) + ;; Assume the worst: any array may contain poison values + #+ubsan (*print-array* nil) ;; Clear the circularity machinery to try to to reduce the ;; pain from sharing the circularity table across all ;; streams; if these are not rebound here, then setting diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index fb8a8fbc0..cf247f60d 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1319,6 +1319,7 @@ NOTE: This interface is experimental and subject to change." (macrolet ((true (sym) `(and (boundp ',sym) ,sym))) (let ((*print-readably* nil) + #+ubsan (*print-array* nil) (*print-level* (or (true *print-level*) 6)) (*print-length* (or (true *print-length*) 12)) #-sb-xc-host (*print-vector-length* (or (true *print-vector-length*) 200))) diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp index 5d2014d1c..0b8a4cf03 100644 --- a/src/code/early-pprint.lisp +++ b/src/code/early-pprint.lisp @@ -109,6 +109,8 @@ (defconstant default-line-length 80) +(defmacro make-buffer (n) `(sb-impl::alloc-string character ,n)) + ;; We're allowed to DXify the pretty-stream used by PPRINT-LOGICAL-BLOCK. ;; "pprint-logical-block and the pretty printing stream it creates have ;; dynamic extent. The consequences are undefined if, outside of this @@ -135,7 +137,7 @@ (char-out-oneshot-hook nil :type (or null function)) ;; A simple string holding all the text that has been output but not yet ;; printed. - (buffer (make-string initial-buffer-size) :type (simple-array character (*))) + (buffer (make-buffer initial-buffer-size) :type (simple-array character (*))) ;; The index into BUFFER where more text should be put. (buffer-fill-pointer 0 :type index) ;; Whenever we output stuff from the buffer, we shift the remaining noise @@ -166,12 +168,12 @@ ;; Buffer holding the per-line prefix active at the buffer start. ;; Indentation is included in this. The length of this is stored ;; in the logical block stack. - (prefix (make-string initial-buffer-size) :type (simple-array character (*))) + (prefix (make-buffer initial-buffer-size) :type (simple-array character (*))) ;; Buffer holding the total remaining suffix active at the buffer start. ;; The characters are right-justified in the buffer to make it easier ;; to output the buffer. The length is stored in the logical block ;; stack. - (suffix (make-string initial-buffer-size) :type (simple-array character (*))) + (suffix (make-buffer initial-buffer-size) :type (simple-array character (*))) ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) ;; cons. Adding things to the queue is basically (setf (cdr head) (list diff --git a/src/code/external-formats/enc-basic.lisp b/src/code/external-formats/enc-basic.lisp index 5f3818e3f..debf1a1fb 100644 --- a/src/code/external-formats/enc-basic.lisp +++ b/src/code/external-formats/enc-basic.lisp @@ -11,6 +11,9 @@ (in-package "SB-IMPL") +;;; For efficiency, ensure that C-STRING-TO-STRING returns unpoisoned strings. +;;; (The code is correct without runtime instrumentation) +(declaim (optimize (sb-c::aref-poison-detect 0))) ;;; ASCII diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 4362e043d..093bc02ca 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1823,10 +1823,12 @@ (cond (character-stream-p (setf (ansi-stream-cin-buffer fd-stream) (make-array +ansi-stream-in-buffer-length+ + #+ubsan :initial-element #+ubsan (code-char 0) :element-type 'character))) ((equal target-type '(unsigned-byte 8)) (setf (ansi-stream-in-buffer fd-stream) (make-array +ansi-stream-in-buffer-length+ + #+ubsan :initial-element #+ubsan 0 :element-type '(unsigned-byte 8)))))))) (when output-p diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 4fbe34fdb..a46f9c91b 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -335,11 +335,12 @@ (define-fop 100 :not-host (fop-base-string ((:operands length))) (logically-readonlyize (read-base-string-as-bytes (fasl-input-stream) - (make-string length :element-type 'base-char)))) + (sb-impl::alloc-string base-char length)))) (define-fop 101 :not-host (fop-character-string ((:operands length))) (logically-readonlyize - (read-char-string-as-varints (fasl-input-stream) (make-string length)))) + (read-char-string-as-varints (fasl-input-stream) + (sb-impl::alloc-string character length)))) (define-fop 92 (fop-vector ((:operands size))) (if (zerop size) diff --git a/src/code/icf.lisp b/src/code/icf.lisp index 984cf9869..b2ed10fa5 100644 --- a/src/code/icf.lisp +++ b/src/code/icf.lisp @@ -25,7 +25,7 @@ ;;; Return T if any pointers were replaced in a code object. (defun apply-forwarding-map (map print &aux any-change) - (declare (optimize (sb-c::aref-trapping 0))) + (declare (optimize (sb-c::aref-poison-detect 0))) (when print (let ((*print-pretty* nil)) (dohash ((k v) map) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 4044a65be..da423dd8e 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -1826,14 +1826,14 @@ symbol-case giving up: case=((V U) (F)) (neq ctype *empty-type*)))) ;; Using MAKE-ARRAY avoids a style-warning if et is 'STANDARD-CHAR: ;; "The default initial element #\Nul is not a STANDARD-CHAR." - 'make-array ; hooray! it's known be a valid string type + `(alloc-string ,(constant-form-value element-type) 31) ;; Force a runtime STRINGP check unless futher transforms ;; deduce a known type. You'll get "could not stack allocate" ;; perhaps, but that's acceptable. - 'make-string))) + `(make-string 31 :element-type ,element-type)))) ;; A full call to MAKE-STRING-OUTPUT-STREAM uses a larger initial buffer ;; if BASE-CHAR but I really don't care to think about that here. - `(,string-let ((,initial-buffer (,string-ctor 31 :element-type ,element-type))) + `(,string-let ((,initial-buffer ,string-ctor)) (dx-let ((,dummy (%allocate-string-ostream))) (let ((,var (%init-string-output-stream ,dummy ,initial-buffer ,wild-result-type))) @@ -2299,3 +2299,25 @@ Works on all CASable places." #-64-bit (sb-xc:defmacro layout-depthoid (x) `(wrapper-depthoid ,x)) (sb-xc:defmacro layout-flags (x) `(wrapper-flags ,x)) ) + +(sb-xc:defmacro alloc-string (element-type length) + #-ubsan `(make-array ,length :element-type ',element-type) + #+ubsan ; Allocate an uninitialized string without shadow bits + (let ((saetp (sb-c::find-saetp element-type))) + (aver saetp) ; can't handle STANDARD-CHAR or other weirdness here + `(truly-the (simple-array ,element-type (*)) + (allocate-vector nil ,(sb-vm:saetp-typecode saetp) + ,length ,(sb-c::calc-nwords-form saetp length))))) + +(sb-xc:defmacro sb-vm:%unpoison (vector &optional element) + (declare (ignorable element)) + #-ubsan vector + #+ubsan + `(let ((v ,vector)) + ,(if element ; unpoison 1 element + `(let ((bits (%primitive sb-vm::slot ,vector 'extra 1 sb-vm:other-pointer-lowtag))) + (when (simple-bit-vector-p bits) + (setf (sbit bits ,element) 1))) + ;; unpoison the entire vector + `(%primitive sb-vm::set-slot v 0 'extra 1 sb-vm:other-pointer-lowtag)) + v)) diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index d40830082..3fa5d66af 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -172,7 +172,7 @@ (+ suffix-length (floor (* additional 5) 4))))) (setf total-suffix - (replace (make-string new-total-suffix-len) total-suffix + (replace (make-buffer new-total-suffix-len) total-suffix :start1 (- new-total-suffix-len suffix-length) :start2 (- total-suffix-len suffix-length))) (setf total-suffix-len new-total-suffix-len) @@ -192,7 +192,7 @@ (column (max minimum column))) (when (> column prefix-len) (setf prefix - (replace (make-string (max (* prefix-len 2) + (replace (make-buffer (max (* prefix-len 2) (+ prefix-len (floor (* (- column prefix-len) 5) 4)))) @@ -384,7 +384,7 @@ (let ((new-length (max (* length 2) (+ fill-ptr (floor (* additional 5) 4))))) - (setf new-buffer (make-string new-length)) + (setf new-buffer (make-buffer new-length)) (setf (pretty-stream-buffer stream) new-buffer))) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) (decf (pretty-stream-buffer-offset stream) additional) @@ -418,7 +418,7 @@ (let* ((new-length (max (* length 2) (+ length (floor (* want 5) 4)))) - (new-buffer (make-string new-length))) + (new-buffer (make-buffer new-length))) (setf (pretty-stream-buffer stream) new-buffer) (replace new-buffer buffer :end1 fill-ptr) (- new-length fill-ptr)))))) @@ -560,7 +560,7 @@ (buffer-length (length buffer))) (when (> new-fill-ptr buffer-length) (setf new-buffer - (make-string (max (* buffer-length 2) + (make-buffer (max (* buffer-length 2) (+ buffer-length (floor (* (- new-fill-ptr buffer-length) 5) diff --git a/src/code/print.lisp b/src/code/print.lisp index f1137f53e..466adede5 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -40,7 +40,7 @@ Does not affect the cases that are already controlled by *PRINT-LENGTH*") circularity in particular) when printing?") (defparameter *print-case* :upcase "What case should the printer should use default?") -(defparameter *print-array* t +(defparameter *print-array* #+ubsan nil #-ubsan t "Should the contents of arrays be printed?") (defparameter *print-gensym* t "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?") @@ -197,7 +197,7 @@ variable: an unreadable object representing the error is printed instead.") (sb-pretty::with-pretty-stream (stream) (funcall fun stream object))) (let ((buffer-size (approx-chars-in-repr object))) - (let* ((string (make-string buffer-size :element-type 'base-char)) + (let* ((string (alloc-string base-char buffer-size)) (stream (%make-finite-base-string-output-stream string))) (declare (inline %make-finite-base-string-output-stream)) (declare (truly-dynamic-extent stream)) @@ -911,7 +911,13 @@ variable: an unreadable object representing the error is printed instead.") (if (and (not (array-element-type array)) *print-readably* *read-eval*) (format stream "#.(~S '~D :ELEMENT-TYPE ~S)" 'make-array (array-dimensions array) nil) - (print-unreadable-object (array stream :type t :identity t))))) + #+ubsan + (let ((shadowp (and (typep array '(simple-array * (*))) + (simple-vector-p (sb-vm::vector-extra-data array))))) + (if shadowp + (print-unreadable-object (array stream :type t :identity t) + (write-string "+shadow" stream)) + (print-unreadable-object (array stream :type t :identity t))))))) ;;; Convert an array into a list that can be used with MAKE-ARRAY's ;;; :INITIAL-CONTENTS keyword argument. diff --git a/src/code/reader.lisp b/src/code/reader.lisp index cf3ec8225..67e2fd7d7 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -617,7 +617,7 @@ standard Lisp readtable when NIL." (let* ((b *read-buffer*) (string (token-buf-string b))) (setf (token-buf-string b) - (replace (make-string (* 2 (length string))) string)))) + (replace (alloc-string character (* 2 (length string))) string)))) ;; Retun the next character from the buffered token, or NIL. (declaim (maybe-inline token-buf-getchar)) @@ -985,10 +985,11 @@ standard Lisp readtable when NIL." "" (let* ((sum (loop for buf in chain sum (length buf))) (result - (make-array (+ sum ptr) - :element-type (if only-base-chars - (%readtable-string-preference rt) - 'character)))) + (sb-vm:%unpoison + (make-array (+ sum ptr) + :element-type (if only-base-chars + (%readtable-string-preference rt) + 'character))))) (setq ptr sum) ;; Now work backwards from the end (replace result buf :start1 ptr) diff --git a/src/code/room.lisp b/src/code/room.lisp index 480c71129..dfa1b678c 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -1159,7 +1159,6 @@ We could try a few things to mitigate this: ;;; code-components are considered to reference their embedded ;;; simple-funs for this purpose; if THIS is a simple-fun, it is ignored. (defun references-p (this that) - (declare (optimize (sb-c::aref-trapping 0))) (macrolet ((test (x) `(when (eq ,x that) (go win)))) (tagbody (do-referenced-object (this test) @@ -1363,8 +1362,8 @@ We could try a few things to mitigate this: (defun !ensure-genesis-code/data-separation () #+gencgc (let* ((n-bits (+ next-free-page 10)) - (code-bits (make-array n-bits :element-type 'bit)) - (data-bits (make-array n-bits :element-type 'bit)) + (code-bits (make-array n-bits :element-type 'bit :initial-element 0)) + (data-bits (make-array n-bits :element-type 'bit :initial-element 0)) (total-code-size 0)) (map-allocated-objects (lambda (obj type size) @@ -1538,7 +1537,6 @@ We could try a few things to mitigate this: (dolist (v (sb-vm:list-allocated-objects :all :type sb-vm:simple-vector-widetag) result) (when (dotimes (i (length v)) - (declare (optimize (sb-c::aref-trapping 0))) (let ((val (svref v i))) (when (= (get-lisp-obj-address val) no-tls-value-marker-widetag) (return t)))) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 49a2c5c81..ac682a8b3 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -1073,6 +1073,8 @@ Users Manual for details about the PROCESS structure. ~2I~_~A~:>" (strerror errno))) (t + ;; SB-UNIX:UNIX-READ can't unpoison, as it takes a SAP, not the vector + #+ubsan (sb-vm::unpoison-range buf read-end (+ read-end count)) (incf read-end count) (funcall copy-fun)))))))) (push handler *handlers-installed*))) diff --git a/src/code/save.lisp b/src/code/save.lisp index 1638d90c6..3c6c7ff6d 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -366,7 +366,7 @@ sufficiently motivated to do lengthy fixes." ;;; Doing too much consing within MAP-ALLOCATED-OBJECTS can lead to heap ;;; exhaustion (due to inhibited GC), so this takes several passes. (defun coalesce-ctypes (&optional verbose) - (declare (optimize (sb-c::aref-trapping 0))) + (declare (optimize (sb-c::aref-poison-detect 0))) (let* ((table (make-hash-table :test 'equal)) interned-ctypes referencing-objects) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 3f6797554..3df98ab22 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -501,6 +501,7 @@ (end end) :check-fill-pointer t :force-inline t) + #+ubsan (aver-unpoisoned data start end) (vector-subseq-dispatch data start end))) (defun list-subseq* (sequence start end) @@ -1129,8 +1130,11 @@ many elements are copied." (let ((length 0)) (declare (index length)) (do-rest-arg ((seq) sequences) + #+ubsan (aver-unpoisoned seq 0 (length seq)) (incf length (length seq))) - (let ((result (make-array length :element-type ',element-type)) + (let ((result ,(if (eq element-type 't) + '(make-array length) + `(alloc-string ,element-type length))) (start 0)) (declare (index start)) (do-rest-arg ((seq) sequences) @@ -3043,3 +3047,4 @@ many elements are copied." (frob 0 initial-contents) (frob (1+ axis) content)))) array)) + diff --git a/src/code/stream.lisp b/src/code/stream.lisp index dcbb02cc1..d4f32a14b 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -300,7 +300,7 @@ (prog1 (fast-read-char-refill stream nil) (setf %frc-index% (ansi-stream-in-index %frc-stream%)))) (build-result (pos n-more-chars) - (let ((res (make-string (+ chunks-total-length n-more-chars))) + (let ((res (alloc-string character (+ chunks-total-length n-more-chars))) (start1 chunks-total-length)) (declare (type index start1)) (when (>= pos 0) @@ -546,6 +546,26 @@ (read-end (stream-read-sequence stream buffer start end))) (eof-or-lose stream (and eof-error-p (< read-end end)) (- read-end start))))) +(macrolet ((unpoison (result-expr) + #-ubsan result-expr + #+ubsan + `(let ((count ,result-expr)) + (when (and (not (system-area-pointer-p buffer)) + (simple-bit-vector-p (sb-vm::vector-extra-data buffer))) + (let ((bits-per-elt (ash 1 (aref sb-vm::%%simple-array-n-bits-shifts%% + (%other-pointer-widetag buffer))))) + (multiple-value-bind (first-elt remainder) + (truncate (* start 8) bits-per-elt) + ;; START is a byte index. Check that it makes sense. + ;; It would be strange if the array were (UNSIGNED-BYTE 16) + ;; and START were 1. + (aver (zerop remainder)) + (multiple-value-bind (n-elts remainder) + (truncate (* count 8) bits-per-elt) + ;; Disallow partial elements + (aver (zerop remainder)) + (sb-vm::unpoison-range buffer first-elt (+ first-elt n-elts)))))) + count))) (defun ansi-stream-read-n-bytes (stream buffer start numbytes eof-error-p) (declare (type ansi-stream stream) (type index numbytes start) @@ -558,6 +578,7 @@ (num-buffered (- +ansi-stream-in-buffer-length+ index))) ;; These bytes are of course actual bytes, i.e. 8-bit octets ;; and not variable-length bytes. + (unpoison (cond ((<= numbytes num-buffered) (%byte-blt in-buffer index buffer start (+ start numbytes)) (setf (ansi-stream-in-index stream) (+ index numbytes)) @@ -568,7 +589,8 @@ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) (+ (funcall (ansi-stream-n-bin stream) stream buffer end (- numbytes num-buffered) eof-error-p) - num-buffered))))))) + num-buffered)))))))) +) ; end MACROLET ;;; the amount of space we leave at the start of the in-buffer for ;;; unreading @@ -1496,11 +1518,11 @@ ;;; avoiding parsing of the specified element-type at runtime. (defun %make-base-string-ostream () (%init-string-output-stream (%allocate-string-ostream) - (make-array 63 :element-type 'base-char) ; 2w + 64b + (alloc-string base-char 63) ; 2w + 64b nil)) (defun %make-character-string-ostream () (%init-string-output-stream (%allocate-string-ostream) - (make-array 32 :element-type 'character) ; 2w + 128b + (alloc-string character 32) ; 2w + 128b nil)) (defun make-string-output-stream (&key (element-type 'character)) @@ -1547,8 +1569,8 @@ benefit of the function GET-OUTPUT-STREAM-STRING." ;; more than FIXNUM characters are being written to the ;; stream, and do something about it. (if (member (string-output-stream-element-type stream) '(base-char nil)) - (make-array size :element-type 'base-char) - (make-array size :element-type 'character))))) + (alloc-string base-char size) + (alloc-string character size))))) ;;; Moves to the end of the next segment or the current one if there are ;;; no more segments. Returns true as long as there are next segments. @@ -1591,6 +1613,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING." (defun string-sout (stream string start end) (declare (explicit-check string) (type index start end)) + #+ubsan (aver-unpoisoned string start end) (let* ((full-length (- end start)) (length full-length) (buffer (string-output-stream-buffer stream)) @@ -1729,8 +1752,8 @@ benefit of the function GET-OUTPUT-STREAM-STRING." ;; Also, how it impacts setting FILE-POSITION on a string stream is unclear. ;; (See https://bugs.launchpad.net/sbcl/+bug/1839040) (result (if base-string-p - (make-string length :element-type 'base-char) - (make-string length)))) + (alloc-string base-char length) + (alloc-string character length)))) (setf (string-output-stream-index stream) 0 (string-output-stream-index-cache stream) 0 @@ -2287,10 +2310,13 @@ benefit of the function GET-OUTPUT-STREAM-STRING." (type index start) (type sequence-end end) (values index)) +(let ((answer (stream-api-dispatch (stream) :simple (error "Unimplemented") ; gets redefined :native (ansi-stream-read-sequence seq stream start end) - :gray (stream-read-sequence stream seq start end))) + :gray (stream-read-sequence stream seq start end)))) + (when (sb-vm::any-poison seq 0 answer) (error "read-sequence failed to unpoison ~s" seq)) + answer)) (declaim (maybe-inline read-sequence/read-function)) (defun read-sequence/read-function (seq stream start %end @@ -2349,15 +2375,23 @@ benefit of the function GET-OUTPUT-STREAM-STRING." ((and (ansi-stream-p stream) (ansi-stream-cin-buffer stream) (typep seq 'simple-string)) - (ansi-stream-read-string-from-frc-buffer seq stream start %end)) + (let ((answer + (ansi-stream-read-string-from-frc-buffer seq stream start %end))) + (when (sb-vm::any-poison seq 0 answer) (error "read-string-from-frc-buffer failed to unpoison ~s" seq)) + answer)) ((typep seq 'vector) (with-array-data ((data seq) (offset-start start) (offset-end end) :check-fill-pointer t) (if (and (ansi-stream-p stream) (compatible-vector-and-stream-element-types-p data stream)) - (read-vector/fast data offset-start) + (let ((answer (read-vector/fast data offset-start))) + (when (sb-vm::any-poison seq 0 answer) (error "read-vector/fast failed to unpoison ~s" seq)) + answer) + (let ((answer (read-vector (compute-read-function (array-element-type data)) - data offset-start offset-end)))) + data offset-start offset-end))) + (when (sb-vm::any-poison seq 0 answer) (error "read-vector failed to unpoison ~s" seq)) + answer)))) (t (read-generic-sequence (compute-read-function nil))))))) diff --git a/src/code/string.lisp b/src/code/string.lisp index 0bceb69b8..4f299acc9 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -443,8 +443,8 @@ new string COUNT long filled with the fill character." (declare (explicit-check)) (cond ((eq element-type 'character) (let ((c (if iep (the character initial-element))) - (s (make-string count :element-type 'character))) - (when c (sb-vm::unpoison s) (fill s c)) + (s (alloc-string character count))) + (when c (fill s c)) s)) ((or (eq element-type 'base-char) (eq element-type 'standard-char) @@ -453,8 +453,8 @@ new string COUNT long filled with the fill character." ;; So that would be 8 bits per character, not 32 bits per character. (eq element-type nil)) (let ((c (if iep (the base-char initial-element))) - (s (make-string count :element-type 'base-char))) - (when c (sb-vm::unpoison s) (fill s c)) + (s (alloc-string base-char count))) + (when c (fill s c)) s)) (t (multiple-value-bind (widetag n-bits-shift) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 3a597c1c6..9960ebfb9 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -11,6 +11,7 @@ ;;;; files for more information. (in-package "SB-IMPL") +(declaim (optimize (sb-c::aref-poison-detect 0))) ;;;; utilities diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index 7a57621ab..b0cfebe26 100644 --- a/src/code/target-random.lisp +++ b/src/code/target-random.lisp @@ -16,6 +16,9 @@ ;;;; files for more information. (in-package "SB-KERNEL") +;;; For efficiency, ensure that RANDOM-STATEs contain unpoisoned arrays. +;;; (The code is correct without runtime instrumentation) +(declaim (optimize (sb-c::aref-poison-detect 0))) ;;;; Constants (defconstant mt19937-n 624) diff --git a/src/code/type.lisp b/src/code/type.lisp index 3a727cde6..a92c3b4fe 100644 --- a/src/code/type.lisp +++ b/src/code/type.lisp @@ -3511,7 +3511,7 @@ used for a COMPLEX component.~:@>" (integer-range (low high) (make-numeric-type :class 'integer :complexp :real :enumerable t :low low :high high))) - (let ((array (make-array (* 32 5))) + (let ((array (make-array (* 32 5) :initial-element nil)) (index 0)) ;; Index 31 is available to store *WILD-TYPE* ;; because there are fewer than 32 array widetags. diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 5e3c944fb..c809d13e2 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -19,6 +19,7 @@ ;;; (including not only the final construction of the core file, but ;;; also the preliminary steps like e.g. building the cross-compiler ;;; and running the cross-compiler to produce target FASL files). +(setq sb-ext:*evaluator-mode* :compile) (defpackage "SB-COLD" (:use "CL")) (in-package "SB-COLD") diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index a23f138f9..bbd4b60a7 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -666,17 +666,18 @@ ;; (and (eq spec 'character) (= bits 32)) )) -(declaim (inline calc-nwords-form)) -(defun calc-nwords-form (saetp const-length +(defun calc-nwords-form (saetp length-var + &optional (const-length + (if (integerp length-var) length-var)) &aux (n-bits (sb-vm:saetp-n-bits saetp)) (n-pad-elements (sb-vm:saetp-n-pad-elements saetp))) (when const-length (return-from calc-nwords-form (if (typep const-length 'index) - (ceiling (* (+ const-length n-pad-elements) n-bits) sb-vm:n-word-bits)))) + (values (ceiling (* (+ const-length n-pad-elements) n-bits) sb-vm:n-word-bits))))) (let ((padded-length-form (if (zerop n-pad-elements) - '%length - `(+ %length ,n-pad-elements)))) + length-var + `(+ ,length-var ,n-pad-elements)))) (cond ((= n-bits 0) 0) ((= n-bits sb-vm:n-word-bits) padded-length-form) ((> n-bits sb-vm:n-word-bits) ; e.g. double-float on 32-bit @@ -742,7 +743,10 @@ (defun transform-make-array-vector (length element-type initial-element initial-contents call &key adjustable fill-pointer + (poisoned + (not (or initial-contents initial-element))) &aux c-length) + (declare (ignorable poisoned)) (when (and initial-contents initial-element) (abort-ir1-transform "Both ~S and ~S specified." :initial-contents :initial-element)) @@ -780,12 +784,13 @@ (give-up-ir1-transform)) (t (find-saetp-by-ctype elt-ctype)))) - (n-words-form (or (calc-nwords-form saetp c-length) (give-up-ir1-transform))) + (n-words-form (or (calc-nwords-form saetp '%length c-length) + (give-up-ir1-transform))) (default-initial-element (sb-vm:saetp-initial-element-default saetp)) (data-alloc-form `(truly-the (simple-array ,(sb-vm:saetp-specifier saetp) (,(or c-length '*))) - (allocate-vector #+ubsan ,(not (or initial-contents initial-element)) + (allocate-vector #+ubsan ,poisoned ,(sb-vm:saetp-typecode saetp) %length nwords)))) (flet ((eliminate-keywords () @@ -918,7 +923,9 @@ ;; otherwise, reading an element can't cause an invalid bit pattern ;; to be observed, but the bits could be random. ;; KLUDGE: backward-compatibile 0-fill - `(sb-vm::splat ,data-alloc-form nwords 0))))))) + data-alloc-form + ;`(sb-vm::splat ,data-alloc-form nwords 0) + )))))) ;; Case (3) - constant :INITIAL-CONTENTS and LENGTH ((and c-length diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 899ab6056..4e282fa26 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -59,7 +59,7 @@ ;; It used to be an adjustable array, but we now do the array size ;; management manually for performance reasons (as of 2006-05-13 hairy ;; array operations are rather slow compared to simple ones). - (buffer (make-array 100 :element-type 'assembly-unit) + (buffer (make-array 100 :element-type 'assembly-unit :initial-element 0) :type (simple-array assembly-unit 1)) (encoder-state) ;; whether or not to run the scheduler. Note: if the instruction @@ -177,7 +177,7 @@ ;; roughly double the vector length: that way growing the array ;; to size N conses only O(N) bytes in total. (setf new-buffer-size (* 2 new-buffer-size))) - (let ((new-buffer (make-array new-buffer-size + (let ((new-buffer (make-array new-buffer-size :initial-element 0 :element-type '(unsigned-byte 8)))) (replace new-buffer buffer) (setf (segment-buffer segment) new-buffer))) diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp index d71d6301e..1d412d0da 100644 --- a/src/compiler/generic/parms.lisp +++ b/src/compiler/generic/parms.lisp @@ -202,6 +202,8 @@ #-sb-thread *stepping* + #+ubsan *ubsan-enable* + ;; threading support #+sb-thread ,@'(sb-thread::*starting-threads* *free-tls-index*) diff --git a/src/compiler/generic/vm-array.lisp b/src/compiler/generic/vm-array.lisp index e99cf7335..01be77b85 100644 --- a/src/compiler/generic/vm-array.lisp +++ b/src/compiler/generic/vm-array.lisp @@ -217,18 +217,13 @@ ;;; the pointer to the shadow bits. ;;; Alternatively we could place them in malloc()'ed memory ;;; but then we'd need a finalizer per array. -#+ubsan +#+(and ubsan (not sb-xc-host)) (progn (export '(vector-extra-data)) (defmacro vector-extra-data (vector) `(%primitive slot ,vector 'length 1 other-pointer-lowtag)) (defmacro set-vector-extra-data (vector data) - `(%primitive set-slot ,vector ,data 'length 1 other-pointer-lowtag)) -(defmacro unpoison (vector) - `(set-vector-extra-data ,vector 0))) -#-ubsan -(defmacro unpoison (vector) - (declare (ignore vector))) + `(%primitive set-slot ,vector ,data 'length 1 other-pointer-lowtag))) ;;; Return T if arrays with the given WIDETAG may contain random data ;;; initially unless expressly initialized. diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 387b70656..46322851b 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -449,12 +449,14 @@ (error "Argument and/or result bit arrays are not the same length:~ ~% ~S~% ~S ~% ~S" bit-array-1 bit-array-2 result-bit-array)))) + #+ubsan (progn (aver-unpoisoned bit-array-1 0 length) + (aver-unpoisoned bit-array-2 0 length)) (dotimes (index (ceiling length sb-vm:n-word-bits)) (declare (optimize (speed 3) (safety 0)) (type index index)) (setf (%vector-raw-bits result-bit-array index) (,wordfun (%vector-raw-bits bit-array-1 index) (%vector-raw-bits bit-array-2 index)))) - result-bit-array)) + (sb-vm:%unpoison result-bit-array))) (flet ((policy-test (node) (policy node (>= speed space)))) (macrolet ((def (bitfun wordfun) @@ -486,11 +488,12 @@ ~% ~S~% ~S" bit-array result-bit-array)))) (let ((length (vector-length result-bit-array))) + #+ubsan (aver-unpoisoned bit-array 0 length) (dotimes (index (ceiling length sb-vm:n-word-bits)) (declare (optimize (speed 3) (safety 0)) (type index index)) (setf (%vector-raw-bits result-bit-array index) (word-logical-not (%vector-raw-bits bit-array index)))) - result-bit-array))) + (sb-vm:%unpoison result-bit-array)))) ;;; This transform has to deal with the fact that unused bits ;;; in the last data word of a simple-bit-vector can be random. @@ -499,6 +502,8 @@ `(let ((length (vector-length x))) (and (= (vector-length y) length) (let ((words (floor length sb-vm:n-word-bits))) + #+ubsan (progn (aver-unpoisoned x 0 length) + (aver-unpoisoned y 0 length)) (and (dotimes (i words t) (unless (= (%vector-raw-bits x i) (%vector-raw-bits y i)) (return nil))) @@ -542,7 +547,7 @@ (declare (optimize (speed 3) (safety 0)) (type index index)) (setf (%vector-raw-bits sequence index) value)) - sequence)) + (sb-vm:%unpoison sequence))) (deftransform fill ((sequence item) (simple-base-string t) * :policy (>= speed space)) @@ -572,7 +577,7 @@ (when (plusp bits) (setf (%vector-raw-bits sequence words) (shift-towards-start value (- bits))))) - sequence))) + (sb-vm:%unpoison sequence)))) ;;;; %BYTE-BLT diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index 582371f1e..f8171c1fb 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -730,8 +730,8 @@ (declare (type component component)) (let* ((gtn-count (1+ (ir2-component-global-tn-counter (component-info component)))) - (saves (make-array gtn-count :element-type 'bit)) - (restores (make-array gtn-count :element-type 'bit)) + (saves (make-array gtn-count :element-type 'bit :initial-element 0)) + (restores (make-array gtn-count :element-type 'bit :initial-element 0)) (block (ir2-block-prev (block-info (component-tail component)))) (head (block-info (component-head component)))) (loop diff --git a/src/compiler/policies.lisp b/src/compiler/policies.lisp index 21e2d623e..db1da816d 100644 --- a/src/compiler/policies.lisp +++ b/src/compiler/policies.lisp @@ -126,7 +126,7 @@ debugger.") (define-optimization-quality insert-array-bounds-checks (if (= safety 0) 0 3) ("no" "yes" "yes" "yes")) -(define-optimization-quality aref-trapping +(define-optimization-quality aref-poison-detect #-ubsan (if (= safety 3) 3 0) ; equiv. to safety unless expressed otherwise #+ubsan 2 ; default to yes ("no" "yes" "yes" "yes")) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 5c8f14c02..e4e888a19 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -292,11 +292,12 @@ (map-into (locally #-sb-xc-host (declare (muffle-conditions array-initial-element-mismatch)) + (sb-vm:%unpoison (make-sequence result-type ,(if (cdr seq-args) `(min ,@(loop for arg in seq-args collect `(length ,arg))) - `(length ,(car seq-args))))) + `(length ,(car seq-args)))))) fun ,@seq-args)))) (t (let* ((all-seqs (cons seq seqs)) @@ -325,7 +326,7 @@ ;;; MAP-INTO (defmacro mapper-from-typecode (typecode) #+sb-xc-host - `(svref ,(let ((a (make-array 256))) + `(svref ,(let ((a (make-array 256 :initial-element nil))) (dovector (info sb-vm:*specialized-array-element-type-properties* a) (setf (aref a (sb-vm:saetp-typecode info)) (package-symbolicate "SB-IMPL" "VECTOR-MAP-INTO/" @@ -1035,7 +1036,12 @@ (sequence-bounding-indices-bad-error seq1 start1 end1)) (unless (<= 0 start2 end2 len2) (sequence-bounding-indices-bad-error seq2 start2 end2)))) +;; ,@(when (policy node (/= sb-c::aref-poison-detect 0)) +;; ;; Do *NOT* scan the entire length implied by end2-start2 +;; '((aver-unpoisoned seq2 start2 (+ start2 replace-len)))) (,bash-function seq2 start2 seq1 start1 replace-len) +;; ,@(when (policy node (/= sb-c::aref-poison-detect 0)) +;; '((sb-vm::unpoison-range seq1 start1 end1))) seq1)) (defun transform-replace (same-types-p node) `(let* ((len1 (length seq1)) @@ -1048,6 +1054,8 @@ (sequence-bounding-indices-bad-error seq1 start1 end1)) (unless (<= 0 start2 end2 len2) (sequence-bounding-indices-bad-error seq2 start2 end2)))) + ,@(when (policy node (/= sb-c::aref-poison-detect 0)) + '((aver-unpoisoned seq2 start2 end2))) ,(flet ((down () '(do ((i (truly-the (or (eql -1) index) (+ start1 replace-len -1)) (1- i)) (j (truly-the (or (eql -1) index) (+ start2 replace-len -1)) (1- j))) @@ -1069,6 +1077,8 @@ (if same-types-p ; source and destination sequences could be EQ `(if (and (eq seq1 seq2) (> start1 start2)) ,(down) ,(up)) (up))) + ,@(when (policy node (/= sb-c::aref-poison-detect 0)) + '((sb-vm::unpoison-range seq1 start1 end1))) seq1)) (deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2) @@ -1089,7 +1099,7 @@ node) (transform-replace t node))) (give-up-ir1-transform)))) -#+sb-unicode +#+(and sb-unicode (not ubsan)) (progn (deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2) (simple-base-string simple-character-string &rest t) simple-base-string @@ -1145,6 +1155,7 @@ (%set-vector-raw-bits dst i (%vector-raw-bits src i))) (values)))) +#-ubsan (loop for i = 1 then (* i 2) do (%deftransform (intern (format nil "UB~D-BASH-COPY" i) "SB-KERNEL") nil @@ -1308,8 +1319,18 @@ ,@(when (policy node (/= insert-array-bounds-checks 0)) '((unless (<= 0 start end length) (sequence-bounding-indices-bad-error seq start end)))) + ,@(when (policy node (/= aref-poison-detect 0)) + '((aver-unpoisoned seq start end))) (let* ((size (- end start)) - (result (make-array size :element-type ',element-type))) + (result + #-ubsan + (make-array size :element-type ',element-type) + #+ubsan + ,(let ((saetp (find-saetp element-type))) + `(truly-the + (simple-array ,element-type (*)) + (allocate-vector nil ,(sb-vm:saetp-typecode saetp) + size ,(calc-nwords-form saetp 'size)))))) ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start) (lvar-value start) 'start) @@ -1703,7 +1724,8 @@ (defun string-concatenate-transform (node type lvars) (let ((vars (make-gensym-list (length lvars)))) - (if (policy node (<= speed space)) + (if (or (policy node (<= speed space)) + #+ubsan t) ; never inline ;; Out-of-line (let ((constants-to-string ;; Strings are handled more efficiently by diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index 3ffdd155a..c8dde384d 100644 --- a/src/compiler/x86-64/alloc.lisp +++ b/src/compiler/x86-64/alloc.lisp @@ -391,8 +391,10 @@ #+ubsan (inst mov :dword (vector-len-ea ,vector-tn ,lowtag) len) #-ubsan (storew* len ,vector-tn vector-length-slot ,lowtag ,zeroed))) - (want-shadow-bits () + (require-shadow-bits () `(and poisoned + (sb-c::policy node (> sb-c::aref-poison-detect 0)) + (if (sc-is length immediate) (> (tn-value length) 0) :maybe) (if (sc-is type immediate) (/= (tn-value type) simple-vector-widetag) :maybe))) @@ -409,14 +411,15 @@ (inst shr :dword ,reg 8) ; divide by 128 and untag as one operation (inst shl :dword ,reg 4) ; multiply by 16 bytes per dualword ,reg))) - (store-originating-pc (vector) - ;; Put the current program-counter into the length slot of the shadow bits - ;; so that we can ascribe blame to the array's creator. - `(let ((here (gen-label))) - (emit-label here) - (inst lea temp-reg-tn (rip-relative-ea here)) - (inst shl temp-reg-tn 4) - (inst mov (ea (- 8 other-pointer-lowtag) ,vector) temp-reg-tn)))) + (alloc-origin-tracker (tn lowtag) + `(let ((origin (sb-assem::asmstream-data-origin-label sb-assem:*asmstream*))) + ;; store CONS-CAR-SLOT + (inst mov :qword (ea (- ,lowtag) ,tn) (make-fixup nil :pc-offset-as-fixnum)) + (inst lea temp-reg-tn (rip-relative-ea origin :code)) + ;; store CONS-CDR-SLOT + (inst mov (ea (- 8 ,lowtag) ,tn) temp-reg-tn) + ;; OR in a list-pointer tag if it was 0 + ,(if (eq lowtag 0) `(inst or :byte ,tn list-pointer-lowtag))))) (define-vop (allocate-vector-on-heap) #+ubsan (:info poisoned) @@ -428,29 +431,34 @@ (:results (result :scs (descriptor-reg) :from :load)) (:arg-types #+ubsan (:constant t) positive-fixnum positive-fixnum positive-fixnum) + #+ubsan (:temporary (:sc unsigned-reg) shadow) (:policy :fast-safe) (:node-var node) (:generator 100 #+ubsan - (when (want-shadow-bits) - ;; allocate a vector of "written" bits unless the vector is simple-vector-T, - ;; which can use unbound-marker as a poison value on reads. + (when (require-shadow-bits) + (zeroize shadow) + ;; allocate a shadow vector unless this vector is simple-vector-T, + ;; which can use unbound-marker as a poison value (when (sc-is type unsigned-reg) (inst cmp :byte type simple-vector-widetag) - (inst push 0) (inst jmp :e NO-SHADOW-BITS)) - ;; It would be possible to do this and the array proper - ;; in a single pseudo-atomic section, but I don't care to do that. - (let ((nbytes (calc-shadow-bits-size result))) + (when (sc-is length any-reg) ; empty array needs no shadow bits + (inst test :dword length length) + (inst jmp :z NO-SHADOW-BITS)) + (let ((nbytes (calc-shadow-bits-size shadow))) (pseudo-atomic () - ;; Allocate the bits into RESULT - (allocation nil nbytes 0 node nil result) - (inst mov :byte (ea result) simple-bit-vector-widetag) - (inst mov :dword (vector-len-ea result 0) + ;; Allocate a cons into RESULT temporarily to store the code and offset + (allocation nil (* cons-size n-word-bytes) 0 node nil result) + (alloc-origin-tracker result 0) + ;; Allocate the shadow bits into SHADOW + (allocation nil nbytes 0 node nil shadow) + (inst mov :byte (ea shadow) simple-bit-vector-widetag) + (inst mov :dword (vector-len-ea shadow 0) (if (sc-is length immediate) (fixnumize (tn-value length)) length)) - (inst or :byte result other-pointer-lowtag))) - (store-originating-pc result) - (inst push result)) ; save the pointer to the shadow bits + ;; Store RESULT (the cons) into the extra slot of SHADOW + (storew result shadow vector-length-slot 0) + (inst or :byte shadow other-pointer-lowtag)))) NO-SHADOW-BITS ;; The LET generates instructions that needn't be pseudoatomic ;; so don't move it inside. @@ -459,21 +467,34 @@ (pseudo-atomic () (allocation nil size 0 node nil result) (put-header result 0 type length t) - (inst or :byte result other-pointer-lowtag))) - #+ubsan - (cond ((want-shadow-bits) - (inst pop temp-reg-tn) ; restore shadow bits - (inst mov (object-slot-ea result 1 other-pointer-lowtag) temp-reg-tn)) - (poisoned ; uninitialized SIMPLE-VECTOR - (store-originating-pc result))))) + (inst or :byte result other-pointer-lowtag) + ;; Don't leave PA section until shadow bits are assigned, + ;; so that GC can decide whether the result can be + ;; relocated to an unbxoxed vs boxed page. + #+ubsan + (cond ((require-shadow-bits) + ;; slight bug - if this was ":maybe" and then the vector is + ;; simple-vector but compile-time-unknown, this will take the jump + ;; to NO-SHADOW-BITS and then store a 0 without storing the PC. + ;; But that's OK because it can be compile-time-unknown only if + ;; called from %MAKE-ARRAY and a few other places which try to + ;; insert the origin location their own by looking up the caller + ;; of the current frame. + (storew shadow result vector-length-slot other-pointer-lowtag)) + (poisoned ; uninitialized SIMPLE-VECTOR + (allocation nil (* cons-size n-word-bytes) 0 node nil shadow) + (alloc-origin-tracker shadow 0) + ;; Store the cons into the spare slot of result + (storew shadow result vector-length-slot other-pointer-lowtag))))))) - (define-vop (allocate-vector-on-stack) + (define-vop (allocate-vector-on-stack) #+ubsan (:info poisoned) (:args (type :scs (unsigned-reg immediate)) (length :scs (any-reg immediate)) (words :scs (any-reg immediate))) (:results (result :scs (descriptor-reg) :from :load)) (:vop-var vop) + (:node-var node) (:arg-types #+ubsan (:constant t) positive-fixnum positive-fixnum positive-fixnum) #+ubsan (:temporary (:sc any-reg :offset rax-offset) rax) @@ -482,41 +503,48 @@ (:policy :fast-safe) (:generator 10 #+ubsan - (when (want-shadow-bits) - ;; allocate a vector of "written" bits unless the vector is simple-vector-T, - ;; which can use unbound-marker as a poison value on reads. - (when (sc-is type unsigned-reg) (bug "vector-on-stack: unknown type")) - (zeroize rax) - (let ((nbytes (calc-shadow-bits-size rcx))) - (stack-allocation rdi nbytes 0) - (when (sc-is length immediate) (inst mov rcx nbytes))) - (inst rep) - (inst stos :byte) ; RAX was zeroed - (inst lea rax (ea other-pointer-lowtag rsp-tn)) - (inst mov :dword (ea (- other-pointer-lowtag) rax) simple-bit-vector-widetag) - (inst mov :dword (vector-len-ea rax) - (if (sc-is length immediate) (fixnumize (tn-value length)) length)) - (store-originating-pc rax)) + (cond + ((require-shadow-bits) + ;; allocate a vector of "written" bits unless the vector is simple-vector-T, + ;; which can use unbound-marker as a poison value on reads. + (when (sc-is type unsigned-reg) (bug "vector-on-stack: unknown type")) + (zeroize rax) + ;; Allocate a cons into RESULT temporarily to store the code and offset + (stack-allocation result (* cons-size n-word-bytes) list-pointer-lowtag) + (alloc-origin-tracker result list-pointer-lowtag) + (let ((nbytes (calc-shadow-bits-size rcx))) + (stack-allocation rdi nbytes 0 t) + (when (sc-is length immediate) (inst mov rcx nbytes))) + (inst rep) + (inst stos :byte) ; RAX was zeroed + (inst lea rax (ea other-pointer-lowtag rsp-tn)) + (inst mov :byte (ea (- other-pointer-lowtag) rax) simple-bit-vector-widetag) + (inst mov :dword (vector-len-ea rax) + (if (sc-is length immediate) (fixnumize (tn-value length)) length)) + ;; Store the origin in the shadow vector + (storew result rax vector-length-slot other-pointer-lowtag)) + (poisoned + ;; Allocate a cons into RAX to store the code and offset + (stack-allocation rax (* cons-size n-word-bytes) list-pointer-lowtag) + (alloc-origin-tracker rax list-pointer-lowtag)) + (t + ;; Always need tostore something in the spare slot, otherwise it could + ;; have a random value that looks like a pointer to shadow bits. + (zeroize rax))) (let ((size (calc-size-in-bytes words result))) ;; Compute tagged pointer sooner than later since access off RSP ;; requires an extra byte in the encoding anyway. (stack-allocation result size other-pointer-lowtag ;; If already aligned RSP, don't need to do it again. - #+ubsan (want-shadow-bits)) + #+ubsan (require-shadow-bits)) ;; NB: store the trailing null BEFORE storing the header, ;; in case the length in words is 0, which stores into the LENGTH slot ;; as if it were element -1 of data (which probably can't happen). (store-string-trailing-null result type length words) ;; FIXME: It would be good to check for stack overflow here. - (put-header result other-pointer-lowtag type length nil) - ) + (put-header result other-pointer-lowtag type length nil)) #+ubsan - (cond ((want-shadow-bits) - (inst mov (ea (- (ash vector-length-slot word-shift) other-pointer-lowtag) - result) - rax)) - (poisoned ; uninitialized SIMPLE-VECTOR - (store-originating-pc result))))) + (storew rax result vector-length-slot other-pointer-lowtag))) #+linux ; unimplemented for others (define-vop (allocate-vector-on-stack+msan-unpoison) diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp index cf1aeb515..7cd20b322 100644 --- a/src/compiler/x86-64/array.lisp +++ b/src/compiler/x86-64/array.lisp @@ -16,48 +16,56 @@ ;; field of an EA can't contain 64 bit values. (sb-xc:deftype low-index () '(signed-byte 29)) +(macrolet ((bit-op (op) + `(progn + (inst mov temp (object-slot-ea array 1 other-pointer-lowtag)) + ;; See if the ancillary slot holds a bit-vector and not + ;; a fixnum or list. + ;; A list will denote the stack trace at the creation site + ;; rather than shadow bits. A fixnum for PC recording + ;; is left-shifted so as not to overlap any lowtag bit. + (inst test :byte temp #b1000) + (inst jmp :z ok) + (if (or (fixnump index) (sc-is index immediate)) + (multiple-value-bind (dword-index bit) + (floor (if (fixnump index) index (tn-value index)) 32) + (inst ,@op :dword (ea (bit-base dword-index) temp) bit)) + (sc-case index + ((signed-reg unsigned-reg) + (inst ,@op (ea (bit-base 0) temp) index)) + (t + (aver (sc-is index any-reg)) + (inst shr :dword index 1) ; untag it + (inst ,@op (ea (bit-base 0) temp) index) + ;; re-tag without affecting CPU flags + (inst lea :dword index (ea index index)))))))) + (defun unpoison-element (array index &optional (addend 0)) #-ubsan (declare (ignore array index addend)) #+ubsan - (let ((no-bits (gen-label))) + (let ((ok (gen-label)) + (temp temp-reg-tn)) (aver (= addend 0)) - (inst mov temp-reg-tn (object-slot-ea array 1 other-pointer-lowtag)) - ;; See if the ancillary slot holds a bit-vector and not a list. - ;; A list will denote the stack trace at the creation site - ;; rather than shadow bits. - (inst test :byte temp-reg-tn #b1000) - (inst jmp :z no-bits) - (flet ((constant-index (index) - (multiple-value-bind (dword-index bit) (floor index 32) dword-index bit - (inst bts :lock :dword (ea (bit-base dword-index) temp-reg-tn) bit)))) - (if (integerp index) - (constant-index index) - (sc-case index - (immediate (constant-index (tn-value index))) - ((signed-reg unsigned-reg) - (inst bts :lock (ea (bit-base 0) temp-reg-tn) index)) - (t - (aver (sc-is index any-reg)) - (inst shr :dword index 1) ; untag it - (inst bts :lock (ea (bit-base 0) temp-reg-tn) index) - (inst shl :dword index 1))))) - (emit-label no-bits))) + (bit-op (bts :lock)) + (emit-label ok))) -(defun test-poisoned (vop temp array index &optional (addend 0)) - (declare (ignore vop temp array index addend)) - #+nil - (unless (sb-c::policy (sb-c::vop-node vop) (= safety 0)) - (let ((ok (gen-label))) - (when (integerp index) (setq index (emit-constant index))) - (inst mov temp (object-slot-ea object 1 other-pointer-lowtag)) ; shadow bits - (inst test :byte temp temp) - (inst jmp :z ok) ; no shadow bits - (if (and (eql addend 0) (eql (tn-sc index unsigned-reg))) - (inst bt (ea (bit-base 0) temp) index) - (error "Unhandled SCs in test-poisoned")) - (inst jmp :nc (generate-error-code vop 'uninitialized-element-error - object index addend)) - (emit-label ok)))) +(defun test-poison-bit (vop temp array index &optional (addend 0)) + #-ubsan (declare (ignore vop temp array index addend)) + #+ubsan + (when (sb-c::policy (sb-c::vop-node vop) (> sb-c::aref-poison-detect 0)) + (aver (= addend 0)) + (let ((ok (gen-label)) (fail (gen-label))) + (bit-op (bt)) ; no :LOCK here + (inst jmp :nc fail) + (emit-label ok) + (assemble (:elsewhere) + (emit-label fail) + (inst test :byte (static-symbol-value-ea '*ubsan-enable*) 2) + (inst jmp :z ok) ; bypass the error + (generate-error-code vop 'uninitialized-element-error + array + (if (integerp index) (emit-constant index) index)) + (inst jmp ok)))))) ;;;; allocator for the array header @@ -290,6 +298,7 @@ ;; for pretty much any general type-unknown AREF. ;; (:note "inline array access") (:translate data-vector-ref-with-offset) + (:vop-var vop) (:policy :fast-safe)) (define-vop (dvset) ;; (:note "inline array store") @@ -475,6 +484,7 @@ (:results (result :scs (any-reg))) (:result-types positive-fixnum) (:generator 3 + (test-poison-bit vop temp-reg-tn object index) ;; using 32-bit operand size might elide the REX prefix on mov + shift (multiple-value-bind (dword-index bit) (floor index 32) (inst mov :dword result (ea (bit-base dword-index) object)) @@ -491,14 +501,10 @@ (:info addend) (:ignore addend) (:arg-types simple-bit-vector positive-fixnum (:constant (integer 0 0))) - ;; SIGNED-REG has a smaller SC number than UNSIGNED-REG so it encodes shorter - ;; in the error trap - (:temporary (:sc signed-reg :offset #.(tn-offset temp-reg-tn)) temp) (:results (result :scs (any-reg))) (:result-types positive-fixnum) - (:vop-var vop) (:generator 4 - (progn temp) + (test-poison-bit vop temp-reg-tn object index) (inst bt (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) object) index) (inst sbb :dword result result) @@ -519,6 +525,7 @@ (:result-types positive-fixnum) (:temporary (:sc unsigned-reg :offset rcx-offset) ecx) (:generator 20 + (test-poison-bit vop temp-reg-tn object index) (move ecx index) (inst shr ecx ,bit-shift) (inst mov result @@ -543,6 +550,7 @@ (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 15 + (test-poison-bit vop temp-reg-tn object index) (multiple-value-bind (word extra) (floor index ,elements-per-word) (loadw result object (+ word vector-data-offset) other-pointer-lowtag) @@ -665,6 +673,7 @@ (:results (value :scs (single-reg))) (:result-types single-float) (:generator 5 + (test-poison-bit vop temp-reg-tn object index) ,@(if use-temp '((move dword-index index) (inst shr dword-index (1+ (- n-fixnum-tag-bits word-shift))) @@ -681,6 +690,7 @@ (:results (value :scs (single-reg))) (:result-types single-float) (:generator 4 + (test-poison-bit vop temp-reg-tn object index) (inst movss value (float-ref-ea object index addend 4)))) #. @@ -728,6 +738,7 @@ (:results (value :scs (double-reg))) (:result-types double-float) (:generator 7 + (test-poison-bit vop temp-reg-tn object index) (inst movsd value (float-ref-ea object index addend 8 :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) @@ -740,6 +751,7 @@ (:results (value :scs (double-reg))) (:result-types double-float) (:generator 6 + (test-poison-bit vop temp-reg-tn object index) (inst movsd value (float-ref-ea object index addend 8)))) (define-vop (data-vector-set-with-offset/simple-array-double-float dvset) @@ -781,6 +793,7 @@ (:results (value :scs (complex-single-reg))) (:result-types complex-single-float) (:generator 5 + (test-poison-bit vop temp-reg-tn object index) (inst movq value (float-ref-ea object index addend 8 :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) @@ -793,6 +806,7 @@ (:results (value :scs (complex-single-reg))) (:result-types complex-single-float) (:generator 4 + (test-poison-bit vop temp-reg-tn object index) (inst movq value (float-ref-ea object index addend 8)))) (define-vop (data-vector-set-with-offset/simple-array-complex-single-float dvset) @@ -832,6 +846,7 @@ (:results (value :scs (complex-double-reg))) (:result-types complex-double-float) (:generator 7 + (test-poison-bit vop temp-reg-tn object index) (inst movapd value (float-ref-ea object index addend 16 :scale (ash 2 (- word-shift n-fixnum-tag-bits)))))) @@ -844,6 +859,7 @@ (:results (value :scs (complex-double-reg))) (:result-types complex-double-float) (:generator 6 + (test-poison-bit vop temp-reg-tn object index) (inst movapd value (float-ref-ea object index addend 16)))) (define-vop (data-vector-set-with-offset/simple-array-complex-double-float dvset) @@ -904,7 +920,12 @@ ,n-bytes vector-data-offset))) (:results (value :scs ,scs)) (:result-types ,type) - (:generator 5 (inst ,mov-inst ',opcode-modifier value ,ea-expr))) + (:args-var args) + (:generator 5 + ;; If the arg is a constant vector then it can't have poison elements. + (unless (sc-is (tn-ref-tn args) constant) + (test-poison-bit vop temp-reg-tn object index)) + (inst ,mov-inst ',opcode-modifier value ,ea-expr))) (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype "-C") dvref) (:args (object :scs (descriptor-reg))) (:info index addend) @@ -913,7 +934,12 @@ ,n-bytes vector-data-offset))) (:results (value :scs ,scs)) (:result-types ,type) - (:generator 4 (inst ,mov-inst ',opcode-modifier value ,ea-expr-const))) + (:args-var args) + (:generator 4 + ;; If the arg is a constant vector then it can't have poison elements. + (unless (sc-is (tn-ref-tn args) constant) + (test-poison-bit vop temp-reg-tn object index)) + (inst ,mov-inst ',opcode-modifier value ,ea-expr-const))) ;; FIXME: these all need to accept immediate SC for the value (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype) dvset) (:args (object :scs (descriptor-reg) :to (:eval 0)) diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp index 86b0e93d6..4f8b7e532 100644 --- a/src/compiler/x86-64/insts.lisp +++ b/src/compiler/x86-64/insts.lisp @@ -1029,11 +1029,18 @@ ;;;; fixup emitters (defun emit-absolute-fixup (segment fixup &optional quad-p) - (note-fixup segment (if quad-p :absolute64 :absolute) fixup) (let ((offset (fixup-offset fixup))) - (if quad-p - (emit-qword segment offset) - (emit-signed-dword segment offset)))) + (cond ((eq (fixup-flavor fixup) :pc-offset-as-fixnum) + ;; This is like the "." symbol in native assembler syntax- + ;; resolved at assembly time. + (emit-back-patch segment 4 + (lambda (segment posn) + (emit-signed-dword segment (fixnumize posn))))) + (t + (note-fixup segment (if quad-p :absolute64 :absolute) fixup) + (if quad-p + (emit-qword segment offset) + (emit-signed-dword segment offset)))))) (defun emit-relative-fixup (segment fixup) (note-fixup segment :relative fixup) diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index a9b42dcda..d1acbbbd3 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -162,6 +162,8 @@ (emit-error-break vop (case error-code ; should be named ERROR-SYMBOL really (invalid-arg-count-error invalid-arg-count-trap) + ;; Allow proceeding past uninitialized-element + (uninitialized-element-error cerror-trap) (t error-trap)) (error-number-or-lose error-code) values) @@ -291,13 +293,34 @@ ;; stored in another thread), then it's a false positive that is indicative ;; of a race. A false negative (failure to signal on a trap value) can not ;; occur unless unsafely using REPLACE into this vector. - (when (memq name '(data-vector-ref-with-offset/simple-vector - data-vector-ref-with-offset/simple-vector-c)) - `((when (sb-c::policy (sb-c::vop-node vop) (> sb-c::aref-trapping 0)) - (inst cmp :byte ea no-tls-value-marker-widetag) - (inst jmp :e (generate-error-code - vop 'uninitialized-element-error object - ,index-to-encode))))))) + (when (eq translate 'data-vector-ref-with-offset) + (ecase type + (simple-vector + `((when (and (sb-c::policy (sb-c::vop-node vop) (> sb-c::aref-poison-detect 0)) + (not (sc-is (tn-ref-tn args) constant))) + (let ((ok (gen-label)) (fail (gen-label))) + (inst cmp :byte ea no-tls-value-marker-widetag) + (inst jmp :e fail) + (emit-label ok) + (assemble (:elsewhere) + (emit-label fail) + (inst test :byte (static-symbol-value-ea '*ubsan-enable*) 2) + (inst jmp :z ok) ; bypass the error + (generate-error-code vop 'uninitialized-element-error object + ,index-to-encode) + (inst jmp ok)))))) + ((simple-array-unsigned-byte-64 + simple-array-signed-byte-64 + ;; TODO: these three types can avoid using shadow bits by robbing one bit + ;; as the poison indicator. To access would require a load, bit-test, + ;; and branch. If the poison bit is as it should be, then all is well. + ;; Something similar could be done for (unsigned-byte 7) and other weird + ;; sizes, but I don't think they are important. + simple-array-unsigned-byte-63 + simple-array-fixnum + simple-array-unsigned-fixnum) + `((unless (sc-is (tn-ref-tn args) constant) + (test-poison-bit vop temp-reg-tn object index addend)))))))) `(progn (define-vop (,name) ,@(when translate `((:translate ,translate))) @@ -311,6 +334,7 @@ (:results (value :scs ,scs)) (:result-types ,el-type) (:vop-var vop) + (:args-var args) (:generator 3 (let ((ea (ea (- (* (+ ,offset addend) n-word-bytes) ,lowtag) object index (ash 1 (- word-shift n-fixnum-tag-bits))))) @@ -331,6 +355,7 @@ (:results (value :scs ,scs)) (:result-types ,el-type) (:vop-var vop) + (:args-var args) (:generator 2 (let ((ea (ea (- (* (+ ,offset index addend) n-word-bytes) ,lowtag) object))) ,@(trap '(emit-constant (+ index addend))) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index a592c5564..ceb42d957 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -56,7 +56,8 @@ (let* ((hash (if name (mix (sxhash name) (sxhash :generic-function)) ; arb. constant (sb-impl::quasi-random-address-based-hash - (load-time-value (make-array 1 :element-type '(and fixnum unsigned-byte))) + (load-time-value (make-array 1 :element-type '(and fixnum unsigned-byte) + :initial-element 0)) most-positive-fixnum))) (slots (make-array (wrapper-length wrapper) :initial-element +slot-unbound+)) (fin (cond #+(and immobile-code) diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c index 2f6e36d9e..def0285a3 100644 --- a/src/runtime/coreparse.c +++ b/src/runtime/coreparse.c @@ -1163,6 +1163,9 @@ static void graph_visit(lispobj __attribute__((unused)) referer, { struct vector* v = (void*)obj; sword_t len = vector_len(v); +#ifdef LISP_FEATURE_UBSAN + RECURSE(v->length_); +#endif for(i=0; idata[i]); } break; @@ -1204,6 +1207,11 @@ static void graph_visit(lispobj __attribute__((unused)) referer, RECURSE(fdefn_callee_lispobj((struct fdefn*)obj)); break; default: +#ifdef LISP_FEATURE_UBSAN + if (specialized_vector_widetag_p(widetag_of(obj))) + RECURSE(((struct vector*)obj)->length_); +#endif + if (!leaf_obj_widetag_p(widetag_of(obj))) { int size = sizetab[widetag_of(obj)](obj); for(i=1; i>4); - lispobj* code = component_ptr_from_pc(origin_pc); - if (code) gc_mark_obj(make_lispobj(code, OTHER_POINTER_LOWTAG)); - /* else lose("can't find code containing %p (vector=%p)", origin_pc, base); */ - } -#endif + if (leaf_obj_widetag_p(widetag) && !specialized_vector_widetag_p(widetag)) return; +#else if (leaf_obj_widetag_p(widetag)) return; +#endif } else { uword_t key = compute_page_key(pointer); int index = compute_dword_number(pointer); @@ -297,14 +291,14 @@ static void trace_object(lispobj* where) struct weak_pointer *weakptr; switch (widetag) { case SIMPLE_VECTOR_WIDETAG: -#ifdef LISP_FEATURE_UBSAN - if (is_lisp_pointer(where[1])) gc_mark_obj(where[1]); -#endif // non-weak hashtable kv vectors are trivial in fullcgc. Keys don't move // so the table will not need rehash as a result of gc. // Ergo, those may be treated just like ordinary simple vectors. // However, weakness remains as a special case. if (vector_flagp(header, VectorWeak)) { +#ifdef LISP_FEATURE_UBSAN + gc_mark_obj(where[1]); // non-weak slot +#endif if (!vector_flagp(header, VectorHashing)) { add_to_weak_vector_list(where, header); return; @@ -368,6 +362,9 @@ static void trace_object(lispobj* where) add_to_weak_pointer_chain(weakptr); return; default: +#ifdef LISP_FEATURE_UBSAN + if (specialized_vector_widetag_p(widetag)) gc_mark_obj(where[1]); +#endif if (leaf_obj_widetag_p(widetag)) return; } for(i=scan_from; ilength_ ? BOXED_PAGE_FLAG : UNBOXED_PAGE_FLAG) #else -#define SPECIALIZED_VECTOR_PAGE_FLAG UNBOXED_PAGE_FLAG +#define SPECIALIZED_VECTOR_PAGE_FLAG(x) UNBOXED_PAGE_FLAG #endif -static inline void check_shadow_bits(lispobj* v) { +static inline void trace_vector_extra(lispobj* v) { #ifdef LISP_FEATURE_UBSAN - if (is_lisp_pointer(v[1])) { - scavenge(v + 1, 1); // shadow bits - if (vector_len((struct vector*)native_pointer(v[1])) < vector_len((struct vector*)v)) - lose("messed up shadow bits for %p\n", v); - } else if (v[1]) { - char *origin_pc = (char*)(v[1]>>4); - lispobj* code = component_ptr_from_pc(origin_pc); - if (code) scavenge((lispobj*)&code, 1); - /* else if (widetag_of(v)==SIMPLE_VECTOR_WIDETAG) - lose("can't find code containing %p (vector=%p)", origin_pc, v); */ + lispobj bitv = v[1]; + if (is_lisp_pointer(bitv)) { + scavenge(v + 1, 1); // shadow bits or origin + bitv = v[1]; + if (lowtag_of(bitv) == OTHER_POINTER_LOWTAG) + if (vector_len((struct vector*)native_pointer(bitv)) + < vector_len((struct vector*)v)) + lose("messed up shadow bits for %p\n", v); } #endif } @@ -944,7 +943,7 @@ static inline void check_shadow_bits(lispobj* v) { #define DEF_SPECIALIZED_VECTOR(name, nwords) \ static sword_t __attribute__((unused)) scav_##name(\ lispobj *where, lispobj __attribute__((unused)) header) { \ - check_shadow_bits(where); \ + trace_vector_extra(where); \ sword_t length = vector_len(((struct vector*)where)); \ return ALIGN_UP(nwords + 2, 2); \ } \ @@ -952,7 +951,7 @@ static inline void check_shadow_bits(lispobj* v) { gc_dcheck(lowtag_of(object) == OTHER_POINTER_LOWTAG); \ sword_t length = vector_len(VECTOR(object)); \ return copy_large_object(object, ALIGN_UP(nwords + 2, 2), \ - SPECIALIZED_VECTOR_PAGE_FLAG); \ + SPECIALIZED_VECTOR_PAGE_FLAG(object)); \ } \ static sword_t __attribute__((unused)) size_##name(lispobj *where) { \ sword_t length = vector_len(((struct vector*)where)); \ @@ -1395,7 +1394,7 @@ scav_vector_t(lispobj *where, lispobj header) { sword_t length = vector_len((struct vector*)where); - check_shadow_bits(where); + trace_vector_extra(where); /* SB-VM:VECTOR-HASHING-FLAG is set for all hash tables in the * Lisp HASH-TABLE code to indicate need for special GC support. * But note that if the vector is a hashing vector that is neither @@ -1729,14 +1728,7 @@ lispobj simple_fun_name_from_pc(char *pc, lispobj** pfun) return 0; // oops, how did this happen? } -#ifdef LISP_FEATURE_UBSAN -// ubsan tracks memory origin by a not-exactly-gc-safe way -// that kinda works, as long as gc_search_space() doesn't crash, -// which it shouldn't if carefully visiting objects. -#define SEARCH_SPACE_FOLLOWS_FORWARDING_POINTERS 1 -#else #define SEARCH_SPACE_FOLLOWS_FORWARDING_POINTERS 0 -#endif /* Scan an area looking for an object which encloses the given pointer. * Return the object start on success, or NULL on failure. */ lispobj * diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 3b1ed87a2..cdd816e32 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -2925,6 +2925,23 @@ static boolean __attribute__((unused)) card_protected_p(void* addr) lose("card_protected_p(%p)", addr); } +static void check_ubsan_data(lispobj* where) +{ +#ifdef LISP_FEATURE_UBSAN + struct vector* v = (void*)where; + lispobj shadow = v->length_; + if (listp(shadow)) { + // TODO: check something + } else if (other_pointer_p(shadow)) { + struct vector* bits = (void*)native_pointer(shadow); + if (header_widetag(bits->header) != SIMPLE_BIT_VECTOR_WIDETAG) + lose("bad shadow bits for %p", where); + // due to shrink-vector, the source vector can be larger + gc_assert(vector_len(bits) >= vector_len((struct vector*)where)); + } +#endif +} + // NOTE: This function can produces false failure indications, // usually related to dynamic space pointing to the stack of a // dead thread, but there may be other reasons as well. @@ -3051,15 +3068,7 @@ verify_range(lispobj *where, sword_t nwords, struct verify_state *state) lose("Unhandled widetag %d at %p", widetag, where); } else if (leaf_obj_widetag_p(widetag)) { #ifdef LISP_FEATURE_UBSAN - if (specialized_vector_widetag_p(widetag)) { - if (is_lisp_pointer(where[1])) { - struct vector* bits = (void*)native_pointer(where[1]); - if (header_widetag(bits->header) != SIMPLE_BIT_VECTOR_WIDETAG) - lose("bad shadow bits for %p", where); - gc_assert(header_widetag(bits->header) == SIMPLE_BIT_VECTOR_WIDETAG); - gc_assert(vector_len(bits) >= vector_len((struct vector*)where)); - } - } + if (specialized_vector_widetag_p(widetag)) check_ubsan_data(where); #endif count = sizetab[widetag](where); if (strict_containment && gencgc_verbose @@ -3069,6 +3078,9 @@ verify_range(lispobj *where, sword_t nwords, struct verify_state *state) } else switch(widetag) { /* boxed or partially boxed objects */ lispobj layout_word; + case SIMPLE_VECTOR_WIDETAG: + check_ubsan_data(where); + break; case FUNCALLABLE_INSTANCE_WIDETAG: case INSTANCE_WIDETAG: layout_word = layout_of(where); @@ -3166,7 +3178,7 @@ verify_range(lispobj *where, sword_t nwords, struct verify_state *state) state->vaddr = 0; count = ALIGN_UP(sizeof (struct fdefn)/sizeof(lispobj), 2); break; - } + } } } static uword_t verify_space(lispobj start, lispobj* end, uword_t flags) { diff --git a/src/runtime/immobile-space.c b/src/runtime/immobile-space.c index 7e60c3c30..004f15e95 100644 --- a/src/runtime/immobile-space.c +++ b/src/runtime/immobile-space.c @@ -1821,6 +1821,7 @@ static inline int layout_size_class_nwords(int index) { } static inline int nwords_to_layout_size_class(unsigned int nwords) { // the smallest layout size class is 8 words + gc_assert(!(nwords & 1)); // not odd int index = nwords <= 8 ? 0 : (nwords - 8)/2; if (index >= MAX_LAYOUT_DEFRAG_SIZE_CLASSES) lose("Oversized layout: can't defragment"); diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 48e99eae3..621cfc42b 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -972,6 +972,17 @@ undo_fake_foreign_function_call(os_context_t __attribute__((unused)) *context) void interrupt_internal_error(os_context_t *context, boolean continuable) { +#ifdef LISP_FEATURE_UBSAN // avoid an infinite chain of sanitizer errors + unsigned char* pc = (void*)*os_context_pc_addr(context); + if (*pc == trap_Cerror && pc[1] == UNINITIALIZED_ELEMENT_ERROR) { + fprintf(stderr, "ubsan error @ %p. bytes @ pc:", pc); + int i; + for(i=-1;i<5;++i) fprintf(stderr, " %02x", pc[i]); + fputc('\n',stderr); + SYMBOL(UBSAN_ENABLE)->value = 0; + } +#endif + DX_ALLOC_SAP(context_sap, context); fake_foreign_function_call(context); diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 8669de41d..3ffce7df2 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -331,6 +331,9 @@ void create_main_lisp_thread(lispobj function) { #ifdef COLLECT_GC_STATS atexit(summarize_gc_stats); +#endif +#ifdef LISP_FEATURE_UBSAN + SYMBOL(UBSAN_ENABLE)->value = 2; // KLUDGE #endif /* WIN32 has a special stack arrangement, calling * call_into_lisp_first_time will put the new stack in the middle diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp index 21a2f30c6..5beccacbd 100644 --- a/tests/array.pure.lisp +++ b/tests/array.pure.lisp @@ -21,7 +21,7 @@ simple-string) (#\space (make-string 11 :initial-element #\space) string) (#\* (make-string 11 :initial-element #\*)) - (#\null (make-string 11)) + #-ubsan (#\null (make-string 11)) ; exploits undefined behavior (#\null (make-string 11 :initial-element #\null)) (#\x (make-string 11 :initial-element #\x)) ;; And the other tweaks made when fixing bug 126 didn't diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 0728465f6..e28eb70b5 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3835,7 +3835,7 @@ (flet ((make-lambda (n) `(lambda (x) (declare (optimize (speed 3) (space 0))) - (concatenate 'string x ,(make-string n))))) + (concatenate 'string x ,(make-string n :initial-element #\nul))))) (let* ((l0 (make-lambda 1)) (l1 (make-lambda 10)) (l2 (make-lambda 100)) diff --git a/tests/run-program.impure.lisp b/tests/run-program.impure.lisp index 8bec61e5b..84a180edd 100644 --- a/tests/run-program.impure.lisp +++ b/tests/run-program.impure.lisp @@ -417,7 +417,7 @@ (with-test (:name (run-program :malloc-deadlock) :broken-on :sb-safepoint - :skipped-on (or (not :sb-thread) :win32)) + :skipped-on (or (not :sb-thread) :win32 :ubsan)) (let* (stop (delay-between-gc (or #+freebsd diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp index 36a955646..9ada97b4d 100644 --- a/tests/seq.pure.lisp +++ b/tests/seq.pure.lisp @@ -546,8 +546,8 @@ (with-test (:name :array-equalp-non-consing :skipped-on :interpreter) - (let ((a (make-array 1000 :element-type 'double-float)) - (b (make-array 1000 :element-type 'double-float))) + (let ((a (make-array 1000 :element-type 'double-float :initial-element 1.0d0)) + (b (make-array 1000 :element-type 'double-float :initial-element 1.0d0))) (ctu:assert-no-consing (equalp a b)))) (with-test (:name (search :array-equalp-numerics)) diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp index 971223272..2f636ac5e 100644 --- a/tests/stream.impure.lisp +++ b/tests/stream.impure.lisp @@ -814,6 +814,7 @@ (n-bin #'mock-fd-stream-n-bin-fun) (cin-buffer (make-array sb-impl::+ansi-stream-in-buffer-length+ + :initial-element #\nul :element-type 'character)))) buffer-chain) diff --git a/tests/system.impure.lisp b/tests/system.impure.lisp index c3b943726..9073a2ece 100644 --- a/tests/system.impure.lisp +++ b/tests/system.impure.lisp @@ -15,7 +15,9 @@ (test-util:with-test (:name :basic-cpuid) (flet ((to-ascii (bits) - (let ((s (make-array 4 :element-type 'base-char))) + (let ((s (make-array 4 :element-type 'base-char + ;; storing via SAP-REF doesn't update the shadow bits if #+ubsan + :initial-element #\space))) (setf (sap-ref-32 (vector-sap s) 0) bits) s))) (multiple-value-bind (a b c d)