anchor.diff:    (declare (ignore object prefix))
     `(progn ,@body))
   
  -(defun scan-object (object transportp)
  +(defun scavenge-many (address n)
  +  (dotimes (i n)
  +    (setf (memref-t address i)
  +          (scavenge-object (memref-t address i)))))
  +
  +(defun scavenge-newspace ()
  +  (mumble "Scav newspace")
  +  (do ((pointer 0))
  +      ((>= pointer *newspace-offset*))
  +    ;; Walk newspace, updating pointers as we go.
  +    (let ((n (- *newspace-offset* pointer)))
  +      (scavenge-many (+ *newspace* (* pointer 8)) n)
  +      (incf pointer n))))
  +
  +;;; Arguments and MV return are to force the data registers on to the stack.
  +;;; This does not work for RBX or R13, but RBX is smashed by the function
  +;;; return and R13 shouldn't matter.
  +(defun scavenge-current-stack-group (a1 a2 a3 a4 a5)
  +  (let* ((sg-pointer (ash (%pointer-field (current-stack-group)) 4))
  +	 (ds-base (memref-unsigned-byte-64 sg-pointer 7))
  +	 (ds-size (memref-unsigned-byte-64 sg-pointer 8))
  +	 (bs-base (memref-unsigned-byte-64 sg-pointer 9))
  +	 (bs-size (memref-unsigned-byte-64 sg-pointer 10))
  +         (binding-stack-pointer (memref-unsigned-byte-64 sg-pointer 1))
  +         (data-stack-pointer (ash (%%get-data-stack-pointer) 3)))
  +    (mumble "Scav control stack")
  +    (do ((fp (read-frame-pointer)
  +             (memref-unsigned-byte-64 fp 0)))
  +        ((= fp 0))
  +      (setf (memref-t fp -2) (scavenge-object (memref-t fp -2))))
  +    (mumble "Scav data stack")
  +    (scavenge-many data-stack-pointer
  +                   (ash (- (+ ds-base ds-size) data-stack-pointer) -3))
  +    (mumble "Scav binding stack")
  +    (scavenge-many binding-stack-pointer
  +                   (ash (- (+ bs-base bs-size) binding-stack-pointer) -3)))
  +  (values a1 a2 a3 a4 a5))
  +
  +(defun scavenge-object (object)
  +  "Scavange one object, returning an updated pointer."
  +  (when (immediatep object)
  +    ;; Don't care about immediate objects, return them unchanged.
  +    (return-from scavenge-object object))
  +  (let ((address (ash (%pointer-field object) 4)))
  +    (cond ((oldspace-pointer-p address)
  +           ;; Object is in oldspace, transport to newspace.
  +           (transport-object object))
  +          ((newspace-pointer-p address)
  +           ;; Object is already in newspace.
  +           object)
  +          ((static-pointer-p address)
  +           ;; Object is in the static area, mark and scan.
  +           (mark-static-object object)
  +           object)
  +          (t
  +           ;; Assume the pointer is on the stack.
  +           ;; TODO: Track scanned stack objects. Allocate a cons with dynamic-extent
  +           ;; and push on some symbol.
  +           (scan-object object)
  +           object))))
  +
  +(defun scan-error (object)
  +  (mumble-hex (lisp-object-address object))
  +  (mumble " ")
  +  (mumble-hex (memref-unsigned-byte-64 (ash (%pointer-field object) 4) 0))
  +  (emergency-halt "unscannable object"))
  +
  +(defun scan-generic (object size)
  +  (scavenge-many (ash (%pointer-field object) 4) size))
  +
  +(defun scan-cons (object)
  +  (scan-generic object 2))
  +
  +(defun scan-symbol (object)
  +  (scan-generic object 6))
  +
  +(defun scan-array-header (object)
  +  (scan-generic object 4))
  +
  +(defun scan-array-t (object)
  +  (let* ((address (ash (%pointer-field object) 4))
  +         (header (memref-unsigned-byte-64 address 0))
  +         (length (ldb (byte 56 8) header))
  +         (word-count (1+ length)))
  +    (when (hash-table-p object)
  +      (setf (hash-table-rehash-required object) 't))
  +    (scavenge-many address word-count)))
  +
  +(defun scan-stack-group (object)
  +  (let ((address (ash (%pointer-field object) 4)))
  +    (scavenge-many address (- 512 64)) ; skip the fxsave area at the end.
  +    ;; Scan the data/binding stacks only when the sg is not active.
  +    (when (not (eql (logand (memref-t address 2) +stack-group-state-mask+) +stack-group-active+))
  +      ;; FIXME: Need to scan the saved RIP, or at least the function associated with it.
  +      (let* ((ds-base (memref-unsigned-byte-64 address 7))
  +             (ds-size (memref-unsigned-byte-64 address 8))
  +             (bs-base (memref-unsigned-byte-64 address 9))
  +             (bs-size (memref-unsigned-byte-64 address 10))
  +             (binding-stack-pointer (memref-unsigned-byte-64 address 1))
  +             (control-stack-pointer (memref-unsigned-byte-64 address 3))
  +             (data-stack-pointer (memref-unsigned-byte-64 control-stack-pointer 2)))
  +        (do ((fp (memref-unsigned-byte-64 control-stack-pointer 0)
  +                 (memref-unsigned-byte-64 fp 0)))
  +            ((= fp 0))
  +          (setf (memref-t fp -2) (scavenge-object (memref-t fp -2))))
  +        (scavenge-many data-stack-pointer
  +                       (ash (- (+ ds-base ds-size) data-stack-pointer) -3))
  +        (scavenge-many binding-stack-pointer
  +                       (ash (- (+ bs-base bs-size) binding-stack-pointer) -3))))
  +    object))
  +
  +(defun scan-numeric-array (object width)
  +  (declare (ignore width))
  +  ;; Numeric arrays have nothing to scan so just return.
  +  object)
  +
  +(defun scan-array-like (object)
  +  (let* ((address (ash (%pointer-field object) 4))
  +         (header (memref-unsigned-byte-64 address 0)))
  +    ;; Dispatch again based on the type.
  +    (case (ldb (byte 5 3) header)
  +      (0  (scan-array-t object)) ; simple-vector
  +      (1  (scan-numeric-array object 8)) ; base-char
  +      (2  (scan-numeric-array object 32)) ; character
  +      (3  (scan-numeric-array object 1)) ; bit
  +      (4  (scan-numeric-array object 2)) ; unsigned-byte 2
  +      (5  (scan-numeric-array object 4)) ; unsigned-byte 4
  +      (6  (scan-numeric-array object 8)) ; unsigned-byte 8
  +      (7  (scan-numeric-array object 16)) ; unsigned-byte 16
  +      (8  (scan-numeric-array object 32)) ; unsigned-byte 32
  +      (9  (scan-numeric-array object 64)) ; unsigned-byte 64
  +      (10 (scan-numeric-array object 1)) ; signed-byte 1
  +      (11 (scan-numeric-array object 2)) ; signed-byte 2
  +      (12 (scan-numeric-array object 4)) ; signed-byte 4
  +      (13 (scan-numeric-array object 8)) ; signed-byte 8
  +      (14 (scan-numeric-array object 16)) ; signed-byte 16
  +      (15 (scan-numeric-array object 32)) ; signed-byte 32
  +      (16 (scan-numeric-array object 64)) ; signed-byte 64
  +      (17 (scan-numeric-array object 32)) ; single-float
  +      (18 (scan-numeric-array object 64)) ; double-float
  +      (19 (scan-numeric-array object 128)) ; long-float
  +      (20 (scan-numeric-array object 128)) ; xmm-vector
  +      (21 (scan-numeric-array object 64)) ; complex single-float
  +      (22 (scan-numeric-array object 128)) ; complex double-float
  +      (23 (scan-numeric-array object 256)) ; complex long-float
  +      (24 (scan-error object)) ; unused (24)
  +      (25 (scan-numeric-array object 64)) ; bignum
  +      (26 (scan-error object)) ; unused (26)
  +      (27 (scan-error object)) ; unused (27)
  +      (28 (scan-error object)) ; unused (28)
  +      (29 (scan-array-t object)) ; std-instance
  +      (30 (scan-stack-group object))
  +      (31 (scan-array-t object)) ; struct
  +      (t (scan-error object)))))
  +
  +(defun scan-function (object)
  +  ;; Scan the constant pool.
  +  (let* ((address (ash (%pointer-field object) 4))
  +         (header (memref-unsigned-byte-64 address 0))
  +         (mc-size (ash (ldb (byte 16 16) header) 1))
  +         (pool-size (ldb (byte 16 32) header)))
  +    (scavenge-many (+ address (* mc-size 8)) pool-size)
  +    object))
  +
  +(defun scan-object (object)
  +  "Scan one object, updating pointer fields."
     (case (%tag-field object)
  -    (0  (scan-error object transportp)) ; even-fixnum
  -    (1  (scan-cons object transportp))
  -    (2  (scan-symbol object transportp))
  -    (3  (scan-array-header object transportp))
  -    (4  (scan-error object transportp)) ; unused
  -    (5  (scan-error object transportp)) ; unused
  -    (6  (scan-error object transportp)) ; unused
  -    (7  (scan-array-like object transportp))
  -    (8  (scan-error object transportp)) ; odd-fixnum
  -    (9  (scan-error object transportp)) ; unused
  -    (10 (scan-error object transportp)) ; character
  -    (11 (scan-error object transportp)) ; unused
  -    (12 (scan-function object transportp))
  -    (13 (scan-error object transportp)) ; unused
  -    (14 (scan-error object transportp)) ; unbound-value
  -    (15 (scan-error object transportp))))
  -
  -(defun scan-and-transport (object)
  -  (with-gc-trace (object #\d)
  -    (scan-object object t)))
  +    (0  (scan-error object)) ; even-fixnum
  +    (1  (scan-cons object))
  +    (2  (scan-symbol object))
  +    (3  (scan-array-header object))
  +    (4  (scan-error object)) ; unused
  +    (5  (scan-error object)) ; unused
  +    (6  (scan-error object)) ; unused
  +    (7  (scan-array-like object))
  +    (8  (scan-error object)) ; odd-fixnum
  +    (9  (scan-error object)) ; unused
  +    (10 (scan-error object)) ; character
  +    (11 (scan-error object)) ; single-float
  +    (12 (scan-function object))
  +    (13 (scan-error object)) ; unused
  +    (14 (scan-error object)) ; unbound-value
  +    (15 (scan-error object)))) ; gc-forward
  +
  +(defun transport-error (object)
  +  (mumble-hex (lisp-object-address object))
  +  (mumble " ")
  +  (mumble-hex (memref-unsigned-byte-64 (ash (%pointer-field object) 4) 0))
  +  (emergency-halt "untransportable object"))
  +
  +(defun transport-generic (object length)
  +  "Transport LENGTH words from oldspace to newspace, returning
  +a pointer to the new object. Leaves a forwarding pointer in place."
  +  (let* ((address (ash (%pointer-field object) 4))
  +         (first-word (memref-t address 0))
  +         (new-address nil))
  +    ;; Check for a GC forwarding pointer.
  +    (when (eql (%tag-field first-word) +tag-gc-forward+)
  +      (return-from transport-generic
  +        (%%assemble-value (ash (%pointer-field first-word) 4)
  +                          (%tag-field object))))
  +    ;; Update meters.
  +    (incf *objects-copied*)
  +    (incf *words-copied* length)
  +    ;; Copy words.
  +    (setf new-address (+ *newspace* (ash *newspace-offset* 3)))
  +    (%fast-copy new-address address (ash length 3))
  +    ;; Update newspace size.
  +    (incf *newspace-offset* length)
  +    (when (oddp length)
  +      (incf *newspace-offset*))
  +    ;; Leave a forwarding pointer.
  +    (setf (memref-t address 0) (%%assemble-value new-address +tag-gc-forward+))
  +    ;; Complete! Return the new object
  +    (%%assemble-value new-address (%tag-field object))))
  +
  +(defun transport-array-like (object)
  +  (let* ((address (ash (%pointer-field object) 4))
  +         (header (memref-unsigned-byte-64 address 0))
  +         (type (ldb (byte 5 3) header))
  +         (length (ldb (byte 56 8) header)))
  +    ;; Check for a forwarding pointer before the type check.
  +    (when (eql (ldb (byte 4 0) header) +tag-gc-forward+)
  +      (return-from transport-array-like
  +        (%%assemble-value (logand header (lognot #b1111))
  +                          +tag-array-like+)))
  +    (when (hash-table-p object)
  +      (setf (hash-table-rehash-required object) 't))
  +    ;; Dispatch again based on the type.
  +    (case type
  +      ((#.+array-type-t+
  +        #.+array-type-std-instance+
  +        #.+array-type-struct+)
  +       ;; simple-vector, std-instance or structure-object.
  +       ;; 1+ to account for the header word.
  +       (transport-generic object (1+ length)))
  +      ;; Nothing else can be transported
  +      (t (transport-error object)))))
  +
  +(defun transport-object (object)
  +  "Transport an object in oldspace to newspace.
  +Leaves pointer fields unchanged and returns the new object."
  +  (case (%tag-field object)
  +    (#.+tag-cons+
  +     (transport-generic object 2))
  +    (#.+tag-symbol+
  +     (transport-generic object 6))
  +    (#.+tag-array-header+
  +     (transport-generic object 4))
  +    (#.+tag-array-like+
  +     (transport-array-like object))
  +    (t (transport-error object))))
   
   (defun mark-static-object (object)
     (let ((address (ash (%pointer-field object) 4)))
  
positive.code:               *newspace-paging-bits* *oldspace-paging-bits*
                *newspace-offset* 0
                *static-mark-bit* (logxor *static-mark-bit* 1))
         ;; Transport the major root, NIL.
         (gc-object 'nil)
         ;; Transport registers, the data stack and the binding stack.
         (transport-registers-and-stack 1 2 3 4 5)
         ;; Make oldspace inaccessible.
         (setf (ldb (byte 2 0) (memref-unsigned-byte-32 *oldspace-paging-bits* 0)) 0)
         ;; Flush TLB.
  
negative.code:       (return-from mark-static-object))
      (setf (ldb (byte 1 0) (memref-unsigned-byte-64 address -1)) *static-mark-bit*)
      (with-gc-trace (object #\s)
        (scan-object object))))
  
  ;;; TODO: This needs to coalesce adjacent free areas.
  (defun sweep-static-space (space)
  