5.5.3 · Compiling combinations

Compile the operator first, preserve argument order, cross one apply boundary.

Inspect the exact instruction order for a nested combination and route primitive, interpreted, and compiled procedures through one application convention.

Guiding question

Which ordering and representation contracts must compiled application code preserve?

Compile an operator before its operand expressions
Compile operands from left to right while preserving argument order
Emit one call instruction after the complete combination state is ready
Observe source-order effects without relying on an unspecified schedule
Share one lexical environment and argument convention across procedure representations
Keep primitive, interpreted, and compiled dispatch visibly distinct

The lesson compiler emits load for the subtraction operator, then the entire code for the left record call, then the entire code for the right record call, and finally one outer call. The stateful record procedure appends labels to observations, so the returned (left right) list confirms that execution follows the emitted source order. The subtraction value also confirms the argument order.

The second program broadens the call boundary. Evaluator code calls a compiled add-three closure, and compiled code calls an interpreted double procedure. Both paths pass an ordered argument list through apply-any, while dispatch-log retains the actual primitive, interpreted, and compiled tags. This records the calling convention used by the lesson.

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

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

Examples

Result—

Output: —
Value: —
Diagnostic: —

Execution trace0 / 0 events

Expected result

The ordering program returns ((17 (left right)) (load load literal literal call load literal literal call call)). The interface program returns ((evaluator-to-compiled 8 (compiled primitive)) (compiled-to-evaluator 14 (interpreted primitive) #t) (representations #t #t)).

Trace focus

In the first run, follow the outer operator load, every instruction of the left record call, every instruction of the right record call, and only then the subtraction call. In the interface run, separate argument preparation from apply-any representation dispatch and confirm that each body receives arguments in its declared parameter order.

Try it yourself

Change the program and compare the result.

Compile a three-operand list call whose operands each record a distinct label, then wrap one operand in a compiled closure call. Predict both the instruction tags and the chronological dispatch log.

Show hint

Finish the operator code first. Each operand contributes its complete code in source order, while the final call consumes the resulting ordered argument list.

Complete this lesson

0 of 23 lessons complete in this chapter0%