[Sbcl-commits] CVS: sbcl/src/code host-alieneval.lisp, 1.40, 1.41 host-c-call.lisp, 1.9, 1.10 target-alieneval.lisp, 1.47, 1.48

[Juho S. <js...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv10024/src/code

Modified Files:
	host-alieneval.lisp host-c-call.lisp target-alieneval.lisp 
Log Message:
1.0.3.11: Fix deportation gc safety bug

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


Index: host-alieneval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/host-alieneval.lisp,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -d -r1.40 -r1.41
--- host-alieneval.lisp	18 Jan 2006 11:28:28 -0000	1.40
+++ host-alieneval.lisp	2 Mar 2007 04:35:59 -0000	1.41
@@ -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))

Index: host-c-call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/host-c-call.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- host-c-call.lisp	6 Sep 2006 20:27:10 -0000	1.9
+++ host-c-call.lisp	2 Mar 2007 04:36:02 -0000	1.10
@@ -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")

Index: target-alieneval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-alieneval.lisp,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- target-alieneval.lisp	23 Oct 2006 13:45:53 -0000	1.47
+++ target-alieneval.lisp	2 Mar 2007 04:36:02 -0000	1.48
@@ -463,6 +463,8 @@
 
 (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 @@
             (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 @@
   (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)