5.3.2 · Maintaining the illusion of infinite memory

Copy live cells, forward repeated references, and leave garbage behind.

Move the graph reachable from an explicit root set into a fresh vector memory, installing forwarding pointers that preserve shared tails and cycles.

Guiding question

How can a collector compact live storage without duplicating shared objects or looping forever through a cycle?

Distinguish from-space from an initially empty to-space
Copy only pair pointers reachable from the supplied roots
Install a forwarding entry before recursively copying fields
Reuse one new pointer for every repeated reference to an old cell
Preserve a cycle by recognizing a forwarded pointer
Measure reclaimed cells and the advancing free pointer

copy-value returns atoms unchanged. For a pair pointer, it first consults forwarding by old index. A missing entry allocates one placeholder cell in to-space and records the new pointer before either field is followed. The car and cdr are then copied recursively into that placeholder. Recording first is what makes both sharing and cycles finite.

The first heap has five allocated cells but only three are reachable from the two roots. The copied left and right cells point to one copied shared tail, while both garbage cells retain false forwarding entries. The second heap contains a self-cycle; copying the cdr reaches the old pointer again and immediately reuses the already installed new pointer. This finite program performs one explicit collection within a fixed semispace capacity.

SICP code4,742 of 1,048,576 UTF-8 bytes

(begin
  (define (tagged-list? value tag)
    (and (pair? value) (eq? (car value) tag)))
  (define (make-vector-memory capacity)
    (list '*vector-memory*
          (make-vector capacity '*unused*)
          (make-vector capacity '*unused*)
          (cons 'free 0)))
  (define (memory-cars memory) (list-ref memory 1))
  (define (memory-cdrs memory) (list-ref memory 2))
  (define (memory-free-cell memory) (list-ref memory 3))
  (define (memory-free memory) (cdr (memory-free-cell memory)))
  (define (set-memory-free! memory value)
    (set-cdr! (memory-free-cell memory) value))

  (define (pair-pointer? value) (tagged-list? value 'ptr))
  (define (make-pointer index) (list 'ptr index))
  (define (pointer-index pointer) (cadr pointer))

  (define (allocate-pair! memory car-value cdr-value)
    (let ((index (memory-free memory)))
      (if (>= index (vector-length (memory-cars memory)))
          (error "vector memory exhausted" index)
          (begin
            (vector-set! (memory-cars memory) index car-value)
            (vector-set! (memory-cdrs memory) index cdr-value)
            (set-memory-free! memory (+ index 1))
            (make-pointer index)))))
  (define (memory-car memory pointer)
    (vector-ref (memory-cars memory) (pointer-index pointer)))
  (define (memory-cdr memory pointer)
    (vector-ref (memory-cdrs memory) (pointer-index pointer)))
  (define (set-memory-car! memory pointer value)
    (vector-set! (memory-cars memory)
                 (pointer-index pointer)
                 value))
  (define (set-memory-cdr! memory pointer value)
    (vector-set! (memory-cdrs memory)
                 (pointer-index pointer)
                 value))

  (define (list->memory values memory)
    (if (null? values)
        '()
        (let ((tail (list->memory (cdr values) memory)))
          (allocate-pair! memory (car values) tail))))
  (define (memory->list pointer memory)
    (if (null? pointer)
        '()
        (cons (memory-car memory pointer)
              (memory->list (memory-cdr memory pointer)
                            memory))))
  (define (used-vector-prefix values count)
    (define (loop index result)
      (if (= index count)
          (reverse result)
          (loop (+ index 1)
                (cons (vector-ref values index) result))))
    (loop 0 '()))
  (define (collect from-memory roots)
    (let ((to-memory
           (make-vector-memory
             (vector-length (memory-cars from-memory))))
          (forwarding
           (make-vector
             (vector-length (memory-cars from-memory))
             #f)))
      (define (copy-value value)
        (if (not (pair-pointer? value))
            value
            (let* ((old-index (pointer-index value))
                   (known (vector-ref forwarding old-index)))
              (if known
                  known
                  (let ((new-pointer
                         (allocate-pair!
                           to-memory
                           '*pending-car*
                           '*pending-cdr*)))
                    (vector-set! forwarding
                                 old-index
                                 new-pointer)
                    (set-memory-car!
                      to-memory
                      new-pointer
                      (copy-value
                        (memory-car from-memory value)))
                    (set-memory-cdr!
                      to-memory
                      new-pointer
                      (copy-value
                        (memory-cdr from-memory value)))
                    new-pointer)))))
      (define new-roots (map copy-value roots))
      (list new-roots to-memory forwarding)))
  (define from-memory (make-vector-memory 10))
  (define shared
    (allocate-pair! from-memory 'shared '()))
  (define left
    (allocate-pair! from-memory 'a shared))
  (define right
    (allocate-pair! from-memory 'b shared))
  (define dead-tail
    (allocate-pair! from-memory 'dead '()))
  (define garbage
    (allocate-pair! from-memory 'garbage dead-tail))
  (define collection
    (collect from-memory (list left right)))
  (define roots (car collection))
  (define to-memory (cadr collection))
  (define forwarding (caddr collection))
  (define new-left (car roots))
  (define new-right (cadr roots))
  (list (memory-free from-memory)
        (memory-free to-memory)
        (- (memory-free from-memory)
           (memory-free to-memory))
        (memory->list new-left to-memory)
        (memory->list new-right to-memory)
        (equal? (memory-cdr to-memory new-left)
                (memory-cdr to-memory new-right))
        (vector-ref forwarding (pointer-index dead-tail))
        (vector-ref forwarding (pointer-index garbage)))
)

(begin
  (define (tagged-list? value tag)
    (and (pair? value) (eq? (car value) tag)))
  (define (make-vector-memory capacity)
    (list '*vector-memory*
          (make-vector capacity '*unused*)
          (make-vector capacity '*unused*)
          (cons 'free 0)))
  (define (memory-cars memory) (list-ref memory 1))
  (define (memory-cdrs memory) (list-ref memory 2))
  (define (memory-free-cell memory) (list-ref memory 3))
  (define (memory-free memory) (cdr (memory-free-cell memory)))
  (define (set-memory-free! memory value)
    (set-cdr! (memory-free-cell memory) value))

(define (pair-pointer? value) (tagged-list? value 'ptr))
  (define (make-pointer index) (list 'ptr index))
  (define (pointer-index pointer) (cadr pointer))

(define (allocate-pair! memory car-value cdr-value)
    (let ((index (memory-free memory)))
      (if (>= index (vector-length (memory-cars memory)))
          (error "vector memory exhausted" index)
          (begin
            (vector-set! (memory-cars memory) index car-value)
            (vector-set! (memory-cdrs memory) index cdr-value)
            (set-memory-free! memory (+ index 1))
            (make-pointer index)))))
  (define (memory-car memory pointer)
    (vector-ref (memory-cars memory) (pointer-index pointer)))
  (define (memory-cdr memory pointer)
    (vector-ref (memory-cdrs memory) (pointer-index pointer)))
  (define (set-memory-car! memory pointer value)
    (vector-set! (memory-cars memory)
                 (pointer-index pointer)
                 value))
  (define (set-memory-cdr! memory pointer value)
    (vector-set! (memory-cdrs memory)
                 (pointer-index pointer)
                 value))

(define (list->memory values memory)
    (if (null? values)
        '()
        (let ((tail (list->memory (cdr values) memory)))
          (allocate-pair! memory (car values) tail))))
  (define (memory->list pointer memory)
    (if (null? pointer)
        '()
        (cons (memory-car memory pointer)
              (memory->list (memory-cdr memory pointer)
                            memory))))
  (define (used-vector-prefix values count)
    (define (loop index result)
      (if (= index count)
          (reverse result)
          (loop (+ index 1)
                (cons (vector-ref values index) result))))
    (loop 0 '()))
  (define (collect from-memory roots)
    (let ((to-memory
           (make-vector-memory
             (vector-length (memory-cars from-memory))))
          (forwarding
           (make-vector
             (vector-length (memory-cars from-memory))
             #f)))
      (define (copy-value value)
        (if (not (pair-pointer? value))
            value
            (let* ((old-index (pointer-index value))
                   (known (vector-ref forwarding old-index)))
              (if known
                  known
                  (let ((new-pointer
                         (allocate-pair!
                           to-memory
                           '*pending-car*
                           '*pending-cdr*)))
                    (vector-set! forwarding
                                 old-index
                                 new-pointer)
                    (set-memory-car!
                      to-memory
                      new-pointer
                      (copy-value
                        (memory-car from-memory value)))
                    (set-memory-cdr!
                      to-memory
                      new-pointer
                      (copy-value
                        (memory-cdr from-memory value)))
                    new-pointer)))))
      (define new-roots (map copy-value roots))
      (list new-roots to-memory forwarding)))
  (define from-memory (make-vector-memory 10))
  (define shared
    (allocate-pair! from-memory 'shared '()))
  (define left
    (allocate-pair! from-memory 'a shared))
  (define right
    (allocate-pair! from-memory 'b shared))
  (define dead-tail
    (allocate-pair! from-memory 'dead '()))
  (define garbage
    (allocate-pair! from-memory 'garbage dead-tail))
  (define collection
    (collect from-memory (list left right)))
  (define roots (car collection))
  (define to-memory (cadr collection))
  (define forwarding (caddr collection))
  (define new-left (car roots))
  (define new-right (cadr roots))
  (list (memory-free from-memory)
        (memory-free to-memory)
        (- (memory-free from-memory)
           (memory-free to-memory))
        (memory->list new-left to-memory)
        (memory->list new-right to-memory)
        (equal? (memory-cdr to-memory new-left)
                (memory-cdr to-memory new-right))
        (vector-ref forwarding (pointer-index dead-tail))
        (vector-ref forwarding (pointer-index garbage)))
)

Examples

Result—

Output: —
Value: —
Diagnostic: —

Execution trace0 / 0 events

Expected result

The shared-graph collection returns (5 3 2 (a shared) (b shared) #t #f #f). The cyclic collection returns (1 node #t #f).

Trace focus

In the shared graph, follow the first old shared pointer into a new allocation and the second occurrence into the existing forwarding entry. Confirm that old indexes 3 and 4 are never visited. In the cycle, locate the forwarding write before the recursive cdr copy reaches the old node again.

Try it yourself

Change the program and compare the result.

Add a third root that points directly to the shared tail, then mutate the copied tail. Predict the new allocation count and every root observation. Next swap the semispaces and allocate one additional cell.

Show hint

An extra root to an already forwarded object adds no copied cell. After collection, all clients must use the rewritten roots in to-space rather than stale from-space pointers.

Complete this lesson

0 of 23 lessons complete in this chapter0%