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

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 328ca45..3877c29 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -217,7 +217,7 @@
               ;; will be a short. On platforms with larger ones, it'll
               ;; be an int.
               (bytes-used (unsigned
-                           #.(if (typep sb!vm:gencgc-page-bytes
+                           #.(if (typep sb!vm:gencgc-card-bytes
                                         '(unsigned-byte 16))
                                  16
                                  32)))
@@ -265,7 +265,7 @@
                    (maybe-skip-page ()
                      #!+gencgc
                      (when (eq space :dynamic)
-                       (loop with page-mask = #.(1- sb!vm:gencgc-page-bytes)
+                       (loop with page-mask = #.(1- sb!vm:gencgc-card-bytes)
                              for addr of-type sb!vm:word = (sap-int current)
                              while (>= addr skip-tests-until-addr)
                              do
@@ -286,8 +286,8 @@
                                  ;; pointer is still below the allocation offset
                                  ;; of the page
                                  (when (and (not (zerop alloc-flag))
-                                            (<= (logand page-mask addr)
-                                                bytes-used))
+                                            (< (logand page-mask addr)
+                                               bytes-used))
                                    ;; Don't bother testing again until we
                                    ;; get past that allocation offset
                                    (setf skip-tests-until-addr
@@ -297,7 +297,7 @@
                                    (return-from maybe-skip-page))
                                  ;; Move CURRENT to start of next page.
                                  (setf current (int-sap (+ (logandc2 addr page-mask)
-                                                           sb!vm:gencgc-page-bytes)))
+                                                           sb!vm:gencgc-card-bytes)))
                                  (maybe-finish-mapping))))))
                    (maybe-map (obj obj-tag n-obj-bytes &optional (ok t))
                      (let ((next (typecase n-obj-bytes
@@ -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*