5.5.3 · Компиляция комбинаций

Порядок компиляции комбинации и граница apply

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

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

Какие контракты порядка и представления должен сохранять скомпилированный код применения?

Компиляция оператора перед выражениями его операндов
Компиляция операндов слева направо с сохранением порядка аргументов
Генерация одной инструкции call после того, как готово полное состояние комбинации
Наблюдение эффектов порядка исходного кода без опоры на неопределенное расписание
Использование общего лексического окружения и соглашения об аргументах между представлениями процедур
Сохранение явного различия между диспетчеризацией примитивных, интерпретируемых и скомпилированных процедур

Учебный компилятор генерирует load для оператора вычитания, затем весь код для вызова левой процедуры record, затем весь код для вызова правой процедуры record и в конце одну внешнюю инструкцию call. Процедура с состоянием record добавляет метки в observations, поэтому возвращаемый список (left right) подтверждает, что выполнение следует сгенерированному порядку исходного кода. Результат вычитания также подтверждает порядок аргументов.

Вторая программа расширяет границы вызовов. Код вычислителя вызывает скомпилированное замыкание add-three, а скомпилированный код вызывает интерпретируемую процедуру double. Оба пути передают упорядоченный список аргументов через apply-any, а dispatch-log сохраняет фактические теги primitive, interpreted и compiled. Это фиксирует соглашение о вызовах, используемое в уроке.

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

(begin
  (define (tagged-list? expression tag)
    (and (pair? expression) (eq? (car expression) tag)))
  (define (self-evaluating? expression)
    (or (number? expression)
        (string? expression)
        (boolean? expression)))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (assignment? expression) (tagged-list? expression 'set!))
  (define (definition? expression) (tagged-list? expression 'define))
  (define (if? expression) (tagged-list? expression 'if))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (begin? expression) (tagged-list? expression 'begin))

  (define (definition-variable expression)
    (if (symbol? (cadr expression))
        (cadr expression)
        (car (cadr expression))))
  (define (definition-value expression)
    (if (symbol? (cadr expression))
        (caddr expression)
        (cons 'lambda
              (cons (cdr (cadr expression))
                    (cddr expression)))))

  (define (compile-sequence expressions)
    (cond ((null? expressions)
           '((literal ok)))
          ((null? (cdr expressions))
           (compile-expression (car expressions)))
          (else
           (append
             (compile-expression (car expressions))
             (cons '(discard)
                   (compile-sequence (cdr expressions)))))))
  (define (compile-operands operands)
    (if (null? operands)
        '()
        (append
          (compile-expression (car operands))
          (compile-operands (cdr operands)))))
  (define (compile-expression expression)
    (cond
      ((self-evaluating? expression)
       (list (list 'literal expression)))
      ((symbol? expression)
       (list (list 'load expression)))
      ((quoted? expression)
       (list (list 'literal (cadr expression))))
      ((assignment? expression)
       (append
         (compile-expression (caddr expression))
         (list (list 'set (cadr expression)))))
      ((definition? expression)
       (append
         (compile-expression (definition-value expression))
         (list (list 'define
                     (definition-variable 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)))
      ((pair? expression)
       (append
         (compile-expression (car expression))
         (append
           (compile-operands (cdr expression))
           (list (list 'call (length (cdr expression)))))))
      (else
       (error "unknown expression for compiler" expression))))

  (define (pair-bindings variables values)
    (cond ((and (null? variables) (null? values)) '())
          ((null? variables) (error "too many arguments"))
          ((null? values) (error "too few arguments"))
          (else
           (cons (cons (car variables) (car values))
                 (pair-bindings (cdr variables)
                                (cdr values))))))
  (define (make-frame variables values)
    (cons '*frame* (pair-bindings variables values)))
  (define (frame-bindings frame) (cdr frame))
  (define (extend-environment variables values environment)
    (cons (make-frame variables values) environment))
  (define (lookup-variable-value variable environment)
    (if (null? environment)
        (error "unbound compiled variable" variable)
        (let ((binding
               (assoc variable
                      (frame-bindings (car environment)))))
          (if binding
              (cdr binding)
              (lookup-variable-value variable
                                     (cdr environment))))))
  (define (define-variable! variable value environment)
    (let* ((frame (car environment))
           (binding (assoc variable (frame-bindings frame))))
      (if binding
          (set-cdr! binding value)
          (set-cdr! frame
                    (cons (cons variable value)
                          (frame-bindings frame)))))
    (list 'defined variable))
  (define (set-variable-value! variable value environment)
    (if (null? environment)
        (error "unbound compiled assignment" variable)
        (let ((binding
               (assoc variable
                      (frame-bindings (car environment)))))
          (if binding
              (begin
                (set-cdr! binding value)
                (list 'assigned variable))
              (set-variable-value! variable
                                   value
                                   (cdr environment))))))

  (define (make-primitive implementation)
    (list 'primitive implementation))
  (define (primitive? procedure)
    (tagged-list? procedure 'primitive))
  (define (primitive-implementation procedure) (cadr 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 (split-call stack count)
    (define (loop remaining-stack remaining-count arguments)
      (if (= remaining-count 0)
          (list (car remaining-stack)
                arguments
                (cdr remaining-stack))
          (loop (cdr remaining-stack)
                (- remaining-count 1)
                (cons (car remaining-stack) arguments))))
    (loop stack count '()))

  (define (run-code code stack environment)
    (if (null? code)
        (list stack environment)
        (let* ((instruction (car code))
               (tag (car instruction)))
          (cond
            ((eq? tag 'literal)
             (run-code (cdr code)
                       (cons (cadr instruction) stack)
                       environment))
            ((eq? tag 'load)
             (run-code
               (cdr code)
               (cons
                 (lookup-variable-value
                   (cadr instruction)
                   environment)
                 stack)
               environment))
            ((eq? tag 'closure)
             (run-code
               (cdr code)
               (cons
                 (make-compiled-procedure
                   (cadr instruction)
                   (caddr instruction)
                   environment)
                 stack)
               environment))
            ((eq? tag 'define)
             (let ((result
                    (define-variable!
                      (cadr instruction)
                      (car stack)
                      environment)))
               (run-code (cdr code)
                         (cons result (cdr stack))
                         environment)))
            ((eq? tag 'set)
             (let ((result
                    (set-variable-value!
                      (cadr instruction)
                      (car stack)
                      environment)))
               (run-code (cdr code)
                         (cons result (cdr stack))
                         environment)))
            ((eq? tag 'discard)
             (run-code (cdr code)
                       (cdr stack)
                       environment))
            ((eq? tag 'branch)
             (let* ((selected
                      (if (car stack)
                          (cadr instruction)
                          (caddr instruction)))
                    (branch-state
                      (run-code selected
                                (cdr stack)
                                environment)))
               (run-code (cdr code)
                         (car branch-state)
                         (cadr branch-state))))
            ((eq? tag 'call)
             (let* ((parts
                      (split-call stack (cadr instruction)))
                    (procedure (car parts))
                    (arguments (cadr parts))
                    (caller-stack (caddr parts)))
               (if (primitive? procedure)
                   (run-code
                     (cdr code)
                     (cons
                       (apply
                         (primitive-implementation procedure)
                         arguments)
                       caller-stack)
                     environment)
                   (if (compiled-procedure? procedure)
                       (let* ((call-environment
                                (extend-environment
                                  (compiled-parameters procedure)
                                  arguments
                                  (compiled-environment procedure)))
                              (call-state
                                (run-code
                                  (compiled-code procedure)
                                  '()
                                  call-environment))
                              (value (car (car call-state))))
                         (run-code (cdr code)
                                   (cons value caller-stack)
                                   environment))
                       (error "not a compiled procedure"
                              procedure)))))
            (else
             (error "unknown compiled instruction"
                    instruction))))))

  (define (make-global-environment)
    (list
      (cons '*frame*
        (list
          (cons '+ (make-primitive +))
          (cons '- (make-primitive -))
          (cons '* (make-primitive *))
          (cons '/ (make-primitive /))
          (cons '= (make-primitive =))
          (cons '< (make-primitive <))
          (cons '> (make-primitive >))
          (cons 'list (make-primitive list))
          (cons 'cons (make-primitive cons))
          (cons 'car (make-primitive car))
          (cons 'cdr (make-primitive cdr))
          (cons 'null? (make-primitive null?))))))
  (define (compile-and-run expression)
    (let* ((code (compile-expression expression))
           (environment (make-global-environment))
           (state (run-code code '() environment)))
      (list (car (car state))
            code
            environment)))
  (define combination
    '(- (record (quote left) 20)
        (record (quote right) 3)))
  (define program
    '(begin
       (define observations (quote ()))
       (define (append-list left right)
         (if (null? left)
             right
             (cons (car left)
                   (append-list (cdr left) right))))
       (define (record label value)
         (begin
           (set! observations
                 (append-list observations (list label)))
           value))
       (define result
         (- (record (quote left) 20)
            (record (quote right) 3)))
       (list result observations)))
  (define result (compile-and-run program))
  (list (car result)
        (map car (compile-expression combination)))
)

(begin
  (define (tagged-list? expression tag)
    (and (pair? expression) (eq? (car expression) tag)))
  (define (self-evaluating? expression)
    (or (number? expression)
        (string? expression)
        (boolean? expression)))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (assignment? expression) (tagged-list? expression 'set!))
  (define (definition? expression) (tagged-list? expression 'define))
  (define (if? expression) (tagged-list? expression 'if))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (begin? expression) (tagged-list? expression 'begin))

(define (definition-variable expression)
    (if (symbol? (cadr expression))
        (cadr expression)
        (car (cadr expression))))
  (define (definition-value expression)
    (if (symbol? (cadr expression))
        (caddr expression)
        (cons 'lambda
              (cons (cdr (cadr expression))
                    (cddr expression)))))

(define (compile-sequence expressions)
    (cond ((null? expressions)
           '((literal ok)))
          ((null? (cdr expressions))
           (compile-expression (car expressions)))
          (else
           (append
             (compile-expression (car expressions))
             (cons '(discard)
                   (compile-sequence (cdr expressions)))))))
  (define (compile-operands operands)
    (if (null? operands)
        '()
        (append
          (compile-expression (car operands))
          (compile-operands (cdr operands)))))
  (define (compile-expression expression)
    (cond
      ((self-evaluating? expression)
       (list (list 'literal expression)))
      ((symbol? expression)
       (list (list 'load expression)))
      ((quoted? expression)
       (list (list 'literal (cadr expression))))
      ((assignment? expression)
       (append
         (compile-expression (caddr expression))
         (list (list 'set (cadr expression)))))
      ((definition? expression)
       (append
         (compile-expression (definition-value expression))
         (list (list 'define
                     (definition-variable 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)))
      ((pair? expression)
       (append
         (compile-expression (car expression))
         (append
           (compile-operands (cdr expression))
           (list (list 'call (length (cdr expression)))))))
      (else
       (error "unknown expression for compiler" expression))))

(define (pair-bindings variables values)
    (cond ((and (null? variables) (null? values)) '())
          ((null? variables) (error "too many arguments"))
          ((null? values) (error "too few arguments"))
          (else
           (cons (cons (car variables) (car values))
                 (pair-bindings (cdr variables)
                                (cdr values))))))
  (define (make-frame variables values)
    (cons '*frame* (pair-bindings variables values)))
  (define (frame-bindings frame) (cdr frame))
  (define (extend-environment variables values environment)
    (cons (make-frame variables values) environment))
  (define (lookup-variable-value variable environment)
    (if (null? environment)
        (error "unbound compiled variable" variable)
        (let ((binding
               (assoc variable
                      (frame-bindings (car environment)))))
          (if binding
              (cdr binding)
              (lookup-variable-value variable
                                     (cdr environment))))))
  (define (define-variable! variable value environment)
    (let* ((frame (car environment))
           (binding (assoc variable (frame-bindings frame))))
      (if binding
          (set-cdr! binding value)
          (set-cdr! frame
                    (cons (cons variable value)
                          (frame-bindings frame)))))
    (list 'defined variable))
  (define (set-variable-value! variable value environment)
    (if (null? environment)
        (error "unbound compiled assignment" variable)
        (let ((binding
               (assoc variable
                      (frame-bindings (car environment)))))
          (if binding
              (begin
                (set-cdr! binding value)
                (list 'assigned variable))
              (set-variable-value! variable
                                   value
                                   (cdr environment))))))

(define (make-primitive implementation)
    (list 'primitive implementation))
  (define (primitive? procedure)
    (tagged-list? procedure 'primitive))
  (define (primitive-implementation procedure) (cadr 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 (split-call stack count)
    (define (loop remaining-stack remaining-count arguments)
      (if (= remaining-count 0)
          (list (car remaining-stack)
                arguments
                (cdr remaining-stack))
          (loop (cdr remaining-stack)
                (- remaining-count 1)
                (cons (car remaining-stack) arguments))))
    (loop stack count '()))

(define (run-code code stack environment)
    (if (null? code)
        (list stack environment)
        (let* ((instruction (car code))
               (tag (car instruction)))
          (cond
            ((eq? tag 'literal)
             (run-code (cdr code)
                       (cons (cadr instruction) stack)
                       environment))
            ((eq? tag 'load)
             (run-code
               (cdr code)
               (cons
                 (lookup-variable-value
                   (cadr instruction)
                   environment)
                 stack)
               environment))
            ((eq? tag 'closure)
             (run-code
               (cdr code)
               (cons
                 (make-compiled-procedure
                   (cadr instruction)
                   (caddr instruction)
                   environment)
                 stack)
               environment))
            ((eq? tag 'define)
             (let ((result
                    (define-variable!
                      (cadr instruction)
                      (car stack)
                      environment)))
               (run-code (cdr code)
                         (cons result (cdr stack))
                         environment)))
            ((eq? tag 'set)
             (let ((result
                    (set-variable-value!
                      (cadr instruction)
                      (car stack)
                      environment)))
               (run-code (cdr code)
                         (cons result (cdr stack))
                         environment)))
            ((eq? tag 'discard)
             (run-code (cdr code)
                       (cdr stack)
                       environment))
            ((eq? tag 'branch)
             (let* ((selected
                      (if (car stack)
                          (cadr instruction)
                          (caddr instruction)))
                    (branch-state
                      (run-code selected
                                (cdr stack)
                                environment)))
               (run-code (cdr code)
                         (car branch-state)
                         (cadr branch-state))))
            ((eq? tag 'call)
             (let* ((parts
                      (split-call stack (cadr instruction)))
                    (procedure (car parts))
                    (arguments (cadr parts))
                    (caller-stack (caddr parts)))
               (if (primitive? procedure)
                   (run-code
                     (cdr code)
                     (cons
                       (apply
                         (primitive-implementation procedure)
                         arguments)
                       caller-stack)
                     environment)
                   (if (compiled-procedure? procedure)
                       (let* ((call-environment
                                (extend-environment
                                  (compiled-parameters procedure)
                                  arguments
                                  (compiled-environment procedure)))
                              (call-state
                                (run-code
                                  (compiled-code procedure)
                                  '()
                                  call-environment))
                              (value (car (car call-state))))
                         (run-code (cdr code)
                                   (cons value caller-stack)
                                   environment))
                       (error "not a compiled procedure"
                              procedure)))))
            (else
             (error "unknown compiled instruction"
                    instruction))))))

(define (make-global-environment)
    (list
      (cons '*frame*
        (list
          (cons '+ (make-primitive +))
          (cons '- (make-primitive -))
          (cons '* (make-primitive *))
          (cons '/ (make-primitive /))
          (cons '= (make-primitive =))
          (cons '< (make-primitive <))
          (cons '> (make-primitive >))
          (cons 'list (make-primitive list))
          (cons 'cons (make-primitive cons))
          (cons 'car (make-primitive car))
          (cons 'cdr (make-primitive cdr))
          (cons 'null? (make-primitive null?))))))
  (define (compile-and-run expression)
    (let* ((code (compile-expression expression))
           (environment (make-global-environment))
           (state (run-code code '() environment)))
      (list (car (car state))
            code
            environment)))
  (define combination
    '(- (record (quote left) 20)
        (record (quote right) 3)))
  (define program
    '(begin
       (define observations (quote ()))
       (define (append-list left right)
         (if (null? left)
             right
             (cons (car left)
                   (append-list (cdr left) right))))
       (define (record label value)
         (begin
           (set! observations
                 (append-list observations (list label)))
           value))
       (define result
         (- (record (quote left) 20)
            (record (quote right) 3)))
       (list result observations)))
  (define result (compile-and-run program))
  (list (car result)
        (map car (compile-expression combination)))
)

Примеры

Результат—

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

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

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

Программа упорядочения возвращает ((17 (left right)) (load load literal literal call load literal literal call call)). Программа интерфейса возвращает ((evaluator-to-compiled 8 (compiled primitive)) (compiled-to-evaluator 14 (interpreted primitive) #t) (representations #t #t)).

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

В первом запуске проследите внешний load оператора, каждую инструкцию левого вызова record, каждую инструкцию правого вызова record и только затем вызов вычитания. В запуске интерфейса отделите подготовку аргументов от диспетчеризации представлений в apply-any и убедитесь, что каждое тело получает аргументы в объявленном порядке параметров.

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

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

Скомпилируйте вызов list с тремя операндами, каждый из которых записывает отдельную метку, затем оберните один операнд в вызов скомпилированного замыкания. Спрогнозируйте как теги инструкций, так и хронологический журнал dispatch-log.

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

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

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

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