common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

remove world-lock from around FASL loading

Browse source 
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.
This commit is contained in:
Nikodemus Siivola 2011-12-09 20:39:57 +02:00
parent 390073eee1
commit e2574c9090
4 changed files with 73 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
NEWS
View file

@ -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)

19
src/code/load.lisp
View file

@ -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?

46
tests/load.impure.lisp
View file

@ -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))))))

17
tests/parallel-fasl-load-test.lisp Normal file
View file

@ -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)