From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 9 Dec 2011 18:39:57 +0000 (+0200)
Subject: remove world-lock from around FASL loading
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e2574c9090a19634f1f903a9f0c229960edfd7b6;p=sbcl.git

remove world-lock from around FASL loading

  The fasl loader itself is thread safe these days, but what about the stuff
  we do at load time?

  In principle it /should/ be, so let the shakeout cruise start.
---

diff --git a/NEWS b/NEWS
index 05db33f..b9acb31 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,6 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.0.56:
+  * enhancement: FASL loading no longer grabs the world-lock.
   * enhancement: GENCGC reclaims space more aggressively when objects being
     allocated are a large fraction of the total available heap space.
     (lp#936304)
diff --git a/src/code/load.lisp b/src/code/load.lisp
index 7960ff6..941891b 100644
--- a/src/code/load.lisp
+++ b/src/code/load.lisp
@@ -469,16 +469,15 @@
   (when (zerop (file-length stream))
     (error "attempt to load an empty FASL file:~%  ~S" (namestring stream)))
   (maybe-announce-load stream verbose)
-  (with-world-lock ()
-    (let* ((*fasl-input-stream* stream)
-           (*fop-table* (make-fop-vector 1000))
-           (*fop-stack* (make-fop-vector 100)))
-      (unwind-protect
-           (loop while (load-fasl-group stream))
-        ;; Nuke the table and stack to avoid keeping garbage on
-        ;; conservatively collected platforms.
-        (nuke-fop-vector *fop-table*)
-        (nuke-fop-vector *fop-stack*))))
+  (let* ((*fasl-input-stream* stream)
+         (*fop-table* (make-fop-vector 1000))
+         (*fop-stack* (make-fop-vector 100)))
+    (unwind-protect
+         (loop while (load-fasl-group stream))
+      ;; Nuke the table and stack to avoid keeping garbage on
+      ;; conservatively collected platforms.
+      (nuke-fop-vector *fop-table*)
+      (nuke-fop-vector *fop-stack*)))
   t)
 
 (declaim (notinline read-byte)) ; Why is it even *declaimed* inline above?
diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp
index a739006..78b6d5c 100644
--- a/tests/load.impure.lisp
+++ b/tests/load.impure.lisp
@@ -305,3 +305,49 @@
 
 (with-test (:name (load "empty.fasl"))
   (assert (not (load-empty-file "fasl"))))
+
+(with-test (:name :parallel-fasl-load)
+  #+sb-thread
+  (let ((lisp #p"parallel-fasl-load-test.lisp")
+        (fasl nil)
+        (ready nil))
+    (unwind-protect
+         (progn
+           (multiple-value-bind (compiled warned failed)
+               (compile-file lisp)
+             (setf fasl compiled)
+             (assert (not warned))
+             (assert (not failed))
+             (labels ((load-loop ()
+                        (let* ((*standard-output* (make-broadcast-stream))
+                               (*error-output* *standard-output*))
+                          (sb-ext:wait-for ready)
+                          (handler-case
+                              (progn
+                                (loop repeat 1000
+                                      do (load fasl)
+                                         (test-it))
+                                t)
+                            (error (e) e))))
+                      (test-it ()
+                        (assert (= 1 (one-fun)))
+                        (assert (= 2 (two-fun)))
+                        (assert (= 42 (symbol-value '*var*)))
+                        (assert (= 13 (symbol-value '*quux*)))))
+               (let ((t1 (sb-thread:make-thread #'load-loop))
+                     (t2 (sb-thread:make-thread #'load-loop))
+                     (t3 (sb-thread:make-thread #'load-loop)))
+                 (setf ready t)
+                 (let ((r1 (sb-thread:join-thread t1))
+                       (r2 (sb-thread:join-thread t2))
+                       (r3 (sb-thread:join-thread t3)))
+                   (unless (and (eq t r1) (eq t r2) (eq t r3))
+                     (error "R1: ~A~2%R2: ~A~2%R2: ~A" r1 r2 r3))
+                   ;; These ones cannot be tested while redefinitions are running:
+                   ;; adding a method implies REMOVE-METHOD, so a call would be racy.
+                   (assert (eq :ok (a-slot (make-instance 'a-class :slot :ok))))
+                   (assert (eq 'cons (gen-fun '(foo))))
+                   (assert (eq 'a-class (gen-fun (make-instance 'a-class)))))
+                 (test-it)))))
+      (when fasl
+        (ignore-errors (delete-file fasl))))))
diff --git a/tests/parallel-fasl-load-test.lisp b/tests/parallel-fasl-load-test.lisp
new file mode 100644
index 0000000..8beb7a2
--- /dev/null
+++ b/tests/parallel-fasl-load-test.lisp
@@ -0,0 +1,17 @@
+(defun one-fun ()
+  1)
+
+(defun two-fun ()
+  2)
+
+(defvar *var* 42 "This is var.")
+
+(defparameter *quux* 13 "This is quux.")
+
+(defclass a-class ()
+  ((slot :initarg :slot :reader a-slot)))
+
+(defgeneric gen-fun (x)
+  (:method ((a cons)) 'cons))
+
+(defmethod gen-fun ((a a-class)) 'a-class)