Evaluator control becomes registers, labels, and stack protocol.
A register-machine controller implements eval and apply directly. The exp, env, val, proc, argl, continue, and unev registers expose the evaluator state.
Guiding question
What changes when the evaluator is no longer expressed by host-language recursion and must preserve every continuation explicitly?
- Dispatch guest syntax through an explicit eval-dispatch controller
- Carry evaluator data through exp, env, val, proc, argl, continue, and unev
- Save and restore unfinished operator and operand work on a machine stack
- Apply primitives and represented compound procedures through separate controller paths
- Restore continue before evaluating the last expression of a sequence
- Observe equal maximum stack depth for two tail-recursive runs of different lengths
- Route if, set!, and define through explicit controller labels
- Run a complete guest program and halt with an empty evaluator stack
The controller starts by loading the global environment and a final continuation, then repeatedly dispatches on the expression in exp. Simple values place their result in val and jump through continue. Applications save the caller continuation and environment, evaluate the operator and operands, build argl, and enter apply-dispatch. Primitive procedures call a host implementation; compound procedures install a new environment and send their body through ev-sequence.
Sequence evaluation is tail recursive because ev-sequence-last-exp restores the caller continuation before sending the final expression back to eval-dispatch. The two sum-iter runs therefore reach the same measured maximum evaluator-stack depth even though one performs more recursive calls. Separate controller paths preserve and restore the expression, environment, and continuation around if, set!, and define. The final guest program combines recursion, lexical closure state, mutation, and a clean halt. These observations describe this finite simulator and controller, not hardware timing or every possible evaluator implementation.
SICP code22,000 of 1,048,576 UTF-8 bytes
(begin
(define (tagged-list? expression tag)
(and (pair? expression) (eq? (car expression) tag)))
(define (make-register name) (cons name '*unassigned*))
(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-state machine) (list-ref machine 6))
(define (lookup-register machine name)
(let ((register (assoc name (machine-registers machine))))
(if register register (error "unknown EC register" name))))
(define (get-register-contents machine name)
(cdr (lookup-register machine name)))
(define (set-register-contents! machine name value)
(set-cdr! (lookup-register machine name) value))
(define (state-cell machine name)
(let ((cell (assoc name (machine-state machine))))
(if cell cell (error "unknown EC state" name))))
(define (state-ref machine name) (cdr (state-cell machine name)))
(define (state-set! machine name value)
(set-cdr! (state-cell machine name) value))
(define (push-stack! machine value)
(let ((stack (machine-stack machine)))
(set-cdr! stack (cons value (cdr stack)))
(state-set! machine 'push-count
(+ (state-ref machine 'push-count) 1))
(let ((depth (+ (state-ref machine 'current-depth) 1)))
(state-set! machine 'current-depth depth)
(if (> depth (state-ref machine 'max-depth))
(state-set! machine 'max-depth depth)
'ok))))
(define (pop-stack! machine)
(let ((stack (machine-stack machine)))
(if (null? (cdr stack))
(error "empty EC stack")
(let ((value (cadr stack)))
(set-cdr! stack (cddr stack))
(state-set! machine 'current-depth
(- (state-ref machine 'current-depth) 1))
value))))
(define (stack-empty? machine)
(null? (cdr (machine-stack machine))))
(define (extract-instructions controller)
(cond ((null? controller) '())
((symbol? (car controller))
(extract-instructions (cdr controller)))
(else
(cons (car controller)
(extract-instructions (cdr controller))))))
(define (build-labels controller instruction-index)
(cond ((null? controller) '())
((symbol? (car controller))
(cons (cons (car controller) instruction-index)
(build-labels (cdr controller) instruction-index)))
(else
(build-labels (cdr controller) (+ instruction-index 1)))))
(define (make-machine register-names operations controller)
(list 'machine
(map make-register register-names)
(cons 'stack '())
operations
(extract-instructions controller)
(build-labels controller 0)
(list (cons 'pc 0)
(cons 'flag #f)
(cons 'halted #f)
(cons 'instruction-count 0)
(cons 'push-count 0)
(cons 'current-depth 0)
(cons 'max-depth 0)
(cons 'global-environment '()))))
(define (lookup-label machine name)
(let ((entry (assoc name (machine-labels machine))))
(if entry (cdr entry) (error "unknown EC label" name))))
(define (lookup-operation machine name)
(let ((entry (assoc name (machine-operations machine))))
(if entry (cdr entry) (error "unknown EC operation" name))))
(define (evaluate-expression expression machine)
(cond ((tagged-list? expression 'const) (cadr expression))
((tagged-list? expression 'reg)
(get-register-contents machine (cadr expression)))
((tagged-list? expression 'label)
(lookup-label machine (cadr expression)))
(else (error "unknown EC expression" expression))))
(define (operation-expression? expressions)
(and (pair? expressions) (tagged-list? (car expressions) 'op)))
(define (evaluate-operation expressions machine)
(apply (lookup-operation machine (cadr (car expressions)))
(map (lambda (expression)
(evaluate-expression expression machine))
(cdr expressions))))
(define (advance-pc! machine)
(state-set! machine 'pc (+ (state-ref machine 'pc) 1)))
(define (execute-instruction! instruction machine)
(cond
((tagged-list? instruction 'assign)
(let ((parts (cddr instruction)))
(set-register-contents!
machine
(cadr instruction)
(if (operation-expression? parts)
(evaluate-operation parts machine)
(evaluate-expression (car parts) machine)))
(advance-pc! machine)))
((tagged-list? instruction 'test)
(state-set! machine 'flag
(evaluate-operation (cdr instruction) machine))
(advance-pc! machine))
((tagged-list? instruction 'branch)
(if (state-ref machine 'flag)
(state-set! machine 'pc
(evaluate-expression (cadr instruction) machine))
(advance-pc! machine)))
((tagged-list? instruction 'goto)
(state-set! machine 'pc
(evaluate-expression (cadr instruction) machine)))
((tagged-list? instruction 'save)
(push-stack! machine
(get-register-contents machine (cadr instruction)))
(advance-pc! machine))
((tagged-list? instruction 'restore)
(set-register-contents! machine
(cadr instruction)
(pop-stack! machine))
(advance-pc! machine))
((tagged-list? instruction 'perform)
(evaluate-operation (cdr instruction) machine)
(advance-pc! machine))
((tagged-list? instruction 'halt)
(state-set! machine 'halted #t))
(else (error "unknown EC instruction" instruction))))
(define (execute-machine! machine)
(if (state-ref machine 'halted)
'done
(let ((pc (state-ref machine 'pc))
(instructions (machine-instructions machine)))
(if (= pc (length instructions))
(state-set! machine 'halted #t)
(begin
(state-set! machine 'instruction-count
(+ (state-ref machine 'instruction-count) 1))
(execute-instruction! (list-ref instructions pc) machine)
(execute-machine! machine))))))
(define (start! machine)
(set-cdr! (machine-stack machine) '())
(state-set! machine 'pc 0)
(state-set! machine 'flag #f)
(state-set! machine 'halted #f)
(state-set! machine 'instruction-count 0)
(state-set! machine 'push-count 0)
(state-set! machine 'current-depth 0)
(state-set! machine 'max-depth 0)
(execute-machine! machine))
(define (self-evaluating? expression)
(or (number? expression) (string? expression) (boolean? expression)))
(define (variable? expression) (symbol? expression))
(define (quoted? expression) (tagged-list? expression 'quote))
(define (text-of-quotation expression) (cadr expression))
(define (assignment? expression) (tagged-list? expression 'set!))
(define (assignment-variable expression) (cadr expression))
(define (assignment-value expression) (caddr expression))
(define (definition? expression) (tagged-list? expression 'define))
(define (definition-variable expression)
(if (symbol? (cadr expression))
(cadr expression)
(caadr expression)))
(define (definition-value expression)
(if (symbol? (cadr expression))
(caddr expression)
(cons 'lambda
(cons (cdar (cdr expression))
(cddr expression)))))
(define (if? expression) (tagged-list? expression 'if))
(define (if-predicate expression) (cadr expression))
(define (if-consequent expression) (caddr expression))
(define (if-alternative expression)
(if (null? (cdddr expression)) #f (cadddr expression)))
(define (lambda? expression) (tagged-list? expression 'lambda))
(define (lambda-parameters expression) (cadr expression))
(define (lambda-body expression) (cddr expression))
(define (begin? expression) (tagged-list? expression 'begin))
(define (begin-actions expression) (cdr expression))
(define (application? expression) (pair? expression))
(define (operator expression) (car expression))
(define (operands expression) (cdr expression))
(define (no-operands? operands) (null? operands))
(define (first-operand operands) (car operands))
(define (rest-operands operands) (cdr operands))
(define (last-operand? operands) (null? (cdr operands)))
(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 EC variable" variable)
(let ((binding
(find-binding
variable
(frame-bindings (first-frame environment)))))
(if binding
(cdr binding)
(lookup-variable-value
variable
(enclosing-environment environment))))))
(define (set-variable-value! variable value environment)
(if (null? environment)
(error "unbound EC assignment" variable)
(let ((binding
(find-binding
variable
(frame-bindings (first-frame environment)))))
(if binding
(set-cdr! binding value)
(set-variable-value!
variable
value
(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 "EC argument count mismatch" variables values)))
(define (make-procedure parameters body environment)
(list 'procedure parameters body environment))
(define (compound-procedure? procedure)
(tagged-list? procedure 'procedure))
(define (procedure-parameters procedure) (cadr procedure))
(define (procedure-body procedure) (caddr procedure))
(define (procedure-environment procedure) (cadddr procedure))
(define (make-primitive implementation)
(list 'primitive implementation))
(define (primitive-procedure? procedure)
(tagged-list? procedure 'primitive))
(define (primitive-implementation procedure) (cadr procedure))
(define (apply-primitive-procedure procedure arguments)
(apply (primitive-implementation procedure) arguments))
(define (empty-arglist) '())
(define (adjoin-arg argument argument-list)
(append argument-list (list argument)))
(define (true? value) value)
(define primitive-bindings
(list (cons '+ +) (cons '- -) (cons '* *) (cons '/ /)
(cons '= =) (cons '< <) (cons '> >)
(cons '<= <=) (cons '>= >=)
(cons 'list list) (cons 'cons cons)
(cons 'car car) (cons 'cdr cdr)
(cons 'null? null?) (cons 'pair? pair?)
(cons 'not not)))
(define (make-global-environment)
(list
(make-frame
(append (map car primitive-bindings) '(true false))
(append
(map (lambda (binding)
(make-primitive (cdr binding)))
primitive-bindings)
(list #t #f)))))
(define (make-evaluator-operations environment)
(list
(cons 'self-evaluating? self-evaluating?)
(cons 'variable? variable?)
(cons 'quoted? quoted?)
(cons 'text-of-quotation text-of-quotation)
(cons 'assignment? assignment?)
(cons 'assignment-variable assignment-variable)
(cons 'assignment-value assignment-value)
(cons 'definition? definition?)
(cons 'definition-variable definition-variable)
(cons 'definition-value definition-value)
(cons 'if? if?)
(cons 'if-predicate if-predicate)
(cons 'if-consequent if-consequent)
(cons 'if-alternative if-alternative)
(cons 'lambda? lambda?)
(cons 'lambda-parameters lambda-parameters)
(cons 'lambda-body lambda-body)
(cons 'begin? begin?)
(cons 'begin-actions begin-actions)
(cons 'application? application?)
(cons 'operator operator)
(cons 'operands operands)
(cons 'no-operands? no-operands?)
(cons 'first-operand first-operand)
(cons 'rest-operands rest-operands)
(cons 'last-operand? last-operand?)
(cons 'lookup-variable-value lookup-variable-value)
(cons 'set-variable-value! set-variable-value!)
(cons 'define-variable! define-variable!)
(cons 'extend-environment extend-environment)
(cons 'make-procedure make-procedure)
(cons 'compound-procedure? compound-procedure?)
(cons 'procedure-parameters procedure-parameters)
(cons 'procedure-body procedure-body)
(cons 'procedure-environment procedure-environment)
(cons 'primitive-procedure? primitive-procedure?)
(cons 'apply-primitive-procedure apply-primitive-procedure)
(cons 'empty-arglist empty-arglist)
(cons 'adjoin-arg adjoin-arg)
(cons 'true? true?)
(cons 'get-global-environment (lambda () environment))))
(define evaluator-controller
'((assign env (op get-global-environment))
(assign continue (label evaluator-done))
(goto (label eval-dispatch))
eval-dispatch
(test (op self-evaluating?) (reg exp))
(branch (label ev-self-eval))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(test (op quoted?) (reg exp))
(branch (label ev-quoted))
(test (op assignment?) (reg exp))
(branch (label ev-assignment))
(test (op definition?) (reg exp))
(branch (label ev-definition))
(test (op if?) (reg exp))
(branch (label ev-if))
(test (op lambda?) (reg exp))
(branch (label ev-lambda))
(test (op begin?) (reg exp))
(branch (label ev-begin))
(test (op application?) (reg exp))
(branch (label ev-application))
ev-self-eval
(assign val (reg exp))
(goto (reg continue))
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(goto (reg continue))
ev-quoted
(assign val (op text-of-quotation) (reg exp))
(goto (reg continue))
ev-lambda
(assign unev (op lambda-parameters) (reg exp))
(assign exp (op lambda-body) (reg exp))
(assign val (op make-procedure) (reg unev) (reg exp) (reg env))
(goto (reg continue))
ev-application
(save continue)
(save env)
(assign unev (op operands) (reg exp))
(save unev)
(assign exp (op operator) (reg exp))
(assign continue (label ev-appl-did-operator))
(goto (label eval-dispatch))
ev-appl-did-operator
(restore unev)
(restore env)
(assign argl (op empty-arglist))
(assign proc (reg val))
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(save proc)
ev-appl-operand-loop
(save argl)
(assign exp (op first-operand) (reg unev))
(test (op last-operand?) (reg unev))
(branch (label ev-appl-last-arg))
(save env)
(save unev)
(assign continue (label ev-appl-accumulate-arg))
(goto (label eval-dispatch))
ev-appl-accumulate-arg
(restore unev)
(restore env)
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(goto (label ev-appl-operand-loop))
ev-appl-last-arg
(assign continue (label ev-appl-accum-last-arg))
(goto (label eval-dispatch))
ev-appl-accum-last-arg
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc)
(goto (label apply-dispatch))
apply-dispatch
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
primitive-apply
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(restore continue)
(goto (reg continue))
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment) (reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))
ev-begin
(assign unev (op begin-actions) (reg exp))
(save continue)
ev-sequence
(assign exp (op first-operand) (reg unev))
(test (op last-operand?) (reg unev))
(branch (label ev-sequence-last-exp))
(save unev)
(save env)
(assign continue (label ev-sequence-continue))
(goto (label eval-dispatch))
ev-sequence-continue
(restore env)
(restore unev)
(assign unev (op rest-operands) (reg unev))
(goto (label ev-sequence))
ev-sequence-last-exp
(restore continue)
(goto (label eval-dispatch))
ev-if
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(goto (label eval-dispatch))
ev-if-decide
(restore continue)
(restore env)
(restore exp)
(test (op true?) (reg val))
(branch (label ev-if-consequent))
(assign exp (op if-alternative) (reg exp))
(goto (label eval-dispatch))
ev-if-consequent
(assign exp (op if-consequent) (reg exp))
(goto (label eval-dispatch))
ev-assignment
(assign unev (op assignment-variable) (reg exp))
(save unev)
(assign exp (op assignment-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-assignment-1))
(goto (label eval-dispatch))
ev-assignment-1
(restore continue)
(restore env)
(restore unev)
(perform (op set-variable-value!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-definition
(assign unev (op definition-variable) (reg exp))
(save unev)
(assign exp (op definition-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-definition-1))
(goto (label eval-dispatch))
ev-definition-1
(restore continue)
(restore env)
(restore unev)
(perform (op define-variable!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
evaluator-done
(halt)))
(define (make-evaluator-machine)
(let ((environment (make-global-environment)))
(let ((machine
(make-machine
'(exp env val proc argl continue unev)
(make-evaluator-operations environment)
evaluator-controller)))
(state-set! machine 'global-environment environment)
machine)))
(define (run-program program)
(let ((machine (make-evaluator-machine)))
(set-register-contents! machine 'exp program)
(start! machine)
machine))
(define core-machine
(run-program '(+ 10 (* 2 16))))
(define tail-small-machine
(run-program
'(begin
(define (sum-iter n total)
(if (= n 0)
total
(sum-iter (- n 1) (+ total n))))
(sum-iter 5 0))))
(define tail-large-machine
(run-program
'(begin
(define (sum-iter n total)
(if (= n 0)
total
(sum-iter (- n 1) (+ total n))))
(sum-iter 20 0))))
(define state-machine
(run-program
'(begin
(define total 4)
(set! total (+ total 5))
(if (> total 8) total 0))))
(define complete-machine
(run-program
'(begin
(define (factorial n)
(if (= n 0) 1 (* n (factorial (- n 1)))))
(define (make-counter start)
(lambda ()
(begin
(set! start (+ start 1))
start)))
(define counter (make-counter 40))
(list (factorial 5) (counter) (counter)))))
(list
(list 'core
(get-register-contents core-machine 'val)
(stack-empty? core-machine)
(> (state-ref core-machine 'instruction-count) 0))
(list 'tail
(get-register-contents tail-small-machine 'val)
(get-register-contents tail-large-machine 'val)
(= (state-ref tail-small-machine 'max-depth)
(state-ref tail-large-machine 'max-depth))
(stack-empty? tail-small-machine)
(stack-empty? tail-large-machine))
(list 'state
(get-register-contents state-machine 'val)
(lookup-variable-value
'total
(state-ref state-machine 'global-environment))
(stack-empty? state-machine))
(list 'run
(get-register-contents complete-machine 'val)
(stack-empty? complete-machine)
(> (state-ref complete-machine 'max-depth) 0))))Examples
Result—
- Output
- —
- Value
- —
- Diagnostic
- —
Execution trace0 / 0 events
The program returns ((core 42 #t #t) (tail 15 210 #t #t #t) (state 9 9 #t) (run (120 41 42) #t #t)). The tail equality records the measured maximum evaluator-stack depth for n = 5 and n = 20 in this controller.
Follow eval-dispatch into the syntax-specific labels, then locate save and restore around operator and operand evaluation. In the tail runs, watch ev-sequence-last-exp restore continue before the recursive application begins. In the state run, follow definition and assignment value evaluation before the global binding changes. In the final run, distinguish the recursive factorial stack from the counter closure’s mutated captured binding and verify the machine halts with no saved evaluator values left.
Change the program and compare the result.
Add a tail-recursive product-iter procedure and run it with two different input sizes. Compare maximum stack depth, final values, and empty-stack status with the shipped sum-iter observations.
Show hint
Keep the recursive call as the final expression of the procedure body. If another operation waits after that call, the controller must preserve additional unfinished work.
Complete this lesson
0 of 23 lessons complete in this chapter0%