diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index db761be59..0ba8c5c8a 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -702,29 +702,43 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (make-emf-cache generic-function valuep cache classes-list new-class)))
 
 (defvar *dfun-miss-gfs-on-stack* ())
+(defvar *dfun-miss-lock-all-p* t)
 
 (defmacro dfun-miss ((gf args wrappers invalidp nemf
-                      &optional type index caching-p applicable)
+                      &optional type index caching-p applicable
+                                (lock-p '*dfun-miss-lock-all-p*))
                      &body body)
   (unless applicable (setq applicable (gensym)))
-  `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp
-                         ,@(when type `(,type ,index)))
-       (cache-miss-values ,gf ,args ',(cond (caching-p 'caching)
-                                            (type 'accessor)
-                                            (t 'checking)))
-    (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
-      (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
-        ,@body))
-    ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached
-    ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is,
-    ;; does not signal a SLOT-UNBOUND error for a boundp test.
-    ,@(if type
-          ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated
-          ;; slots?)
-          `((if (and (eq ,type 'boundp) (integerp ,nemf))
-                (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args)
-                (invoke-emf ,nemf ,args)))
-          `((invoke-emf ,nemf ,args)))))
+  `(multiple-value-bind (,nemf ,@(when type `(,type)))
+       (flet ((_racy ()
+                (multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp
+                                      ,@(when type `(,type ,index)))
+                    (cache-miss-values ,gf ,args ',(cond (caching-p 'caching)
+                                                         (type 'accessor)
+                                                         (t 'checking)))
+                  (when (and ,applicable
+                             (not (memq ,gf *dfun-miss-gfs-on-stack*)))
+                    (let ((*dfun-miss-gfs-on-stack*
+                           (cons ,gf *dfun-miss-gfs-on-stack*)))
+                      ,@body))
+                  (values ,nemf ,@(when type `(,type))))))
+         ,(if lock-p
+              `(if ,lock-p
+                   (with-world-lock ()
+                     (sb-thread::call-with-recursive-system-lock #'_racy
+                                                                 (gf-lock ,gf)))
+                   (_racy))
+              `(_racy)))
+     ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached
+     ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is,
+     ;; does not signal a SLOT-UNBOUND error for a boundp test.
+     ,@(if type
+           ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated
+           ;; slots?)
+           `((if (and (eq ,type 'boundp) (integerp ,nemf))
+                 (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args)
+                 (invoke-emf ,nemf ,args)))
+           `((invoke-emf ,nemf ,args)))))
 
 ;;; The dynamically adaptive method lookup algorithm is implemented is
 ;;; implemented as a kind of state machine. The kinds of