(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))))))
(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)))))
(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))))
(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)
(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)
(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
(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))
(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)
(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
(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*
(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)))
(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
(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
;; 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)))
;;; 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
\f
;;; 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)
;;; 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"
projects / sbcl.git / commitdiff