[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-commits
Subject: [Sbcl-commits] master: remove world-lock from around FASL loading
From: "Nikodemus Siivola" <demoss () users ! sourceforge ! net>
Date: 2012-04-24 10:27:24
Message-ID: E1SMcy0-0008VL-Qe () sfs-ml-2 ! v29 ! ch3 ! sourceforge ! com
[Download RAW message or body]
The branch "master" has been updated in SBCL:
via e2574c9090a19634f1f903a9f0c229960edfd7b6 (commit)
from 390073eee1f9738487bf22c7fd118156899fabbe (commit)
- Log -----------------------------------------------------------------
commit e2574c9090a19634f1f903a9f0c229960edfd7b6
Author: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri Dec 9 20:39:57 2011 +0200
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.
---
NEWS | 1 +
src/code/load.lisp | 19 +++++++--------
tests/load.impure.lisp | 46 ++++++++++++++++++++++++++++++++++++
tests/parallel-fasl-load-test.lisp | 17 +++++++++++++
4 files changed, 73 insertions(+), 10 deletions(-)
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)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
------------------------------------------------------------------------------
Live Security Virtual Conference
Exclusive live event will cover all the ways today's security and
threat landscape has changed and how IT managers can respond. Discussions
will include endpoint security, mobile security and the latest in malware
threats. http://www.accelacomm.com/jaw/sfrnl04242012/114/50122263/
_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic