commit 2eb5beb3c8b51d6c7b88f6d88f68e502c7884a89
parent 1f7921ed6268a66b5ba9b71cc096f723ccfa2cdb
Author: Miroslav Urbanek <mu@miroslavurbanek.com>
Date: Wed, 28 Jun 2017 11:45:21 +0200
Pin array storage vectors instead of arrays
SBCL was crashing with errors "GC invariant lost" and "no scavenge
function for object". Crashes began with the SBCL commit 1439c9f07ad8
("In GC cards that are pointed to conservatively, wipe out unused
words."). The bug was in not pinning vectors returned by
storage-array-vector. It was present from the very first version on
and only manifested itself due to the commit above.
Diffstat:
4 files changed, 40 insertions(+), 14 deletions(-)
diff --git a/tebdol/array.lisp b/tebdol/array.lisp
@@ -1,5 +1,5 @@
(defpackage :array
- (:use :common-lisp :sb-alien :util :blas)
+ (:use :common-lisp :sb-ext :sb-alien :util :blas)
(:export :array-copy
:array-scalar-/
:array-conjugate
@@ -81,7 +81,7 @@
(l (loop for i below rx unless (member i ix) collect (nth i d))))
(values d k l)))
(alien (a)
- `(sap-alien (sb-sys:vector-sap (sb-ext:array-storage-vector ,a)) (* double)))
+ `(sap-alien (sb-sys:vector-sap (array-storage-vector ,a)) (* double)))
(contract (pa pb)
(let (transa transb lda ldb)
(if (eql pa :left)
@@ -90,7 +90,12 @@
(if (eql pb :left)
(setf transa "n" lda 'm)
(setf transa "t" lda 'k))
- `(sb-sys:with-pinned-objects (a b c *blas-alien-0* *blas-alien-1*)
+ `(sb-sys:with-pinned-objects
+ ((array-storage-vector a)
+ (array-storage-vector b)
+ (array-storage-vector c)
+ (array-storage-vector *blas-alien-0*)
+ (array-storage-vector *blas-alien-1*))
(zgemm ,transa ,transb m n k ,(alien *blas-alien-1*) ,(alien 'b) ,lda
,(alien 'a) ,ldb ,(alien '*blas-alien-0*) ,(alien 'c) m)
c))))
@@ -159,7 +164,6 @@
(if (numberp indices)
(setf indices (list indices)))
(let ((r (array-rank array)))
-
;; permute indices if they are not in the correct order
(unless (and (eql (indices-position r indices) :left)
(apply #'< indices))
@@ -185,7 +189,13 @@
(iwork (make-integer-array (* 8 min))))
;; svd
- (sb-sys:with-pinned-objects (array s u vt rwork iwork)
+ (sb-sys:with-pinned-objects
+ ((array-storage-vector array)
+ (array-storage-vector s)
+ (array-storage-vector u)
+ (array-storage-vector vt)
+ (array-storage-vector rwork)
+ (array-storage-vector iwork))
(let ((ba (blas-array-alien array))
(bs (blas-array-alien s))
(bu (blas-array-alien u))
@@ -194,7 +204,7 @@
(biwork (blas-array-alien iwork)))
(macrolet ((f ()
;; todo: zgesdd returns info parameter, check it
- `(sb-sys:with-pinned-objects (work)
+ `(sb-sys:with-pinned-objects ((array-storage-vector work))
(zgesdd "s" m n ba m bs bu m bvt min (blas-array-alien work)
lwork brwork biwork))))
(f)
@@ -207,6 +217,9 @@
(defun array-addf (x y)
(unless (= (array-total-size x) (array-total-size y))
(error "Array dimensions do not match."))
- (sb-sys:with-pinned-objects (x y *blas-alien-1*)
+ (sb-sys:with-pinned-objects
+ ((array-storage-vector x)
+ (array-storage-vector y)
+ (array-storage-vector *blas-alien-1*))
(zaxpy (array-total-size x) (blas-array-alien *blas-alien-1*)
(blas-array-alien y) 1 (blas-array-alien x) 1)))
diff --git a/tebdol/exp.lisp b/tebdol/exp.lisp
@@ -1,5 +1,5 @@
(defpackage :exp
- (:use :common-lisp :blas :array)
+ (:use :common-lisp :sb-ext :blas :array)
(:export :hermitian-matrix-exponential))
(in-package :exp)
@@ -21,14 +21,21 @@
(lrwork -1)
(iwork (make-integer-array 1))
(liwork -1))
- (sb-sys:with-pinned-objects (matrix w z isuppz)
+ (sb-sys:with-pinned-objects
+ ((array-storage-vector matrix)
+ (array-storage-vector w)
+ (array-storage-vector z)
+ (array-storage-vector isuppz))
(let ((ba (double-array-alien matrix))
(bw (double-array-alien w))
(bz (double-array-alien z))
(bisuppz (integer-array-alien isuppz)))
(macrolet ((m ()
;; todo: zheevr returns info parameter, check it
- `(sb-sys:with-pinned-objects (work rwork iwork)
+ `(sb-sys:with-pinned-objects
+ ((array-storage-vector work)
+ (array-storage-vector rwork)
+ (array-storage-vector iwork))
(let ((bwork (double-array-alien work))
(brwork (double-array-alien rwork))
(biwork (integer-array-alien iwork)))
diff --git a/tebdol/mpi.lisp b/tebdol/mpi.lisp
@@ -185,7 +185,8 @@
(defun mpi-send-object (object dest)
(let ((buf (serialize object)))
- (sb-sys:with-pinned-objects (buf)
+ (sb-sys:with-pinned-objects
+ ((sb-ext:array-storage-vector buf))
(alien-mpi-send
(sap-alien
(sb-sys:vector-sap (sb-ext:array-storage-vector buf))
@@ -225,7 +226,8 @@
(alien-mpi-probe source 0 *mpi-comm-world* (addr status))
(alien-mpi-get-count (addr status) *mpi-byte* (addr count))
(let ((buf (make-array count :element-type '(unsigned-byte 8))))
- (sb-sys:with-pinned-objects (buf)
+ (sb-sys:with-pinned-objects
+ ((sb-ext:array-storage-vector buf))
(alien-mpi-recv
(sap-alien
(sb-sys:vector-sap (sb-ext:array-storage-vector buf))
diff --git a/tebdol/serial.lisp b/tebdol/serial.lisp
@@ -153,7 +153,9 @@
(i (ser d buf pos)))
(declare (type fixnum n i))
(if (plusp (length buf))
- (sb-sys:with-pinned-objects (obj buf)
+ (sb-sys:with-pinned-objects
+ ((sb-ext:array-storage-vector obj)
+ (sb-ext:array-storage-vector buf))
(sb-sys:memmove
(sb-alien:sap-alien
(sb-sys:sap+
@@ -173,7 +175,9 @@
(let* ((obj (make-blas-array d))
(n (* (array-total-size obj) +blas-float-size+)))
(declare (type fixnum n))
- (sb-sys:with-pinned-objects (obj buf)
+ (sb-sys:with-pinned-objects
+ ((sb-ext:array-storage-vector obj)
+ (sb-ext:array-storage-vector buf))
(sb-sys:memmove
(sb-alien:sap-alien
(sb-sys:vector-sap (sb-ext:array-storage-vector obj))
