5.5.2 · Компиляция выражений

Компиляция форм исходного кода в теги инструкций

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

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

Какие решения исходного языка исчезают из цикла выполнения после компиляции?

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

compile-expression выполняет всю классификацию исходного кода. Результат содержит только инструкции literal, load, closure, define, set, discard, branch и call. Форма lambda сохраняет уже скомпилированный код тела со своими параметрами. Форма begin вставляет discard между нефинальными формами, а применение помещает код оператора перед кодом операндов перед единственной инструкцией call.

run-code выполняет диспетчеризацию по тегам скомпилированных инструкций после того, как compile-expression классифицирует формы исходного кода. Скомпилированная процедура расширяет лексическое окружение, захваченное при создании замыкания, и выполняет код своего тела на чистом стеке операндов. Эта учебная VM выполняет глобальные определения, захваченные локальные присваивания, цитирование, ветвление, замыкания и применение примитивов с помощью указанного набора инструкций.

Код SICP10,895 из 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 program
    '(begin
       (define base 10)
       (define (make-adder x)
         (lambda (y) (+ x y)))
       (define add-three (make-adder 3))
       (set! base (+ base 5))
       (if (> base 12)
           (list (add-three base) (quote large) base)
           (list 0 (quote small) base))))
  (define result (compile-and-run program))
  (list (car result)
        (map car (cadr result))
        (length (cadr result)))
)

(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 program
    '(begin
       (define base 10)
       (define (make-adder x)
         (lambda (y) (+ x y)))
       (define add-three (make-adder 3))
       (set! base (+ base 5))
       (if (> base 12)
           (list (add-three base) (quote large) base)
           (list 0 (quote small) base))))
  (define result (compile-and-run program))
  (list (car result)
        (map car (cadr result))
        (length (cadr result)))
)

Примеры

Результат—

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

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

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

Первая скомпилированная программа возвращает ((18 large 15) (literal define discard closure define discard load literal call define discard load load literal call set discard load load literal call branch) 22). Замыкание с состоянием возвращает ((12 15 5 ok) (literal define discard closure define discard load literal call define discard load load literal call load literal call load literal call) 21).

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

Сначала проверьте теги кода и убедитесь, что в них не осталось тегов форм исходного кода. Во время выполнения проследите создание замыкания до вызова make-adder или make-counter, новый кадр вызова для каждого скомпилированного применения, изменение захваченной записи start между вызовами counter и выбор ровно одного вложенного списка кода в branch.

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

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

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

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

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

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

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