common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Ubsan feature mostly working

Browse source
This commit is contained in:
Douglas Katzman 2021-06-15 17:19:27 -04:00
parent 002fea56ce
commit d931c7eb7b
58 changed files with 567 additions and 260 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
contrib/sb-md5/md5.lisp
View file

@ -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

5
contrib/sb-posix/posix-tests.lisp
View file

@ -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))

3
contrib/sb-posix/strtod.lisp
View file

@ -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

2
package-data-list.lisp-expr
View file

@ -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"

14
src/code/array.lisp
View file

@ -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)

54
src/code/bit-bash.lisp
View file

@ -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))))))

7
src/code/coerce.lisp
View file

@ -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))

23
src/code/condition.lisp
View file

@ -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?

3
src/code/cross-float.lisp
View file

@ -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)

3
src/code/debug-int.lisp
View file

@ -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)

3
src/code/debug-var-io.lisp
View file

@ -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)))))))

2
src/code/debug.lisp
View file

@ -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

1
src/code/early-extensions.lisp
View file

@ -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)))

8
src/code/early-pprint.lisp
View file

@ -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

3
src/code/external-formats/enc-basic.lisp
View file

@ -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

2
src/code/fd-stream.lisp
View file

@ -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

5
src/code/fop.lisp
View file

@ -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)

2
src/code/icf.lisp
View file

@ -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)

28
src/code/macros.lisp
View file

@ -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))

10
src/code/pprint.lisp
View file

@ -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)

12
src/code/print.lisp
View file

@ -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.

11
src/code/reader.lisp
View file

@ -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)

6
src/code/room.lisp
View file

@ -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))))

2
src/code/run-program.lisp
View file

@ -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*)))

2
src/code/save.lisp
View file

@ -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)

7
src/code/seq.lisp
View file

@ -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))

58
src/code/stream.lisp
View file

@ -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)))))))

8
src/code/string.lisp
View file

@ -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)

1
src/code/target-hash-table.lisp
View file

@ -11,6 +11,7 @@
;;;; files for more information.
(in-package "SB-IMPL")
(declaim (optimize (sb-c::aref-poison-detect 0)))
;;;; utilities

3
src/code/target-random.lisp
View file

@ -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)

2
src/code/type.lisp
View file

@ -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.

1
src/cold/shared.lisp
View file

@ -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")

23
src/compiler/array-tran.lisp
View file

@ -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

4
src/compiler/assem.lisp
View file

@ -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)))

2
src/compiler/generic/parms.lisp
View file

@ -202,6 +202,8 @@
#-sb-thread *stepping*
#+ubsan *ubsan-enable*
;; threading support
#+sb-thread ,@'(sb-thread::*starting-threads* *free-tls-index*)

9
src/compiler/generic/vm-array.lisp
View file

@ -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.

13
src/compiler/generic/vm-tran.lisp
View file

@ -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

4
src/compiler/pack.lisp
View file

@ -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

2
src/compiler/policies.lisp
View file

@ -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"))

32
src/compiler/seqtran.lisp
View file

@ -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

138
src/compiler/x86-64/alloc.lisp
View file

@ -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)

114
src/compiler/x86-64/array.lisp
View file

@ -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))

15
src/compiler/x86-64/insts.lisp
View file

@ -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)

39
src/compiler/x86-64/macros.lisp
View file

@ -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)))

3
src/pcl/braid.lisp
View file

@ -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)

8
src/runtime/coreparse.c
View file

@ -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; i<len; ++i) RECURSE(v->data[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<size; ++i) RECURSE(obj[i]);

21
src/runtime/fullcgc.c
View file

@ -208,16 +208,10 @@ void __mark_obj(lispobj pointer)
*base |= markbit;
}
#ifdef LISP_FEATURE_UBSAN
if (specialized_vector_widetag_p(widetag) && is_lisp_pointer(base[1]))
gc_mark_obj(base[1]);
else if (widetag == SIMPLE_VECTOR_WIDETAG && fixnump(base[1])) {
char *origin_pc = (char*)(base[1]>>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; i<scan_to; ++i)

42
src/runtime/gc-common.c
View file

@ -918,25 +918,24 @@ static inline uword_t NWORDS(uword_t x, uword_t n_bits)
}
#ifdef LISP_FEATURE_UBSAN
// If specialized vectors point to a vector of bits in their first
// word after the header, they can't be relocated to unboxed pages.
#define SPECIALIZED_VECTOR_PAGE_FLAG BOXED_PAGE_FLAG
// If a specialized vector point to a vector of shadow bits
// then it can't be relocated to an unboxed page.
#define SPECIALIZED_VECTOR_PAGE_FLAG(x) \
(VECTOR(x)->length_ ? 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 *

32
src/runtime/gencgc.c
View file

@ -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) {

1
src/runtime/immobile-space.c
View file

@ -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");

11
src/runtime/interrupt.c
View file

@ -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);

3
src/runtime/thread.c
View file

@ -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

2
tests/array.pure.lisp
View file

@ -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

2
tests/compiler.pure.lisp
View file

@ -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))

2
tests/run-program.impure.lisp
View file

@ -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

4
tests/seq.pure.lisp
View file

@ -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))

1
tests/stream.impure.lisp
View file

@ -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)

4
tests/system.impure.lisp
View file

@ -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)