5.2.5 · Генерация процедур выполнения

Замыкания инструкций вместо диспетчеризации в цикле

Каждая инструкция становится замыканием со своими операндами и правилом управления, а вектор процедур переиспользуется между экземплярами машины.

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

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

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

Процедура make-execution-procedure выполняет диспетчеризацию по тегу инструкции во время ассемблирования. Каждая ветвь возвращает замыкание, которое запоминает целевой регистр, выражение источника, метку или необходимую операцию со стеком. Цикл выполнения больше не содержит форму cond для assign/test/branch/goto, а выбирает замыкание по значению pc и вызывает его.

Первая программа показывает, что даже присваивание, пропущенное ветвлением по истине, получает процедуру выполнения, поскольку ассемблирование охватывает структуру контроллера, а не один путь выполнения. Программа вычисления factorial один раз ассемблирует шесть замыканий и использует ту же последовательность для двух новых экземпляров машины. Замыкания по-прежнему получают текущую машину, поэтому регистры, стек, flag, pc и пакет операций остаются индивидуальными для каждого экземпляра.

Код SICP9,477 из 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 (make-execution-procedure instruction)
    (let ((tag (car instruction)))
      (cond
        ((eq? tag 'assign)
         (let ((target (cadr instruction))
               (source (caddr instruction)))
           (lambda (machine)
             (set-register! machine
                            target
                            (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'test)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-flag! machine
                                (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'branch)
         (let ((label (cadr instruction)))
           (lambda (machine)
             (if (machine-flag machine)
                 (set-machine-pc! machine
                                  (label-position machine label))
                 (advance! machine)))))
        ((eq? tag 'goto)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-pc! machine
                              (evaluate-source machine source)))))
        ((eq? tag 'save)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (push! machine (get-register machine register))
             (advance! machine))))
        ((eq? tag 'restore)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (set-register! machine register (pop! machine))
             (advance! machine))))
        ((eq? tag 'perform)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (evaluate-source machine source)
             (advance! machine))))
        ((eq? tag 'halt)
         (lambda (machine) (halt-machine! machine)))
        (else
         (error "unknown instruction at assembly" instruction)))))
  (define (run-procedures! machine procedures remaining)
    (cond ((machine-halted? machine) 'complete)
          ((= remaining 0) 'step-limit)
          (else
           (increment-machine-steps! machine)
           ((list-ref procedures (machine-pc machine)) machine)
           (run-procedures! machine
                            procedures
                            (- remaining 1)))))
  (define observations '())
  (define operations
    (list
      (cons '= =)
      (cons 'record
            (lambda (value)
              (set! observations
                    (append observations (list value)))
              'ok))))
  (define controller
    '(start
       (assign val (const 10))
       (test (op = (reg val) (const 10)))
       (branch after-skip)
       (assign val (const -1))
      after-skip
       (assign continue (label after-goto))
       (goto (reg continue))
      after-goto
       (save val)
       (assign val (const 0))
       (restore val)
       (perform (op record (reg val)))
       (halt)))
  (define machine
    (make-machine '(val continue) operations controller))
  (define generation-log '())
  (define procedures
    (map
      (lambda (instruction)
        (set! generation-log
              (append generation-log (list (car instruction))))
        (make-execution-procedure instruction))
      (machine-instructions machine)))
  (define (all-procedures? values)
    (if (null? values)
        #t
        (and (procedure? (car values))
             (all-procedures? (cdr values)))))
  (define status (run-procedures! machine procedures 30))
  (list generation-log
        (length procedures)
        (all-procedures? procedures)
        status
        (get-register machine 'val)
        observations
        (machine-steps machine))
)

(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 (make-execution-procedure instruction)
    (let ((tag (car instruction)))
      (cond
        ((eq? tag 'assign)
         (let ((target (cadr instruction))
               (source (caddr instruction)))
           (lambda (machine)
             (set-register! machine
                            target
                            (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'test)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-flag! machine
                                (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'branch)
         (let ((label (cadr instruction)))
           (lambda (machine)
             (if (machine-flag machine)
                 (set-machine-pc! machine
                                  (label-position machine label))
                 (advance! machine)))))
        ((eq? tag 'goto)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-pc! machine
                              (evaluate-source machine source)))))
        ((eq? tag 'save)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (push! machine (get-register machine register))
             (advance! machine))))
        ((eq? tag 'restore)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (set-register! machine register (pop! machine))
             (advance! machine))))
        ((eq? tag 'perform)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (evaluate-source machine source)
             (advance! machine))))
        ((eq? tag 'halt)
         (lambda (machine) (halt-machine! machine)))
        (else
         (error "unknown instruction at assembly" instruction)))))
  (define (run-procedures! machine procedures remaining)
    (cond ((machine-halted? machine) 'complete)
          ((= remaining 0) 'step-limit)
          (else
           (increment-machine-steps! machine)
           ((list-ref procedures (machine-pc machine)) machine)
           (run-procedures! machine
                            procedures
                            (- remaining 1)))))
  (define observations '())
  (define operations
    (list
      (cons '= =)
      (cons 'record
            (lambda (value)
              (set! observations
                    (append observations (list value)))
              'ok))))
  (define controller
    '(start
       (assign val (const 10))
       (test (op = (reg val) (const 10)))
       (branch after-skip)
       (assign val (const -1))
      after-skip
       (assign continue (label after-goto))
       (goto (reg continue))
      after-goto
       (save val)
       (assign val (const 0))
       (restore val)
       (perform (op record (reg val)))
       (halt)))
  (define machine
    (make-machine '(val continue) operations controller))
  (define generation-log '())
  (define procedures
    (map
      (lambda (instruction)
        (set! generation-log
              (append generation-log (list (car instruction))))
        (make-execution-procedure instruction))
      (machine-instructions machine)))
  (define (all-procedures? values)
    (if (null? values)
        #t
        (and (procedure? (car values))
             (all-procedures? (cdr values)))))
  (define status (run-procedures! machine procedures 30))
  (list generation-log
        (length procedures)
        (all-procedures? procedures)
        status
        (get-register machine 'val)
        observations
        (machine-steps machine))
)

Примеры

Результат—

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

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

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

Журнал ассемблирования возвращает ((assign test branch assign assign goto save assign restore perform halt) 11 #t complete 10 (10) 10). Повторно используемая последовательность factorial возвращает (6 (complete 120 28) (complete 6 18)).

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

Отделите однократный проход map по данным инструкций от последующего цикла выборки и вызова. Пропущенное присваивание -1 все еще присутствует в generation-log, тогда как путь выполнения никогда не вызывает его замыкание. В примере с factorial убедитесь, что оба экземпляра машины разделяют список процедур, но не свои изменяемые регистры или счетчики.

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

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

Добавьте save и restore в контроллер factorial или оснастите каждое созданное замыкание записью тега инструкции. Предскажите, какая работа выполняется во время ассемблирования, а какая повторяется при каждом запуске машины.

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

Все, что определяется исключительно синтаксисом контроллера, относится к созданному замыканию. Значения регистров и зависящее от pc управление остаются входными данными времени выполнения.

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

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