Ticket #1257: read-serialized-string-bug.3.lisp

File read-serialized-string-bug.3.lisp, 3.7 KB (added by wws, 5 years ago)

New attachment identifies the bug as a garbage collection problem

Line 
1;;;; Reproduce the dot-context error I'm seeing in my application.
2;;;; Only happens on multi-core ARM processors.
3
4;;;; Load this file and execute (cl-user::read-from-serialized-string)
5;;;; To get fewer errors, pass a :thread-count of the number of cores
6;;;; on your machine. You'll pretty quickly get a break in
7;;;; read-list-expression-advice informing you of a mismatch between
8;;;; *stream* and stream. It seems that the garbage collector
9;;;; sometimes moves *stream*, but neglects to move the local copy.
10
11;;;; The error message will print as two instances of
12;;;; STRING-INPUT-STREAM at different addresses. If you look at the
13;;;; local var STREAM later, it will likely be a BOGUS-OBJECT due to
14;;;; being overwritten by consing from the other thread(s).
15
16(in-package :cl-user)
17
18(defvar *schedule-in-reader-p* nil)
19
20(defvar *stream* nil)
21
22(defun read-list-expression-advice (arglist)
23  (when *schedule-in-reader-p*
24    (ccl:process-allow-schedule)
25    (when *stream*
26      (let* ((stream (car arglist)))
27        (unless (eq stream *stream*)
28          (break "stream: ~s, *stream*: ~s" stream *stream*))))))
29
30(ccl:advise ccl::%read-list-expression
31            (progn
32              (read-list-expression-advice arglist)
33              (:do-it))
34            :when :around
35            :name read-serialized-string)
36
37(defun read-from-serialized-string (&key (thread-count 7)
38                                    (loop-count 1000)
39                                    (string (make-nested-bars-string))
40                                    (schedule-in-reader-p t))
41  (let ((done-flags (make-array thread-count :initial-element nil)))
42    (dotimes (i thread-count)
43      (process-run-function (format nil "Reader ~d" i)
44                            (lambda (i)
45                              (unwind-protect
46                                   (let ((*schedule-in-reader-p* schedule-in-reader-p))
47                                     (dotimes (j loop-count)
48                                       (setf (ccl:process-name ccl:*current-process*)
49                                             (format nil "Reader ~d: ~d" i j))
50                                       (with-input-from-string (*stream* string)
51                                         (read *stream*))))
52                              (setf (elt done-flags i) t)))
53                            i))
54    (loop do
55         (unless (position nil done-flags) (return)))))
56
57(defun print-readable-instance (instance &optional (stream t))
58  (check-type instance standard-object)
59  (format stream "#.(read-instance '~s" (type-of instance))
60  (let* ((class (class-of instance)))
61    (dolist (slotd (ccl:class-slots class))
62      (let ((name (ccl:slot-definition-name slotd)))
63        (format stream " '(~s . ~s)" name (slot-value instance name))))
64    (format stream ")")))
65
66(defun read-instance (type &rest slot-values)
67  (let ((res (allocate-instance (find-class type))))
68    (loop for (name . value) in slot-values
69       do (setf (slot-value res name) value))
70    res))
71
72(defclass bar ()
73  ((x :initarg :x :initform :x :accessor bar-x)
74   (y :initarg :y :initform :y :accessor bar-y)
75   (z :initarg :z :initform :z :accessor bar-z)))
76
77(defmethod print-object ((bar bar) stream)
78  (print-readable-instance bar stream))
79
80(defun make-nested-bars (&key (index 0) (depth 4))
81  (let ((bar (make-instance 'bar)))
82    (cond ((<= depth 0)
83           (setf (bar-x bar) index
84                 (bar-y bar) (1+ index)))
85          (t (setf (bar-x bar) (make-nested-bars :index (+ index 1) :depth (1- depth))
86                   (bar-y bar) (make-nested-bars :index (+ index 2) :depth (1- depth))
87                   (bar-z bar) (make-nested-bars :index (+ index 3) :depth (1- depth)))))
88    bar))
89
90(defun make-nested-bars-string (&key (depth 4))
91  (format nil "~s" (make-nested-bars :depth depth)))