5.3.2 · Поддержание иллюзии бесконечной памяти

Копирующая сборка мусора с указателями пересылки

Граф, достижимый из корневого набора, переносится в новую векторную память, а указатели пересылки сохраняют и общие хвосты, и циклы.

Вопрос для размышления

Как сборщик может уплотнять живую память без дублирования разделяемых объектов и без бесконечного зацикливания при наличии циклов?

Различение from-space и изначально пустого to-space
Копирование только указателей на пары, достижимых из переданных корней root
Установка записи forwarding перед рекурсивным копированием полей
Повторное использование одного нового указателя для каждой повторной ссылки на старую ячейку
Сохранение цикла через распознавание указателя forwarding
Измерение освобожденных ячеек и продвижения указателя free

copy-value возвращает атомы без изменений. Для указателя на пару процедура сначала проверяет запись forwarding по старому индексу. При отсутствии записи выделяется одна ячейка placeholder в to-space и записывается новый указатель еще до перехода по любому из полей. Затем car и cdr рекурсивно копируются в эту ячейку placeholder. Запись нового указателя в первую очередь делает конечной обработку как разделяемых данных, так и циклов.

В первой куче выделено пять ячеек, но только три из них достижимы из двух корней root. Скопированные ячейки left и right указывают на один скопированный разделяемый хвост shared, тогда как обе ячейки мусора сохраняют ложные записи forwarding. Вторая куча содержит цикл на себя, поэтому копирование cdr снова встречает старый указатель и сразу повторно использует уже установленный новый указатель. Эта конечная программа выполняет один явный сбор мусора в пределах фиксированной емкости semispace.

Код SICP4,742 из 1,048,576 байт UTF-8

(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)))
)

Примеры

Результат—

Вывод: —
Значение: —
Диагностика: —

Трасса выполнения0 / 0 событий

Ожидаемый результат

Сборка мусора для графа с разделением возвращает (5 3 2 (a shared) (b shared) #t #f #f). Сборка циклического графа возвращает (1 node #t #f).

На что обратить внимание в трассе

В графе с разделением проследите переход первого старого указателя shared в новое выделение памяти, а второго вхождения в существующую запись forwarding. Убедитесь, что старые индексы 3 и 4 никогда не посещаются. В цикле найдите запись forwarding до того, как рекурсивное копирование cdr снова достигнет старого узла.

Попробуйте сами

Измените программу и сравните результат.

Добавьте третий корень root, указывающий прямо на разделяемый хвост shared, затем измените скопированный хвост. Спрогнозируйте новое количество выделенных ячеек и каждое наблюдение через root. Затем поменяйте местами semispace и выделите еще одну ячейку.

Показать подсказку

Дополнительный корень root к уже пересланному объекту не добавляет скопированных ячеек. После сборки мусора все клиенты должны использовать перезаписанные корни root в to-space, а не устаревшие указатели из from-space.

Завершить этот урок

В этой главе пройдено 0 из 23 урока0%