5.5.7 · Compiled code meets the evaluator

One apply boundary can connect two procedure representations.

An evaluator can call compiled procedures and compiled code can call interpreted procedures when both share one environment model and argument convention.

Guiding question

Which runtime agreements let interpreted and compiled procedures call across their representation boundary without pretending they are the same object?

Keep interpreted and compiled procedures as distinct tagged representations
Share one lexical environment and argument-list convention
Route primitive, interpreted, and compiled procedures through one apply boundary
Call compiled code from the evaluator
Call an interpreted procedure from compiled code
Record the actual representation dispatch order for both directions
Describe the shared apply boundary through its environment, argument, and dispatch contracts

The shared global environment stores wrapped primitives, one interpreted procedure named double, and one compiled procedure named add-three. evaluate creates interpreted closures whose bodies remain expression data. compile-expression creates stack-machine code and closure instructions whose bodies are instruction lists. The two representations remain visibly different, but both carry parameters and a lexical environment and both accept the same ordered argument list.

apply-any is the interface. An evaluator application reaches it after evaluating an operator and operands. A compiled call instruction reaches the same boundary after popping its procedure and arguments from the VM stack. The evaluator-to-compiled run records (compiled primitive): add-three enters compiled code, whose addition calls a primitive. The compiled-to-evaluator run records (interpreted primitive): compiled code calls double, whose interpreted body multiplies through a primitive. The lesson model records the exact cross-call contract for both directions.

SICP code11,508 of 1,048,576 UTF-8 bytes

(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))))

Examples

Result—

Output: —
Value: —
Diagnostic: —

Execution trace0 / 0 events

Expected result

The program returns ((evaluator-to-compiled 8 (compiled primitive)) (compiled-to-evaluator 14 (interpreted primitive) #t) (representations #t #t)). The dispatch lists record the actual procedure representations entered by each selected run.

Trace focus

First follow evaluator lookup of add-three into apply-any, then the compiled closure’s VM lookup and primitive call. Next follow the compiled call instruction for double into the interpreted branch, environment extension, expression-body evaluation, and primitive multiplication. Confirm that both paths use the same global environment and ordered argument convention while preserving distinct interpreted and compiled procedure tags.

Try it yourself

Change the program and compare the result.

Add an interpreted procedure that calls add-three and compile a procedure that calls double. Invoke both wrappers and predict the nested dispatch logs before running them.

Show hint

Each wrapper adds its own representation to the front of the chronological path. Follow the outer call first, then the representation entered by its body.

Complete this lesson

0 of 23 lessons complete in this chapter0%