X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=ec6888e608e7fa3f75ce9c95ec91f2c6dd3185d8;hb=152c97de336af584a9b133207a772c704e3245cf;hp=328ca458cad10bdc2bc516fb63165a7b9f47da45;hpb=79a8e51bf4b06a5bd57bc90233605f98fee3b041;p=sbcl.git

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 328ca45..ec6888e 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -784,6 +784,26 @@
        space)
       res)))
 
+;;; Calls FUNCTION with all object that have (possibly conservative)
+;;; references to them on current stack.
+(defun map-stack-references (function)
+  (let ((end
+         (sb!di::descriptor-sap
+          #!+stack-grows-downward-not-upward *control-stack-end*
+          #!-stack-grows-downward-not-upward *control-stack-start*))
+        (sp (current-sp))
+        (seen nil))
+    (loop until #!+stack-grows-downward-not-upward (sap> sp end)
+                #!-stack-grows-downward-not-upward (sap< sp end)
+          do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
+               (when (and ok (typep obj '(not (or fixnum character))))
+                 (unless (member obj seen :test #'eq)
+                   (funcall function obj)
+                   (push obj seen))))
+             (setf sp
+                   #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
+                   #!-stack-grows-downward-not-upward (sap+ sp (- n-word-bytes))))))
+
 (defun map-referencing-objects (fun space object)
   (declare (type spaces space) (inline map-allocated-objects))
   (unless *ignore-after*