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

1.0.3.11: Fix deportation gc safety bug

Browse source 
* Pin objects that are deported by taking a SAP to a GCd object
          * In some cases the object that the SAP is taken to isn't actually
            EQ to the one that was deported -> split deportation into
            separate alien-type-class-methods for the allocation and the
            actual deportation.
          * Don't do pinning on non-x86oids, since we can't really disable
            the GC during all alien calls.
This commit is contained in:
Juho Snellman 2007-03-02 04:35:58 +00:00
parent ecfebb8709
commit 6fa968aaa8
10 changed files with 118 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
NEWS
View file

@ -13,6 +13,8 @@ changes in sbcl-1.0.4 relative to sbcl-1.0.3:
and 1.0.3).
* bug fix: SHADOW accepts characters as string designators, as required
by the spec (thanks to Eric Marsden)
* bug fix: fixed GC safety issues when foreign functions are called with
non-base strings as arguments
changes in sbcl-1.0.3 relative to sbcl-1.0.2:
* new platform: NetBSD/PPC. (thanks to Aymeric Vincent)

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

@ -103,11 +103,12 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"ALIEN-VALUE-SAP" "ALIEN-VALUE-P"
"ALIEN-VALUES-TYPE" "ALIEN-VALUES-TYPE-P"
"ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "ALIEN-VOID-TYPE-P"
"COMPUTE-ALIEN-REP-TYPE"
"COMPUTE-ALIEN-REP-TYPE" "COMPUTE-DEPORT-ALLOC-LAMBDA"
"COMPUTE-DEPORT-LAMBDA" "COMPUTE-DEPOSIT-LAMBDA"
"COMPUTE-EXTRACT-LAMBDA" "COMPUTE-LISP-REP-TYPE"
"COMPUTE-NATURALIZE-LAMBDA" "DEFINE-ALIEN-TYPE-CLASS"
"DEFINE-ALIEN-TYPE-METHOD" "DEFINE-ALIEN-TYPE-TRANSLATOR" "DEPORT"
"DEFINE-ALIEN-TYPE-METHOD" "DEFINE-ALIEN-TYPE-TRANSLATOR"
"DEPORT" "DEPORT-ALLOC"
"DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN"
"*ENTER-ALIEN-CALLBACK*" "ENTER-ALIEN-CALLBACK"
"EXTRACT-ALIEN-VALUE"
@ -116,7 +117,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P"
"LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE"
"MAKE-ALIEN-FUN-TYPE" "MAKE-ALIEN-POINTER-TYPE"
"MAKE-ALIEN-VALUE"
"MAKE-ALIEN-VALUE" "MAYBE-WITH-PINNED-OBJECTS"
"MAKE-LOCAL-ALIEN" "NATURALIZE"
"NOTE-LOCAL-ALIEN-TYPE"
"PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE"))

53
src/code/host-alieneval.lisp
View file

@ -43,6 +43,8 @@
(deposit-gen nil :type (or null function))
(naturalize-gen nil :type (or null function))
(deport-gen nil :type (or null function))
(deport-alloc-gen nil :type (or null function))
(deport-pin-p nil :type (or null function))
;; Cast?
(arg-tn nil :type (or null function))
(result-tn nil :type (or null function))
@ -73,6 +75,8 @@
(:deposit-gen . alien-type-class-deposit-gen)
(:naturalize-gen . alien-type-class-naturalize-gen)
(:deport-gen . alien-type-class-deport-gen)
(:deport-alloc-gen . alien-type-class-deport-alloc-gen)
(:deport-pin-p . alien-type-class-deport-pin-p)
;; cast?
(:arg-tn . alien-type-class-arg-tn)
(:result-tn . alien-type-class-result-tn)))
@ -445,6 +449,11 @@
(ignore ignore))
,form)))
(defun compute-deport-alloc-lambda (type)
`(lambda (value ignore)
(declare (ignore ignore))
,(invoke-alien-type-method :deport-alloc-gen type 'value)))
(defun compute-extract-lambda (type)
`(lambda (sap offset ignore)
(declare (type system-area-pointer sap)
@ -453,20 +462,38 @@
(naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset)
',type)))
(def!macro maybe-with-pinned-objects (variables types &body body)
(let ((pin-variables
;; Only pin things on x86/x86-64, since on non-conservative
;; gcs it'd imply disabling the GC. Which is something we
;; don't want to do every time we're calling to C.
#+(or x86 x86-64)
(loop for variable in variables
for type in types
when (invoke-alien-type-method :deport-pin-p type)
collect variable)))
(if pin-variables
`(with-pinned-objects ,pin-variables
,@body)
`(progn
,@body))))
(defun compute-deposit-lambda (type)
(declare (type alien-type type))
`(lambda (sap offset ignore value)
(declare (type system-area-pointer sap)
(type unsigned-byte offset)
(ignore ignore))
(let ((value (deport value ',type)))
,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
;; Note: the reason we don't just return the pre-deported value
;; is because that would inhibit any (deport (naturalize ...))
;; optimizations that might have otherwise happen. Re-naturalizing
;; the value might cause extra consing, but is flushable, so probably
;; results in better code.
(naturalize value ',type))))
(let ((alloc-tmp (deport-alloc value ',type)))
(maybe-with-pinned-objects (alloc-tmp) (,type)
(let ((value (deport alloc-tmp ',type)))
,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
;; Note: the reason we don't just return the pre-deported value
;; is because that would inhibit any (deport (naturalize ...))
;; optimizations that might have otherwise happen. Re-naturalizing
;; the value might cause extra consing, but is flushable, so probably
;; results in better code.
(naturalize value ',type))))))
(defun compute-lisp-rep-type (type)
(invoke-alien-type-method :lisp-rep type))
@ -502,6 +529,16 @@
(declare (ignore object))
(error "cannot represent ~S typed aliens" type))
(define-alien-type-method (root :deport-alloc-gen) (type object)
(declare (ignore type))
object)
(define-alien-type-method (root :deport-pin-p) (type)
(declare (ignore type))
;; Override this method to return T for classes which take a SAP to a
;; GCable lisp object when deporting.
nil)
(define-alien-type-method (root :extract-gen) (type sap offset)
(declare (ignore sap offset))
(error "cannot represent ~S typed aliens" type))

48
src/code/host-c-call.lisp
View file

@ -36,7 +36,11 @@
(define-alien-type-method (c-string :lisp-rep) (type)
(declare (ignore type))
'(or simple-string null (alien (* char))))
'(or simple-string null (alien (* char)) (simple-array (unsigned-byte 8))))
(define-alien-type-method (c-string :deport-pin-p) (type)
(declare (ignore type))
t)
(defun c-string-needs-conversion-p (type)
#+sb-xc-host
@ -77,45 +81,27 @@
`(%naturalize-c-string ,alien))))
(define-alien-type-method (c-string :deport-gen) (type value)
(declare (ignore type))
`(etypecase ,value
(null (int-sap 0))
((alien (* char)) (alien-sap ,value))
;; FIXME: GC safety alert! These SAPs are not safe, since the
;; Lisp string can move. This is not hard to arrange, for example
;; the following will fail very quickly on a SB-UNICODE build:
;;
;; (setf (bytes-consed-between-gcs) 4096)
;; (define-alien-routine "strcmp" int (s1 c-string) (s2 c-string))
;;
;; (loop
;; (let ((string "hello, world"))
;; (assert (zerop (strcmp string string)))))
;;
;; (This will appear to work on post-0.9.8.19 GENCGC, since
;; the GC no longer zeroes memory immediately after releasing
;; it after a minor GC. Either enabling the READ_PROTECT_FREE_PAGES
;; #define in gencgc.c or modifying the example so that a major
;; GC will occasionally be triggered would unmask the bug).
;;
;; The pure VECTOR-SAP branch for the SIMPLE-BASE-STRING case
;; will generally be very hard to trigger on GENCGC (even when
;; threaded) thanks to GC conservativeness. It's mostly a problem
;; on cheneygc. -- JES, 2006-01-13
(vector (vector-sap ,value))))
(define-alien-type-method (c-string :deport-alloc-gen) (type value)
`(etypecase ,value
(null nil)
((alien (* char)) ,value)
(simple-base-string
,(if (c-string-needs-conversion-p type)
;; If the alien type is not ascii-compatible (+SB-UNICODE)
;; or latin-1-compatible (-SB-UNICODE), we need to do
;; external format conversion.
`(vector-sap (string-to-c-string ,value
(c-string-external-format ,type)))
`(string-to-c-string ,value
(c-string-external-format ,type))
;; Otherwise we can just pass it uncopied.
`(vector-sap ,value)))
;; This case, on the other hand, will cause trouble on GENCGC, since
;; we're taking the SAP of a immediately discarded temporary -> the
;; conservativeness doesn't protect us.
;; -- JES, 2006-01-13
value))
(simple-string
(vector-sap (string-to-c-string ,value
(c-string-external-format ,type))))))
(string-to-c-string ,value
(c-string-external-format ,type)))))
(/show0 "host-c-call.lisp end of file")

13
src/code/target-alieneval.lisp
View file

@ -463,6 +463,8 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
(define-setf-expander local-alien (&whole whole info alien)
(let ((value (gensym))
(info-var (gensym))
(alloc-tmp (gensym))
(info (if (and (consp info)
(eq (car info) 'quote))
(second info)
@ -473,8 +475,10 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
(list value)
`(if (%local-alien-forced-to-memory-p ',info)
(%set-local-alien ',info ,alien ,value)
(setf ,alien
(deport ,value ',(local-alien-info-type info))))
(let* ((,info-var ',(local-alien-info-type info))
(,alloc-tmp (deport-alloc ,value ,info-var)))
(maybe-with-pinned-objects (,alloc-tmp) (,(local-alien-info-type info))
(setf ,alien (deport ,alloc-tmp ,info-var)))))
whole)))
(defun %local-alien-forced-to-memory-p (info)
@ -544,6 +548,11 @@ allocated using ``malloc'', so it can be passed to foreign functions which use
(funcall (coerce (compute-deport-lambda type) 'function)
value type))
(defun deport-alloc (value type)
(declare (type alien-type type))
(funcall (coerce (compute-deport-alloc-lambda type) 'function)
value type))
(defun extract-alien-value (sap offset type)
(declare (type system-area-pointer sap)
(type unsigned-byte offset)

25
src/compiler/aliencomp.lisp
View file

@ -61,6 +61,8 @@
(flushable movable))
(defknown deport (alien alien-type) t
(flushable movable))
(defknown deport-alloc (alien alien-type) t
(flushable movable))
(defknown extract-alien-value (system-area-pointer unsigned-byte alien-type) t
(flushable))
(defknown deposit-alien-value (system-area-pointer unsigned-byte alien-type t) t
@ -506,6 +508,8 @@
(%computed-lambda #'compute-naturalize-lambda type))
(deftransform deport ((alien type) * * :important t)
(%computed-lambda #'compute-deport-lambda type))
(deftransform deport-alloc ((alien type) * * :important t)
(%computed-lambda #'compute-deport-alloc-lambda type))
(deftransform extract-alien-value ((sap offset type) * * :important t)
(%computed-lambda #'compute-extract-lambda type))
(deftransform deposit-alien-value ((sap offset type value) * * :important t)
@ -627,10 +631,31 @@
(let ((param (gensym)))
(params param)
(deports `(deport ,param ',arg-type))))
;; Build BODY from the inside out.
(let ((return-type (alien-fun-type-result-type alien-type))
;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
;; to them) and do the call.
(body `(%alien-funcall (deport function ',alien-type)
',alien-type
,@(deports))))
;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
;; the SAPs are taken for won't be moved by the GC. (If
;; needed: some alien types won't need it).
(setf body `(maybe-with-pinned-objects ,(params) ,arg-types
,body))
;; Around that handle any memory allocation that's needed.
;; Mostly the DEPORT-ALLOC alien-type-methods are just an
;; identity operation, but for example for deporting a
;; Unicode string we need to convert the string into an
;; octet array. This step needs to be done before the pinning
;; to ensure we pin the right objects, so it can't be combined
;; with the deporting.
;; -- JES 2006-03-16
(loop for param in (params)
for arg-type in arg-types
do (setf body
`(let ((,param (deport-alloc ,param ',arg-type)))
,body)))
(if (alien-values-type-p return-type)
(collect ((temps) (results))
(dolist (type (alien-values-type-values return-type))

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

@ -732,3 +732,14 @@
result)
adds
shifts)))
;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
;;; VOP can't handle them.
(deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg fixnum)))
(ash (lvar-value obj) sb!vm::n-fixnum-tag-bits))
(deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg character)))
(logior sb!vm::character-widetag
(ash (char-code (lvar-value obj)) sb!vm::n-widetag-bits)))

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

@ -414,7 +414,7 @@
(move result value)))))
;;; helper for alien stuff.
(defmacro with-pinned-objects ((&rest objects) &body body)
(def!macro with-pinned-objects ((&rest objects) &body body)
"Arrange with the garbage collector that the pages occupied by
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger

2
src/compiler/x86/macros.lisp
View file

@ -507,7 +507,7 @@
(move result value)))))
;;; helper for alien stuff.
(defmacro with-pinned-objects ((&rest objects) &body body)
(def!macro with-pinned-objects ((&rest objects) &body body)
"Arrange with the garbage collector that the pages occupied by
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger

2
version.lisp-expr
View file

@ -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.3.10"
"1.0.3.11"