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

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

File to reproduce Ticket #1257

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(defun read-from-serialized-string (&key (thread-count 7) (loop-count 1000)
18                                      (string (make-nested-bars-string)))
19  (let ((done-flags (make-array thread-count :initial-element nil)))
20    (dotimes (i thread-count)
21      (process-run-function (format nil "Reader ~d" i)
22                            (lambda (i)
23                              (unwind-protect
24                                   (dotimes (j loop-count)
25                                     (setf (ccl:process-name ccl:*current-process*)
26                                           (format nil "Reader ~d: ~d" i j))
27                                     (read-from-string string))
28                              (setf (elt done-flags i) t)))
29                            i))
30    (loop do
31         (unless (position nil done-flags) (return)))))
32
33(defstruct foo
34  x y z)
35
36(defun make-long-struct-list (&key (len 100))
37  (let ((res (make-array len)))
38    (dotimes (i len)
39      (setf (elt res i) (make-foo :x i :y (1+ i) :z (+ i 2))))
40    res))
41
42;; This doesn't tickle the bug
43(defun make-long-struct-string (&key (len 100))
44  (format nil "~s" (make-long-struct-list :len len)))
45
46(defun print-readable-instance (instance &optional (stream t))
47  (check-type instance standard-object)
48  (format stream "#.(read-instance '~s" (type-of instance))
49  (let* ((class (class-of instance)))
50    (dolist (slotd (ccl:class-slots class))
51      (let ((name (ccl:slot-definition-name slotd)))
52        (format stream " '(~s . ~s)" name (slot-value instance name))))
53    (format stream ")")))
54
55(defun read-instance (type &rest slot-values)
56  (let ((res (allocate-instance (find-class type))))
57    (loop for (name . value) in slot-values
58       do (setf (slot-value res name) value))
59    res))
60
61(defclass bar ()
62  ((x :initarg :x :initform :x :accessor bar-x)
63   (y :initarg :y :initform :y :accessor bar-y)
64   (z :initarg :z :initform :z :accessor bar-z)))
65
66(defmethod print-object ((bar bar) stream)
67  (print-readable-instance bar stream))
68
69(defun make-long-bar-list (&key (len 100))
70  (let ((res (make-array len)))
71    (dotimes (i len)
72      (setf (elt res i) (make-instance 'bar :x i :y (1+ i) :z (+ i 2))))
73    res))
74
75;; This doesn't tickle the bug
76(defun make-long-bar-string (&key (len 100))
77  (format nil "~s" (make-long-bar-list :len len)))
78
79(defun make-nested-bars (&key (index 0) (depth 4))
80  (let ((bar (make-instance 'bar)))
81    (cond ((<= depth 0)
82           (setf (bar-x bar) index
83                 (bar-y bar) (1+ index)))
84          (t (setf (bar-x bar) (make-nested-bars :index (+ index 1) :depth (1- depth))
85                   (bar-y bar) (make-nested-bars :index (+ index 2) :depth (1- depth))
86                   (bar-z bar) (make-nested-bars :index (+ index 3) :depth (1- depth)))))
87    bar))
88
89;; This DOES tickle the bug, but not as often as an application-specific string
90;; that I've removed from this public bug report.
91(defun make-nested-bars-string (&key (depth 4))
92  (format nil "~s" (make-nested-bars :depth depth)))