5.1.2 · Абстракция при проектировании машин

Стабильный контроллер над сменными операциями

Контроллер опирается на именованные контракты операций вместо одного арифметического метода, а цикл управления на протокол регистрового банка.

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

Какие границы позволяют изменять конструкцию машины локально, не переписывая ее контроллер?

Отделение структуры контроллера от вызываемого им пакета операций
Запуск одного контроллера с евклидовым пакетом редукции и пакетом редукции через вычитание
Сравнение затрат процесса без изменения текста контроллера
Сокрытие хранилища регистров за сообщениями read и write
Сравнение одной границы абстракции на двух измеренных реализациях

Контроллер редукции знает только имена done?, next-a, next-b и answer. Евклидов пакет связывает эти имена с редукцией через остаток от деления, а пакет вычитания связывает их с редукцией через повторяющуюся разность. Обе машины используют одинаковую последовательность ассемблированных инструкций и возвращают один и тот же наибольший общий делитель, но число инструкций выявляет различия процессов.

Вторая программа предоставляет одному и тому же контроллеру счетчика два банка регистров. Один банк хранит изменяемые ассоциативные записи, а другой банк хранит значения в векторе за таблицей соответствия имен индексам. Контроллер отправляет только сообщения read и write. Одинаковые результаты наблюдений показывают, что конечный контракт клиента сохраняется при изменении способа хранения.

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

(begin
  (define (tagged-list? value tag)
    (and (pair? value) (eq? (car value) tag)))

  (define (extract-labels controller position)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (cons (cons (car controller) position)
                 (extract-labels (cdr controller) position)))
          (else
           (extract-labels (cdr controller) (+ position 1)))))
  (define (extract-instructions controller)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (extract-instructions (cdr controller)))
          (else
           (cons (car controller)
                 (extract-instructions (cdr controller))))))

  (define (make-registers names)
    (map (lambda (name) (cons name '*unassigned*)) names))
  (define (make-machine register-names operations controller)
    (list '*machine*
          (make-registers register-names)
          (cons '*stack* '())
          operations
          (extract-instructions controller)
          (extract-labels controller 0)
          (cons 'pc 0)
          (cons 'flag #f)
          (cons 'halted #f)
          (cons 'steps 0)))

  (define (machine-registers machine) (list-ref machine 1))
  (define (machine-stack machine) (list-ref machine 2))
  (define (machine-operations machine) (list-ref machine 3))
  (define (machine-instructions machine) (list-ref machine 4))
  (define (machine-labels machine) (list-ref machine 5))
  (define (machine-pc-cell machine) (list-ref machine 6))
  (define (machine-flag-cell machine) (list-ref machine 7))
  (define (machine-halted-cell machine) (list-ref machine 8))
  (define (machine-steps-cell machine) (list-ref machine 9))

  (define (machine-pc machine) (cdr (machine-pc-cell machine)))
  (define (set-machine-pc! machine value)
    (set-cdr! (machine-pc-cell machine) value))
  (define (machine-flag machine) (cdr (machine-flag-cell machine)))
  (define (set-machine-flag! machine value)
    (set-cdr! (machine-flag-cell machine) value))
  (define (machine-halted? machine) (cdr (machine-halted-cell machine)))
  (define (halt-machine! machine)
    (set-cdr! (machine-halted-cell machine) #t))
  (define (machine-steps machine) (cdr (machine-steps-cell machine)))
  (define (increment-machine-steps! machine)
    (set-cdr! (machine-steps-cell machine)
              (+ (machine-steps machine) 1)))

  (define (register-cell machine name)
    (let ((cell (assoc name (machine-registers machine))))
      (if cell cell (error "unknown register" name))))
  (define (get-register machine name)
    (cdr (register-cell machine name)))
  (define (set-register! machine name value)
    (set-cdr! (register-cell machine name) value))

  (define (push! machine value)
    (set-cdr! (machine-stack machine)
              (cons value (cdr (machine-stack machine)))))
  (define (pop! machine)
    (let ((values (cdr (machine-stack machine))))
      (if (null? values)
          (error "empty machine stack")
          (let ((value (car values)))
            (set-cdr! (machine-stack machine) (cdr values))
            value))))
  (define (stack-empty? machine)
    (null? (cdr (machine-stack machine))))

  (define (operation machine name)
    (let ((binding (assoc name (machine-operations machine))))
      (if binding (cdr binding) (error "unknown operation" name))))
  (define (label-position machine name)
    (let ((binding (assoc name (machine-labels machine))))
      (if binding (cdr binding) (error "unknown label" name))))

  (define (evaluate-source machine source)
    (cond ((tagged-list? source 'const) (cadr source))
          ((tagged-list? source 'reg)
           (get-register machine (cadr source)))
          ((tagged-list? source 'label)
           (label-position machine (cadr source)))
          ((tagged-list? source 'op)
           (apply (operation machine (cadr source))
                  (map (lambda (operand)
                         (evaluate-source machine operand))
                       (cddr source))))
          (else
           (error "unknown machine source" source))))

  (define (advance! machine)
    (set-machine-pc! machine (+ (machine-pc machine) 1)))
  (define (execute-one! machine)
    (let* ((instruction
             (list-ref (machine-instructions machine)
                       (machine-pc machine)))
           (tag (car instruction)))
      (increment-machine-steps! machine)
      (cond
        ((eq? tag 'assign)
         (set-register! machine
                        (cadr instruction)
                        (evaluate-source machine (caddr instruction)))
         (advance! machine))
        ((eq? tag 'test)
         (set-machine-flag! machine
                            (evaluate-source machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'branch)
         (if (machine-flag machine)
             (set-machine-pc!
               machine
               (label-position machine (cadr instruction)))
             (advance! machine)))
        ((eq? tag 'goto)
         (set-machine-pc! machine
                          (evaluate-source machine (cadr instruction))))
        ((eq? tag 'save)
         (push! machine (get-register machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'restore)
         (set-register! machine (cadr instruction) (pop! machine))
         (advance! machine))
        ((eq? tag 'perform)
         (evaluate-source machine (cadr instruction))
         (advance! machine))
        ((eq? tag 'halt)
         (halt-machine! machine))
        (else
         (error "unknown machine instruction" instruction)))))

  (define (run-machine! machine step-limit)
    (cond ((machine-halted? machine) 'complete)
          ((= step-limit 0) 'step-limit)
          (else
           (execute-one! machine)
           (run-machine! machine (- step-limit 1)))))
  (define controller
    '(loop
       (test (op done? (reg a) (reg b)))
       (branch done)
       (assign next-a (op next-a (reg a) (reg b)))
       (assign next-b (op next-b (reg a) (reg b)))
       (assign a (reg next-a))
       (assign b (reg next-b))
       (goto (label loop))
      done
       (assign answer (op answer (reg a) (reg b)))
       (halt)))
  (define euclid-operations
    (list
      (cons 'done? (lambda (a b) (= b 0)))
      (cons 'next-a (lambda (a b) b))
      (cons 'next-b (lambda (a b) (remainder a b)))
      (cons 'answer (lambda (a b) a))))
  (define subtraction-operations
    (list
      (cons 'done? (lambda (a b) (= a b)))
      (cons 'next-a
            (lambda (a b) (if (> a b) (- a b) a)))
      (cons 'next-b
            (lambda (a b) (if (> b a) (- b a) b)))
      (cons 'answer (lambda (a b) a))))
  (define (run-with operations)
    (let ((machine
           (make-machine
             '(a b next-a next-b answer)
             operations
             controller)))
      (set-register! machine 'a 206)
      (set-register! machine 'b 40)
      (list (run-machine! machine 200)
            (get-register machine 'answer)
            (machine-steps machine)
            (machine-instructions machine))))
  (let ((euclid (run-with euclid-operations))
        (subtraction (run-with subtraction-operations)))
    (list (list 'euclid (car euclid) (cadr euclid) (caddr euclid))
          (list 'subtraction
                (car subtraction)
                (cadr subtraction)
                (caddr subtraction))
          (equal? (list-ref euclid 3)
                  (list-ref subtraction 3))))
)

(begin
  (define (tagged-list? value tag)
    (and (pair? value) (eq? (car value) tag)))

(define (extract-labels controller position)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (cons (cons (car controller) position)
                 (extract-labels (cdr controller) position)))
          (else
           (extract-labels (cdr controller) (+ position 1)))))
  (define (extract-instructions controller)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (extract-instructions (cdr controller)))
          (else
           (cons (car controller)
                 (extract-instructions (cdr controller))))))

(define (make-registers names)
    (map (lambda (name) (cons name '*unassigned*)) names))
  (define (make-machine register-names operations controller)
    (list '*machine*
          (make-registers register-names)
          (cons '*stack* '())
          operations
          (extract-instructions controller)
          (extract-labels controller 0)
          (cons 'pc 0)
          (cons 'flag #f)
          (cons 'halted #f)
          (cons 'steps 0)))

(define (machine-registers machine) (list-ref machine 1))
  (define (machine-stack machine) (list-ref machine 2))
  (define (machine-operations machine) (list-ref machine 3))
  (define (machine-instructions machine) (list-ref machine 4))
  (define (machine-labels machine) (list-ref machine 5))
  (define (machine-pc-cell machine) (list-ref machine 6))
  (define (machine-flag-cell machine) (list-ref machine 7))
  (define (machine-halted-cell machine) (list-ref machine 8))
  (define (machine-steps-cell machine) (list-ref machine 9))

(define (machine-pc machine) (cdr (machine-pc-cell machine)))
  (define (set-machine-pc! machine value)
    (set-cdr! (machine-pc-cell machine) value))
  (define (machine-flag machine) (cdr (machine-flag-cell machine)))
  (define (set-machine-flag! machine value)
    (set-cdr! (machine-flag-cell machine) value))
  (define (machine-halted? machine) (cdr (machine-halted-cell machine)))
  (define (halt-machine! machine)
    (set-cdr! (machine-halted-cell machine) #t))
  (define (machine-steps machine) (cdr (machine-steps-cell machine)))
  (define (increment-machine-steps! machine)
    (set-cdr! (machine-steps-cell machine)
              (+ (machine-steps machine) 1)))

(define (register-cell machine name)
    (let ((cell (assoc name (machine-registers machine))))
      (if cell cell (error "unknown register" name))))
  (define (get-register machine name)
    (cdr (register-cell machine name)))
  (define (set-register! machine name value)
    (set-cdr! (register-cell machine name) value))

(define (push! machine value)
    (set-cdr! (machine-stack machine)
              (cons value (cdr (machine-stack machine)))))
  (define (pop! machine)
    (let ((values (cdr (machine-stack machine))))
      (if (null? values)
          (error "empty machine stack")
          (let ((value (car values)))
            (set-cdr! (machine-stack machine) (cdr values))
            value))))
  (define (stack-empty? machine)
    (null? (cdr (machine-stack machine))))

(define (operation machine name)
    (let ((binding (assoc name (machine-operations machine))))
      (if binding (cdr binding) (error "unknown operation" name))))
  (define (label-position machine name)
    (let ((binding (assoc name (machine-labels machine))))
      (if binding (cdr binding) (error "unknown label" name))))

(define (evaluate-source machine source)
    (cond ((tagged-list? source 'const) (cadr source))
          ((tagged-list? source 'reg)
           (get-register machine (cadr source)))
          ((tagged-list? source 'label)
           (label-position machine (cadr source)))
          ((tagged-list? source 'op)
           (apply (operation machine (cadr source))
                  (map (lambda (operand)
                         (evaluate-source machine operand))
                       (cddr source))))
          (else
           (error "unknown machine source" source))))

(define (advance! machine)
    (set-machine-pc! machine (+ (machine-pc machine) 1)))
  (define (execute-one! machine)
    (let* ((instruction
             (list-ref (machine-instructions machine)
                       (machine-pc machine)))
           (tag (car instruction)))
      (increment-machine-steps! machine)
      (cond
        ((eq? tag 'assign)
         (set-register! machine
                        (cadr instruction)
                        (evaluate-source machine (caddr instruction)))
         (advance! machine))
        ((eq? tag 'test)
         (set-machine-flag! machine
                            (evaluate-source machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'branch)
         (if (machine-flag machine)
             (set-machine-pc!
               machine
               (label-position machine (cadr instruction)))
             (advance! machine)))
        ((eq? tag 'goto)
         (set-machine-pc! machine
                          (evaluate-source machine (cadr instruction))))
        ((eq? tag 'save)
         (push! machine (get-register machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'restore)
         (set-register! machine (cadr instruction) (pop! machine))
         (advance! machine))
        ((eq? tag 'perform)
         (evaluate-source machine (cadr instruction))
         (advance! machine))
        ((eq? tag 'halt)
         (halt-machine! machine))
        (else
         (error "unknown machine instruction" instruction)))))

(define (run-machine! machine step-limit)
    (cond ((machine-halted? machine) 'complete)
          ((= step-limit 0) 'step-limit)
          (else
           (execute-one! machine)
           (run-machine! machine (- step-limit 1)))))
  (define controller
    '(loop
       (test (op done? (reg a) (reg b)))
       (branch done)
       (assign next-a (op next-a (reg a) (reg b)))
       (assign next-b (op next-b (reg a) (reg b)))
       (assign a (reg next-a))
       (assign b (reg next-b))
       (goto (label loop))
      done
       (assign answer (op answer (reg a) (reg b)))
       (halt)))
  (define euclid-operations
    (list
      (cons 'done? (lambda (a b) (= b 0)))
      (cons 'next-a (lambda (a b) b))
      (cons 'next-b (lambda (a b) (remainder a b)))
      (cons 'answer (lambda (a b) a))))
  (define subtraction-operations
    (list
      (cons 'done? (lambda (a b) (= a b)))
      (cons 'next-a
            (lambda (a b) (if (> a b) (- a b) a)))
      (cons 'next-b
            (lambda (a b) (if (> b a) (- b a) b)))
      (cons 'answer (lambda (a b) a))))
  (define (run-with operations)
    (let ((machine
           (make-machine
             '(a b next-a next-b answer)
             operations
             controller)))
      (set-register! machine 'a 206)
      (set-register! machine 'b 40)
      (list (run-machine! machine 200)
            (get-register machine 'answer)
            (machine-steps machine)
            (machine-instructions machine))))
  (let ((euclid (run-with euclid-operations))
        (subtraction (run-with subtraction-operations)))
    (list (list 'euclid (car euclid) (cadr euclid) (caddr euclid))
          (list 'subtraction
                (car subtraction)
                (cadr subtraction)
                (caddr subtraction))
          (equal? (list-ref euclid 3)
                  (list-ref subtraction 3))))
)

Примеры

Результат—

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

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

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

Программа с пакетами операций возвращает ((euclid complete 2 32) (subtraction complete 2 95) #t). Программа с банками регистров возвращает ((4 10) (4 10) #t).

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

В первом запуске убедитесь, что обе машины выбирают одинаковые теги инструкций, тогда как поиск операций выбирает различные процедуры. Сравните четыре евклидовых цикла редукции с тринадцатью циклами вычитания. Во втором запуске проследите, как одна и та же последовательность вызовов read и write переходит в различные скрытые операции хранилища.

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

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

Добавьте пакет операций для бинарного алгоритма НОД или третье представление банка регистров. Сохраните текст контроллера без изменений и укажите, каким контрактам операций или хранилища должна удовлетворять новая замена.

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

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

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

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