평가기의 제어가 레지스터와 레이블과 스택 규약이 된다.
레지스터 기계 컨트롤러는 eval과 apply를 직접 구현할 수 있습니다. exp와 env와 val과 proc과 argl과 continue와 unev 레지스터는 평가기 상태를 드러내고, 레이블과 스택은 문법 디스패치와 적용과 수열과 조건식과 대입과 정의 사이의 미완료 작업을 보존합니다.
생각해 볼 질문
평가기가 호스트 언어 재귀로 표현되지 않고 모든 continuation을 직접 보존해야 할 때 무엇이 달라질까요?
- 명시적인 eval-dispatch 컨트롤러로 guest 문법 디스패치하기
- exp, env, val, proc, argl, continue, unev에 평가기 데이터 전달하기
- 연산자와 피연산자의 미완료 작업을 기계 스택에 저장하고 복원하기
- 원시 프로시저와 표현된 복합 프로시저를 별도 컨트롤러 경로로 적용하기
- 수열의 마지막 식을 평가하기 전에 continue 복원하기
- 길이가 다른 두 꼬리 재귀 실행에서 같은 최대 스택 깊이 관찰하기
- if와 set!과 define을 명시적인 컨트롤러 레이블로 처리하기
- 완전한 guest 프로그램을 실행하고 빈 평가기 스택으로 halt하기
컨트롤러는 전역 환경과 마지막 continuation을 불러온 뒤 exp에 들어 있는 식의 종류를 반복해서 디스패치합니다. 단순한 값은 결과를 val에 넣고 continue를 따라갑니다. 적용은 호출자의 continuation과 환경을 저장하고 연산자와 피연산자를 평가해 argl을 만든 뒤 apply-dispatch로 들어갑니다. 원시 프로시저는 호스트 구현을 호출하고 복합 프로시저는 새 환경을 설치한 뒤 본문을 ev-sequence로 보냅니다.
수열 평가는 ev-sequence-last-exp가 마지막 식을 eval-dispatch로 보내기 전에 호출자의 continuation을 복원하므로 꼬리 재귀입니다. 따라서 두 sum-iter 실행은 재귀 호출 수가 달라도 측정한 평가기 최대 스택 깊이가 같습니다. 별도의 컨트롤러 경로는 if와 set!과 define 주변의 식과 환경과 continuation을 저장하고 복원합니다. 마지막 guest 프로그램은 재귀와 어휘 클로저 상태와 변경을 함께 실행하고 빈 스택으로 멈춥니다. 이 관찰은 유한 시뮬레이터와 선택한 컨트롤러의 정확한 상태 변화를 기록합니다.
SICP 코드UTF-8 22,000 / 1,048,576바이트
(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))))예제
결과—
- 출력
- —
- 값
- —
- 진단
- —
실행 추적0 / 0 개 이벤트
프로그램은 ((core 42 #t #t) (tail 15 210 #t #t #t) (state 9 9 #t) (run (120 41 42) #t #t))을 반환합니다. tail의 #t는 n = 5와 n = 20에서 측정한 평가기 최대 스택 깊이가 같다는 관찰을 기록합니다.
eval-dispatch에서 문법별 레이블로 이동한 뒤 연산자와 피연산자 평가 주변의 save와 restore를 찾으세요. tail 실행에서는 재귀 적용이 시작되기 전에 ev-sequence-last-exp가 continue를 복원하는지 확인하세요. state 실행에서는 전역 바인딩이 바뀌기 전에 정의와 대입 값이 평가되는 경로를 따라가세요. 마지막 실행에서는 재귀 factorial 스택과 counter 클로저가 캡처한 바인딩의 변경을 구분하고 저장된 평가기 값 없이 기계가 halt하는지 확인하세요.
프로그램을 수정하고 결과를 비교해 보세요.
꼬리 재귀 product-iter를 추가하고 서로 다른 두 입력 크기로 실행하세요. 최대 스택 깊이와 최종 값과 빈 스택 상태를 제공된 sum-iter 관찰과 비교하세요.
힌트 보기
재귀 호출을 프로시저 본문의 마지막 식으로 유지하세요. 호출 뒤에 다른 연산이 기다리면 컨트롤러는 미완료 작업을 더 보존해야 합니다.
이 수업 완료하기
이 장의 총 23개 수업 중 0개 완료0%