5.5.7 · Связь скомпилированного кода и вычислителя

Единая граница apply для двух представлений

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

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

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

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

Общее глобальное окружение хранит обернутые примитивы, одну интерпретируемую процедуру с именем double и одну скомпилированную процедуру с именем add-three. Процедура evaluate создает интерпретируемые замыкания, чьи тела остаются данными выражений. Процедура compile-expression создает код для стековой машины и инструкции замыканий, чьи тела являются списками инструкций. Два представления остаются заметно различными, но оба содержат параметры и лексическое окружение, а также принимают одинаковый упорядоченный список аргументов.

Интерфейсом служит процедура apply-any. Применение в вычислителе достигает этой границы после вычисления оператора и операндов. Скомпилированная инструкция call достигает той же границы после извлечения процедуры и аргументов из стека VM. Запуск от вычислителя к скомпилированному коду записывает (compiled primitive), так как add-three входит в скомпилированный код, чье сложение вызывает примитив. Запуск от скомпилированного кода к вычислителю записывает (interpreted primitive), так как скомпилированный код вызывает double, чье интерпретируемое тело умножает через примитив. Модель урока фиксирует точный контракт взаимных вызовов для обоих направлений.

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

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

  (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 shared variable" variable)
        (let ((binding
                (find-binding
                  variable
                  (frame-bindings (first-frame environment)))))
          (if binding
              (cdr binding)
              (lookup-variable-value
                variable
                (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 "shared argument count mismatch" variables values)))

  (define (make-primitive implementation)
    (list 'primitive implementation))
  (define (primitive-procedure? procedure)
    (tagged-list? procedure 'primitive))
  (define (primitive-implementation procedure) (cadr procedure))

  (define (make-interpreted-procedure parameters body environment)
    (list 'interpreted parameters body environment))
  (define (interpreted-procedure? procedure)
    (tagged-list? procedure 'interpreted))
  (define (interpreted-parameters procedure) (cadr procedure))
  (define (interpreted-body procedure) (caddr procedure))
  (define (interpreted-environment procedure) (cadddr procedure))

  (define (make-compiled-procedure parameters code environment)
    (list 'compiled parameters code environment))
  (define (compiled-procedure? procedure)
    (tagged-list? procedure 'compiled))
  (define (compiled-parameters procedure) (cadr procedure))
  (define (compiled-code procedure) (caddr procedure))
  (define (compiled-environment procedure) (cadddr procedure))

  (define (self-evaluating? expression)
    (or (number? expression) (string? expression) (boolean? expression)))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (if? expression) (tagged-list? expression 'if))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (begin? expression) (tagged-list? expression 'begin))
  (define (application? expression) (pair? expression))

  (define (eval-sequence expressions environment)
    (cond ((null? expressions)
           (error "empty interpreted sequence"))
          ((null? (cdr expressions))
           (evaluate (car expressions) environment))
          (else
           (evaluate (car expressions) environment)
           (eval-sequence (cdr expressions) environment))))
  (define (list-of-values expressions environment)
    (if (null? expressions)
        '()
        (cons (evaluate (car expressions) environment)
              (list-of-values (cdr expressions) environment))))
  (define (evaluate expression environment)
    (cond ((self-evaluating? expression) expression)
          ((symbol? expression)
           (lookup-variable-value expression environment))
          ((quoted? expression) (cadr expression))
          ((if? expression)
           (if (evaluate (cadr expression) environment)
               (evaluate (caddr expression) environment)
               (evaluate (cadddr expression) environment)))
          ((lambda? expression)
           (make-interpreted-procedure
             (cadr expression)
             (cddr expression)
             environment))
          ((begin? expression)
           (eval-sequence (cdr expression) environment))
          ((application? expression)
           (apply-any
             (evaluate (car expression) environment)
             (list-of-values (cdr expression) environment)))
          (else (error "unknown interpreted expression" expression))))

  (define (compile-expression expression)
    (cond ((self-evaluating? expression)
           (list (list 'constant expression)))
          ((symbol? expression)
           (list (list 'lookup expression)))
          ((quoted? expression)
           (list (list 'constant (cadr expression))))
          ((if? expression)
           (append
             (compile-expression (cadr expression))
             (list
               (list 'branch
                     (compile-expression (caddr expression))
                     (compile-expression (cadddr expression))))))
          ((lambda? expression)
           (list
             (list 'closure
                   (cadr expression)
                   (compile-sequence (cddr expression)))))
          ((begin? expression)
           (compile-sequence (cdr expression)))
          ((application? expression)
           (append
             (compile-expression (car expression))
             (compile-operands (cdr expression))
             (list (list 'call (length (cdr expression))))))
          (else (error "unknown compiled expression" expression))))
  (define (compile-operands expressions)
    (if (null? expressions)
        '()
        (append (compile-expression (car expressions))
                (compile-operands (cdr expressions)))))
  (define (compile-sequence expressions)
    (cond ((null? expressions)
           (error "empty compiled sequence"))
          ((null? (cdr expressions))
           (compile-expression (car expressions)))
          (else
           (append (compile-expression (car expressions))
                   (list (list 'pop))
                   (compile-sequence (cdr expressions))))))

  (define (make-stack) (cons 'stack '()))
  (define (push-stack! stack value)
    (set-cdr! stack (cons value (cdr stack))))
  (define (pop-stack! stack)
    (if (null? (cdr stack))
        (error "empty shared stack")
        (let ((value (cadr stack)))
          (set-cdr! stack (cddr stack))
          value)))
  (define (top-stack stack)
    (if (null? (cdr stack))
        (error "missing shared result")
        (cadr stack)))
  (define (stack-empty? stack) (null? (cdr stack)))
  (define (pop-arguments! count stack)
    (if (= count 0)
        '()
        (let ((argument (pop-stack! stack)))
          (append (pop-arguments! (- count 1) stack)
                  (list argument)))))

  (define (execute-code code environment stack)
    (if (null? code)
        (top-stack stack)
        (let ((instruction (car code))
              (remaining (cdr code)))
          (cond
            ((tagged-list? instruction 'constant)
             (push-stack! stack (cadr instruction))
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'lookup)
             (push-stack!
               stack
               (lookup-variable-value (cadr instruction) environment))
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'closure)
             (push-stack!
               stack
               (make-compiled-procedure
                 (cadr instruction)
                 (caddr instruction)
                 environment))
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'pop)
             (pop-stack! stack)
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'branch)
             (let ((predicate (pop-stack! stack)))
               (execute-code
                 (if predicate (cadr instruction) (caddr instruction))
                 environment
                 stack)
               (execute-code remaining environment stack)))
            ((tagged-list? instruction 'call)
             (let ((arguments
                     (pop-arguments! (cadr instruction) stack)))
               (let ((procedure (pop-stack! stack)))
                 (push-stack! stack (apply-any procedure arguments))
                 (execute-code remaining environment stack))))
            (else (error "unknown shared instruction" instruction))))))

  (define dispatch-log '())
  (define (procedure-kind procedure)
    (cond ((primitive-procedure? procedure) 'primitive)
          ((interpreted-procedure? procedure) 'interpreted)
          ((compiled-procedure? procedure) 'compiled)
          (else (error "unknown shared procedure" procedure))))
  (define (record-dispatch! procedure)
    (set! dispatch-log
          (cons (procedure-kind procedure) dispatch-log)))
  (define (apply-any procedure arguments)
    (record-dispatch! procedure)
    (cond
      ((primitive-procedure? procedure)
       (apply (primitive-implementation procedure) arguments))
      ((interpreted-procedure? procedure)
       (eval-sequence
         (interpreted-body procedure)
         (extend-environment
           (interpreted-parameters procedure)
           arguments
           (interpreted-environment procedure))))
      ((compiled-procedure? procedure)
       (let ((stack (make-stack)))
         (let ((value
                 (execute-code
                   (compiled-code procedure)
                   (extend-environment
                     (compiled-parameters procedure)
                     arguments
                     (compiled-environment procedure))
                   stack)))
           (pop-stack! stack)
           value)))
      (else (error "cannot apply shared procedure" procedure))))

  (define primitive-bindings
    (list (cons '+ +) (cons '- -) (cons '* *)
          (cons '= =) (cons '< <) (cons 'list list)))
  (define global-environment
    (list
      (make-frame
        (map car primitive-bindings)
        (map (lambda (binding)
               (make-primitive (cdr binding)))
             primitive-bindings))))

  (define double
    (make-interpreted-procedure
      '(x)
      '((* x 2))
      global-environment))
  (define-variable! 'double double global-environment)

  (define closure-stack (make-stack))
  (define add-three
    (execute-code
      (compile-expression '(lambda (x) (+ x 3)))
      global-environment
      closure-stack))
  (pop-stack! closure-stack)
  (define-variable! 'add-three add-three global-environment)

  (set! dispatch-log '())
  (define evaluator-value
    (evaluate '(add-three 5) global-environment))
  (define evaluator-dispatches (reverse dispatch-log))

  (set! dispatch-log '())
  (define compiled-call-stack (make-stack))
  (define compiled-value
    (execute-code
      (compile-expression '(double 7))
      global-environment
      compiled-call-stack))
  (pop-stack! compiled-call-stack)
  (define compiled-dispatches (reverse dispatch-log))

  (list
    (list 'evaluator-to-compiled
          evaluator-value
          evaluator-dispatches)
    (list 'compiled-to-evaluator
          compiled-value
          compiled-dispatches
          (stack-empty? compiled-call-stack))
    (list 'representations
          (compiled-procedure? add-three)
          (interpreted-procedure? double))))

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

(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 shared variable" variable)
        (let ((binding
                (find-binding
                  variable
                  (frame-bindings (first-frame environment)))))
          (if binding
              (cdr binding)
              (lookup-variable-value
                variable
                (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 "shared argument count mismatch" variables values)))

(define (make-primitive implementation)
    (list 'primitive implementation))
  (define (primitive-procedure? procedure)
    (tagged-list? procedure 'primitive))
  (define (primitive-implementation procedure) (cadr procedure))

(define (make-interpreted-procedure parameters body environment)
    (list 'interpreted parameters body environment))
  (define (interpreted-procedure? procedure)
    (tagged-list? procedure 'interpreted))
  (define (interpreted-parameters procedure) (cadr procedure))
  (define (interpreted-body procedure) (caddr procedure))
  (define (interpreted-environment procedure) (cadddr procedure))

(define (make-compiled-procedure parameters code environment)
    (list 'compiled parameters code environment))
  (define (compiled-procedure? procedure)
    (tagged-list? procedure 'compiled))
  (define (compiled-parameters procedure) (cadr procedure))
  (define (compiled-code procedure) (caddr procedure))
  (define (compiled-environment procedure) (cadddr procedure))

(define (self-evaluating? expression)
    (or (number? expression) (string? expression) (boolean? expression)))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (if? expression) (tagged-list? expression 'if))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (begin? expression) (tagged-list? expression 'begin))
  (define (application? expression) (pair? expression))

(define (eval-sequence expressions environment)
    (cond ((null? expressions)
           (error "empty interpreted sequence"))
          ((null? (cdr expressions))
           (evaluate (car expressions) environment))
          (else
           (evaluate (car expressions) environment)
           (eval-sequence (cdr expressions) environment))))
  (define (list-of-values expressions environment)
    (if (null? expressions)
        '()
        (cons (evaluate (car expressions) environment)
              (list-of-values (cdr expressions) environment))))
  (define (evaluate expression environment)
    (cond ((self-evaluating? expression) expression)
          ((symbol? expression)
           (lookup-variable-value expression environment))
          ((quoted? expression) (cadr expression))
          ((if? expression)
           (if (evaluate (cadr expression) environment)
               (evaluate (caddr expression) environment)
               (evaluate (cadddr expression) environment)))
          ((lambda? expression)
           (make-interpreted-procedure
             (cadr expression)
             (cddr expression)
             environment))
          ((begin? expression)
           (eval-sequence (cdr expression) environment))
          ((application? expression)
           (apply-any
             (evaluate (car expression) environment)
             (list-of-values (cdr expression) environment)))
          (else (error "unknown interpreted expression" expression))))

(define (compile-expression expression)
    (cond ((self-evaluating? expression)
           (list (list 'constant expression)))
          ((symbol? expression)
           (list (list 'lookup expression)))
          ((quoted? expression)
           (list (list 'constant (cadr expression))))
          ((if? expression)
           (append
             (compile-expression (cadr expression))
             (list
               (list 'branch
                     (compile-expression (caddr expression))
                     (compile-expression (cadddr expression))))))
          ((lambda? expression)
           (list
             (list 'closure
                   (cadr expression)
                   (compile-sequence (cddr expression)))))
          ((begin? expression)
           (compile-sequence (cdr expression)))
          ((application? expression)
           (append
             (compile-expression (car expression))
             (compile-operands (cdr expression))
             (list (list 'call (length (cdr expression))))))
          (else (error "unknown compiled expression" expression))))
  (define (compile-operands expressions)
    (if (null? expressions)
        '()
        (append (compile-expression (car expressions))
                (compile-operands (cdr expressions)))))
  (define (compile-sequence expressions)
    (cond ((null? expressions)
           (error "empty compiled sequence"))
          ((null? (cdr expressions))
           (compile-expression (car expressions)))
          (else
           (append (compile-expression (car expressions))
                   (list (list 'pop))
                   (compile-sequence (cdr expressions))))))

(define (make-stack) (cons 'stack '()))
  (define (push-stack! stack value)
    (set-cdr! stack (cons value (cdr stack))))
  (define (pop-stack! stack)
    (if (null? (cdr stack))
        (error "empty shared stack")
        (let ((value (cadr stack)))
          (set-cdr! stack (cddr stack))
          value)))
  (define (top-stack stack)
    (if (null? (cdr stack))
        (error "missing shared result")
        (cadr stack)))
  (define (stack-empty? stack) (null? (cdr stack)))
  (define (pop-arguments! count stack)
    (if (= count 0)
        '()
        (let ((argument (pop-stack! stack)))
          (append (pop-arguments! (- count 1) stack)
                  (list argument)))))

(define (execute-code code environment stack)
    (if (null? code)
        (top-stack stack)
        (let ((instruction (car code))
              (remaining (cdr code)))
          (cond
            ((tagged-list? instruction 'constant)
             (push-stack! stack (cadr instruction))
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'lookup)
             (push-stack!
               stack
               (lookup-variable-value (cadr instruction) environment))
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'closure)
             (push-stack!
               stack
               (make-compiled-procedure
                 (cadr instruction)
                 (caddr instruction)
                 environment))
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'pop)
             (pop-stack! stack)
             (execute-code remaining environment stack))
            ((tagged-list? instruction 'branch)
             (let ((predicate (pop-stack! stack)))
               (execute-code
                 (if predicate (cadr instruction) (caddr instruction))
                 environment
                 stack)
               (execute-code remaining environment stack)))
            ((tagged-list? instruction 'call)
             (let ((arguments
                     (pop-arguments! (cadr instruction) stack)))
               (let ((procedure (pop-stack! stack)))
                 (push-stack! stack (apply-any procedure arguments))
                 (execute-code remaining environment stack))))
            (else (error "unknown shared instruction" instruction))))))

(define dispatch-log '())
  (define (procedure-kind procedure)
    (cond ((primitive-procedure? procedure) 'primitive)
          ((interpreted-procedure? procedure) 'interpreted)
          ((compiled-procedure? procedure) 'compiled)
          (else (error "unknown shared procedure" procedure))))
  (define (record-dispatch! procedure)
    (set! dispatch-log
          (cons (procedure-kind procedure) dispatch-log)))
  (define (apply-any procedure arguments)
    (record-dispatch! procedure)
    (cond
      ((primitive-procedure? procedure)
       (apply (primitive-implementation procedure) arguments))
      ((interpreted-procedure? procedure)
       (eval-sequence
         (interpreted-body procedure)
         (extend-environment
           (interpreted-parameters procedure)
           arguments
           (interpreted-environment procedure))))
      ((compiled-procedure? procedure)
       (let ((stack (make-stack)))
         (let ((value
                 (execute-code
                   (compiled-code procedure)
                   (extend-environment
                     (compiled-parameters procedure)
                     arguments
                     (compiled-environment procedure))
                   stack)))
           (pop-stack! stack)
           value)))
      (else (error "cannot apply shared procedure" procedure))))

(define primitive-bindings
    (list (cons '+ +) (cons '- -) (cons '* *)
          (cons '= =) (cons '< <) (cons 'list list)))
  (define global-environment
    (list
      (make-frame
        (map car primitive-bindings)
        (map (lambda (binding)
               (make-primitive (cdr binding)))
             primitive-bindings))))

(define double
    (make-interpreted-procedure
      '(x)
      '((* x 2))
      global-environment))
  (define-variable! 'double double global-environment)

(define closure-stack (make-stack))
  (define add-three
    (execute-code
      (compile-expression '(lambda (x) (+ x 3)))
      global-environment
      closure-stack))
  (pop-stack! closure-stack)
  (define-variable! 'add-three add-three global-environment)

(set! dispatch-log '())
  (define evaluator-value
    (evaluate '(add-three 5) global-environment))
  (define evaluator-dispatches (reverse dispatch-log))

(set! dispatch-log '())
  (define compiled-call-stack (make-stack))
  (define compiled-value
    (execute-code
      (compile-expression '(double 7))
      global-environment
      compiled-call-stack))
  (pop-stack! compiled-call-stack)
  (define compiled-dispatches (reverse dispatch-log))

(list
    (list 'evaluator-to-compiled
          evaluator-value
          evaluator-dispatches)
    (list 'compiled-to-evaluator
          compiled-value
          compiled-dispatches
          (stack-empty? compiled-call-stack))
    (list 'representations
          (compiled-procedure? add-three)
          (interpreted-procedure? double))))

Примеры

Результат—

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

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

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

Программа возвращает ((evaluator-to-compiled 8 (compiled primitive)) (compiled-to-evaluator 14 (interpreted primitive) #t) (representations #t #t)). Списки диспетчеризации фиксируют фактические представления процедур, в которые входит каждый выбранный запуск.

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

Сначала проследите поиск add-three в вычислителе с переходом в ветку apply-any для скомпилированного кода, а затем поиск замыкания в VM и вызов примитива. Затем проследите скомпилированную инструкцию call для double с переходом в интерпретируемую ветку, расширение окружения, вычисление тела выражения и умножение через примитив. Убедитесь, что оба пути используют общее глобальное окружение и соглашение об упорядоченных аргументах, сохраняя при этом раздельные теги интерпретируемых и скомпилированных процедур.

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

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

Добавьте интерпретируемую процедуру, вызывающую add-three, и скомпилируйте процедуру, вызывающую double. Вызовите обе обертки и предскажите вложенные журналы диспетчеризации перед их запуском.

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

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

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

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