(wat-aro)2016/01/08
遅延評価と末尾再帰フィボナッチ
前回のSICP問題4.29で遅延評価する評価器でメモ化しない場合に，する場合と比べてはるかに遅くなるプログラムの例としてフィボナッチを書きました．
ただ，あまりに差が大きくてなぜそうなるのかがわからなかったので考えてみました．
評価器は最後に載せておきます．
フィボナッチの定義は以下の通り，末尾再帰で書いています．
(define (fib n)
(let iter ((a 0) (b 1) (count n))
(if (= count 0)
a
(iter b (+ a b) (- count 1)))))
メモ化した場合は
;;; M-Eval input:
(fib 10000)
;(time (actual-value input the-global-environment))
; real 0.190
; user 0.190
; sys 0.000
;;; M-Eval value:
33644764876431783266621612005107543310302148460680063906564769974680081442166662368155595513633734025582065332680836159373734790483865268263040892463056431887354544369559827491606602099884183933864652731300088830269235673613135117579297437854413752130520504347701602264758318906527890855154366159582987279682987510631200575428783453215515103870818298969791613127856265033195487140214287532698187962046936097879900350962302291026368131493195275630227837628441540360584402572114334961180023091208287046088923962328835461505776583271252546093591128203925285393434620904245248929403901706233888991085841065183173360437470737908552631764325733993712871937587746897479926305837065742830161637408969178426378624212835258112820516370298089332099905707920064367426202389783111470054074998459250360633560933883831923386783056136435351892133279732908133732642652633989763922723407882928177953580570993691049175470808931841056146322338217465637321248226383092103297701648054726243842374862411453093812206564914032751086643394517512161526545361333111314042436854805106765843493523836959653428071768775328348234345557366719731392746273629108210679280784718035329131176778924659089938635459327894523777674406192240337638674004021330343297496902028328145933418826817683893072003634795623117103101291953169794607632737589253530772552375943788434504067715555779056450443016640119462580972216729758615026968443146952034614932291105970676243268515992834709891284706740862008587135016260312071903172086094081298321581077282076353186624611278245537208532365305775956430072517744315051539600905168603220349163222640885248852433158051534849622434848299380905070483482449327453732624567755879089187190803662058009594743150052402532709746995318770724376825907419939632265984147498193609285223945039707165443156421328157688908058783183404917434556270520223564846495196112460268313970975069382648706613264507665074611512677522748621598642530711298441182622661057163515069260029861704945425047491378115154139941550671256271197133252763631939606902895650288268608362241082050562430701794976171121233066073310059947366875
メモ化していない場合は
;;; M-Eval input:
(fib 30)
;(time (actual-value input the-global-environment))
; real 6.628
; user 6.620
; sys 0.010
;;; M-Eval value:
832040メモ化していない場合になぜこれだけ遅いかを検証します．
(iter 0 1 30)から考えます．
(if (= count 0)
a
(iter b (+ a b) (- count 1)))
なのでまずa b countはそれぞれ(thunk 0) (thunk 1) (thunk 30)となります．
(define (eval-if exp env)
(if (true? (actual-value (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
なのでpredicateが評価され，countは30となります．
次のiterが呼ばれます．この時のa b countは(thunk 1) (thunk (+ (thunk 0) (thunk 1))) (thunk (- 30 1))です．
これがcountが0になるまで続けられます．
countが0になるとifのconsequentが評価されます．
ここで初めてaが評価されることになります．
この時にはaには二つ上のthunkとさらに一つ上のthunkを足したものが再帰的になったthunkが入っています．
bには一つ上のthunkとさらに一つ上のthunkを足したものが再帰的になったthunkが入っています．
つまり，(+ (fib (- n 1)) (fib (- n 2)))を計算するのと同じような計算が必要になります．
メモ化していない場合はこれらをすべて計算していくことになります．
メモ化している場合はそれぞれの階層のiterの環境にbindされている手続きがevaluated-thunkと値に置き換えられていくので無駄な計算が生じません．
遅延評価だと引数は必要になるまで評価されないので末尾再帰で書いてもメモ化しない場合はあまり効率的にはなりません．
[評価器]
(define true #t)
(define false #f)
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((let? exp) (eval (let->combination exp) env))
((let*? exp) (eval (let*->nested-lets exp) env))
((letrec? exp) (eval (letrec->let exp) env)) ;;letrecを追加
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((and? exp) (eval-and exp env))
((or? exp) (eval-or exp env))
((application? exp)
(my-apply (actual-value (operator exp) env)
(operands exp)
env)
;; (my-apply (eval (operator exp) env)
;; (list-of-values (operands exp) env))
)
(else
(error "Unknown expression type --EVAL" exp))))
;; メモ化する評価器
(define (force-it obj)
(cond ((thunk? obj)
(let ((result (actual-value (thunk-exp obj)
(thunk-env obj))))
(set-car! obj 'evaluated-thunk)
(set-car! (cdr obj) result) ;;expをその値で置き換える
(set-cdr! (cdr obj) '()) ;;必要のなくなったenvを忘れる
result))
((evaluated-thunk? obj) (thunk-value obj))
(else obj)))
;; メモ化しない評価器
;; (define (force-it obj)
;; (if (thunk? obj)
;; (actual-value (thunk-exp obj) (thunk-env obj))
;; obj))
(define (delay-it exp env) (list 'thunk exp env))
(define (thunk? exp) (tagged-list? exp 'thunk))
(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))
(define (evaluated-thunk? obj) (tagged-list? obj 'evaluated-thunk))
(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
(define (actual-value exp env)
(force-it (eval exp env)))
(define (foo bar)
(bar 'a))
;; apply
(define (my-apply procedure arguments env)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure
procedure
(list-of-arg-values arguments env))) ; changed
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment (procedure-parameters procedure)
(list-of-delayed-args arguments env) ; changed
(procedure-environment procedure))))
(else (error "Unknown procedure type: APPLY" procedure))))
(define (list-of-arg-values exps env)
(if (no-operands? exps)
'()
(cons (actual-value (first-operand exps) env)
(list-of-arg-values (rest-operands exps) env))))
(define (list-of-delayed-args exps env)
(if (no-operands? exps)
'()
(cons (delay-it (first-operand exps) env)
(list-of-delayed-args (rest-operands exps) env))))
(define (eval-if exp env)
(if (true? (actual-value (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(define (eval-sequence exps env)
(cond ((last-exp? exps) (eval (first-exp exps) env))
(else (eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env))))
;; 代入
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env)
'ok)
;; 定義
(define (eval-definition exp env)
(define-variable!
(definition-variable exp)
(eval (definition-value exp) env)
env)
'ok)
;; 自己評価式
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
(else false)))
;; 変数
(define (variable? exp) (symbol? exp))
;; クオート
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
;; 代入
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
;; 定義
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp) ;;仮パラメタ
(cddr exp)))) ;;本体
;; lambda式
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (def-body-list proc-body)
(let iter ((proc-body proc-body)
(def '())
(body '()))
(cond ((null? proc-body) (cons (reverse def) (reverse body)))
((definition? (car proc-body)) (iter (cdr proc-body)
(cons (car proc-body) def)
body))
(else (iter (cdr proc-body)
def
(cons (car proc-body) body))))))
;; ((define u e1) (define v e2) e3 e4)
;; => ((let ((u *unassigned*) (v *unassigned*)) (set! u e1) (set! v e2) e3 e4))
(define (scan-out-defines body)
(define (split-def-body proc-body)
(let iter ((proc-body proc-body)
(def '())
(body '()))
(cond ((null? proc-body) (cons (reverse def) (reverse body)))
((definition? (car proc-body)) (iter (cdr proc-body)
(cons (car proc-body) def)
body))
(else (iter (cdr proc-body)
def
(cons (car proc-body) body))))))
(let* ((def-body-list (split-def-body body))
(def-list (car def-body-list))
(body-list (cdr def-body-list)))
(if (null? def-list)
body
(list (make-let (map (lambda (x) (list (definition-variable x) ''*unassigned*))
def-list)
(append (map (lambda (x) (list 'set! (definition-variable x)
(definition-value x)))
def-list)
body-list))))))
;; if
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
;; begin
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
;; 任意の合成式
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
;; 派生式
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF" clauses))
(let ((action (cond-actions first))
(predicate (cond-predicate first)))
(make-if predicate
(if (eq? (car action) '=>)
(list (cadr action) predicate)
(sequence->exp action))
(expand-clauses rest)))))))
;; and
(define (and? exp) (tagged-list? exp 'and))
(define (and-clauses exp) (cdr exp))
(define (eval-and exp env)
(let iter ((clauses (and-clauses exp)))
(if (null? clauses)
'true
(let ((first (eval (car clauses) env)))
(cond ((null? (cdr clauses)) first)
(first (iter (cdr clauses)))
(else 'false))))))
;; or
(define (or? exp) (tagged-list? exp 'or))
(define (or-clauses exp) (cdr exp))
(define (eval-or exp env)
(let iter ((clauses (or-clauses exp)))
(if (null? clauses)
'false
(let ((first (eval (car clauses) env)))
(cond ((null? (cdr clauses)) first)
(first 'true)
(else (iter (cdr clauses))))))))
;; let
(define (let? exp) (tagged-list? exp 'let))
(define (let-parameters exp) (cadr exp))
(define (let-variables exp) (map car (let-parameters exp)))
(define (let-expressions exp) (map cadr (let-parameters exp)))
(define (let-bodys exp) (cddr exp))
(define (let->combination exp)
(if (symbol? (cadr exp)) ;; 2番目の要素がシンボルならnamed-let
(named-let->define (named-let-func-name exp)
(named-let-variables exp)
(named-let-expressions exp)
(named-let-bodys exp))
(cons (make-lambda (let-variables exp)
(let-bodys exp))
(let-expressions exp))))
;; let*
(define (let*? exp) (tagged-list? exp 'let*))
(define (let*-parameters exp) (cadr exp))
(define (let*-variables exp) (map car (let*-parameters exp)))
(define (let*-expressions exp) (map cadr (let*-parameters exp)))
(define (let*-body exp) (cddr exp))
(define (make-let parameters bodys)
(cons 'let (cons parameters bodys)))
(define (let*->nested-lets exp)
(expand-lets (let-parameters exp) (let-bodys exp)))
(define (expand-lets parameters bodys)
(cond ((null? parameters) (error "EXPAND-LETS required pair, but " parameters))
((null? (cdr parameters))
(make-let (list (car parameters))
bodys))
(else (make-let (list (car parameters))
(list (expand-lets (cdr parameters) bodys))))))
;; named-let
(define (named-let? exp) (symbol? (cadr exp)))
(define (named-let-func-name exp) (cadr exp))
(define (named-let-parameters exp) (caddr exp))
(define (named-let-variables exp) (map car (named-let-parameters exp)))
(define (named-let-expressions exp) (map cadr (named-let-parameters exp)))
(define (named-let-bodys exp) (cdddr exp))
(define (make-definition variable value)
(list 'define variable value))
(define (named-let->define func-name variables expressions bodys)
(make-begin (list (make-definition func-name (make-lambda variables bodys))
(cons func-name expressions))))
;; 術後のテスト
(define (true? x)
(not (eq? x '#f)))
(define (false? x)
(eq? x '#f))
;; 手続きの表現
(define (make-procedure parameters body env)
(list 'procedure parameters (scan-out-defines body) env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
;; 環境に対する操作
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())
;; フレーム
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (frame-variables frame)))
(set-cdr! frame (cons val (frame-values frame))))
;; 変数を値に対応づける新しいフレーム
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(if (eq? (car vals) '*unassigned*)
(error "*Unassigned* variable" var)
(car vals)))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
(list '= =)
(list '- -)
(list '+ +)
(list '* *)
(list '/ /)))
(define (primitive-procedure-names)
(map car primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
(define apply-in-underlying-scheme apply)
;; 環境
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true #t initial-env)
(define-variable! 'false #f initial-env)
initial-env))
(define the-global-environment (setup-environment))
(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output (time (actual-value input the-global-environment)))) ;; test用にtimeマクロを入れている
(announce-output output-prompt)
(user-print output)))
(driver-loop))
(define (prompt-for-input string)
(newline)
(newline)
(display string)
(newline))
(define (announce-output string)
(newline)
(display string)
(newline))
(define (user-print object)
(if (compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>))
(display object)))
;; lambda式
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (def-body-list proc-body)
(let iter ((proc-body proc-body)
(def '())
(body '()))
(cond ((null? proc-body) (cons (reverse def) (reverse body)))
((definition? (car proc-body)) (iter (cdr proc-body)
(cons (car proc-body) def)
body))
(else (iter (cdr proc-body)
def
(cons (car proc-body) body))))))
(define (letrec? exp) (tagged-list? exp 'letrec))
(define (letrec-parameters exp) (cadr exp))
(define (letrec-variables exp) (map car (letrec-parameters exp)))
(define (letrec-expressions exp) (map cadr (letrec-parameters exp)))
(define (letrec-body exp) (cddr exp))
(define (letrec->let exp)
(make-let (map (lambda (x) (list x ''*unassigned*))
(letrec-variables exp))
(append (map (lambda (x y) (list 'set! x y))
(letrec-variables exp)
(letrec-expressions exp))
(letrec-body exp))))