From ad6345c0021507c8830c7c8541ed651a89792335 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 19 Jul 2007 12:58:59 +0000 Subject: [PATCH] 1.0.7.30: be more paranoid about saps * Since compiler transformations can introduce closures and hence cause "this is obviously always on stack or in register" intuition to be wrong, be more vigilant about pinning objects before sap-taking. * Also convert a couple of WITHOUT-GCINGs to WITH-PINNED-OBJECTS instead. --- contrib/sb-posix/interface.lisp | 25 +++++++------ contrib/sb-simple-streams/internal.lisp | 19 ++++++---- src/code/fd-stream.lisp | 66 +++++++++++++++------------------ src/code/stream.lisp | 16 ++++---- src/code/target-alieneval.lisp | 1 + src/code/unix.lisp | 26 ++++++------- src/compiler/generic/vm-tran.lisp | 2 +- src/compiler/target-disassem.lisp | 3 +- version.lisp-expr | 2 +- 9 files changed, 81 insertions(+), 79 deletions(-) diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 37ad3c8c5..91c5b3232 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -305,9 +305,10 @@ (defun wait (&optional statusptr) (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr)) (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) - (pid (alien-funcall - (extern-alien "wait" (function pid-t (* int))) - (sb-sys:vector-sap ptr)))) + (pid (sb-sys:with-pinned-objects (ptr) + (alien-funcall + (extern-alien "wait" (function pid-t (* int))) + (sb-sys:vector-sap ptr))))) (if (minusp pid) (syscall-error) (values pid (aref ptr 0)))))) @@ -321,10 +322,11 @@ (type (sb-alien:alien int) options) (type (or null (simple-array (signed-byte 32) (1))) statusptr)) (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) - (pid (alien-funcall - (extern-alien "waitpid" (function pid-t - pid-t (* int) int)) - pid (sb-sys:vector-sap ptr) options))) + (pid (sb-sys:with-pinned-objects (ptr) + (alien-funcall + (extern-alien "waitpid" (function pid-t + pid-t (* int) int)) + pid (sb-sys:vector-sap ptr) options)))) (if (minusp pid) (syscall-error) (values pid (aref ptr 0))))) @@ -457,10 +459,11 @@ (declare (type (or null (simple-array (signed-byte 32) (2))) filedes2)) (unless filedes2 (setq filedes2 (make-array 2 :element-type '(signed-byte 32)))) - (let ((r (alien-funcall - ;; FIXME: (* INT)? (ARRAY INT 2) would be better - (extern-alien "pipe" (function int (* int))) - (sb-sys:vector-sap filedes2)))) + (let ((r (sb-sys:with-pinned-objects (filedes2) + (alien-funcall + ;; FIXME: (* INT)? (ARRAY INT 2) would be better + (extern-alien "pipe" (function int (* int))) + (sb-sys:vector-sap filedes2))))) (when (minusp r) (syscall-error))) (values (aref filedes2 0) (aref filedes2 1)))) diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp index 44eff2b70..0aefd13a7 100644 --- a/contrib/sb-simple-streams/internal.lisp +++ b/contrib/sb-simple-streams/internal.lisp @@ -28,7 +28,8 @@ (declare (type simple-stream-buffer buffer) (type (integer 0 #.most-positive-fixnum) index)) (if (vectorp buffer) - (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) + (sb-sys:with-pinned-objects (buffer) + (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index)) (sb-sys:sap-ref-8 buffer index))) (defun (setf bref) (octet buffer index) @@ -36,7 +37,8 @@ (type simple-stream-buffer buffer) (type (integer 0 #.most-positive-fixnum) index)) (if (vectorp buffer) - (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet) + (sb-sys:with-pinned-objects (buffer) + (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet)) (setf (sb-sys:sap-ref-8 buffer index) octet))) (defun buffer-copy (src soff dst doff length) @@ -338,8 +340,9 @@ (setf (bref buffer i) 0)) (setf (bref buffer (1- end)) 0) (multiple-value-bind (bytes errno) - (sb-unix:unix-read fd (buffer-sap buffer start) - (the fixnum (- end start))) + (sb-sys:with-pinned-objects (buffer) + (sb-unix:unix-read fd (buffer-sap buffer start) + (the fixnum (- end start)))) (declare (type (or null fixnum) bytes) (type (integer 0 100) errno)) (when bytes @@ -388,8 +391,9 @@ (let ((count 0)) (tagbody again (multiple-value-bind (bytes errno) - (sb-unix:unix-write fd (buffer-sap buffer) start - (- end start)) + (sb-sys:with-pinned-objects (buffer) + (sb-unix:unix-write fd (buffer-sap buffer) start + (- end start))) (when bytes (incf count bytes) (incf start bytes)) @@ -419,7 +423,8 @@ (type sb-int:index start end len)) (tagbody again (multiple-value-bind (bytes errno) - (sb-unix:unix-write fd (buffer-sap buffer) start len) + (sb-sys:with-pinned-objects (buffer) + (sb-unix:unix-write fd (buffer-sap buffer) start len)) (cond ((null bytes) (if (= errno sb-unix:eintr) (go again) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index d87be01ff..26d8f0729 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1227,26 +1227,22 @@ bytes-per-buffer of memory.") (let* ((length (length string)) (,n-buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8))) - ;; This SAP-taking may seem unsafe without pinning, - ;; but since the variable name is a gensym OUT-EXPR - ;; cannot close over it even if it tried, so the buffer - ;; will always be either in a register or on stack. - ;; FIXME: But ...this is true on x86oids only! - (sap (vector-sap ,n-buffer)) (tail 0) (stream ,name)) - (declare (type index length tail) - (type system-area-pointer sap)) - (dotimes (i length) - (let* ((byte (aref string i)) - (bits (char-code byte))) - (declare (ignorable byte bits)) - ,out-expr) - (incf tail ,size)) - (let* ((bits 0) - (byte (code-char bits))) - (declare (ignorable bits byte)) - ,out-expr) + (declare (type index length tail)) + (with-pinned-objects (,n-buffer) + (let ((sap (vector-sap ,n-buffer))) + (declare (system-area-pointer sap)) + (dotimes (i length) + (let* ((byte (aref string i)) + (bits (char-code byte))) + (declare (ignorable byte bits)) + ,out-expr) + (incf tail ,size)) + (let* ((bits 0) + (byte (code-char bits))) + (declare (ignorable bits byte)) + ,out-expr))) ,n-buffer))) (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function @@ -1479,29 +1475,25 @@ bytes-per-buffer of memory.") (tail 0) (,n-buffer (make-array buffer-length :element-type '(unsigned-byte 8))) - ;; This SAP-taking may seem unsafe without pinning, - ;; but since the variable name is a gensym OUT-EXPR - ;; cannot close over it even if it tried, so the buffer - ;; will always be either in a register or on stack. - ;; FIXME: But ...this is true on x86oids only! - (sap (vector-sap ,n-buffer)) stream) (declare (type index length buffer-length tail) - (type system-area-pointer sap) (type null stream) (ignorable stream)) - (loop for i of-type index below length - for byte of-type character = (aref string i) - for bits = (char-code byte) - for size of-type index = (aref char-length i) - do (prog1 - ,out-expr - (incf tail size))) - (let* ((bits 0) - (byte (code-char bits)) - (size (aref char-length length))) - (declare (ignorable bits byte size)) - ,out-expr) + (with-pinned-objects (,n-buffer) + (let ((sap (vector-sap ,n-buffer))) + (declare (system-area-pointer sap)) + (loop for i of-type index below length + for byte of-type character = (aref string i) + for bits = (char-code byte) + for size of-type index = (aref char-length i) + do (prog1 + ,out-expr + (incf tail size))) + (let* ((bits 0) + (byte (code-char bits)) + (size (aref char-length length))) + (declare (ignorable bits byte size)) + ,out-expr))) ,n-buffer))) (setf *external-formats* diff --git a/src/code/stream.lisp b/src/code/stream.lisp index d2614b988..cbbdf974e 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1136,14 +1136,14 @@ (truly-the index (+ index copy))) ;; FIXME: why are we VECTOR-SAP'ing things here? what's the point? ;; and are there SB-UNICODE issues here as well? --njf, 2005-03-24 - (without-gcing - (system-area-ub8-copy (vector-sap string) - index - (if (typep buffer 'system-area-pointer) - buffer - (vector-sap buffer)) - start - copy))) + (with-pinned-objects (string buffer) + (system-area-ub8-copy (vector-sap string) + index + (if (typep buffer 'system-area-pointer) + buffer + (vector-sap buffer)) + start + copy))) (if (and (> requested copy) eof-error-p) (error 'end-of-file :stream stream) copy))) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 5d0036a28..37600b6f4 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -792,6 +792,7 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (vector-push-extend (alien-callback-lisp-trampoline wrapper function) *alien-callback-trampolines*) + ;; Assembler-wrapper is static, so sap-taking is safe. (let ((sap (vector-sap assembler-wrapper))) (push (cons sap (make-callback-info :specifier specifier :function function diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 4c2bc79d3..7021ce4a1 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -295,19 +295,19 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun unix-write (fd buf offset len) (declare (type unix-fd fd) (type (unsigned-byte 32) offset len)) - (int-syscall ("write" int (* char) int) - fd - (with-alien ((ptr (* char) (etypecase buf - ((simple-array * (*)) - ;; This SAP-taking is - ;; safe as BUF remains - ;; either in a register - ;; or on stack. - (vector-sap buf)) - (system-area-pointer - buf)))) - (addr (deref ptr offset))) - len)) + (flet ((%write (sap) + (declare (system-area-pointer sap)) + (int-syscall ("write" int (* char) int) + fd + (with-alien ((ptr (* char) sap)) + (addr (deref ptr offset))) + len))) + (etypecase buf + ((simple-array * (*)) + (with-pinned-objects (buf) + (%write (vector-sap buf)))) + (system-area-pointer + (%write buf))))) ;;; Set up a unix-piping mechanism consisting of an input pipe and an ;;; output pipe. Return two values: if no error occurred the first diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 8530c1c6e..a4fb8fd9b 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -599,7 +599,7 @@ ;; declare it in the DEFKNOWN too.) ((simple-unboxed-array (*)) (vector-sap thing))))) (declare (inline sapify)) - (without-gcing + (with-pinned-objects (dst src) (memmove (sap+ (sapify dst) dst-start) (sap+ (sapify src) src-start) (- dst-end dst-start))) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 996bc96c8..ae62e1a30 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -796,6 +796,7 @@ ;;; Make a disassembler-state object. (defun make-dstate (&optional (fun-hooks *default-dstate-hooks*)) (let ((sap + ;; FIXME: What is this for? This cannot be safe! (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8))))) (alignment *disassem-inst-alignment-bytes*) (arg-column @@ -827,8 +828,8 @@ ;;; A SAP-MAKER is a no-argument function that returns a SAP. +;; FIXME: Are the objects we are taking saps for always pinned? #!-sb-fluid (declaim (inline sap-maker)) - (defun sap-maker (function input offset) (declare (optimize (speed 3)) (type (function (t) sb!sys:system-area-pointer) function) diff --git a/version.lisp-expr b/version.lisp-expr index ee2190b7a..b6abbe37c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.7.29" +"1.0.7.30" -- 2.11.4.GIT