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)
"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"
"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"))
(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))
(: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)))
(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)
(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))
(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))
(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
`(%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")
(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)
(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)
(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)
(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
(%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)
(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))
result)
adds
shifts)))
+
+\f
+;;; 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)))
(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
(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
;;; 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"
projects / sbcl.git / commitdiff