anchor.diff:        (incf total-used allocated-words)
         (incf total total-words)
         (when (eql verbosity t)
  -        (print-n-allocated-objects-table n-allocated-objects allocated-object-sizes)))
  -    (multiple-value-bind (allocated-words total-words largest-free-space n-allocated-objects allocated-object-sizes)
  -        (pinned-area-info (* 2 1024 1024 1024) *pinned-area-bump*)
  +        (print-n-allocated-objects-table n-allocated-objects allocated-object-sizes allocated-classes)))
  +    (multiple-value-bind (allocated-words total-words largest-free-space n-allocated-objects allocated-object-sizes allocated-classes)
  +        (area-info :pinned)
         (format t "Pinned area: ~:D/~:D words allocated (~D%).~%"
                 allocated-words total-words
                 (truncate (* allocated-words 100) total-words))
  
positive.code:       (incf total-used allocated-words)
        (incf total total-words)
        (when (eql verbosity t)
          (print-n-allocated-objects-table n-allocated-objects allocated-object-sizes)))
      (format t "Total ~:D/~:D words used (~D%).~%"
              total-used total
              (truncate (* total-used 100) total))
  
negative.code:     (format t "~:D words to next GC.~%" (truncate *memory-expansion-remaining* 8)))
    (values))
  
  (defun %walk-pinned-area (base limit fn)
    (let ((address base))
      (loop
         (when (>= address limit)
           (return))
         (let ((size (align-up (size-of-pinned-area-allocation address) 2))
               ;; Carefully read the type, avoid bignums.
               (type (ldb (byte +object-type-size+ +object-type-shift+)
                          (memref-unsigned-byte-8 address 0))))
           (funcall fn
                    (if (eql type +object-tag-cons+)
                        (%%assemble-value (+ address 16) +tag-cons+)
                        (%%assemble-value address +tag-object+))
                    address
                    size)
           (incf address (* size 8))))))
  
  (defun %walk-general-area (fn)
    (let ((finger 0))
      (loop
         (when (eql finger *general-area-bump*)
           (return))
         (let* ((address (logior finger
                                 (ash +address-tag-general+ +address-tag-shift+)
                                 *dynamic-mark-bit*))
                (object (%%assemble-value address +tag-object+))
                (size (object-size object)))
           (funcall fn object address size)
           (when (oddp size)
             (incf size))
           (incf finger (* size 8))))))
  
  (defun %walk-cons-area (fn)
    (let ((finger 0))
      (loop
         (when (eql finger *cons-area-bump*)
           (return))
         (let* ((address (logior finger
                                 (ash +address-tag-cons+ +address-tag-shift+)
                                 *dynamic-mark-bit*))
                (object (%%assemble-value address +tag-cons+)))
           (funcall fn object address 2)
           (incf finger 16)))))
  
  (defun walk-area (area fn)
    "Call FN with the value, address and size of every object in AREA.
  FN will be called with the world stopped, it must not allocate."
    (check-type area (member :pinned :wired :general :cons))
    (mezzano.supervisor:with-world-stopped ()
      (case area
        (:pinned (%walk-pinned-area (* 2 1024 1024 1024) *pinned-area-bump* fn))
        (:wired (%walk-pinned-area (* 2 1024 1024) *wired-area-bump* fn))
        (:general (%walk-general-area fn))
        (:cons (%walk-cons-area fn)))))
  
  (defun area-info (area)
    (let ((largest-free-space 0)
          (allocated-words 0)
          (total-words 0)
          (n-allocated-objects (make-array (ash 1 +object-type-size+)
                                           :initial-element 0))
          (allocated-objects-sizes (make-array (ash 1 +object-type-size+)
                                               :initial-element 0))
          ;; TODO: Should keep this sorted by address for binary searching, and
          ;; need to expand it when needed. Not possible with-world-stopped.
          (allocated-classes (make-array 1000 :fill-pointer 0)))
      (flet ((add-class (class)
               (loop
                  for i below (length allocated-classes) by 2
                  when (eql (aref allocated-classes i) class)
                  do
                    (incf (aref allocated-classes (1+ i)))
                    (return)
                  finally
                    ;; Not seen yet.
                    (vector-push class allocated-classes)
                    (vector-push 1 allocated-classes))))
        (walk-area area
                   (lambda (object address size)
                     (let ((tag (if (consp object)
                                    +object-tag-cons+
                                    (%object-tag object))))
                       (incf (svref n-allocated-objects tag))
                       (incf (svref allocated-objects-sizes tag) size)
                       (incf total-words size)
                       (when (not (eql tag +object-tag-freelist-entry+))
                         (incf allocated-words size))
                       (case tag
                         (#.+object-tag-freelist-entry+
                          (setf largest-free-space (max largest-free-space size)))
                         (#.+object-tag-std-instance+
                          (add-class (std-instance-class object)))
                         (#.+object-tag-funcallable-instance+
                          (add-class (funcallable-std-instance-class object)))
                         (#.+object-tag-structure-object+
                          (add-class (%struct-slot object 0))))))))
      (values allocated-words total-words largest-free-space
              n-allocated-objects allocated-objects-sizes allocated-classes)))
  
  (defun gc ()
    "Run a garbage-collection cycle."
  