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

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

Adding (process-allow-schedule) to advice on ccl::%read-list-expression greatly increases the frequency of errors

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;;;; It doesn't always error, but it often gets either a dot-context error from
6;;;; from the reader, or sometimes a bogus-object error. I've also
7;;;; seen type-mismatch errors, where something expected to be a stream
8;;;; was an instance of BAR.
9
10;;;; The error doesn't happen often, but this tends to reproduce it for me on a
11;;;; two-core ARM after 5 minutes or so.
12;;;;
13;;;; (loop (time (read-from-serialized-string)))
14
15(in-package :cl-user)
16
17(defvar *schedule-in-reader-p* nil)
18
19(ccl:advise ccl::%read-list-expression
20            (progn
21              (when *schedule-in-reader-p* (ccl:process-allow-schedule))
22              (:do-it))
23            :when :around
24            :name read-serialized-string)
25
26(defun read-from-serialized-string (&key (thread-count 7)
27                                    (loop-count 1000)
28                                    (string (make-nested-bars-string))
29                                    (schedule-in-reader-p t))
30  (let ((done-flags (make-array thread-count :initial-element nil)))
31    (dotimes (i thread-count)
32      (process-run-function (format nil "Reader ~d" i)
33                            (lambda (i)
34                              (unwind-protect
35                                   (let ((*schedule-in-reader-p* schedule-in-reader-p))
36                                     (dotimes (j loop-count)
37                                       (setf (ccl:process-name ccl:*current-process*)
38                                             (format nil "Reader ~d: ~d" i j))
39                                       (read-from-string string)))
40                              (setf (elt done-flags i) t)))
41                            i))
42    (loop do
43         (unless (position nil done-flags) (return)))))
44
45(defstruct foo
46  x y z)
47
48(defun make-long-struct-list (&key (len 100))
49  (let ((res (make-array len)))
50    (dotimes (i len)
51      (setf (elt res i) (make-foo :x i :y (1+ i) :z (+ i 2))))
52    res))
53
54;; This doesn't tickle the bug
55(defun make-long-struct-string (&key (len 100))
56  (format nil "~s" (make-long-struct-list :len len)))
57
58(defun print-readable-instance (instance &optional (stream t))
59  (check-type instance standard-object)
60  (format stream "#.(read-instance '~s" (type-of instance))
61  (let* ((class (class-of instance)))
62    (dolist (slotd (ccl:class-slots class))
63      (let ((name (ccl:slot-definition-name slotd)))
64        (format stream " '(~s . ~s)" name (slot-value instance name))))
65    (format stream ")")))
66
67(defun read-instance (type &rest slot-values)
68  (let ((res (allocate-instance (find-class type))))
69    (loop for (name . value) in slot-values
70       do (setf (slot-value res name) value))
71    res))
72
73(defclass bar ()
74  ((x :initarg :x :initform :x :accessor bar-x)
75   (y :initarg :y :initform :y :accessor bar-y)
76   (z :initarg :z :initform :z :accessor bar-z)))
77
78(defmethod print-object ((bar bar) stream)
79  (print-readable-instance bar stream))
80
81(defun make-long-bar-list (&key (len 100))
82  (let ((res (make-array len)))
83    (dotimes (i len)
84      (setf (elt res i) (make-instance 'bar :x i :y (1+ i) :z (+ i 2))))
85    res))
86
87;; This doesn't tickle the bug
88(defun make-long-bar-string (&key (len 100))
89  (format nil "~s" (make-long-bar-list :len len)))
90
91(defun make-nested-bars (&key (index 0) (depth 4))
92  (let ((bar (make-instance 'bar)))
93    (cond ((<= depth 0)
94           (setf (bar-x bar) index
95                 (bar-y bar) (1+ index)))
96          (t (setf (bar-x bar) (make-nested-bars :index (+ index 1) :depth (1- depth))
97                   (bar-y bar) (make-nested-bars :index (+ index 2) :depth (1- depth))
98                   (bar-z bar) (make-nested-bars :index (+ index 3) :depth (1- depth)))))
99    bar))
100
101;; This DOES tickle the bug, but not as often as an application-specific string
102;; that I've removed from this public bug report.
103(defun make-nested-bars-string (&key (depth 4))
104  (format nil "~s" (make-nested-bars :depth depth)))