5.1.5 · Вычислитель с явным управлением

Вычислитель с явным управлением на регистрах

Контроллер регистровой машины реализует eval и apply. Регистры exp, env, val, proc, argl, continue и unev раскрывают состояние вычислителя.

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

Что меняется, когда вычислитель больше не выражается рекурсией хост-языка и должен сохранять каждое continuation явно?

Диспетчеризация гостевого синтаксиса через явный контроллер eval-dispatch
Передача данных вычислителя через exp, env, val, proc, argl, continue и unev
Сохранение и восстановление незавершенной работы с операторами и операндами в машинном стеке
Применение примитивов и представленных составных процедур через отдельные пути контроллера
Восстановление continue перед вычислением последнего выражения последовательности
Наблюдение одинаковой максимальной глубины стека для двух хвостовых рекурсивных запусков разной длины
Направление if, set! и define через явные метки контроллера
Запуск полной гостевой программы и остановка halt с пустым стеком вычислителя

Контроллер начинает с загрузки глобального окружения и финального continuation, затем многократно выполняет диспетчеризацию по выражению в exp. Простые значения помещают свой результат в val и переходят по continue. Применения сохраняют continuation и окружение вызывающего кода, вычисляют оператор и операнды, строят argl и входят в apply-dispatch. Примитивные процедуры вызывают реализацию хост-языка, а составные процедуры устанавливают новое окружение и направляют свое тело через ev-sequence.

Вычисление последовательности является хвосторекурсивным, так как ev-sequence-last-exp восстанавливает continuation вызывающего кода перед отправкой финального выражения обратно в eval-dispatch. Поэтому два запуска sum-iter достигают одинаковой измеренной максимальной глубины стека вычислителя, хотя один из них выполняет больше рекурсивных вызовов. Отдельные пути контроллера сохраняют и восстанавливают выражение, окружение и continuation вокруг if, set! и define. Финальная гостевая программа объединяет рекурсию, состояние лексического замыкания, изменение состояния и чистую остановку. Эти наблюдения описывают данный конечный симулятор и контроллер, а не аппаратные задержки или все возможные реализации вычислителя.

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

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

  (define (make-register name) (cons name '*unassigned*))
  (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-state machine) (list-ref machine 6))

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

  (define (push-stack! machine value)
    (let ((stack (machine-stack machine)))
      (set-cdr! stack (cons value (cdr stack)))
      (state-set! machine 'push-count
                  (+ (state-ref machine 'push-count) 1))
      (let ((depth (+ (state-ref machine 'current-depth) 1)))
        (state-set! machine 'current-depth depth)
        (if (> depth (state-ref machine 'max-depth))
            (state-set! machine 'max-depth depth)
            'ok))))
  (define (pop-stack! machine)
    (let ((stack (machine-stack machine)))
      (if (null? (cdr stack))
          (error "empty EC stack")
          (let ((value (cadr stack)))
            (set-cdr! stack (cddr stack))
            (state-set! machine 'current-depth
                        (- (state-ref machine 'current-depth) 1))
            value))))
  (define (stack-empty? machine)
    (null? (cdr (machine-stack machine))))

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

  (define (make-machine register-names operations controller)
    (list 'machine
          (map make-register register-names)
          (cons 'stack '())
          operations
          (extract-instructions controller)
          (build-labels controller 0)
          (list (cons 'pc 0)
                (cons 'flag #f)
                (cons 'halted #f)
                (cons 'instruction-count 0)
                (cons 'push-count 0)
                (cons 'current-depth 0)
                (cons 'max-depth 0)
                (cons 'global-environment '()))))

  (define (lookup-label machine name)
    (let ((entry (assoc name (machine-labels machine))))
      (if entry (cdr entry) (error "unknown EC label" name))))
  (define (lookup-operation machine name)
    (let ((entry (assoc name (machine-operations machine))))
      (if entry (cdr entry) (error "unknown EC operation" name))))
  (define (evaluate-expression expression machine)
    (cond ((tagged-list? expression 'const) (cadr expression))
          ((tagged-list? expression 'reg)
           (get-register-contents machine (cadr expression)))
          ((tagged-list? expression 'label)
           (lookup-label machine (cadr expression)))
          (else (error "unknown EC expression" expression))))
  (define (operation-expression? expressions)
    (and (pair? expressions) (tagged-list? (car expressions) 'op)))
  (define (evaluate-operation expressions machine)
    (apply (lookup-operation machine (cadr (car expressions)))
           (map (lambda (expression)
                  (evaluate-expression expression machine))
                (cdr expressions))))
  (define (advance-pc! machine)
    (state-set! machine 'pc (+ (state-ref machine 'pc) 1)))

  (define (execute-instruction! instruction machine)
    (cond
      ((tagged-list? instruction 'assign)
       (let ((parts (cddr instruction)))
         (set-register-contents!
           machine
           (cadr instruction)
           (if (operation-expression? parts)
               (evaluate-operation parts machine)
               (evaluate-expression (car parts) machine)))
         (advance-pc! machine)))
      ((tagged-list? instruction 'test)
       (state-set! machine 'flag
                   (evaluate-operation (cdr instruction) machine))
       (advance-pc! machine))
      ((tagged-list? instruction 'branch)
       (if (state-ref machine 'flag)
           (state-set! machine 'pc
                       (evaluate-expression (cadr instruction) machine))
           (advance-pc! machine)))
      ((tagged-list? instruction 'goto)
       (state-set! machine 'pc
                   (evaluate-expression (cadr instruction) machine)))
      ((tagged-list? instruction 'save)
       (push-stack! machine
                    (get-register-contents machine (cadr instruction)))
       (advance-pc! machine))
      ((tagged-list? instruction 'restore)
       (set-register-contents! machine
                               (cadr instruction)
                               (pop-stack! machine))
       (advance-pc! machine))
      ((tagged-list? instruction 'perform)
       (evaluate-operation (cdr instruction) machine)
       (advance-pc! machine))
      ((tagged-list? instruction 'halt)
       (state-set! machine 'halted #t))
      (else (error "unknown EC instruction" instruction))))

  (define (execute-machine! machine)
    (if (state-ref machine 'halted)
        'done
        (let ((pc (state-ref machine 'pc))
              (instructions (machine-instructions machine)))
          (if (= pc (length instructions))
              (state-set! machine 'halted #t)
              (begin
                (state-set! machine 'instruction-count
                            (+ (state-ref machine 'instruction-count) 1))
                (execute-instruction! (list-ref instructions pc) machine)
                (execute-machine! machine))))))
  (define (start! machine)
    (set-cdr! (machine-stack machine) '())
    (state-set! machine 'pc 0)
    (state-set! machine 'flag #f)
    (state-set! machine 'halted #f)
    (state-set! machine 'instruction-count 0)
    (state-set! machine 'push-count 0)
    (state-set! machine 'current-depth 0)
    (state-set! machine 'max-depth 0)
    (execute-machine! machine))

  (define (self-evaluating? expression)
    (or (number? expression) (string? expression) (boolean? expression)))
  (define (variable? expression) (symbol? expression))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (text-of-quotation expression) (cadr expression))
  (define (assignment? expression) (tagged-list? expression 'set!))
  (define (assignment-variable expression) (cadr expression))
  (define (assignment-value expression) (caddr expression))
  (define (definition? expression) (tagged-list? expression 'define))
  (define (definition-variable expression)
    (if (symbol? (cadr expression))
        (cadr expression)
        (caadr expression)))
  (define (definition-value expression)
    (if (symbol? (cadr expression))
        (caddr expression)
        (cons 'lambda
              (cons (cdar (cdr expression))
                    (cddr expression)))))
  (define (if? expression) (tagged-list? expression 'if))
  (define (if-predicate expression) (cadr expression))
  (define (if-consequent expression) (caddr expression))
  (define (if-alternative expression)
    (if (null? (cdddr expression)) #f (cadddr expression)))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (lambda-parameters expression) (cadr expression))
  (define (lambda-body expression) (cddr expression))
  (define (begin? expression) (tagged-list? expression 'begin))
  (define (begin-actions expression) (cdr expression))
  (define (application? expression) (pair? expression))
  (define (operator expression) (car expression))
  (define (operands expression) (cdr expression))
  (define (no-operands? operands) (null? operands))
  (define (first-operand operands) (car operands))
  (define (rest-operands operands) (cdr operands))
  (define (last-operand? operands) (null? (cdr operands)))

  (define (make-frame variables values)
    (cons 'frame (map cons variables values)))
  (define (frame-bindings frame) (cdr frame))
  (define (first-frame environment) (car environment))
  (define (enclosing-environment environment) (cdr environment))
  (define (find-binding variable bindings)
    (cond ((null? bindings) #f)
          ((eq? variable (caar bindings)) (car bindings))
          (else (find-binding variable (cdr bindings)))))
  (define (lookup-variable-value variable environment)
    (if (null? environment)
        (error "unbound EC variable" variable)
        (let ((binding
                (find-binding
                  variable
                  (frame-bindings (first-frame environment)))))
          (if binding
              (cdr binding)
              (lookup-variable-value
                variable
                (enclosing-environment environment))))))
  (define (set-variable-value! variable value environment)
    (if (null? environment)
        (error "unbound EC assignment" variable)
        (let ((binding
                (find-binding
                  variable
                  (frame-bindings (first-frame environment)))))
          (if binding
              (set-cdr! binding value)
              (set-variable-value!
                variable
                value
                (enclosing-environment environment))))))
  (define (define-variable! variable value environment)
    (let ((frame (first-frame environment)))
      (let ((binding (find-binding variable (frame-bindings frame))))
        (if binding
            (set-cdr! binding value)
            (set-cdr! frame
                      (cons (cons variable value)
                            (frame-bindings frame)))))))
  (define (extend-environment variables values base-environment)
    (if (= (length variables) (length values))
        (cons (make-frame variables values) base-environment)
        (error "EC argument count mismatch" variables values)))

  (define (make-procedure parameters body environment)
    (list 'procedure parameters body environment))
  (define (compound-procedure? procedure)
    (tagged-list? procedure 'procedure))
  (define (procedure-parameters procedure) (cadr procedure))
  (define (procedure-body procedure) (caddr procedure))
  (define (procedure-environment procedure) (cadddr procedure))
  (define (make-primitive implementation)
    (list 'primitive implementation))
  (define (primitive-procedure? procedure)
    (tagged-list? procedure 'primitive))
  (define (primitive-implementation procedure) (cadr procedure))
  (define (apply-primitive-procedure procedure arguments)
    (apply (primitive-implementation procedure) arguments))
  (define (empty-arglist) '())
  (define (adjoin-arg argument argument-list)
    (append argument-list (list argument)))
  (define (true? value) value)

  (define primitive-bindings
    (list (cons '+ +) (cons '- -) (cons '* *) (cons '/ /)
          (cons '= =) (cons '< <) (cons '> >)
          (cons '<= <=) (cons '>= >=)
          (cons 'list list) (cons 'cons cons)
          (cons 'car car) (cons 'cdr cdr)
          (cons 'null? null?) (cons 'pair? pair?)
          (cons 'not not)))
  (define (make-global-environment)
    (list
      (make-frame
        (append (map car primitive-bindings) '(true false))
        (append
          (map (lambda (binding)
                 (make-primitive (cdr binding)))
               primitive-bindings)
          (list #t #f)))))

  (define (make-evaluator-operations environment)
    (list
      (cons 'self-evaluating? self-evaluating?)
      (cons 'variable? variable?)
      (cons 'quoted? quoted?)
      (cons 'text-of-quotation text-of-quotation)
      (cons 'assignment? assignment?)
      (cons 'assignment-variable assignment-variable)
      (cons 'assignment-value assignment-value)
      (cons 'definition? definition?)
      (cons 'definition-variable definition-variable)
      (cons 'definition-value definition-value)
      (cons 'if? if?)
      (cons 'if-predicate if-predicate)
      (cons 'if-consequent if-consequent)
      (cons 'if-alternative if-alternative)
      (cons 'lambda? lambda?)
      (cons 'lambda-parameters lambda-parameters)
      (cons 'lambda-body lambda-body)
      (cons 'begin? begin?)
      (cons 'begin-actions begin-actions)
      (cons 'application? application?)
      (cons 'operator operator)
      (cons 'operands operands)
      (cons 'no-operands? no-operands?)
      (cons 'first-operand first-operand)
      (cons 'rest-operands rest-operands)
      (cons 'last-operand? last-operand?)
      (cons 'lookup-variable-value lookup-variable-value)
      (cons 'set-variable-value! set-variable-value!)
      (cons 'define-variable! define-variable!)
      (cons 'extend-environment extend-environment)
      (cons 'make-procedure make-procedure)
      (cons 'compound-procedure? compound-procedure?)
      (cons 'procedure-parameters procedure-parameters)
      (cons 'procedure-body procedure-body)
      (cons 'procedure-environment procedure-environment)
      (cons 'primitive-procedure? primitive-procedure?)
      (cons 'apply-primitive-procedure apply-primitive-procedure)
      (cons 'empty-arglist empty-arglist)
      (cons 'adjoin-arg adjoin-arg)
      (cons 'true? true?)
      (cons 'get-global-environment (lambda () environment))))

  (define evaluator-controller
    '((assign env (op get-global-environment))
      (assign continue (label evaluator-done))
      (goto (label eval-dispatch))

      eval-dispatch
      (test (op self-evaluating?) (reg exp))
      (branch (label ev-self-eval))
      (test (op variable?) (reg exp))
      (branch (label ev-variable))
      (test (op quoted?) (reg exp))
      (branch (label ev-quoted))
      (test (op assignment?) (reg exp))
      (branch (label ev-assignment))
      (test (op definition?) (reg exp))
      (branch (label ev-definition))
      (test (op if?) (reg exp))
      (branch (label ev-if))
      (test (op lambda?) (reg exp))
      (branch (label ev-lambda))
      (test (op begin?) (reg exp))
      (branch (label ev-begin))
      (test (op application?) (reg exp))
      (branch (label ev-application))

      ev-self-eval
      (assign val (reg exp))
      (goto (reg continue))
      ev-variable
      (assign val (op lookup-variable-value) (reg exp) (reg env))
      (goto (reg continue))
      ev-quoted
      (assign val (op text-of-quotation) (reg exp))
      (goto (reg continue))
      ev-lambda
      (assign unev (op lambda-parameters) (reg exp))
      (assign exp (op lambda-body) (reg exp))
      (assign val (op make-procedure) (reg unev) (reg exp) (reg env))
      (goto (reg continue))

      ev-application
      (save continue)
      (save env)
      (assign unev (op operands) (reg exp))
      (save unev)
      (assign exp (op operator) (reg exp))
      (assign continue (label ev-appl-did-operator))
      (goto (label eval-dispatch))
      ev-appl-did-operator
      (restore unev)
      (restore env)
      (assign argl (op empty-arglist))
      (assign proc (reg val))
      (test (op no-operands?) (reg unev))
      (branch (label apply-dispatch))
      (save proc)
      ev-appl-operand-loop
      (save argl)
      (assign exp (op first-operand) (reg unev))
      (test (op last-operand?) (reg unev))
      (branch (label ev-appl-last-arg))
      (save env)
      (save unev)
      (assign continue (label ev-appl-accumulate-arg))
      (goto (label eval-dispatch))
      ev-appl-accumulate-arg
      (restore unev)
      (restore env)
      (restore argl)
      (assign argl (op adjoin-arg) (reg val) (reg argl))
      (assign unev (op rest-operands) (reg unev))
      (goto (label ev-appl-operand-loop))
      ev-appl-last-arg
      (assign continue (label ev-appl-accum-last-arg))
      (goto (label eval-dispatch))
      ev-appl-accum-last-arg
      (restore argl)
      (assign argl (op adjoin-arg) (reg val) (reg argl))
      (restore proc)
      (goto (label apply-dispatch))

      apply-dispatch
      (test (op primitive-procedure?) (reg proc))
      (branch (label primitive-apply))
      (test (op compound-procedure?) (reg proc))
      (branch (label compound-apply))
      primitive-apply
      (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
      (restore continue)
      (goto (reg continue))
      compound-apply
      (assign unev (op procedure-parameters) (reg proc))
      (assign env (op procedure-environment) (reg proc))
      (assign env (op extend-environment) (reg unev) (reg argl) (reg env))
      (assign unev (op procedure-body) (reg proc))
      (goto (label ev-sequence))

      ev-begin
      (assign unev (op begin-actions) (reg exp))
      (save continue)
      ev-sequence
      (assign exp (op first-operand) (reg unev))
      (test (op last-operand?) (reg unev))
      (branch (label ev-sequence-last-exp))
      (save unev)
      (save env)
      (assign continue (label ev-sequence-continue))
      (goto (label eval-dispatch))
      ev-sequence-continue
      (restore env)
      (restore unev)
      (assign unev (op rest-operands) (reg unev))
      (goto (label ev-sequence))
      ev-sequence-last-exp
      (restore continue)
      (goto (label eval-dispatch))

      ev-if
      (save exp)
      (save env)
      (save continue)
      (assign continue (label ev-if-decide))
      (assign exp (op if-predicate) (reg exp))
      (goto (label eval-dispatch))
      ev-if-decide
      (restore continue)
      (restore env)
      (restore exp)
      (test (op true?) (reg val))
      (branch (label ev-if-consequent))
      (assign exp (op if-alternative) (reg exp))
      (goto (label eval-dispatch))
      ev-if-consequent
      (assign exp (op if-consequent) (reg exp))
      (goto (label eval-dispatch))

      ev-assignment
      (assign unev (op assignment-variable) (reg exp))
      (save unev)
      (assign exp (op assignment-value) (reg exp))
      (save env)
      (save continue)
      (assign continue (label ev-assignment-1))
      (goto (label eval-dispatch))
      ev-assignment-1
      (restore continue)
      (restore env)
      (restore unev)
      (perform (op set-variable-value!) (reg unev) (reg val) (reg env))
      (assign val (const ok))
      (goto (reg continue))

      ev-definition
      (assign unev (op definition-variable) (reg exp))
      (save unev)
      (assign exp (op definition-value) (reg exp))
      (save env)
      (save continue)
      (assign continue (label ev-definition-1))
      (goto (label eval-dispatch))
      ev-definition-1
      (restore continue)
      (restore env)
      (restore unev)
      (perform (op define-variable!) (reg unev) (reg val) (reg env))
      (assign val (const ok))
      (goto (reg continue))

      evaluator-done
      (halt)))

  (define (make-evaluator-machine)
    (let ((environment (make-global-environment)))
      (let ((machine
              (make-machine
                '(exp env val proc argl continue unev)
                (make-evaluator-operations environment)
                evaluator-controller)))
        (state-set! machine 'global-environment environment)
        machine)))

  (define (run-program program)
    (let ((machine (make-evaluator-machine)))
      (set-register-contents! machine 'exp program)
      (start! machine)
      machine))

  (define core-machine
    (run-program '(+ 10 (* 2 16))))

  (define tail-small-machine
    (run-program
      '(begin
         (define (sum-iter n total)
           (if (= n 0)
               total
               (sum-iter (- n 1) (+ total n))))
         (sum-iter 5 0))))
  (define tail-large-machine
    (run-program
      '(begin
         (define (sum-iter n total)
           (if (= n 0)
               total
               (sum-iter (- n 1) (+ total n))))
         (sum-iter 20 0))))

  (define state-machine
    (run-program
      '(begin
         (define total 4)
         (set! total (+ total 5))
         (if (> total 8) total 0))))

  (define complete-machine
    (run-program
      '(begin
         (define (factorial n)
           (if (= n 0) 1 (* n (factorial (- n 1)))))
         (define (make-counter start)
           (lambda ()
             (begin
               (set! start (+ start 1))
               start)))
         (define counter (make-counter 40))
         (list (factorial 5) (counter) (counter)))))

  (list
    (list 'core
          (get-register-contents core-machine 'val)
          (stack-empty? core-machine)
          (> (state-ref core-machine 'instruction-count) 0))
    (list 'tail
          (get-register-contents tail-small-machine 'val)
          (get-register-contents tail-large-machine 'val)
          (= (state-ref tail-small-machine 'max-depth)
             (state-ref tail-large-machine 'max-depth))
          (stack-empty? tail-small-machine)
          (stack-empty? tail-large-machine))
    (list 'state
          (get-register-contents state-machine 'val)
          (lookup-variable-value
            'total
            (state-ref state-machine 'global-environment))
          (stack-empty? state-machine))
    (list 'run
          (get-register-contents complete-machine 'val)
          (stack-empty? complete-machine)
          (> (state-ref complete-machine 'max-depth) 0))))

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

(define (make-register name) (cons name '*unassigned*))
  (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-state machine) (list-ref machine 6))

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

(define (push-stack! machine value)
    (let ((stack (machine-stack machine)))
      (set-cdr! stack (cons value (cdr stack)))
      (state-set! machine 'push-count
                  (+ (state-ref machine 'push-count) 1))
      (let ((depth (+ (state-ref machine 'current-depth) 1)))
        (state-set! machine 'current-depth depth)
        (if (> depth (state-ref machine 'max-depth))
            (state-set! machine 'max-depth depth)
            'ok))))
  (define (pop-stack! machine)
    (let ((stack (machine-stack machine)))
      (if (null? (cdr stack))
          (error "empty EC stack")
          (let ((value (cadr stack)))
            (set-cdr! stack (cddr stack))
            (state-set! machine 'current-depth
                        (- (state-ref machine 'current-depth) 1))
            value))))
  (define (stack-empty? machine)
    (null? (cdr (machine-stack machine))))

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

(define (make-machine register-names operations controller)
    (list 'machine
          (map make-register register-names)
          (cons 'stack '())
          operations
          (extract-instructions controller)
          (build-labels controller 0)
          (list (cons 'pc 0)
                (cons 'flag #f)
                (cons 'halted #f)
                (cons 'instruction-count 0)
                (cons 'push-count 0)
                (cons 'current-depth 0)
                (cons 'max-depth 0)
                (cons 'global-environment '()))))

(define (lookup-label machine name)
    (let ((entry (assoc name (machine-labels machine))))
      (if entry (cdr entry) (error "unknown EC label" name))))
  (define (lookup-operation machine name)
    (let ((entry (assoc name (machine-operations machine))))
      (if entry (cdr entry) (error "unknown EC operation" name))))
  (define (evaluate-expression expression machine)
    (cond ((tagged-list? expression 'const) (cadr expression))
          ((tagged-list? expression 'reg)
           (get-register-contents machine (cadr expression)))
          ((tagged-list? expression 'label)
           (lookup-label machine (cadr expression)))
          (else (error "unknown EC expression" expression))))
  (define (operation-expression? expressions)
    (and (pair? expressions) (tagged-list? (car expressions) 'op)))
  (define (evaluate-operation expressions machine)
    (apply (lookup-operation machine (cadr (car expressions)))
           (map (lambda (expression)
                  (evaluate-expression expression machine))
                (cdr expressions))))
  (define (advance-pc! machine)
    (state-set! machine 'pc (+ (state-ref machine 'pc) 1)))

(define (execute-instruction! instruction machine)
    (cond
      ((tagged-list? instruction 'assign)
       (let ((parts (cddr instruction)))
         (set-register-contents!
           machine
           (cadr instruction)
           (if (operation-expression? parts)
               (evaluate-operation parts machine)
               (evaluate-expression (car parts) machine)))
         (advance-pc! machine)))
      ((tagged-list? instruction 'test)
       (state-set! machine 'flag
                   (evaluate-operation (cdr instruction) machine))
       (advance-pc! machine))
      ((tagged-list? instruction 'branch)
       (if (state-ref machine 'flag)
           (state-set! machine 'pc
                       (evaluate-expression (cadr instruction) machine))
           (advance-pc! machine)))
      ((tagged-list? instruction 'goto)
       (state-set! machine 'pc
                   (evaluate-expression (cadr instruction) machine)))
      ((tagged-list? instruction 'save)
       (push-stack! machine
                    (get-register-contents machine (cadr instruction)))
       (advance-pc! machine))
      ((tagged-list? instruction 'restore)
       (set-register-contents! machine
                               (cadr instruction)
                               (pop-stack! machine))
       (advance-pc! machine))
      ((tagged-list? instruction 'perform)
       (evaluate-operation (cdr instruction) machine)
       (advance-pc! machine))
      ((tagged-list? instruction 'halt)
       (state-set! machine 'halted #t))
      (else (error "unknown EC instruction" instruction))))

(define (execute-machine! machine)
    (if (state-ref machine 'halted)
        'done
        (let ((pc (state-ref machine 'pc))
              (instructions (machine-instructions machine)))
          (if (= pc (length instructions))
              (state-set! machine 'halted #t)
              (begin
                (state-set! machine 'instruction-count
                            (+ (state-ref machine 'instruction-count) 1))
                (execute-instruction! (list-ref instructions pc) machine)
                (execute-machine! machine))))))
  (define (start! machine)
    (set-cdr! (machine-stack machine) '())
    (state-set! machine 'pc 0)
    (state-set! machine 'flag #f)
    (state-set! machine 'halted #f)
    (state-set! machine 'instruction-count 0)
    (state-set! machine 'push-count 0)
    (state-set! machine 'current-depth 0)
    (state-set! machine 'max-depth 0)
    (execute-machine! machine))

(define (self-evaluating? expression)
    (or (number? expression) (string? expression) (boolean? expression)))
  (define (variable? expression) (symbol? expression))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (text-of-quotation expression) (cadr expression))
  (define (assignment? expression) (tagged-list? expression 'set!))
  (define (assignment-variable expression) (cadr expression))
  (define (assignment-value expression) (caddr expression))
  (define (definition? expression) (tagged-list? expression 'define))
  (define (definition-variable expression)
    (if (symbol? (cadr expression))
        (cadr expression)
        (caadr expression)))
  (define (definition-value expression)
    (if (symbol? (cadr expression))
        (caddr expression)
        (cons 'lambda
              (cons (cdar (cdr expression))
                    (cddr expression)))))
  (define (if? expression) (tagged-list? expression 'if))
  (define (if-predicate expression) (cadr expression))
  (define (if-consequent expression) (caddr expression))
  (define (if-alternative expression)
    (if (null? (cdddr expression)) #f (cadddr expression)))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (lambda-parameters expression) (cadr expression))
  (define (lambda-body expression) (cddr expression))
  (define (begin? expression) (tagged-list? expression 'begin))
  (define (begin-actions expression) (cdr expression))
  (define (application? expression) (pair? expression))
  (define (operator expression) (car expression))
  (define (operands expression) (cdr expression))
  (define (no-operands? operands) (null? operands))
  (define (first-operand operands) (car operands))
  (define (rest-operands operands) (cdr operands))
  (define (last-operand? operands) (null? (cdr operands)))

(define (make-frame variables values)
    (cons 'frame (map cons variables values)))
  (define (frame-bindings frame) (cdr frame))
  (define (first-frame environment) (car environment))
  (define (enclosing-environment environment) (cdr environment))
  (define (find-binding variable bindings)
    (cond ((null? bindings) #f)
          ((eq? variable (caar bindings)) (car bindings))
          (else (find-binding variable (cdr bindings)))))
  (define (lookup-variable-value variable environment)
    (if (null? environment)
        (error "unbound EC variable" variable)
        (let ((binding
                (find-binding
                  variable
                  (frame-bindings (first-frame environment)))))
          (if binding
              (cdr binding)
              (lookup-variable-value
                variable
                (enclosing-environment environment))))))
  (define (set-variable-value! variable value environment)
    (if (null? environment)
        (error "unbound EC assignment" variable)
        (let ((binding
                (find-binding
                  variable
                  (frame-bindings (first-frame environment)))))
          (if binding
              (set-cdr! binding value)
              (set-variable-value!
                variable
                value
                (enclosing-environment environment))))))
  (define (define-variable! variable value environment)
    (let ((frame (first-frame environment)))
      (let ((binding (find-binding variable (frame-bindings frame))))
        (if binding
            (set-cdr! binding value)
            (set-cdr! frame
                      (cons (cons variable value)
                            (frame-bindings frame)))))))
  (define (extend-environment variables values base-environment)
    (if (= (length variables) (length values))
        (cons (make-frame variables values) base-environment)
        (error "EC argument count mismatch" variables values)))

(define (make-procedure parameters body environment)
    (list 'procedure parameters body environment))
  (define (compound-procedure? procedure)
    (tagged-list? procedure 'procedure))
  (define (procedure-parameters procedure) (cadr procedure))
  (define (procedure-body procedure) (caddr procedure))
  (define (procedure-environment procedure) (cadddr procedure))
  (define (make-primitive implementation)
    (list 'primitive implementation))
  (define (primitive-procedure? procedure)
    (tagged-list? procedure 'primitive))
  (define (primitive-implementation procedure) (cadr procedure))
  (define (apply-primitive-procedure procedure arguments)
    (apply (primitive-implementation procedure) arguments))
  (define (empty-arglist) '())
  (define (adjoin-arg argument argument-list)
    (append argument-list (list argument)))
  (define (true? value) value)

(define primitive-bindings
    (list (cons '+ +) (cons '- -) (cons '* *) (cons '/ /)
          (cons '= =) (cons '< <) (cons '> >)
          (cons '<= <=) (cons '>= >=)
          (cons 'list list) (cons 'cons cons)
          (cons 'car car) (cons 'cdr cdr)
          (cons 'null? null?) (cons 'pair? pair?)
          (cons 'not not)))
  (define (make-global-environment)
    (list
      (make-frame
        (append (map car primitive-bindings) '(true false))
        (append
          (map (lambda (binding)
                 (make-primitive (cdr binding)))
               primitive-bindings)
          (list #t #f)))))

(define (make-evaluator-operations environment)
    (list
      (cons 'self-evaluating? self-evaluating?)
      (cons 'variable? variable?)
      (cons 'quoted? quoted?)
      (cons 'text-of-quotation text-of-quotation)
      (cons 'assignment? assignment?)
      (cons 'assignment-variable assignment-variable)
      (cons 'assignment-value assignment-value)
      (cons 'definition? definition?)
      (cons 'definition-variable definition-variable)
      (cons 'definition-value definition-value)
      (cons 'if? if?)
      (cons 'if-predicate if-predicate)
      (cons 'if-consequent if-consequent)
      (cons 'if-alternative if-alternative)
      (cons 'lambda? lambda?)
      (cons 'lambda-parameters lambda-parameters)
      (cons 'lambda-body lambda-body)
      (cons 'begin? begin?)
      (cons 'begin-actions begin-actions)
      (cons 'application? application?)
      (cons 'operator operator)
      (cons 'operands operands)
      (cons 'no-operands? no-operands?)
      (cons 'first-operand first-operand)
      (cons 'rest-operands rest-operands)
      (cons 'last-operand? last-operand?)
      (cons 'lookup-variable-value lookup-variable-value)
      (cons 'set-variable-value! set-variable-value!)
      (cons 'define-variable! define-variable!)
      (cons 'extend-environment extend-environment)
      (cons 'make-procedure make-procedure)
      (cons 'compound-procedure? compound-procedure?)
      (cons 'procedure-parameters procedure-parameters)
      (cons 'procedure-body procedure-body)
      (cons 'procedure-environment procedure-environment)
      (cons 'primitive-procedure? primitive-procedure?)
      (cons 'apply-primitive-procedure apply-primitive-procedure)
      (cons 'empty-arglist empty-arglist)
      (cons 'adjoin-arg adjoin-arg)
      (cons 'true? true?)
      (cons 'get-global-environment (lambda () environment))))

(define evaluator-controller
    '((assign env (op get-global-environment))
      (assign continue (label evaluator-done))
      (goto (label eval-dispatch))

eval-dispatch
      (test (op self-evaluating?) (reg exp))
      (branch (label ev-self-eval))
      (test (op variable?) (reg exp))
      (branch (label ev-variable))
      (test (op quoted?) (reg exp))
      (branch (label ev-quoted))
      (test (op assignment?) (reg exp))
      (branch (label ev-assignment))
      (test (op definition?) (reg exp))
      (branch (label ev-definition))
      (test (op if?) (reg exp))
      (branch (label ev-if))
      (test (op lambda?) (reg exp))
      (branch (label ev-lambda))
      (test (op begin?) (reg exp))
      (branch (label ev-begin))
      (test (op application?) (reg exp))
      (branch (label ev-application))

ev-self-eval
      (assign val (reg exp))
      (goto (reg continue))
      ev-variable
      (assign val (op lookup-variable-value) (reg exp) (reg env))
      (goto (reg continue))
      ev-quoted
      (assign val (op text-of-quotation) (reg exp))
      (goto (reg continue))
      ev-lambda
      (assign unev (op lambda-parameters) (reg exp))
      (assign exp (op lambda-body) (reg exp))
      (assign val (op make-procedure) (reg unev) (reg exp) (reg env))
      (goto (reg continue))

ev-application
      (save continue)
      (save env)
      (assign unev (op operands) (reg exp))
      (save unev)
      (assign exp (op operator) (reg exp))
      (assign continue (label ev-appl-did-operator))
      (goto (label eval-dispatch))
      ev-appl-did-operator
      (restore unev)
      (restore env)
      (assign argl (op empty-arglist))
      (assign proc (reg val))
      (test (op no-operands?) (reg unev))
      (branch (label apply-dispatch))
      (save proc)
      ev-appl-operand-loop
      (save argl)
      (assign exp (op first-operand) (reg unev))
      (test (op last-operand?) (reg unev))
      (branch (label ev-appl-last-arg))
      (save env)
      (save unev)
      (assign continue (label ev-appl-accumulate-arg))
      (goto (label eval-dispatch))
      ev-appl-accumulate-arg
      (restore unev)
      (restore env)
      (restore argl)
      (assign argl (op adjoin-arg) (reg val) (reg argl))
      (assign unev (op rest-operands) (reg unev))
      (goto (label ev-appl-operand-loop))
      ev-appl-last-arg
      (assign continue (label ev-appl-accum-last-arg))
      (goto (label eval-dispatch))
      ev-appl-accum-last-arg
      (restore argl)
      (assign argl (op adjoin-arg) (reg val) (reg argl))
      (restore proc)
      (goto (label apply-dispatch))

apply-dispatch
      (test (op primitive-procedure?) (reg proc))
      (branch (label primitive-apply))
      (test (op compound-procedure?) (reg proc))
      (branch (label compound-apply))
      primitive-apply
      (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
      (restore continue)
      (goto (reg continue))
      compound-apply
      (assign unev (op procedure-parameters) (reg proc))
      (assign env (op procedure-environment) (reg proc))
      (assign env (op extend-environment) (reg unev) (reg argl) (reg env))
      (assign unev (op procedure-body) (reg proc))
      (goto (label ev-sequence))

ev-begin
      (assign unev (op begin-actions) (reg exp))
      (save continue)
      ev-sequence
      (assign exp (op first-operand) (reg unev))
      (test (op last-operand?) (reg unev))
      (branch (label ev-sequence-last-exp))
      (save unev)
      (save env)
      (assign continue (label ev-sequence-continue))
      (goto (label eval-dispatch))
      ev-sequence-continue
      (restore env)
      (restore unev)
      (assign unev (op rest-operands) (reg unev))
      (goto (label ev-sequence))
      ev-sequence-last-exp
      (restore continue)
      (goto (label eval-dispatch))

ev-if
      (save exp)
      (save env)
      (save continue)
      (assign continue (label ev-if-decide))
      (assign exp (op if-predicate) (reg exp))
      (goto (label eval-dispatch))
      ev-if-decide
      (restore continue)
      (restore env)
      (restore exp)
      (test (op true?) (reg val))
      (branch (label ev-if-consequent))
      (assign exp (op if-alternative) (reg exp))
      (goto (label eval-dispatch))
      ev-if-consequent
      (assign exp (op if-consequent) (reg exp))
      (goto (label eval-dispatch))

ev-assignment
      (assign unev (op assignment-variable) (reg exp))
      (save unev)
      (assign exp (op assignment-value) (reg exp))
      (save env)
      (save continue)
      (assign continue (label ev-assignment-1))
      (goto (label eval-dispatch))
      ev-assignment-1
      (restore continue)
      (restore env)
      (restore unev)
      (perform (op set-variable-value!) (reg unev) (reg val) (reg env))
      (assign val (const ok))
      (goto (reg continue))

ev-definition
      (assign unev (op definition-variable) (reg exp))
      (save unev)
      (assign exp (op definition-value) (reg exp))
      (save env)
      (save continue)
      (assign continue (label ev-definition-1))
      (goto (label eval-dispatch))
      ev-definition-1
      (restore continue)
      (restore env)
      (restore unev)
      (perform (op define-variable!) (reg unev) (reg val) (reg env))
      (assign val (const ok))
      (goto (reg continue))

evaluator-done
      (halt)))

(define (make-evaluator-machine)
    (let ((environment (make-global-environment)))
      (let ((machine
              (make-machine
                '(exp env val proc argl continue unev)
                (make-evaluator-operations environment)
                evaluator-controller)))
        (state-set! machine 'global-environment environment)
        machine)))

(define (run-program program)
    (let ((machine (make-evaluator-machine)))
      (set-register-contents! machine 'exp program)
      (start! machine)
      machine))

(define core-machine
    (run-program '(+ 10 (* 2 16))))

(define tail-small-machine
    (run-program
      '(begin
         (define (sum-iter n total)
           (if (= n 0)
               total
               (sum-iter (- n 1) (+ total n))))
         (sum-iter 5 0))))
  (define tail-large-machine
    (run-program
      '(begin
         (define (sum-iter n total)
           (if (= n 0)
               total
               (sum-iter (- n 1) (+ total n))))
         (sum-iter 20 0))))

(define state-machine
    (run-program
      '(begin
         (define total 4)
         (set! total (+ total 5))
         (if (> total 8) total 0))))

(define complete-machine
    (run-program
      '(begin
         (define (factorial n)
           (if (= n 0) 1 (* n (factorial (- n 1)))))
         (define (make-counter start)
           (lambda ()
             (begin
               (set! start (+ start 1))
               start)))
         (define counter (make-counter 40))
         (list (factorial 5) (counter) (counter)))))

(list
    (list 'core
          (get-register-contents core-machine 'val)
          (stack-empty? core-machine)
          (> (state-ref core-machine 'instruction-count) 0))
    (list 'tail
          (get-register-contents tail-small-machine 'val)
          (get-register-contents tail-large-machine 'val)
          (= (state-ref tail-small-machine 'max-depth)
             (state-ref tail-large-machine 'max-depth))
          (stack-empty? tail-small-machine)
          (stack-empty? tail-large-machine))
    (list 'state
          (get-register-contents state-machine 'val)
          (lookup-variable-value
            'total
            (state-ref state-machine 'global-environment))
          (stack-empty? state-machine))
    (list 'run
          (get-register-contents complete-machine 'val)
          (stack-empty? complete-machine)
          (> (state-ref complete-machine 'max-depth) 0))))

Примеры

Результат—

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

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

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

Программа возвращает ((core 42 #t #t) (tail 15 210 #t #t #t) (state 9 9 #t) (run (120 41 42) #t #t)). Равенство в блоке tail фиксирует измеренную максимальную глубину стека вычислителя для n = 5 и n = 20 в этом контроллере.

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

Следуйте из eval-dispatch к меткам для конкретного синтаксиса, затем найдите save и restore вокруг вычисления оператора и операндов. В запусках с хвостовой рекурсией проследите, как ev-sequence-last-exp восстанавливает continue перед началом рекурсивного применения. В запуске с состоянием проследите вычисление значений определения и присваивания до изменения глобального связывания. В финальном запуске отличите стек рекурсивного factorial от измененного захваченного связывания замыкания счетчика и убедитесь, что машина останавливается по halt без оставшихся сохраненных значений вычислителя.

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

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

Добавьте хвостовую рекурсивную процедуру product-iter и запустите ее с двумя разными размерами входных данных. Сравните максимальную глубину стека, итоговые значения и состояние пустого стека с предоставленными наблюдениями для sum-iter.

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

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

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

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