5.2.5 · Generating execution procedures

Assembly can move instruction dispatch out of the run loop.

Turn each controller instruction into a closure that captures its operands and control rule, then reuse the assembled procedure vector across machines.

Guiding question

Which work can the assembler perform once so the machine loop only fetches and invokes an execution procedure?

Generate one execution closure for every assembled instruction
Capture register names, source expressions, and branch targets during assembly
Keep fetched-instruction counting in the machine loop
Execute controllers without rechecking instruction tags on every cycle
Reuse one execution-procedure sequence with fresh machine states

make-execution-procedure performs the instruction-tag dispatch during assembly. Each branch returns a closure that remembers the destination register, source expression, label, or stack operation it needs. The run loop no longer contains an assign/test/branch/goto cond; it selects the closure at pc and invokes it.

The first program shows that even the assignment skipped by a true branch receives an execution procedure, because assembly covers controller structure rather than one run path. The factorial program assembles six closures once and uses the same sequence with two fresh machine instances. The closures still receive the current machine, so registers, stack, flag, pc, and operation package remain instance-specific.

SICP code9,477 of 1,048,576 UTF-8 bytes

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

  (define (extract-labels controller position)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (cons (cons (car controller) position)
                 (extract-labels (cdr controller) position)))
          (else
           (extract-labels (cdr controller) (+ position 1)))))
  (define (extract-instructions controller)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (extract-instructions (cdr controller)))
          (else
           (cons (car controller)
                 (extract-instructions (cdr controller))))))

  (define (make-registers names)
    (map (lambda (name) (cons name '*unassigned*)) names))
  (define (make-machine register-names operations controller)
    (list '*machine*
          (make-registers register-names)
          (cons '*stack* '())
          operations
          (extract-instructions controller)
          (extract-labels controller 0)
          (cons 'pc 0)
          (cons 'flag #f)
          (cons 'halted #f)
          (cons 'steps 0)))

  (define (machine-registers machine) (list-ref machine 1))
  (define (machine-stack machine) (list-ref machine 2))
  (define (machine-operations machine) (list-ref machine 3))
  (define (machine-instructions machine) (list-ref machine 4))
  (define (machine-labels machine) (list-ref machine 5))
  (define (machine-pc-cell machine) (list-ref machine 6))
  (define (machine-flag-cell machine) (list-ref machine 7))
  (define (machine-halted-cell machine) (list-ref machine 8))
  (define (machine-steps-cell machine) (list-ref machine 9))

  (define (machine-pc machine) (cdr (machine-pc-cell machine)))
  (define (set-machine-pc! machine value)
    (set-cdr! (machine-pc-cell machine) value))
  (define (machine-flag machine) (cdr (machine-flag-cell machine)))
  (define (set-machine-flag! machine value)
    (set-cdr! (machine-flag-cell machine) value))
  (define (machine-halted? machine) (cdr (machine-halted-cell machine)))
  (define (halt-machine! machine)
    (set-cdr! (machine-halted-cell machine) #t))
  (define (machine-steps machine) (cdr (machine-steps-cell machine)))
  (define (increment-machine-steps! machine)
    (set-cdr! (machine-steps-cell machine)
              (+ (machine-steps machine) 1)))

  (define (register-cell machine name)
    (let ((cell (assoc name (machine-registers machine))))
      (if cell cell (error "unknown register" name))))
  (define (get-register machine name)
    (cdr (register-cell machine name)))
  (define (set-register! machine name value)
    (set-cdr! (register-cell machine name) value))

  (define (push! machine value)
    (set-cdr! (machine-stack machine)
              (cons value (cdr (machine-stack machine)))))
  (define (pop! machine)
    (let ((values (cdr (machine-stack machine))))
      (if (null? values)
          (error "empty machine stack")
          (let ((value (car values)))
            (set-cdr! (machine-stack machine) (cdr values))
            value))))
  (define (stack-empty? machine)
    (null? (cdr (machine-stack machine))))

  (define (operation machine name)
    (let ((binding (assoc name (machine-operations machine))))
      (if binding (cdr binding) (error "unknown operation" name))))
  (define (label-position machine name)
    (let ((binding (assoc name (machine-labels machine))))
      (if binding (cdr binding) (error "unknown label" name))))

  (define (evaluate-source machine source)
    (cond ((tagged-list? source 'const) (cadr source))
          ((tagged-list? source 'reg)
           (get-register machine (cadr source)))
          ((tagged-list? source 'label)
           (label-position machine (cadr source)))
          ((tagged-list? source 'op)
           (apply (operation machine (cadr source))
                  (map (lambda (operand)
                         (evaluate-source machine operand))
                       (cddr source))))
          (else
           (error "unknown machine source" source))))

  (define (advance! machine)
    (set-machine-pc! machine (+ (machine-pc machine) 1)))
  (define (execute-one! machine)
    (let* ((instruction
             (list-ref (machine-instructions machine)
                       (machine-pc machine)))
           (tag (car instruction)))
      (increment-machine-steps! machine)
      (cond
        ((eq? tag 'assign)
         (set-register! machine
                        (cadr instruction)
                        (evaluate-source machine (caddr instruction)))
         (advance! machine))
        ((eq? tag 'test)
         (set-machine-flag! machine
                            (evaluate-source machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'branch)
         (if (machine-flag machine)
             (set-machine-pc!
               machine
               (label-position machine (cadr instruction)))
             (advance! machine)))
        ((eq? tag 'goto)
         (set-machine-pc! machine
                          (evaluate-source machine (cadr instruction))))
        ((eq? tag 'save)
         (push! machine (get-register machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'restore)
         (set-register! machine (cadr instruction) (pop! machine))
         (advance! machine))
        ((eq? tag 'perform)
         (evaluate-source machine (cadr instruction))
         (advance! machine))
        ((eq? tag 'halt)
         (halt-machine! machine))
        (else
         (error "unknown machine instruction" instruction)))))

  (define (run-machine! machine step-limit)
    (cond ((machine-halted? machine) 'complete)
          ((= step-limit 0) 'step-limit)
          (else
           (execute-one! machine)
           (run-machine! machine (- step-limit 1)))))
  (define (make-execution-procedure instruction)
    (let ((tag (car instruction)))
      (cond
        ((eq? tag 'assign)
         (let ((target (cadr instruction))
               (source (caddr instruction)))
           (lambda (machine)
             (set-register! machine
                            target
                            (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'test)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-flag! machine
                                (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'branch)
         (let ((label (cadr instruction)))
           (lambda (machine)
             (if (machine-flag machine)
                 (set-machine-pc! machine
                                  (label-position machine label))
                 (advance! machine)))))
        ((eq? tag 'goto)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-pc! machine
                              (evaluate-source machine source)))))
        ((eq? tag 'save)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (push! machine (get-register machine register))
             (advance! machine))))
        ((eq? tag 'restore)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (set-register! machine register (pop! machine))
             (advance! machine))))
        ((eq? tag 'perform)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (evaluate-source machine source)
             (advance! machine))))
        ((eq? tag 'halt)
         (lambda (machine) (halt-machine! machine)))
        (else
         (error "unknown instruction at assembly" instruction)))))
  (define (run-procedures! machine procedures remaining)
    (cond ((machine-halted? machine) 'complete)
          ((= remaining 0) 'step-limit)
          (else
           (increment-machine-steps! machine)
           ((list-ref procedures (machine-pc machine)) machine)
           (run-procedures! machine
                            procedures
                            (- remaining 1)))))
  (define observations '())
  (define operations
    (list
      (cons '= =)
      (cons 'record
            (lambda (value)
              (set! observations
                    (append observations (list value)))
              'ok))))
  (define controller
    '(start
       (assign val (const 10))
       (test (op = (reg val) (const 10)))
       (branch after-skip)
       (assign val (const -1))
      after-skip
       (assign continue (label after-goto))
       (goto (reg continue))
      after-goto
       (save val)
       (assign val (const 0))
       (restore val)
       (perform (op record (reg val)))
       (halt)))
  (define machine
    (make-machine '(val continue) operations controller))
  (define generation-log '())
  (define procedures
    (map
      (lambda (instruction)
        (set! generation-log
              (append generation-log (list (car instruction))))
        (make-execution-procedure instruction))
      (machine-instructions machine)))
  (define (all-procedures? values)
    (if (null? values)
        #t
        (and (procedure? (car values))
             (all-procedures? (cdr values)))))
  (define status (run-procedures! machine procedures 30))
  (list generation-log
        (length procedures)
        (all-procedures? procedures)
        status
        (get-register machine 'val)
        observations
        (machine-steps machine))
)

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

(define (extract-labels controller position)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (cons (cons (car controller) position)
                 (extract-labels (cdr controller) position)))
          (else
           (extract-labels (cdr controller) (+ position 1)))))
  (define (extract-instructions controller)
    (cond ((null? controller) '())
          ((symbol? (car controller))
           (extract-instructions (cdr controller)))
          (else
           (cons (car controller)
                 (extract-instructions (cdr controller))))))

(define (make-registers names)
    (map (lambda (name) (cons name '*unassigned*)) names))
  (define (make-machine register-names operations controller)
    (list '*machine*
          (make-registers register-names)
          (cons '*stack* '())
          operations
          (extract-instructions controller)
          (extract-labels controller 0)
          (cons 'pc 0)
          (cons 'flag #f)
          (cons 'halted #f)
          (cons 'steps 0)))

(define (machine-registers machine) (list-ref machine 1))
  (define (machine-stack machine) (list-ref machine 2))
  (define (machine-operations machine) (list-ref machine 3))
  (define (machine-instructions machine) (list-ref machine 4))
  (define (machine-labels machine) (list-ref machine 5))
  (define (machine-pc-cell machine) (list-ref machine 6))
  (define (machine-flag-cell machine) (list-ref machine 7))
  (define (machine-halted-cell machine) (list-ref machine 8))
  (define (machine-steps-cell machine) (list-ref machine 9))

(define (machine-pc machine) (cdr (machine-pc-cell machine)))
  (define (set-machine-pc! machine value)
    (set-cdr! (machine-pc-cell machine) value))
  (define (machine-flag machine) (cdr (machine-flag-cell machine)))
  (define (set-machine-flag! machine value)
    (set-cdr! (machine-flag-cell machine) value))
  (define (machine-halted? machine) (cdr (machine-halted-cell machine)))
  (define (halt-machine! machine)
    (set-cdr! (machine-halted-cell machine) #t))
  (define (machine-steps machine) (cdr (machine-steps-cell machine)))
  (define (increment-machine-steps! machine)
    (set-cdr! (machine-steps-cell machine)
              (+ (machine-steps machine) 1)))

(define (register-cell machine name)
    (let ((cell (assoc name (machine-registers machine))))
      (if cell cell (error "unknown register" name))))
  (define (get-register machine name)
    (cdr (register-cell machine name)))
  (define (set-register! machine name value)
    (set-cdr! (register-cell machine name) value))

(define (push! machine value)
    (set-cdr! (machine-stack machine)
              (cons value (cdr (machine-stack machine)))))
  (define (pop! machine)
    (let ((values (cdr (machine-stack machine))))
      (if (null? values)
          (error "empty machine stack")
          (let ((value (car values)))
            (set-cdr! (machine-stack machine) (cdr values))
            value))))
  (define (stack-empty? machine)
    (null? (cdr (machine-stack machine))))

(define (operation machine name)
    (let ((binding (assoc name (machine-operations machine))))
      (if binding (cdr binding) (error "unknown operation" name))))
  (define (label-position machine name)
    (let ((binding (assoc name (machine-labels machine))))
      (if binding (cdr binding) (error "unknown label" name))))

(define (evaluate-source machine source)
    (cond ((tagged-list? source 'const) (cadr source))
          ((tagged-list? source 'reg)
           (get-register machine (cadr source)))
          ((tagged-list? source 'label)
           (label-position machine (cadr source)))
          ((tagged-list? source 'op)
           (apply (operation machine (cadr source))
                  (map (lambda (operand)
                         (evaluate-source machine operand))
                       (cddr source))))
          (else
           (error "unknown machine source" source))))

(define (advance! machine)
    (set-machine-pc! machine (+ (machine-pc machine) 1)))
  (define (execute-one! machine)
    (let* ((instruction
             (list-ref (machine-instructions machine)
                       (machine-pc machine)))
           (tag (car instruction)))
      (increment-machine-steps! machine)
      (cond
        ((eq? tag 'assign)
         (set-register! machine
                        (cadr instruction)
                        (evaluate-source machine (caddr instruction)))
         (advance! machine))
        ((eq? tag 'test)
         (set-machine-flag! machine
                            (evaluate-source machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'branch)
         (if (machine-flag machine)
             (set-machine-pc!
               machine
               (label-position machine (cadr instruction)))
             (advance! machine)))
        ((eq? tag 'goto)
         (set-machine-pc! machine
                          (evaluate-source machine (cadr instruction))))
        ((eq? tag 'save)
         (push! machine (get-register machine (cadr instruction)))
         (advance! machine))
        ((eq? tag 'restore)
         (set-register! machine (cadr instruction) (pop! machine))
         (advance! machine))
        ((eq? tag 'perform)
         (evaluate-source machine (cadr instruction))
         (advance! machine))
        ((eq? tag 'halt)
         (halt-machine! machine))
        (else
         (error "unknown machine instruction" instruction)))))

(define (run-machine! machine step-limit)
    (cond ((machine-halted? machine) 'complete)
          ((= step-limit 0) 'step-limit)
          (else
           (execute-one! machine)
           (run-machine! machine (- step-limit 1)))))
  (define (make-execution-procedure instruction)
    (let ((tag (car instruction)))
      (cond
        ((eq? tag 'assign)
         (let ((target (cadr instruction))
               (source (caddr instruction)))
           (lambda (machine)
             (set-register! machine
                            target
                            (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'test)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-flag! machine
                                (evaluate-source machine source))
             (advance! machine))))
        ((eq? tag 'branch)
         (let ((label (cadr instruction)))
           (lambda (machine)
             (if (machine-flag machine)
                 (set-machine-pc! machine
                                  (label-position machine label))
                 (advance! machine)))))
        ((eq? tag 'goto)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (set-machine-pc! machine
                              (evaluate-source machine source)))))
        ((eq? tag 'save)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (push! machine (get-register machine register))
             (advance! machine))))
        ((eq? tag 'restore)
         (let ((register (cadr instruction)))
           (lambda (machine)
             (set-register! machine register (pop! machine))
             (advance! machine))))
        ((eq? tag 'perform)
         (let ((source (cadr instruction)))
           (lambda (machine)
             (evaluate-source machine source)
             (advance! machine))))
        ((eq? tag 'halt)
         (lambda (machine) (halt-machine! machine)))
        (else
         (error "unknown instruction at assembly" instruction)))))
  (define (run-procedures! machine procedures remaining)
    (cond ((machine-halted? machine) 'complete)
          ((= remaining 0) 'step-limit)
          (else
           (increment-machine-steps! machine)
           ((list-ref procedures (machine-pc machine)) machine)
           (run-procedures! machine
                            procedures
                            (- remaining 1)))))
  (define observations '())
  (define operations
    (list
      (cons '= =)
      (cons 'record
            (lambda (value)
              (set! observations
                    (append observations (list value)))
              'ok))))
  (define controller
    '(start
       (assign val (const 10))
       (test (op = (reg val) (const 10)))
       (branch after-skip)
       (assign val (const -1))
      after-skip
       (assign continue (label after-goto))
       (goto (reg continue))
      after-goto
       (save val)
       (assign val (const 0))
       (restore val)
       (perform (op record (reg val)))
       (halt)))
  (define machine
    (make-machine '(val continue) operations controller))
  (define generation-log '())
  (define procedures
    (map
      (lambda (instruction)
        (set! generation-log
              (append generation-log (list (car instruction))))
        (make-execution-procedure instruction))
      (machine-instructions machine)))
  (define (all-procedures? values)
    (if (null? values)
        #t
        (and (procedure? (car values))
             (all-procedures? (cdr values)))))
  (define status (run-procedures! machine procedures 30))
  (list generation-log
        (length procedures)
        (all-procedures? procedures)
        status
        (get-register machine 'val)
        observations
        (machine-steps machine))
)

Examples

Result—

Output: —
Value: —
Diagnostic: —

Execution trace0 / 0 events

Expected result

The assembly log returns ((assign test branch assign assign goto save assign restore perform halt) 11 #t complete 10 (10) 10). The reusable factorial sequence returns (6 (complete 120 28) (complete 6 18)).

Trace focus

Separate the one-time map over instruction data from the later fetch-and-call loop. The skipped -1 assignment still appears in generation-log, while the run path never invokes its closure. In the factorial example, verify that both machine instances share the procedure list but not their mutable registers or counters.

Try it yourself

Change the program and compare the result.

Add save and restore to the factorial controller or instrument each generated closure with its instruction tag. Predict which work happens during assembly and which work repeats for every machine run.

Show hint

Anything derived only from controller syntax belongs in the generated closure. Register values and pc-dependent control remain runtime inputs.

Complete this lesson

0 of 23 lessons complete in this chapter0%