SICP 5.5.7 Interfacing Compiled Code to the Evaluator / Exercise 5.52
ノート
Exercise 5.52
C言語でShemeコンパイラを作れと言っているのではなく、この章のコンパイラをCのプログラムを吐く様に改造せよと言っている。
ここでもswiftを使う事にする。
直ぐに気づく問題点は
- レジスタマシンやアセンブラのレベルに変換する訳ではないのでプログラムの構造は殆どそのまま変換すれば良い
- と言う事は「使うレジスタ」とか「値を保存するレジスタ」とかの指定はおそらく不要。リンケージは要る。
- 識別子（シンボル）：Schemeでは-とか!とかを識別子の一部に使えるけど、大抵の他の言語では使えないので変換する必要がある。
- コンパイラの出力形態：データとしてはリストしか持てないので、おそらくシンボルのリストを作って、最終段で文字列にへ関して出力する事になる。
まずは、Metacircular Evaluatorを手で、しかも極力機械的に変換して、更に補助的な関数を色々と加えて動く所まで持って行く。
実際に作業するにして変換に必要だった作業は以下の通り：
- Schemeの変数には型がないので環境も含めて全ての値は一つのデータ型で表す
- condはcond->ifでifの連続に変換してコンパイルする
- 関数名の?は"p"に変換
- 関数名の->は"_to_"に変換
- 関数名の!は削除する
- 関数名が予約後の場合には後ろに"_"を追加
- 関数の引数は全てExpression型、関数値も全てExpresion型（Ex 5.51のResult型のエラーはExpressionで表現）
- defineは変数の定義と関数の定義を別に扱う必要がある。swiftでクロージャーが自分自身を参照出来ないため。
- '()はExpression.LIST([])
- リンケージがreturnの場合はreturn
- シンボル'ok / 'quoteはExpression.SYMBOL("ok")などに変換
- true / falseはExpression.BOOLEAN(true) / Expression.BOOLEAN(false)に変換
- letはそのままswiftのletを使う
- ifをそのままswiftのifに変換すると、predicateの部分はExpression型では駄目でBoolにする必要がある。?が付く手続きの戻り値の型を常にBoolとする約束にする事も出来るが、swfitのifの条件式は常にExpression.BOOLEAN(true)と同じかをチェックするコードを吐く事にする。
- 環境とプリミティブとの橋渡しは実行環境の一部なのでコンパイルの対象とはしない。
関数の定義はクロージャが自分自身を参照出来ないので以下の様なスタイルにする。これだと関数内の関数も問題なく動作する。
var func1: (Int -> Int) = {n in return 0} func1 = {n in var inner: (Int -> Int) = {n in return 0} inner = {n in if n > 1 { return n * inner(n - 1) } else { return n } } return inner(n) } func1(6)
また、swiftでは後方で定義される関数や変数を参照出来ないので、クロージャをバインドする変数を最初に全て定義してしまってから、クロージャをバインドし直す形にする。
mutableのリストが作れないので、環境だけはExercise 5.51と同様に環境オブジェクトを使うプリミティブを用意する。
とりあえず動かす事は出来た。こんな感じ。
;;; M-Eval input: (define (factorial n)
(if (= n 1)
1
(* (factorial (- n 1)) n)))
;;; M-Eval value:
ok
;;; M-Eval input: (factorial 6)
;;; M-Eval value:
720
;;; M-Eval input: 次に、これと同じコードを吐き出す様にコンパイラを改造する。
元のレジスタマシンはS式がそのままプログラムだったが、swiftにする為には文字列にして、最後に連結して出力する事にする。
(define (print-result instructions) (for-each (lambda (s) (if (pair? s) (print-result s) (display s))) instructions))
【target】
これは要らない。
【linkage】
gotoでジャンプする事は無いので、'nextならただ式を吐き出す、'returnなら「return 式」と言う文を吐き出す。compile-linkageは不要で、end-with-linkageをシンプルに以下の様にする。
(define (end-with-linkage linkage instruction-sequence) (if (eq? linkage 'return) (list "return " insruction-sequence) instruction-sequence))
【self-evaluating】
Metacircular Evaluatorには数値のリテラルは出て来ず、文字列しか出て来ない。例えばevalの最後のerrorの呼び出しは
(error "Unknown expression type -- EVAL" exp)
これを
error("Unknown expression type -- EVAL", exp)
こう変換したい。文字列をdisplayすると文字列の中身だけになってしまうので文字列リテラルにする必要がある。一方数値はそのまま出力すれば良いのでcompile-numberとcompile-stringに分割して、self-evaluating?を呼び出す部分もnumber?とstring?に分割する。
(define (compile-number exp linkage) (end-with-linkage linkage (list exp))) (define (compile-string exp linkage) (end-with-linkage linkage (list "\"" exp "\"")))
【quoted】
Metacircular Evaluatorのコードに登場するquote（シンボルかquoteされたリスト）は'okとか'quoteとか'lambdaとか。
'ok
は
Expression.SYMBOL("ok")
だし
(tagged-list? exp 'quote)
は
tagged_list_p(exp, Expression.SYMBOL("quote"))
と変換したので、一つのシンボルであればそのままExpressionにする。リストであればシンボルのリストに変換する。
(define (compile-symbol exp) (list "Expression.SYMBOL(\"" exp "\")")) (define (compile-list l) (cond ((symbol? l) (compile-symbol l)) ((not (null? l)) (list "Expression.LIST([" (add-between (map compile-list l) ",") "])")) (else (list "Expression.LIST([])")))) (define (compile-quoted exp linkage) (end-with-linkage linkage (compile-list (text-of-quotation exp))))
【variable】
Metacircular Evaluatorのプログラムの変数あるいは手続き名。手作業コンパイルの時と同様に変換しなければならない。
変数名は定義している部分と参照している部分があり、evalを通るのは参照している側だけなので、compile-variableと名前を変換する手続きは分離する。
(define (generate-identifier sym) (define (replace str) (cond ((equal? str "var") "var_") ((equal? str "operator") "operator_") ((equal? str "true") "true_") ((equal? str "false") "false_") (else (let ((lst (string->list str))) (list->string (map (lambda (c) (cond ((equal? c #\-) #\_) ((equal? c #\?) #\p) ((equal? c #\!) #\b) ((equal? c #\>) #\_) (else c))) lst)) )))) (string->symbol (replace (symbol->string sym)))) (define (compile-variable exp linkage) (end-with-linkage linkage (list (generate-identifier exp))))
この手続きの都合（mapを使っているので一文字を一文字にしか変換できない）により->は__、!はbに、?はpに変換する事にする。
Racketではtrueとfalseは予約語の様にあらかじめ定義されたシンボルでquoteの必要がないのであたかも変数の様に書かれる。しかもこれらはswiftでも予約語なので_を付けて変換した上で、true_とfalse_を定義しておく。
var true_ = Expression.BOOLEAN(true) var false_ = Expression.BOOLEAN(false)
【assignment】
Metacircular Evaluatorのコードにset!は登場しないが、単に代入で良いはず。ただし変数名は変換が必要。
(define (compile-assignment exp linkage) (list (generate-identifier (assignment-variable exp)) " = " (compile (assignment-value exp) 'next)))
代入文は値を持たないはずなのでlinkageのコードは吐かない。
【definition】
変数の場合は単に代入文で良いが、手続きの場合は一旦変数を一時的な手続きで初期化してから代入し直す必要がある（再帰をサポートする為）。手続きをバインドする変数は、後方で定義される手続きを呼び出せるようにする為にコードの最初に定義する必要がある。predefined-variablesに登録しておき、最後に別途出力する事にする。
(define predefined-variables (make-hash)) (define (generate-arg-type-list n) (define (generate-list n) (if (= n 0) '() (cons "Expression" (generate-list (- n 1))))) (apply string-append (add-between (generate-list n) ","))) (define (compile-definition exp linkage) (let ((value (definition-value exp))) (if (lambda? value) (begin (dict-set! predefined-variables (generate-identifier (definition-variable exp)) (string-append ": (" (generate-arg-type-list (length (lambda-parameters value))) ") -> Expression = {_ in Expression.SYMBOL(\"undefined\")}")) (list (generate-identifier (definition-variable exp)) " = " (compile value 'next))) (list "var " (compile-assignment exp linkage))) )) (define (print-pridefined-variables) (for-each (lambda (k) (display "var ")(display k)(display (dict-ref predefined-variables k))(newline)) (dict-keys predefined-variables)))
【if】
ifの形式に変換するだけ。書式も殆ど変わらない。
(define (compile-if exp linkage) (list "if " (compile (if-predicate exp) 'next) ".isTrue() {" (compile (if-consequent exp) linkage) "} else {" (compile (if-alternative exp) linkage) "}"))
【begin】
ここは元のコードとあまり変わらない。文を区切るセミコロンを挟む必要がある。
(define (compile-sequence seq linkage) (if (last-exp? seq) (compile (first-exp seq) linkage) (add-between (list (compile (first-exp seq) 'next) (compile-sequence (rest-exps seq) linkage)) ";")))
【lambda】
クロージャの形式に変換するだけ。
(define (compile-lambda exp linkage) (list "{" (add-between (map symbol->string (lambda-parameters exp)) ",") " in " (compile-sequence (lambda-body exp) 'return) "}" ))
【application】
引数をコンパイルして関数呼び出しの形に変換するだけ。
(define (compile-application exp linkage) (end-with-linkage linkage (list (compile (operator exp) 'next) "(" (add-between (map (lambda (operand) (compile operand 'next)) (operands exp)) ",") ")")))
【let】
expand-clausesがletを使っているのでcompileもletをサポートする必要がある。ただ、letを単にラムダ式に展開して、そのまま呼び出す事は出来ないので、普通に変数を定義する文にコンパイルする。
(define (let? exp) (tagged-list? exp 'let)) (define (let-variables exp) (cadr exp)) (define (let-body exp) (cddr exp)) (define (compile-let exp linkage) (list (add-between (map (lambda (v) (list "var " (compile (car v) 'next) " = " (compile (cadr v) 'next))) (let-variables exp)) ";") ";" (compile-sequence (let-body exp) linkage)))
【compile】
ここは殆どtargetを省略しただけ。
(define (compile exp linkage) (cond ((number? exp) (compile-number exp linkage)) ((string? exp) (compile-string exp linkage)) ((quoted? exp) (compile-quoted exp linkage)) ((variable? exp) (compile-variable exp linkage)) ((assignment? exp) (compile-assignment exp linkage)) ((definition? exp) (compile-definition exp linkage)) ((if? exp) (compile-if exp linkage)) ((lambda? exp) (compile-lambda exp linkage)) ((begin? exp) (compile-sequence (begin-actions exp) linkage)) ((cond? exp) (compile (cond->if exp) linkage)) ((let? exp) (compile (let->combination exp) linkage)) ((application? exp) (compile-application exp linkage)) (else (error "Unknown expression type -- COMPILE" exp))))
これを使って4.1.1〜4.1.3のコードをコンパイルして行く。出力されたコードをX-codeの方に手動でコピペするするところがちょっと情けない。
例えば
(print-result (compile '(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)) ((begin? exp) (eval-sequence (begin-actions exp) env)) ((cond? exp) (eval (cond->if exp) env)) ((application? exp) (apply (eval (operator exp) env) (list-of-values (operands exp) env))) (else (error "Unknown expression type -- EVAL" exp)))) 'return))(newline)
の出力結果
eval = {exp,env in if self_evaluatingp(exp).isTrue() {exp} else {if variablep(exp).isTrue() {lookup_variable_value(exp,env)} else {if quotedp(exp).isTrue() {text_of_quotation(exp)} else {if assignmentp(exp).isTrue() {eval_assignment(exp,env)} else {if definitionp(exp).isTrue() {eval_definition(exp,env)} else {if ifp(exp).isTrue() {eval_if(exp,env)} else {if lambdap(exp).isTrue() {make_procedure(lambda_parameters(exp),lambda_body(exp),env)} else {if beginp(exp).isTrue() {eval_sequence(begin_actions(exp),env)} else {if condp(exp).isTrue() {eval(cond__if(exp),env)} else {if applicationp(exp).isTrue() {apply(eval(operator_(exp),env),list_of_values(operands(exp),env))} else {error("Unknown expression type -- EVAL",exp)}}}}}}}}}}}
最後にpredefined-variablesを出力してコンパイルしたコードの先頭に挿入する。
(print-pridefined-variables)
var beginp: (Expression) -> Expression = {_ in Expression.SYMBOL("undefined")} var condp: (Expression) -> Expression = {_ in Expression.SYMBOL("undefined")} var definition_value: (Expression) -> Expression = {_ in Expression.SYMBOL("undefined")} var cond_else_clausep: (Expression) -> Expression = {_ in Expression.SYMBOL("undefined")} （以下省略）
サポートする部分のコードは以下の通り。
enum Expression { case BOOLEAN(Bool) case NUMBER(Int) case STRING(String) case SYMBOL(String) case LIST([Expression]) case ENVIRONMENT(Environment) case PRIMITIVE(([Expression]->Expression)) case ERROR(String) } extension Expression { var list: Optional<[Expression]> { switch self { case let .LIST(l): return .Some(l) default: return .None } } var environment: Optional<Environment> { switch self { case let .ENVIRONMENT(e): return .Some(e) default: return .None } } var primitive: Optional<([Expression] -> Expression)> { switch self { case let .PRIMITIVE(p): return .Some(p) default: return .None } } func description() -> String { switch self { case let .BOOLEAN(b): return b.description case let .NUMBER(n): return n.description case let .STRING(s): return "\"" + s + "\"" case let .SYMBOL(s): return s case let .LIST(list): return "(" + join(" ", list.map({$0.description()})) + ")" case let .ENVIRONMENT(env): return env.description() case let .PRIMITIVE(p): return "procedure" case let .ERROR(s): return s } } func isTrue() -> Bool { switch self { case let .BOOLEAN(b): return b default: return false } } } func == (a: Expression, b: Expression) -> Bool { switch (a, b) { case let (.BOOLEAN(x), .BOOLEAN(y)): return x == y case let (.NUMBER(x), .NUMBER(y)): return x == y case let (.STRING(x), .STRING(y)): return x == y case let (.SYMBOL(x), .SYMBOL(y)): return x == y case let (.ERROR(x), .ERROR(y)): return y == y default: // LIST, PRIMITIVE, ENVIRONMENT return false } } func error(msg: String, args: Expression...) -> Expression { return Expression.ERROR(msg + ":" + " ".join(args.map({$0.description()}))) } class Environment { var frame = Dictionary<String, Expression>() var parent:Environment? = nil func add(sym:String, exp:Expression) -> Expression { frame[sym] = exp return Expression.ENVIRONMENT(self) } func value(sym:String) -> Expression { switch frame[sym] { case let .Some(exp): return exp default: if parent != nil { return parent!.value(sym) } else { return error("Unbound variable: " + sym) } } } func extend(vars: [Expression], values: [Expression]) -> Environment { var newEnv = Environment() newEnv.parent = self for (variable, value) in Array(Zip2(vars, values)) { switch variable { case let .SYMBOL(sym): newEnv.add(sym, exp: value) default: continue } } return newEnv } func description() -> String { return frame.description } } func extend_environment(variables: Expression, values: Expression, base_env: Expression) -> Expression { switch (variables, values, base_env) { case let (.LIST(vars), .LIST(vals), .ENVIRONMENT(env)): return Expression.ENVIRONMENT(env.extend(vars, values: vals)) default: return error("Wrong environment") } } func lookup_variable_value(variable: Expression, environment: Expression) -> Expression { switch (variable, environment) { case let (.SYMBOL(sym), .ENVIRONMENT(env)): return env.value(sym) default: return error("Wrong variable reference") } } func set_variable_valueb(variable: Expression, value: Expression, environment: Expression) -> Expression { switch (variable, environment) { case let (.SYMBOL(sym), .ENVIRONMENT(env)): return env.add(sym, exp: value) default: return error("Wrong variable reference") } } func define_variableb(variable: Expression, value: Expression, environment: Expression) -> Expression { return set_variable_valueb(variable, value, environment) } // Primitive Procedures func _car<Any>(list: [Any]) -> Any { return list[0] } func _cdr<Any>(list:[Any]) -> [Any] { if list.endIndex == 1 { return [] } else { return Array(list[1...(list.count - 1)]) } } func apply_number(argl:[Expression], op:((Int, Expression)->Int)) -> Expression { switch argl[0] { case let .NUMBER(initialValue): return Expression.NUMBER(_cdr(argl).reduce(initialValue, combine: op)) default: return Expression.BOOLEAN(false) } } func plus(argl:[Expression]) -> Expression { return apply_number(argl, {value, arg in switch arg { case let .NUMBER(n): return value + n default: return value } }) } func minus(argl:[Expression]) -> Expression { return apply_number(argl, {value, arg in switch arg { case let .NUMBER(n): return value - n default: return value } }) } func multiply(argl:[Expression]) -> Expression { return apply_number(argl, {value, arg in switch arg { case let .NUMBER(n): return value * n default: return value } }) } func equal_aux(initValue:Int, argl:[Expression]) -> Bool { if (argl.count > 0) { switch argl[0] { case let .NUMBER(n): return n == initValue && equal_aux(initValue, Array(argl[1..<argl.endIndex])) default: return false } } else { return true } } func equal(argl:[Expression]) -> Expression { switch argl[0] { case let .NUMBER(initialValue): return Expression.BOOLEAN(equal_aux(initialValue, Array(argl[1..<argl.endIndex]))) default: return Expression.BOOLEAN(false) } } func symbolp(exp: Expression) -> Expression { switch exp { case .SYMBOL: return Expression.BOOLEAN(true) default: return Expression.BOOLEAN(false) } } func pairp(exp: Expression) -> Expression { switch exp { case .LIST: return Expression.BOOLEAN(true) default: return Expression.BOOLEAN(false) } } func numberp(exp: Expression) -> Expression { switch exp { case .NUMBER: return Expression.BOOLEAN(true) default: return Expression.BOOLEAN(false) } } func stringp(exp: Expression) -> Expression { switch exp { case .STRING: return Expression.BOOLEAN(true) default: return Expression.BOOLEAN(false) } } func eqp(a: Expression, b: Expression) -> Expression { return Expression.BOOLEAN(a == b) } func if_list(exp: Expression)(op: ([Expression] -> Expression)) -> Expression { switch exp { case let .LIST(list): return op(list) default: return error("Internal software error @op_list: " + exp.description()) } } func not(exp: Expression) -> Expression { switch exp { case .BOOLEAN(let b): return Expression.BOOLEAN(!b) default: return exp } } func nullp(exp: Expression) -> Expression { return if_list (exp) (op: {list in Expression.BOOLEAN(list.isEmpty) }) } func list(args: Expression...) -> Expression { return Expression.LIST(args) } func cons(car: Expression, cdr:Expression) -> Expression { return if_list (cdr) (op:{list in var result = list result.insert(car, atIndex: 0) return Expression.LIST(result) }) } func car(exp: Expression) -> Expression { return if_list (exp) (op: {list in list[0] }) } func cdr(exp: Expression) -> Expression { return if_list (exp) (op: {list in Expression.LIST(_cdr(list)) }) } func cadr(exp: Expression) -> Expression { return if_list (exp) (op: {list in car(Expression.LIST(_cdr(list))) }) } func caadr(exp: Expression) -> Expression { return car(cadr(exp)) } func cddr(exp: Expression) -> Expression { return cdr(cdr(exp)) } func caddr(exp: Expression) -> Expression { return car(cddr(exp)) } func cdadr(exp: Expression) -> Expression { return cdr(cadr(exp)) } func cdddr(exp: Expression) -> Expression { return cdr(cdr(cdr(exp))) } func cadddr(exp: Expression) -> Expression { return car(cdddr(exp)) } func primitive_procedurep(proc: Expression) -> Expression { switch proc { case .PRIMITIVE: return Expression.BOOLEAN(true) default: return Expression.BOOLEAN(false) } } func apply_primitive_procedure(proc: Expression, args: Expression) -> Expression { switch (proc, args) { case let (.PRIMITIVE(p), .LIST(a)): return p(a) default: return error("invalid primitive application") } }
実行環境のサポートは以下の通り
func skip_spaces(input: String) -> String { if input.hasPrefix(" ") { return skip_spaces(input.substringFromIndex(advance(input.startIndex, 1))) } else { return input } } func find_string_end(input: String) -> Int { var i = 1 for c in input.substringFromIndex(advance(input.startIndex, 1)) { if c != "\"" { i++ } else { break } } return i + 1 } func find_word_end(input: String) -> Int { var i = 0 for c in input { if c != " " && c != ")" { i++ } else { break } } return i } func tokenize_one(input: String) -> (String, String) { var w = skip_spaces(input) var i : Int if w.hasPrefix("(") || w.hasPrefix(")") { i = 1 } else if w.hasPrefix("\"") { i = find_string_end(w) } else { i = find_word_end(w) } return (w.substringToIndex(advance(w.startIndex, i)), w.substringFromIndex(advance(w.startIndex, i))) } func tokenize(input: String) -> [String] { let (word, rest) = tokenize_one(input) var list: [String] = [word] if rest.isEmpty || skip_spaces(rest).isEmpty { return list } else { return list + tokenize(rest) } } func parse_list(tokens:[String]) -> ([Expression], [String]) { if tokens[0] == ")" { return ([], _cdr(tokens)) } else { let (val, rest) = parse_token(tokens) var (list, beyond_list) = parse_list(rest) list.insert(val, atIndex: 0) return (list, beyond_list) } } func parse_token(tokens: [String]) -> (Expression, [String]) { if tokens.isEmpty { return (Expression.LIST([]), []) } else if tokens[0] == ")" { return (Expression.LIST([]), _cdr(tokens)) } else if tokens[0] == "(" { let (list, rest) = parse_list(_cdr(tokens)) return (Expression.LIST(list), rest) } else if let n = tokens[0].toInt() { return (Expression.NUMBER(n), _cdr(tokens)) } else if (tokens[0] == "true") { return (Expression.BOOLEAN(true), _cdr(tokens)) } else if (tokens[0] == "false") { return (Expression.BOOLEAN(false), _cdr(tokens)) } else if (tokens[0].hasPrefix("\"")) { var str = tokens[0].substringToIndex(advance(tokens[0].startIndex, count(tokens[0].utf16) - 1)).substringFromIndex(advance(tokens[0].startIndex, 1)) // get rid of quotation marks return (Expression.STRING(str), _cdr(tokens)) } else { return (Expression.SYMBOL(tokens[0]), _cdr(tokens)) } } func parse(input: String) -> Expression { let tokens = tokenize(input) let (value, rest) = parse_token(tokens) return value } func expand_quote(tokens: [String]) -> [String] { if tokens.isEmpty { return [] } else if tokens[0] == "'(" { return ["(", "quote"] + expand_quote(_cdr(tokens)) } else if tokens[0].hasPrefix("'(") { return ["(", "quote", tokens[0].substringFromIndex(advance(tokens[0].startIndex, 2))] + expand_quote(_cdr(tokens)) } else if tokens[0].hasPrefix("'") { return ["(", "quote", tokens[0].substringFromIndex(advance(tokens[0].startIndex, 1)), ")"] + expand_quote(_cdr(tokens)) } else { return [tokens[0]] + expand_quote(_cdr(tokens)) } } func expand_syntax_sugar(tokens: [String]) -> [String] { return expand_quote(tokens) } // REPL func nest(tokens: [String]) -> Int { return tokens.reduce(0, combine: {n, token in switch token { case "(": return n + 1 case ")": return n - 1 default: return n } }) } func read_line() -> String { var str = NSString(data: NSFileHandle.fileHandleWithStandardInput().availableData, encoding: NSUTF8StringEncoding)! as String return str.substringToIndex(advance(str.startIndex, count(str.utf8) - 1)) + " " // replace new line to a space } func read() -> Expression { var input = "" while (true) { input = input + read_line() let tokenized = tokenize(input) let n = nest(tokenized) if n < 0 { return Expression.SYMBOL("Parentheses mismatch") } else if n == 0 { let (value, rest) = parse_token(expand_syntax_sugar(tokenized)) return value } } } func user_print(object: Expression) { if compound_procedurep(object).isTrue() { println(list(Expression.SYMBOL("compound-procedure"), procedure_parameters(object), procedure_body(object), Expression.SYMBOL("<procedure-env>")).description()) } else { println(object.description()) } } var the_global_environment = Expression.ENVIRONMENT(Environment()) if the_global_environment.environment != nil { the_global_environment.environment!.add("true", exp: Expression.BOOLEAN(true)) the_global_environment.environment!.add("false", exp: Expression.BOOLEAN(false)) the_global_environment.environment!.add("+", exp: Expression.PRIMITIVE(plus)) the_global_environment.environment!.add("-", exp: Expression.PRIMITIVE(minus)) the_global_environment.environment!.add("*", exp: Expression.PRIMITIVE(multiply)) the_global_environment.environment!.add("=", exp: Expression.PRIMITIVE(equal)) } func driver_loop() { print(";;; M-Eval input: ") let input = read() let output = eval(input, the_global_environment) println(";;; M-Eval value: ") user_print(output) return driver_loop() } driver_loop()
- サポートコード
- print-pridefined-variablesの出力
- その他のcompileの結果をprint-resultで出力したもの
- 下記の実行環境サポート
の順でX-codeにコピペして実行。
実行結果。
;;; M-Eval input: (define (factorial n) (if (= n 0) 1 (* (factorial (- n 1)) n))) ;;; M-Eval value: ok ;;; M-Eval input: (factorial 6) ;;; M-Eval value: 720 ;;; M-Eval input:
まぁ簡単なプログラムしかコンパイルはしていないけど、一応これで動いている。
あとがき
手元に残っているソースファイルの日付を見ると2009年6月4日。第２章の終わりまで読み進めたところで、どうもSchemeの知識が足りなさすぎる感じがしたので一旦中断。『Schem手習い』『Scheme修行』等を経て、2012年にもう一度最初の問題からやる直して全ての問題に取り組む決意を以って再開。このブログにSICPのノートをつけ始めたのは2012年5月19日。今日は2015年4月25日。ほぼ６年掛けて、再開後も３年を掛けて漸く最後まで辿り着いた。そもそも最後の5.5.7節だけで３ヶ月は要した。一応全ての問題に回答した筈。第４章の最後の問題だけ微妙だけど。あまりにも長く掛かったので自分のプログラミングに変化があるのか良く分からなくなっているが、Racketで実行していた関係でmutable/immutableを明確に区別して考える癖がついている気がするし、値を返さない文（set!とか）がとても特殊に感じる様になった。Scheme以外の言語を触っていてもifが値を返さないのがとても不便に感じたり。言語処理系を勉強するだけでなく、遅延評価や論理プログラミングなども実際に手を動かして中で何が起きているのかも勉強する事ができた。
さて、この後はCTMCPに行くか、関数型プログラミング入門に行くかまだ思案中。
SICP 5.5.7 Interfacing Compiled Code to the Evaluator / Exercise 5.51
ノート
Exercise 5.51
5.2ではレジスタマシン・シミュレータをSchemeで実装したが、これをC言語で実装するなら5.4のExplicit Evaluatorは基本的には何も変換する必要はない筈なのできっと問題の意図とは異なる。そうすると『レジスタマシン相当の実行環境をC言語で作って、それを使ったExplicit Evaluatorを同じくC言語で実装する』と解釈する。
ただ、今更Cですか？と言う気もするし、折角Macを使っているので、ここはswiftにチャレンジしてみる。
変換の大まかな方針：
- レジスタは変数だけど、save / restoreは言語の関数呼び出しの仕組みに任せる
- レジスタマシンのレジスタはSchemeと同じく何でも入ったので、これをうまく実装する必要がある
- リストは必ずしもconsセルで表現しなくても良いかも。swiftの配列でも（ある程度？）表現出来る。
- 環境はハッシュテーブル（swiftだとDictionary）が使えそう。
- gotoとbranchはエラーでREPLに強制的に戻る時以外は基本的には分岐と関数呼び出しに割り振れそう。
【データの表現】
enum Expression { case BOOLEAN(Bool) case NUMBER(Int) case STRING(String) case SYMBOL(String) case LIST([Expression]) case ENVIRONMENT(Environment) case PRIMITIVE(([Expression]->Expression)) func description() -> String { switch self { case let .BOOLEAN(b): return b.description case let .NUMBER(n): return n.description case let .STRING(s): return "\"" + s + "\"" case let .SYMBOL(s): return s case let .LIST(list): return "(" + join(" ", list.map({$0.description()})) + ")" case let .ENVIRONMENT(env): return env.description() case let .PRIMITIVE(p): return "procedure" } } } enum Result : Printable { case EXPRESSION(Expression) case ERROR(String) var description: String { switch self { case let .EXPRESSION(exp): return exp.description() case let .ERROR(err): return err } } }
ExpressionはPrintableにしようとしたけど、何故かLISTの部分で落ちるので仕方なくこの形に。
Resultはswiftに例外がなかったので、エラーの時には戻り値で表現する為。
【パーサー】
swiftでパーサーコンビネータとか出来そうだけど、LISPの場合は括弧以外は基本的にはスペースで単語が区切れていて、そこまでのものは必要なさそうなので単純に実装してみる。
func skip_spaces(input: String) -> String { if input.hasPrefix(" ") { return skip_spaces(input.substringFromIndex(advance(input.startIndex, 1))) } else { return input } } func find_string_end(input: String) -> Int { var i = 1 for c in input.substringFromIndex(advance(input.startIndex, 1)) { if c != "\"" { i++ } else { break } } return i + 1 } func find_word_end(input: String) -> Int { var i = 0 for c in input { if c != " " && c != ")" { i++ } else { break } } return i } func tokenize_one(input: String) -> (String, String) { var w = skip_spaces(input) var i : Int if w.hasPrefix("(") || w.hasPrefix(")") { i = 1 } else if w.hasPrefix("\"") { i = find_string_end(w) } else { i = find_word_end(w) } return (w.substringToIndex(advance(w.startIndex, i)), w.substringFromIndex(advance(w.startIndex, i))) } func tokenize(input: String) -> [String] { let (word, rest) = tokenize_one(input) var list: [String] = [word] if rest.isEmpty || skip_spaces(rest).isEmpty { return list } else { return list + tokenize(rest) } } func parse_list(tokens:[String]) -> ([Expression], [String]) { if tokens[0] == ")" { return ([], cdr(tokens)) } else { let (val, rest) = parse_token(tokens) var (list, beyond_list) = parse_list(rest) list.insert(val, atIndex: 0) return (list, beyond_list) } } func parse_token(tokens: [String]) -> (Expression, [String]) { if tokens.isEmpty { return (Expression.LIST([]), []) } else if tokens[0] == ")" { return (Expression.LIST([]), cdr(tokens)) } else if tokens[0] == "(" { let (list, rest) = parse_list(cdr(tokens)) return (Expression.LIST(list), rest) } else if let n = tokens[0].toInt() { return (Expression.NUMBER(n), cdr(tokens)) } else if (tokens[0] == "true") { return (Expression.BOOLEAN(true), cdr(tokens)) } else if (tokens[0] == "false") { return (Expression.BOOLEAN(false), cdr(tokens)) } else if (tokens[0].hasPrefix("\"")) { var str = tokens[0].substringToIndex(advance(tokens[0].startIndex, count(tokens[0].utf16) - 1)).substringFromIndex(advance(tokens[0].startIndex, 1)) // get rid of quotation marks return (Expression.STRING(str), cdr(tokens)) } else { return (Expression.SYMBOL(tokens[0]), cdr(tokens)) } }
tokenizeは括弧とダブルクォートで囲まれた文字列のみ特別扱いして、それ以外はスペース区切り。parse_tokenはそれをExpressionに変換するだけ。Expressionの文字列にする時にはダブルクォートを削除する。
【環境】
swiftのDictionary（配列）は値セマンティクスで関数に渡す時にコピーが作られてしまうが、クロージャや関数の定義に関しては都合が悪い。4.1.6節での議論も関連。再帰関数を作る時にはクロージャを作る時に取り込む環境は、その瞬間の環境のスナップショット（コピー）ではだめで参照である必要がる。クロージャ作成時には参照している環境に自分自身がまだ登録されていないので、その後に書き換えられる必要があるから。
swiftで参照を使うためにはオブジェクトにする必要があるので環境はクラスとして定義する。環境を拡張する時に親となる環境も参照した時点より後に変化するため、親子関係も参照を使う。
class Environment { var frame = Dictionary<String, Expression>() var parent:Environment? = nil func add(sym:String, exp:Expression) { frame[sym] = exp } func value(sym:String) -> Result { switch frame[sym] { case let .Some(exp): return Result.EXPRESSION(exp) default: if parent != nil { return parent!.value(sym) } else { return Result.ERROR("Unbound variable: " + sym) } } } func extend(vars: [Expression], values: [Expression]) -> Environment { var newEnv = Environment() newEnv.parent = self for (variable, value) in Array(Zip2(vars, values)) { switch variable { case let .SYMBOL(sym): newEnv.add(sym, exp: value) default: continue } } return newEnv } func description() -> String { return frame.description } }
【tagged list】
SchemeでのMetacircular EvaluatorとかExplicit Control Evaluatorの真似をしてtagged listを使う。
func tagged_list(exp: Expression, tag:String) -> Bool { switch exp { case let .LIST(list): switch list[0] { case let .SYMBOL(sym): if (sym == tag) { return true } else { return false } default: return false } default: return false } } func is_quoted(exp: Expression) -> Bool { return tagged_list(exp, "quote") } func is_assignment(exp: Expression) -> Bool { return tagged_list(exp, "set!") } func is_definition(exp: Expression) -> Bool { return tagged_list(exp, "define") } func is_if(exp: Expression) -> Bool { return tagged_list(exp, "if") } func is_lambda(exp: Expression) -> Bool { return tagged_list(exp, "lambda") } func is_begin(exp: Expression) -> Bool { return tagged_list(exp, "begin") } func is_primitive_procedure(exp: Expression) -> Bool { return tagged_list(exp, "primitive") } func is_compound_procedure(exp: Expression) -> Bool { return tagged_list(exp, "procedure") }
【Explicit Control Evaluator】
代数データ型をenumで表現するとコードのそこら中に同じswitch文が沢山書く事になったので、ちょっと纏める便利関数を作った。
func if_expression(value: Result)(op: (Expression -> Result)) -> Result { switch value { case let .EXPRESSION(exp): return op(exp) case .ERROR: return value } } func is_expression(value: Result) -> Bool { switch value { case .EXPRESSION: return true case .ERROR: return false } } func if_list(exp: Expression)(op: ([Expression] -> Result)) -> Result { switch exp { case let .LIST(list): return op(list) default: return Result.ERROR("Internal software error @op_list: " + exp.description()) } } func if_symbol(exp: Expression)(op: (String -> Result)) -> Result { switch exp { case let .SYMBOL(sym): return op(sym) default: return Result.ERROR("Invalid symbol: " + exp.description()) } } func cdr<Any>(list:[Any]) -> [Any] { if list.endIndex == 1 { return [] } else { return Array(list[1...(list.count - 1)]) } }
本題の評価器のポーティング。概ねストレートに置き換えているつもり。
func eval_dispatch(exp:Expression, inout env:Environment) -> Result { switch exp { case .BOOLEAN: return Result.EXPRESSION(exp) case .NUMBER: return Result.EXPRESSION(exp) case .STRING: return Result.EXPRESSION(exp) case let .SYMBOL(sym): return ev_variable(sym, env) case .LIST: if (is_quoted(exp)) { return ev_quote(exp) } else if (is_assignment(exp)) { return ev_assignment(exp, &env) } else if (is_definition(exp)) { return ev_definition(exp, &env) } else if (is_if(exp)) { return ev_if(exp, &env) } else if (is_lambda(exp)) { return ev_lambda(exp, &env) } else if (is_begin(exp)) { return ev_begin(exp, &env) } else { // application return ev_application(exp, &env) } default: return Result.ERROR("Unknown expression @eval_dispatch") } }
func ev_variable(sym:String, env:Environment) -> Result { return env.value(sym) } func ev_quote(exp: Expression) -> Result { return if_list (exp) (op: {list in Result.EXPRESSION(Expression.LIST(cdr(list))) }) } func assign_variable(sym:String, exp: Expression, inout env: Environment) -> Result { return if_expression (eval_dispatch(exp, &env )) (op: {newValue in env.add(sym, exp: newValue) return Result.EXPRESSION(Expression.SYMBOL("ok")) }) } func ev_assignment(exp: Expression, inout env: Environment) -> Result { return if_list (exp) (op: {list in if_symbol (list[1]) (op: {sym in if_expression (env.value(sym)) (op: {exp in // check if the variable (sym) exists assign_variable(sym, list[2], &env) }) }) }) } func ev_definition(exp: Expression, inout env: Environment) -> Result { return if_list (exp) (op: {list in switch list[1] { case let .LIST(form): return if_symbol (form[0]) (op: {sym in assign_variable(sym, Expression.LIST([Expression.SYMBOL("lambda"), Expression.LIST(cdr(form)), list[2]]), &env)}) case let .SYMBOL(sym): return assign_variable(sym, list[2], &env) default: return Result.ERROR("Bad definition: " + exp.description()) } }) } func ev_if(exp: Expression, inout env: Environment) -> Result { return if_list(exp) (op: {list in if_expression (eval_dispatch(list[1], &env)) (op: {exp in switch exp { case let .BOOLEAN(b): if (b) { return eval_dispatch(list[2], &env) } else { return eval_dispatch(list[3], &env) } default: return Result.ERROR("Bad condition: " + exp.description()) } }) }) } func ev_lambda(exp: Expression, inout env: Environment) -> Result { return if_list (exp) (op: {list in if_list (list[1]) (op: {parameters in Result.EXPRESSION( Expression.LIST([ Expression.SYMBOL("procedure"), Expression.LIST(parameters), Expression.LIST(cdr(cdr(list))), Expression.ENVIRONMENT(env)])) }) }) } func ev_sequence(list: [Expression], inout env: Environment) -> Result { if (list.count > 2) { for exp in Array(list[0...(list.endIndex - 2)]) { let result = eval_dispatch(exp, &env) } } return eval_dispatch(list[list.endIndex - 1], &env) } func ev_begin(exp: Expression, inout env: Environment) -> Result { return if_list(exp) (op: {list in ev_sequence(cdr(list), &env) }) } func apply_primitive_procedure(exp: Expression, argl: [Expression]) -> Result { return if_list(exp) (op: {list in switch list[1] { case let .PRIMITIVE(op): return Result.EXPRESSION(op(argl)) default: return Result.ERROR("Invalid primitive procedure") } }) } func compound_apply(op: Expression, argl: [Expression]) -> Result { return if_list (op) (op: {list in switch list[1] { case let .LIST(parameters): switch list[2] { case let .LIST(body): switch list[3] { case let .ENVIRONMENT(env): var newEnv = env.extend(parameters, values: argl) return ev_sequence(body, &newEnv) default: return Result.ERROR("Invalid compound procedure env") } default: return Result.ERROR("Invalid compound procedure body") } default: return Result.ERROR("Invalid compound procedure parameters") } }) } func ev_application(exp: Expression, inout env: Environment) -> Result { return if_list(exp) (op: {list in if_expression (eval_dispatch(list[0], &env)) (op: {op in var argl: [Expression] = [] for result in cdr(list).map({exp in eval_dispatch(exp, &env)}) { switch result { case let .EXPRESSION(exp): argl.append(exp) case .ERROR: return result } } if (is_primitive_procedure(op)) { return apply_primitive_procedure(op, argl) } else if (is_compound_procedure(op)) { return compound_apply(op, argl) } else { return Result.ERROR("Unknown procedure type: " + op.description()) } }) }) }
defineの扱いは、(define func (lambda (arg) ...)となっていれば普通の変数の定義と同じに出来るが、(define (func arg) ...)の形だと変換が必要になる。Schemeではreadがよしなにlamdaに変換してくれていたが、ここは自前でやらなければならない。パースする手前では難しいのでev_definitionで対応せざるを得ない。
【プリミティブ】
引数の型がどうしてもExpressionの配列となってしまい、そのまま呼び出せないのでラッパーが必要。
func apply_number(argl:[Expression], op:((Int, Expression)->Int)) -> Expression { switch argl[0] { case let .NUMBER(initialValue): return Expression.NUMBER(cdr(argl).reduce(initialValue, combine: op)) default: return Expression.BOOLEAN(false) } } func plus(argl:[Expression]) -> Expression { return apply_number(argl, {value, arg in switch arg { case let .NUMBER(n): return value + n default: return value } }) } func minus(argl:[Expression]) -> Expression { return apply_number(argl, {value, arg in switch arg { case let .NUMBER(n): return value - n default: return value } }) } func multiply(argl:[Expression]) -> Expression { return apply_number(argl, {value, arg in switch arg { case let .NUMBER(n): return value * n default: return value } }) } func equal_aux(initValue:Int, argl:[Expression]) -> Bool { if (argl.count > 0) { switch argl[0] { case let .NUMBER(n): return n == initValue && equal_aux(initValue, Array(argl[1..<argl.endIndex])) default: return false } } else { return true } } func equal(argl:[Expression]) -> Expression { switch argl[0] { case let .NUMBER(initialValue): return Expression.BOOLEAN(equal_aux(initialValue, Array(argl[1..<argl.endIndex]))) default: return Expression.BOOLEAN(false) } }
【REPL】
func nest(tokens: [String]) -> Int { return tokens.reduce(0, combine: {n, token in switch token { case "(": return n + 1 case ")": return n - 1 default: return n } }) } func read_line() -> String { var str = NSString(data: NSFileHandle.fileHandleWithStandardInput().availableData, encoding: NSUTF8StringEncoding)! as String return str.substringToIndex(advance(str.startIndex, count(str.utf8) - 1)) + " " // replace new line to a space } func read() -> Expression { var input = "" while (true) { input = input + read_line() let tokenized = tokenize(input) let n = nest(tokenized) if n < 0 { return Expression.SYMBOL("Parentheses mismatch") } else if n == 0 { let (value, rest) = parse_token(expand_syntax_sugar(tokenized)) return value } } } func read_eval_print_loop(inout env: Environment) -> () { while (true) { print(";;; EC-Eval input: ") println(eval_dispatch(read(), &env)) } }
Schemeのreadがよしなにやってくれていたもう一つの機能：シングルクォートをquote式に変換する事、をこのレベルで実装。
func expand_quote(tokens: [String]) -> [String] { if tokens.isEmpty { return [] } else if tokens[0] == "'(" { return ["(", "quote"] + expand_quote(cdr(tokens)) } else if tokens[0].hasPrefix("'(") { return ["(", "quote", tokens[0].substringFromIndex(advance(tokens[0].startIndex, 2))] + expand_quote(cdr(tokens)) } else if tokens[0].hasPrefix("'") { return ["(", "quote", tokens[0].substringFromIndex(advance(tokens[0].startIndex, 1)), ")"] + expand_quote(cdr(tokens)) } else { return [tokens[0]] + expand_quote(cdr(tokens)) } } func expand_syntax_sugar(tokens: [String]) -> [String] { return expand_quote(tokens) }
【動作確認】
とりあえず最小のプリミティブで実現出来るテスト。
var global_env = Environment() global_env.add("+", exp: Expression.LIST([ Expression.SYMBOL("primitive"), Expression.PRIMITIVE(plus)])) global_env.add("=", exp: Expression.LIST([ Expression.SYMBOL("primitive"), Expression.PRIMITIVE(equal)])) global_env.add("-", exp: Expression.LIST([ Expression.SYMBOL("primitive"), Expression.PRIMITIVE(minus)])) global_env.add("*", exp: Expression.LIST([ Expression.SYMBOL("primitive"), Expression.PRIMITIVE(multiply)])) read_eval_print_loop(&global_env)
動作結果
;;; EC-Eval input: (define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) ok ;;; EC-Eval input: (factorial 5) 120 ;;; EC-Eval input:
SICP 5.5.7 Interfacing Compiled Code to the Evaluator
ついに最終節
ノート
REPLからコンパイラを呼び出して、REPLの環境で実行する。
explicit controller machineはインタープリタだが、コードをコンパイルする組み込みの手続きを用意する。変数として格納されている手続きをオペレータとしてprocに入れた後に、それがコンパイルされたコードだったらそのエントリーポイントにジャンプする。コードの実行が終わったらcontinueに入っているエントリーポイントにジャンプする。
REPLに入る前にflagレジスタがtrueになっていたらexternal-entryにジャンプするコードを挿入。external-entryに飛ぶ場合はvalにエントリーポイントが入っている事が前提。実行が終わるとREPLに入る。
variableのbound/unbound（Exercise 5.30）とlexical addressing（Section 5.5.6）が邪魔なのでこれらを取り除いて、compile-and-goを試して見る。
> (compile-and-go '(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n)))) ;;; EC-Eval value: ok ;;; EC-Eval input: (factorial 5) ;;; EC-Eval value: 120 ;;; EC-Eval input: .
期待通り。
5.4.4節に倣って、エントリーポイントprint-resultsに
(perform (op print-stack-statistics))
を足して、
> (compile-and-go '(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n)))) (total-pushes = 0 maximum-depth = 0) ;;; EC-Eval value: ok ;;; EC-Eval input: (factorial 5) (total-pushes = 31 maximum-depth = 14) ;;; EC-Eval value: 120 ;;; EC-Eval input: .
確かにかなり余分なpush/restoreは省かれている。
Interpretation and compilation
これで、インタープリタで解釈実行する事とコンパイルして実行する事の比較ができるようになった。
また、新しい計算機（新しいOSとかプロセッサとか）でLisp（ここではScheme）を動かしたいなら
Exercise 5.45
factorial専用のマシンとコンパイラが生成したコードとの性能の比較。
a.
コンパイルしたコード
| n | total push | max depth |
|---|---|---|
| 3 | 19 | 8 |
| 4 | 25 | 11 |
| 5 | 31 | 14 |
| 6 | 37 | 17 |
スピード（total push）は、スペース（max depth）は
| n | total push | max depth |
|---|---|---|
| 3 | 80 | 18 |
| 4 | 112 | 23 |
| 5 | 144 | 28 |
| 6 | 176 | 33 |
スピード（total push）は、スペース（max depth）は
| n | total push | max depth |
|---|---|---|
| 3 | 0.2375 | 0.4444 |
| 4 | 0.2232 | 0.4783 |
| 5 | 0.2153 | 0.5 |
| 6 | 0.2102 | 0.5152 |
nが大きくなると定数項は無視できるので、コンパイラのコードはインタープリタに対して6/32=18.75%の計算時間、3/5=60%のスペースで計算できると言える。
factorial machine
| n | total push | max depth |
|---|---|---|
| 3 | 4 | 4 |
| 4 | 6 | 6 |
| 5 | 8 | 8 |
| 6 | 10 | 10 |
スピード（total push）、スペース（max depth）ともに。
比率=コンパイラ/専用マシン
| n | total push | max depth |
|---|---|---|
| 3 | 4.75 | 2 |
| 4 | 4.167 | 1.833 |
| 5 | 3.875 | 1.75 |
| 6 | 3.7 | 1.7 |
nが大きくなった時を考えると、コンパイラのコードはインタープリタに対して300%の計算時間、150%のスペースを要する。
インタープリタと専用マシンのtotal pushの比は16倍。
b.
専用マシンのコード：
(controller (assign continue (label fact-done)) ; set up final return address fact-loop (test (op =) (reg n) (const 1)) (branch (label base-case)) ;; Set up for the recursive call by saving n and continue. ;; Set up continue so that the computation will continue ;; at after-fact when the subroutine returns. (save continue) (save n) (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) after-fact (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)! (goto (reg continue)) ; return to caller base-case (assign val (const 1)) ; base case: 1! = 1 (goto (reg continue)) ; return to caller fact-done)
専用マシンの
(test (op =) (reg n) (const 1))
の１行に相当するコンパイラが吐いたコードは
(assign proc (op lookup-variable-value) (const =) (reg env)) (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call8 (restore env) (restore continue) (test (op false?) (reg val))
ここから見えることは
- 専用マシンがレジスタnを持っているのに対して、コンパイラのコードは変数nを環境に持っていること。環境からいちいちレジスタに値を読み出す必要が生じる。
- 手続き=がプリミティブである事を実行時に判断している
- 手続き=の引数はリストで受け取り、レジスタを直接比較する訳ではない
これらの不利な点を改善するとしたら
くらいでしょうか。実装は難しそうだけど。
Exercise 5.46
コンパイルしたコード
| n | total push | max depth |
|---|---|---|
| 3 | 27 | 8 |
| 4 | 47 | 11 |
| 5 | 77 | 14 |
| 6 | 127 | 17 |
| 7 | 207 | 20 |
| 8 | 337 | 23 |
| 9 | 547 | 26 |
| 10 | 887 | 29 |
max depthは。total pushはn=3の時は
から、n=10では
なので全体にはnの３乗弱辺りに落ち着くのか。
| n | total push | max depth |
|---|---|---|
| 3 | 128 | 18 |
| 4 | 240 | 23 |
| 5 | 408 | 28 |
| 6 | 688 | 33 |
| 7 | 1136 | 38 |
| 8 | 1864 | 43 |
| 9 | 3040 | 48 |
| 10 | 4944 | 53 |
max depthは相変わらずと線形。total pushはn=3で
、n=10で
。どの辺りに落ち着くのか。
| n | total push | max depth |
|---|---|---|
| 3 | 0.2109375 | 0.4444444444 |
| 4 | 0.1958333333 | 0.4782608696 |
| 5 | 0.1887254902 | 0.5 |
| 6 | 0.1845930233 | 0.5151515152 |
| 7 | 0.1822183099 | 0.5263157895 |
| 8 | 0.1807939914 | 0.5348837209 |
| 9 | 0.1799342105 | 0.5416666667 |
| 10 | 0.1794093851 | 0.5471698113 |
専用マシン
| n | total push | max depth |
|---|---|---|
| 3 | 8 | 4 |
| 4 | 16 | 6 |
| 5 | 28 | 8 |
| 6 | 48 | 10 |
| 7 | 80 | 12 |
| 8 | 132 | 14 |
| 9 | 216 | 16 |
| 10 | 352 | 18 |
max depthは。total pushはn=3で
、n=10で
。
比率=コンパイラ/専用マシン
| n | total push | max depth |
|---|---|---|
| 3 | 3.375 | 2 |
| 4 | 2.9375 | 1.8333333333 |
| 5 | 2.75 | 1.75 |
| 6 | 2.6458333333 | 1.7 |
| 7 | 2.5875 | 1.6666666667 |
| 8 | 2.553030303 | 1.6428571429 |
| 9 | 2.5324074074 | 1.625 |
| 10 | 2.5198863636 | 1.6111111111 |
と言う性能差。
Exercise 5.47
compile-procedure-callをコンパイルされていない、定義が環境に入っているだけの手続きも呼び出せる様に改造する。つまり評価機のcompound-applyにジャンプするコードを生成する事になるが、compound-applyと言うラベルを直接参照するコードは吐けないので、REPLに入る前にcompappと言うレジスタにラベルを代入しておく。
元のcompile-procedure-callはプリミティブでなければcompiledのコードに突入する様になっているが、もう一段compiled-procedure?を使って、compiledのコードにジャンプするコードを生成する。compound procedureの為のコードはcompile-proc-applを参考にして作る。
compile-proc-applで
- targetがvalでlinkageがreturnではない時、continueにlinkageを入れてcompappにジャンプ
- targetがvalではなくlinkageがretunでない時、continueに戻り先ラベルを入れてcompappにジャンプして、戻って来たらlinkageにジャンプ
- tagetがvalでlinkageがreturnの時、continueを設定する必要はなく、compappにジャンプ
compound-applyはev-sequenceにジャンプして、その前のev-applicationでセーブしたcontinueに戻るコードを辿るので、ev-sequenceから戻る場所をcontinueに入れておく必要がある。
(define (compile-procedure-call target linkage) (let ((primitive-branch (make-label 'primitive-branch)) (compiled-branch (make-label 'compiled-branch)) (after-call (make-label 'after-call))) (let ((compiled-linkage (if (eq? linkage 'next) after-call linkage))) (append-instruction-sequences (make-instruction-sequence '(proc) '() `((test (op primitive-procedure?) (reg proc)) (branch (label ,primitive-branch)) (test (op compiled-procedure?) (reg proc)) (branch (label ,compiled-branch)))) (parallel-instruction-sequences (parallel-instruction-sequences (append-instruction-sequences (compile-compound-proc target compiled-linkage)) (append-instruction-sequences compiled-branch (compile-proc-appl target compiled-linkage))) (append-instruction-sequences primitive-branch (end-with-linkage linkage (make-instruction-sequence '(proc argl) (list target) `((assign ,target (op apply-primitive-procedure) (reg proc) (reg argl))))))) after-call)))) (define (compile-compound-proc target linkage) (cond ((and (eq? target 'val) (not (eq? linkage 'return))) (make-instruction-sequence '(proc) all-regs `((assign continue (label ,linkage)) (save continue) (goto (reg compapp))))) ((and (not (eq? target 'val)) (not (eq? linkage 'return))) (let ((comp-proc-return (make-label 'comp-proc-return))) (make-instruction-sequence '(proc) all-regs `((assign continue (label ,comp-proc-return)) (save continue) (goto (reg compapp)) ,comp-proc-return (assign ,target (reg val)) (goto (label ,linkage)))))) ((and (eq? target 'val) (eq? linkage 'return)) (make-instruction-sequence '(proc continue) all-regs '((save continue) (goto (reg compapp))))) ((and (not (eq? target 'val)) (eq? linkage 'return)) (error "return linkage, target not val -- COMPILE" target))))
分かりやすい様にプリミティブにdisplayとnewlineを追加して動作確認。
> (compile-and-go '(define (f) (display "f")(newline)(g))) (total-pushes = 0 maximum-depth = 0) ;;; EC-Eval value: ok ;;; EC-Eval input: (define (g) (display "g")(newline)) (total-pushes = 3 maximum-depth = 3) ;;; EC-Eval value: ok ;;; EC-Eval input: (f) f g (total-pushes = 18 maximum-depth = 6) ;;; EC-Eval value: #<void> ;;; EC-Eval input:
一応シンプルなコードは動いている。
Exercise 5.48
従来は
- レジスタマシンを作った時点で指定されたプログラム（評価器）を実行するか、（start-eceval）
- 引数で指定されたプログラムをコンパイルして、それを最初に実行してからレジスタマシンを作った時点で指定されたプログラム（評価器）に入る（compile-and-go）
のどちらかだった。
compile-and-runはJust-In-Timeコンパイルをしてから実行する事を指定するので、レジスタマシンに対する命令と言える。レジスタマシンに対する命令をレジスタマシン上で動いているプログラム（評価器）から実行する事になるのでかなり特殊な状況を作る必要がある。
まずは評価機がcompile-and-runを解釈出来なければならないが、これは普通の手続き呼び出しの様な形式なので
- defineの様にspecial formにする
- プリミティブとして用意しておく
が考えられる。
compile-and-runの引数のプログラムをinstruction sequenceに変換（assemble）してREPLに戻るように準備した上で実行すれば良い。assembleには引数としてmachineが必要だが、レジスタマシンから自分自身を参照する手段がない。
上記のプリミティブはそもそもREPL入力の引数しか手続きに渡せないので無理。
special formであればレジスタマシンにselfと言うレジスタを用意して、ecevalをスタートさせる前にecevalにmachineを拘束しておいて、special formを処理するときにmachineを渡すコードにしておけば何とか可能。
もう一つ考えられるのは、primitiveとかcompiledの様な手続きの種類としてmeta-procedureと言う種類を用意しておく。手続きはあらかじめ環境に入れておき、評価器の手続き処理にひと種類追加する事になる。今回これを実装してみる。
meta-procedureとして用意するcompile-and-runの実装。assembleした結果のinstruction sequenceにジャンプしたいのだが、meta-procedureの処理から戻る前に実行する必要が有るので、強制的にpcをassembleした結果に設定するのだが、実行する前にpcをひとつ進めてしまうのでダミーをひとつ噛ませて、pcをひとつ進めてからinstructionの実行に移る様にする。
(define (compile-and-run args machine) (let ((instructions (assemble (statements (compile (car args) 'val 'return)) machine))) (set-register-contents! machine 'pc (cons 'dummy-instruction instructions))))
meta-procedureをサポートする手続き
(define (meta-procedure? proc) (tagged-list? proc 'meta-proc)) (define (meta-implementation proc) (cadr proc)) (define (apply-meta-procedure proc args machine) (apply-in-underlying-scheme (meta-implementation proc) (list args machine))) (define (meta-apply-succeeded? result) (car result)) (define (meta-apply-result result) (cdr result))
setup-environmentを拡張。meta-procedureのエントリーを追加。
(define meta-procedures (list (list 'compile-and-run compile-and-run) )) (define (meta-procedure-names) (map car meta-procedures)) (define (meta-procedure-objects) (map (lambda (proc) (list 'meta-proc (cadr proc))) meta-procedures)) (define (setup-environment) (let ((initial-env (extend-environment (meta-procedure-names) (meta-procedure-objects) (extend-environment (primitive-procedure-names) (primitive-procedure-objects) the-empty-environment)))) (define-variable! 'true true initial-env) (define-variable! 'false false initial-env) initial-env))
eceval-operationsに追加
(define eceval-operations (list (list 'self-evaluating? self-evaluating?) （中略） (list 'meta-procedure? meta-procedure?) (list 'apply-meta-procedure apply-meta-procedure) ))
apply-dispatchを拡張。primitive-applyに比べて引数にmachineが増えている。
apply-dispatch
(test (op meta-procedure?) (reg proc))
(branch (label meta-apply))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
(test (op compiled-procedure?) (reg proc))
(branch (label compiled-apply))
(goto (label unknown-procedure-type))
compiled-apply
(restore continue)
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
meta-apply
(assign continue (label after-meta-apply))
(assign val (op apply-meta-procedure)
(reg proc)
(reg argl)
(reg machine))
after-meta-apply
(restore continue)
(goto (reg continue))
start-ecevalを拡張
(define (start-eceval) (set! the-global-environment (setup-environment)) (set-register-contents! eceval 'machine eceval) (set-register-contents! eceval 'flag false) (start eceval))
実行結果
> (start-eceval) ;;; EC-Eval input: (compile-and-run '(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n)))) (total-pushes = 5 maximum-depth = 3) ;;; EC-Eval value: ok ;;; EC-Eval input: (factorial 5) (total-pushes = 31 maximum-depth = 14) ;;; EC-Eval value: 120 ;;; EC-Eval input: (compile-and-run '(define (inc x) (+ x 1))) (total-pushes = 5 maximum-depth = 3) ;;; EC-Eval value: ok ;;; EC-Eval input: (inc 3) (total-pushes = 5 maximum-depth = 3) ;;; EC-Eval value: 4 ;;; EC-Eval input: (define (increase x) (+ x 1)) (total-pushes = 3 maximum-depth = 3) ;;; EC-Eval value: ok ;;; EC-Eval input: (increase 3) (total-pushes = 13 maximum-depth = 5) ;;; EC-Eval value: 4 ;;; EC-Eval input: .
コンパイルした方が効率が良くなっている事が分かる。
Exercise 5.49
つまり常にread、compile-and-run、print-resultだけを行うレジスタマシンを実装する。
オペレーションとしてcompile、statements、assembleを登録。
(define rcepl-operations (list (list 'self-evaluating? self-evaluating?) （中略：ecevalと同じ） (list 'compile compile) (list 'statements statements) (list 'assemble assemble) ))
レジスタマシンはecevalのREPLを参考にcompile-and-runの内容を手動で（？）コンパイルして埋め込む。
(define rcepl (make-machine rcepl-operations '(read-compile-execute-print-loop (perform (op initialize-stack)) (perform (op prompt-for-input) (const ";;; RCEPL input:")) (assign exp (op read)) (assign env (op get-global-environment)) (assign continue (label print-result)) (assign val (op compile) (reg exp) (const val) (const return)) (assign val (op statements) (reg val)) (assign val (op assemble) (reg val) (reg machine)) (goto (reg val)) print-result (perform (op print-stack-statistics))
SICP 5.5.2 Compiling Expressions
ノート
Compiling linkage code
compile-linkageは各式を命令に変換した後、次の命令への繋ぎを生成する。
引数が'returnの時はレジスタcontinueの内容にジャンプ、'nextであれば何もしない、その他であれば引数をラベルとみなしてそのラベルにジャンプする命令を生成する。
Compiling simple expressions
compile-self-evaluating、compile-quoted、compile-variableはほぼ自明。
compile-assignmentは、まず式の部分を評価してvalに保存するようにコンパイルする。compile-definitionも同様。
Compiling conditional expressions
compile-ifのポイントはif式の後がどこに繋がるかで命令が若干変わることと、ラベルをこの式固有のものを生成しなければならない事。
Compiling lambda expressions
ラムダ式の中身の命令はその場に挿入するが、式の途中などにラムダ式があるような場合には、この部分をジャンプして実行が進むようにしなければならない。
5.5.3 Compiling Combinations
オペレータ、オペランドの評価。引数リストをconsで構築する関係で、引数の評価は最右から行う。
Applying procedures
適用する手続きがプリミティブか否かを判断して適用するコードを生成する。
Applying compiled procedures
複合手続きの呼び出しは、呼び出した後の処理によって生成するコードが変わる。
5.5.4 Combining Instruction Sequences
append-instruction-sequencesは可変長引数を取る。これをappend-2-sequencesで順番に連結して行く。append-2-sequencesでは当然命令を連結するだけではなく、必要としているレジスタのリスト、変更されるレジスタのリストをそれぞれマージする。
ここでpreserving。引数のレジスタのリストに登録されているそれぞれのレジスタについて、二番目の命令列がそれを参照するなら一番目の命令列をsaveとrestoreで囲む。
tack-on-instruction-sequenceはラムダ式で生成した本体を命令列の間に挿入する。挿入にあたってはラムダ式の本体で何のレジスタを使うかとかは考慮する必要はない。
parallel-instruction-sequencesはifとか手続き適用部分で使用する。二つの命令列のどちらかしか通らないので互いのレジスタ使用は無視して連結できる。手続き適用の際にはプリミティブか否かで二つの命令列を用意するので。
5.5.5 An Example of Compiled Code
まずは、サンプルをコンパイルしてみる
> (compile '(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) 'val 'next) '((env) ; あらかじめ初期化されている必要があるレジスタ。 (val) ; ここで変更されるレジスタ。 ((assign val (op make-compiled-procedure) (label entry1) (reg env)) ; 「手続きですよ」と言うタグが付いたリストを作る。 (goto (label after-lambda2)) ; 変数factorialを登録するところまでジャンプ entry1 ; ここからがラムダ式の本体 (assign env (op compiled-procedure-env) (reg proc)) ; make-compiled-procedureで作ったリストから環境を取り出す (assign env (op extend-environment) (const (n)) (reg argl) (reg env)) ; 環境に引数のnを追加する (save continue) (save env) (assign proc (op lookup-variable-value) (const =) (reg env)) ; (= n 1)式を作る (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) ; =を適用 (branch (label primitive-branch6)) compiled-branch7 (assign continue (label after-call8)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call8 ; =の適用が終わったところ (restore env) (restore continue) (test (op false?) (reg val)) ; ifの条件判断 (branch (label false-branch4)) true-branch3 ; ifの条件がtrueの時 (assign val (const 1)) (goto (reg continue)) false-branch4 ; ifの条件がfalseの時 (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* (factorial (- n 1)) n)式を構築 (save continue) ; (factorial (- n 1))で必要なレジスタを退避 (save proc) ; factorialの呼び出しでもprocを使うので一旦退避 (assign val (op lookup-variable-value) (const n) (reg env)) ; 式の最後のnを引数リストに代入 (assign argl (op list) (reg val)) ; 最右の引数なのでリストにして代入するだけ (save argl) ; factorialの呼び出しでもarglを使うので一旦退避 (assign proc (op lookup-variable-value) (const factorial) (reg env)) (save proc) ; (- n 1)の呼び出しでもprocを使うので一旦退避 (assign proc (op lookup-variable-value) (const -) (reg env)) ; (- n 1)式を構築 (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) ; -の適用 (branch (label primitive-branch9)) compiled-branch10 (assign continue (label after-call11)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch9 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call11 ; -の適用が終わったところ (assign argl (op list) (reg val)) ; (- n 1)の結果をfactorial用の引数リストとして初期化 (restore proc) ; factorialを戻して (test (op primitive-procedure?) (reg proc)) ; factorialを適用 (branch (label primitive-branch12)) compiled-branch13 (assign continue (label after-call14)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch12 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call14 ; factorialの適用が終わったところ (restore argl) ; *用の引数リストを復元 (assign argl (op cons) (reg val) (reg argl)) ; *用の引数リストに(factorial (- n 1))の結果を追加 (restore proc) ; *を復元 (restore continue) ; *の適用が終わったら戻るべき場所を復元 (test (op primitive-procedure?) (reg proc)) ; *の適用 (branch (label primitive-branch15)) compiled-branch16 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch15 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (goto (reg continue)) after-call17 ; *の適用が終わったところだけど、ここには戻って来ない after-if5 ; if式を抜けたところ after-lambda2 ; 変数factorialに拘束する (perform (op define-variable!) (const factorial) (reg val) (reg env)) (assign val (const ok)))) >
Exercise 5.33
まずはコンパイルしてみる。
> (compile '(define (factorial-alt n) (if (= n 1) 1 (* n (factorial-alt (- n 1))))) 'val 'next) '((env) (val) ((assign val (op make-compiled-procedure) (label entry1) (reg env)) (goto (label after-lambda2)) entry1 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (n)) (reg argl) (reg env)) (save continue) (save env) (assign proc (op lookup-variable-value) (const =) (reg env)) (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) compiled-branch7 (assign continue (label after-call8)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call8 (restore env) (restore continue) (test (op false?) (reg val)) (branch (label false-branch4)) true-branch3 (assign val (const 1)) (goto (reg continue)) false-branch4 (assign proc (op lookup-variable-value) (const *) (reg env)) (save continue) (save proc) (save env) (assign proc (op lookup-variable-value) (const factorial-alt) (reg env)) (save proc) (assign proc (op lookup-variable-value) (const -) (reg env)) (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch9)) compiled-branch10 (assign continue (label after-call11)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch9 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call11 (assign argl (op list) (reg val)) (restore proc) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch12)) compiled-branch13 (assign continue (label after-call14)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch12 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call14 (assign argl (op list) (reg val)) (restore env) (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (restore proc) (restore continue) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch15)) compiled-branch16 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch15 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (goto (reg continue)) after-call17 after-if5 after-lambda2 (perform (op define-variable!) (const factorial-alt) (reg val) (reg env)) (assign val (const ok)))) >
異なる部分。元のコードでは
false-branch4 ; ifの条件がfalseの時 (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* (factorial (- n 1)) n)式を構築 (save continue) ; (factorial (- n 1))で必要なレジスタを退避 (save proc) ; factorialの呼び出しでもprocを使うので一旦退避 (assign val (op lookup-variable-value) (const n) (reg env)) ; 式の最後のnを引数リストに代入 (assign argl (op list) (reg val)) ; 最右の引数なのでリストにして代入するだけ (save argl) ; factorialの呼び出しでもarglを使うので一旦退避 (assign proc (op lookup-variable-value) (const factorial) (reg env)) (save proc) ; (- n 1)の呼び出しでもprocを使うので一旦退避 (assign proc (op lookup-variable-value) (const -) (reg env)) ; (- n 1)式を構築 (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) ; -の適用 (branch (label primitive-branch9)) compiled-branch10 (assign continue (label after-call11)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch9 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call11 ; -の適用が終わったところ (assign argl (op list) (reg val)) ; (- n 1)の結果をfactorial用の引数リストとして初期化 (restore proc) ; factorialを戻して (test (op primitive-procedure?) (reg proc)) ; factorialを適用 (branch (label primitive-branch12)) compiled-branch13 (assign continue (label after-call14)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch12 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call14 ; factorialの適用が終わったところ (restore argl) ; *用の引数リストを復元 (assign argl (op cons) (reg val) (reg argl)) ; *用の引数リストに(factorial (- n 1))の結果を追加
新しいコードでは
false-branch4 (assign proc (op lookup-variable-value) (const *) (reg env)) (save continue) (save proc) (save env) ; factorial-altを呼び出した後に変数nを参照しなければならないのでenvを退避する必要がある (assign proc (op lookup-variable-value) (const factorial-alt) (reg env)) (save proc) (assign proc (op lookup-variable-value) (const -) (reg env)) (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch9)) compiled-branch10 (assign continue (label after-call11)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch9 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call11 (assign argl (op list) (reg val)) ; (- n 1)の結果でarglを初期化する (restore proc) ; factorial-altを復元 (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch12)) compiled-branch13 (assign continue (label after-call14)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch12 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call14 (assign argl (op list) (reg val)) ; ここで初めて*用のarglを初期化する (restore env) ; envを戻して変数nを参照してarglに追加する (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op cons) (reg val) (reg argl))
元の定義では掛け算の引数を評価する際にenvを退避する必要がない代わりに、最初にnをarglに入れてしまうのでfactorialを呼び出す前にarglを退避しなければならない。
新しい定義は逆に最初にfactorial-altを呼び出す関係で、envを対ししておく必要がある代わりにfactorial-altの呼び出しが終わってから掛け算のためのarglを用意するので、arglを退避する必要がない。
と言う訳で、効率的には基本的には同じ。
Exercise 5.34
コンパイルしてみる。
> (compile '(define (factorial n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1)) 'val 'next) '((env) (val) ((assign val (op make-compiled-procedure) (label entry18) (reg env)) ; 手続きfactorialをvalに代入してafter-lambda19までジャンプ (goto (label after-lambda19)) entry18 ; factorialの本体 (assign env (op compiled-procedure-env) (reg proc)) ; make-compiled-procedureで作ったリストから環境を取り出す (assign env (op extend-environment) (const (n)) (reg argl) (reg env)) ; 環境に引数のnを追加する (assign val (op make-compiled-procedure) (label entry20) (reg env)) ; 手続きiterをvalに代入してafter-lambda21までジャンプ (goto (label after-lambda21)) entry20 ; iterの本体 (assign env (op compiled-procedure-env) (reg proc)) ; make-compiled-procedureで作ったリストから環境を取り出す (assign env (op extend-environment) (const (product counter)) (reg argl) (reg env)) ; 環境に引数のproductとcounterを追加する (save continue) (save env) (assign proc (op lookup-variable-value) (const >) (reg env)) ; (> counter n)式を構築 (assign val (op lookup-variable-value) (const n) (reg env)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const counter) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) ; >の適用 (branch (label primitive-branch25)) compiled-branch26 (assign continue (label after-call27)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch25 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call27 ; >の適用が終わったところ (restore env) (restore continue) (test (op false?) (reg val)) ; ifの条件判断 (branch (label false-branch23)) true-branch22 ; ifの条件がtrueの時 (assign val (op lookup-variable-value) (const product) (reg env)) (goto (reg continue)) false-branch23 ; ifの条件がfalseの時 (assign proc (op lookup-variable-value) (const iter) (reg env)) ; (iter (* counter product) (+ counter 1))式の構築 (save continue) (save proc) (save env) (assign proc (op lookup-variable-value) (const +) (reg env)) ; (+ counter 1)式の構築 (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const counter) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) ; +の適用 (branch (label primitive-branch31)) compiled-branch32 (assign continue (label after-call33)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch31 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call33 ; +の適用終わり (assign argl (op list) (reg val)) ; +の結果をiter用のarglに代入 (restore env) (save argl) (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* counter product)式の構築 (assign val (op lookup-variable-value) (const product) (reg env)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const counter) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) ; *の適用 (branch (label primitive-branch28)) compiled-branch29 (assign continue (label after-call30)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch28 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call30 ; *の適用終わり (restore argl) (assign argl (op cons) (reg val) (reg argl)) ; *の結果をiter用のarglに代入 (restore proc) ; iterを復元 (restore continue) (test (op primitive-procedure?) (reg proc)) ; iterの適用 ※この時点で全てのレジスタが復元されている (branch (label primitive-branch34)) compiled-branch35 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch34 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (goto (reg continue)) after-call36 ; iterの適用終わり。でもここには来ない after-if24 ; if式の終わり after-lambda21; iter定義の終わり (perform (op define-variable!) (const iter) (reg val) (reg env)) ; lamda式のエントリーを変数iterとして登録 (assign val (const ok)) ; iterの定義終わり (assign proc (op lookup-variable-value) (const iter) (reg env)) ; (iter 1 1)式の構築 (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (const 1)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) ; iterの適用 (branch (label primitive-branch37)) compiled-branch38 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch37 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (goto (reg continue)) after-call39 ; iterの適用終わり after-lambda19 (perform (op define-variable!) (const factorial) (reg val) (reg env)) ; lambda式のエントリーを変数factorialに拘束する (assign val (const ok)))) ; factorialの定義終わり >
再帰のfactorialではfactorialの適用が終わった段階で、argl、proc、continueを復元するのでfactorialを呼び出す数だけこれらのレジスタ用のスタック領域が必要となる。
Exercise 5.35
逆アセンブル問題
(assign val (op make-compiled-procedure) (label entry16) (reg env)) (goto (label after-lambda15)) … after-lambda15 (perform (op define-variable!) (const f) (reg val) (reg env)) (assign val (const ok))
ここはラムダ式を変数fに拘束している。
entry16 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (x)) (reg argl) (reg env))
ラムダ式の初期化部分。仮引数はxのみ。
(assign proc (op lookup-variable-value) (const +) (reg env)) (save continue) (save proc) (save env)
＋演算の式を構築し始めるけど、これらのレジスタを退避するということは引数にも式がある。
(assign proc (op lookup-variable-value) (const g) (reg env)) (save proc)
手続きgを適用する式を作り始めるけど、これも退避するのでgに対する引数に式がある。
(assign proc (op lookup-variable-value) (const +) (reg env)) (assign val (const 2)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const x) (reg env)) (assign argl (op cons) (reg val) (reg argl))
引数リストは右側から構築するので(+ x 2)式を構築。
(test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch19)) compiled-branch18 (assign continue (label after-call17)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch19 (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(+ x 2)を評価。
after-call17 (assign argl (op list) (reg val)) (restore proc) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch22)) compiled-branch21 (assign continue (label after-call20)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch22 (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(+ x 2)の結果を引数に復元したproc、即ち手続きgを適用する。
(assign argl (op list) (reg val)) (restore env) (assign val (op lookup-variable-value) (const x) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (restore proc)
(g (+ x 2))の結果を引数に、さらに引数にxを追加して復元したproc、即ち+を適用する。
(restore continue) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch25)) compiled-branch24 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch25 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (goto (reg continue))
continueを復元しているので+の適用が最後の式。
まとめると
(define (f x) (+ x (g (+ x 2))))
Exercise 5.36
式のオペランドの処理は右から行われる、つまりright-to-left。「arglに追加するときにconsを使う都合上」とテキストにも書いてある。
この部分の処理はconstruct-arglistで行っている。最初にoperand-codesをreverseして、そのcarに対してcode-to-get-last-argを適用している部分。
left-to-rightにするには、
- construct-arglistでreverseをやめる
- arglに追加するときにconsではなくadjoin-argを使用する
(define (construct-arglist operand-codes) (if (null? operand-codes) (make-instruction-sequence '() '(argl) '((assign argl (const ())))) (let ((code-to-get-last-arg (append-instruction-sequences (car operand-codes) (make-instruction-sequence '(val) '(argl) '((assign argl (op list) (reg val))))))) (if (null? (cdr operand-codes)) code-to-get-last-arg (preserving '(env) code-to-get-last-arg (code-to-get-rest-args (cdr operand-codes))))))) (define (code-to-get-rest-args operand-codes) (let ((code-for-next-arg (preserving '(argl) (car operand-codes) (make-instruction-sequence '(val argl) '(argl) '((assign argl (op adjoin-arg) (reg val) (reg argl))))))) ; Ex 5.36 (if (null? (cdr operand-codes)) code-for-next-arg (preserving '(env) code-for-next-arg (code-to-get-rest-args (cdr operand-codes))))))
動作確認
> (compile '(+ x (* y 2)) 'val 'next) '((env) (env proc argl continue val) ((assign proc (op lookup-variable-value) (const +) (reg env)) (save proc) (assign val (op lookup-variable-value) (const x) (reg env)) ; xからリストに追加する (assign argl (op list) (reg val)) (save argl) (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* y 2)を評価 (assign val (op lookup-variable-value) (const y) (reg env)) (assign argl (op list) (reg val)) (assign val (const 2)) (assign argl (op adjoin-arg) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch1)) compiled-branch2 (assign continue (label after-call3)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch1 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call3 (restore argl) (assign argl (op adjoin-arg) (reg val) (reg argl)) ; adjoin-argで追加 (restore proc) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch4)) compiled-branch5 (assign continue (label after-call6)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch4 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call6)) >
元のコードでの出力は
> (compile '(+ x (* y 2)) 'val 'next) '((env) (env proc argl continue val) ((assign proc (op lookup-variable-value) (const +) (reg env)) (save proc) (save env) ; (* y 2)を評価した後xを参照するのでenvをセーブする必要がある (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* y 2)を評価 (assign val (const 2)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const y) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch1)) compiled-branch2 (assign continue (label after-call3)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch1 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call3 (assign argl (op list) (reg val)) (restore env) (assign val (op lookup-variable-value) (const x) (reg env)) (assign argl (op cons) (reg val) (reg argl)) ; consで追加 (restore proc) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch4)) compiled-branch5 (assign continue (label after-call6)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch4 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call6)) >
code-to-get-last-argと言う変数の名前は変えた方が良いかもしれないけど。
Exercise 5.37
preservingのコードの以下の部分
(if (and (needs-register? seq2 first-reg) (modifies-register? seq1 first-reg))
「あるレジスタが二番目の命令列で必要としていて、かつ、最初の命令列で変更する場合にのみ」の条件分岐を取り除けば、preservingに渡されれるレジスタは全て保存される。
(define (preserving regs seq1 seq2) (if (null? regs) (append-instruction-sequences seq1 seq2) (let ((first-reg (car regs))) (preserving (cdr regs) (make-instruction-sequence (list-union (list first-reg) (registers-needed seq1)) (list-difference (registers-modified seq1) (list first-reg)) (append `((save ,first-reg)) (statements seq1) `((restore ,first-reg)))) seq2))))
実行してみる。
まずは元のコードの出力。
> (compile '(+ 1 2) 'var 'next) '((env) (env proc val argl continue var) ((assign proc (op lookup-variable-value) (const +) (reg env)) (assign val (const 2)) (assign argl (op list) (reg val)) (assign val (const 1)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch1)) compiled-branch2 (assign continue (label proc-return4)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) proc-return4 (assign var (reg val)) (goto (label after-call3)) primitive-branch1 (assign var (op apply-primitive-procedure) (reg proc) (reg argl)) after-call3)) >
定数だけなので実は全くsave/restoreは不要。
冗長なコードの出力。そもそも全てのsave/restoreは不要。
> (compile '(+ 1 2) 'var 'next) '((env continue) ; continueは使うけどlinkageがnextなので破壊して良い (env proc val argl continue var) ((save continue) ; continue保存する必要なし (save env) ; 変数は使っていないのでenvを参照する事はないし、よって保存する必要もなし (save continue) ; なんの変更もせずcontinueを２回セーブする。そもそもprocを設定するのにcontinueを保存する必要なし (assign proc (op lookup-variable-value) (const +) (reg env)) (restore continue) (restore env) (restore continue) (save continue) ; restoreしたばかりなのにまたセーブ (save proc) ; これ以降procは全く書き換えられないので保存する必要なし (save env) (save continue) ; valに定数2を代入するのにcontinueを保存する必要なし (assign val (const 2)) (restore continue) (assign argl (op list) (reg val)) (restore env) (save argl) ; valに定数1を代入するのにarglを保存する必要なし (save continue) ; valに定数1を代入するのにcontinueを保存する必要なし (assign val (const 1)) (restore continue) (restore argl) (assign argl (op cons) (reg val) (reg argl)) (restore proc) (restore continue) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch1)) compiled-branch2 (assign continue (label proc-return4)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) proc-return4 (assign var (reg val)) (goto (label after-call3)) primitive-branch1 (save continue) (assign var (op apply-primitive-procedure) (reg proc) (reg argl)) (restore continue) after-call3)) >
Exercise 5.38
現に(+ a 1)をコンパイルすると
> (compile '(+ a 1) 'var 'next) '((env) (env proc val argl continue var) ((assign proc (op lookup-variable-value) (const +) (reg env)) (assign val (const 1)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const a) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch1)) compiled-branch2 (assign continue (label proc-return4)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) proc-return4 (assign var (reg val)) (goto (label after-call3)) primitive-branch1 (assign var (op apply-primitive-procedure) (reg proc) (reg argl)) after-call3)) >
コンパイラが特定の演算子についてはインラインにコードを展開する様にコンパイラを改造する。
arglに入っている引数に対してprocを適用するのではなく、新しい二つのレジスタarg1およびarg2を使い、プリミティブのオペレーションを使って演算するコードを生成する。
a.
オペランドのリストを受け取り、それぞれをarg1およびarg2をターゲットにしてコンパイルする。
元のcompile-applicationからconstruct-arglistに渡すコンパイルされたそれぞれの引数を評価するコードのリストを生成する部分
(operand-codes (map (lambda (operand) (compile operand 'val 'next)) (operands exp))))
に相当する。
オペランドの数は二つに限定するので、それぞれを引数として受け取る事にする。
(define (spread-arguments exp1 exp2) (list (compile exp1 'arg1 'next) (compile exp2 'arg2 'next)))
保存する必要がある可能性があるのはarg2だが、それは
- arg1の値を生成するコードがarg2を破壊する
- 演算を行うコードがarg2を必要としている
ので。とするとpreservingを呼び出すのは演算を行うコードを生成する時点。なのでここではない。
疑問点：
b.
compile-applicationに相当する手続き。引数は式、ターゲット、リンク。
compile-procedure-callの部分は不要で、ここが単にopで手続きを呼び出して結果をvalに代入するだけの命令列を生成する。compile-procedure-callのプリミティブを呼び出す部分を参考にする。
arg2の値を生成するコードと、arg2を保存したままarg1を生成するコードと演算を行うコードを連結したものを連結する。
(define (compile-open-code-primitive exp target linkage) (if (= (length exp) 3) (let* ((operator (car exp)) (operand-codes (spread-arguments (cadr exp) (caddr exp))) (operand1 (car operand-codes)) (operand2 (cadr operand-codes))) (end-with-linkage linkage (append-instruction-sequences operand2 (preserving '(arg2) operand1 (make-instruction-sequence '(arg1 arg2) (list target) `((assign ,target (op ,operator) (reg arg1) (reg arg2)))))))) (error "Arity mismatch -- COMPILE-OPEN-CODE-PRIMITIVE" exp))) ; raise compile time error
ここまでを単純な例で実行してみる。
> (compile-open-code-primitive '(+ 1 2) 'val 'next) '(() (arg2 arg1 val) ((assign arg2 (const 2)) (assign arg1 (const 1)) (assign val (op +) (reg arg1) (reg arg2)))) >
ディスパッチする部分
(define (compile exp target linkage) (cond ((self-evaluating? exp) … ((cond? exp) (compile (cond->if exp) target linkage)) ((open-code-primitive? exp) (compile-open-code-primitive exp target linkage)) ((application? exp) (compile-application exp target linkage)) (else (error "Unknown expression type -- COMPILE" exp)))) (define (open-code-primitive? exp) (memq (car exp) '(= * - +)))
複合の式で試してみる。
> (compile '(+ (+ 1 2) 3) 'val 'next) '(() (arg2 arg1 val) ((assign arg2 (const 3)) (save arg2) (assign arg2 (const 2)) (assign arg1 (const 1)) (assign arg1 (op +) (reg arg1) (reg arg2)) (restore arg2) (assign val (op +) (reg arg1) (reg arg2)))) >
c.
> (compile '(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) 'val 'next) '((env) (val) ((assign val (op make-compiled-procedure) (label entry1) (reg env)) (goto (label after-lambda2)) entry1 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (n)) (reg argl) (reg env)) (assign arg2 (const 1)) ; ここから (assign arg1 (op lookup-variable-value) (const n) (reg env)) (assign val (op =) (reg arg1) (reg arg2)) ; ここが短くなった (test (op false?) (reg val)) (branch (label false-branch4)) true-branch3 (assign val (const 1)) (goto (reg continue)) false-branch4 (save continue) (assign arg2 (op lookup-variable-value) (const n) (reg env)) ; nをarg2に入れて退避 (save arg2) (assign proc (op lookup-variable-value) (const factorial) (reg env)) (assign arg2 (const 1)) ; ここから (assign arg1 (op lookup-variable-value) (const n) (reg env)) (assign val (op -) (reg arg1) (reg arg2)) ; ここも短くなった (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) compiled-branch7 (assign continue (label proc-return9)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) proc-return9 (assign arg1 (reg val)) (goto (label after-call8)) primitive-branch6 (assign arg1 (op apply-primitive-procedure) (reg proc) (reg argl)) ; レジスタvalを使わず after-call8 (restore arg2) ; 退避していたnを復元 (assign val (op *) (reg arg1) (reg arg2)) ; 演算部分が短くなった (restore continue) (goto (reg continue)) after-if5 after-lambda2 (perform (op define-variable!) (const factorial) (reg val) (reg env)) (assign val (const ok)))) >
d.
入力の式を変形する事を考える。
(define (make-nest exp) (let ((op (car exp))) (define (aug operands) (if (= (length operands) 2) (cons op operands) (list op (car operands) (aug (cdr operands))))) (aug (cdr exp))))
動作は
> (make-nest '(+ 1 2 3 4 5)) '(+ 1 (+ 2 (+ 3 (+ 4 5)))) >
面倒なのでopen-codeにするのは+と*だけにして
(define (open-code-primitive? exp) (memq (car exp) '(* +)))
compile-open-code-primitiveでは一旦式を変換してからコンパイルする
(define (compile-open-code-primitive exp target linkage) (let ((exp (make-nest exp))) (let* ((operator (car exp)) (operand-codes (spread-arguments (cadr exp) (caddr exp))) (operand1 (car operand-codes)) (operand2 (cadr operand-codes))) (end-with-linkage linkage (append-instruction-sequences operand2 (preserving '(arg2) operand1 (make-instruction-sequence '(arg1 arg2) (list target) `((assign ,target (op ,operator) (reg arg1) (reg arg2))))))))))
動作確認
> (compile '(+ 1 2 3 4) 'val 'next) '(() (arg2 arg1 val) ((assign arg2 (const 4)) (assign arg1 (const 3)) (assign arg2 (op +) (reg arg1) (reg arg2)) (assign arg1 (const 2)) (assign arg2 (op +) (reg arg1) (reg arg2)) (assign arg1 (const 1)) (assign val (op +) (reg arg1) (reg arg2)))) >
SICP 5.5 Compilation
ノート
前節のインタープリタのプログラムは機械語のプログラムと捉えることができる。
ソースプログラムと機械語とを橋渡しする方法には二つある。
一つはインタープリタ。インタープリタの基本的な命令は機械語のサブルーチンとして実現されていて、ソースプログラムはデータとして存在している。データであるソースプログラムを解釈しながら適切な機械語のサブルーチンを呼び出してプログラムを実行してゆく。
もう一つはコンパイラ。コンパイラはソースプログラムを機械語のプログラムに翻訳する。
コンパイルすると実行の効率は良いが、インタープリタの方は対話的な開発やデバッグ等に優れた環境を提供できる。
近年ではこれら二つの方式が混在する環境が求められている。
An overview of the compiler
後々のインタープリタとコンパイルされたプログラムの混在を考慮して、コンパイラもインタープリタと同じレジスタの使い方をするようなプログラムを生成させる。4.1.7 Separating Syntactic Analysis from Executionで行ったのと同様に、プログラムの解釈と実行を分離する。4.1.7の時はlambda式のリストを生成していた。
レジスタの対比についてはインタープリタよりもコンパイラの方が最適化出来る。インタープリタでは、入れ子の式を評価するのに使用中の全てのレジスタを対比する必要があったが、コンパイラではその間に使用されるレジスタが分かるので、必要最小限のレジスタ退避で済む。
変数の検索も実行時に行わずに済む。
5.5.1 Structure of the Compiler
最上位の手続きcompileは4.1.1節のeval、4.1.7節のanalyze、5.4.1節のeval-dispatchと同じ役割。
Targets and linkages
手続きcompileの引数はプログラムとしての式expの他にtargetとlinkage。
targetは式を評価した結果を保存するレジスタ。linkageはコンパイルしたコードが実行を終えた後の続きを示す。
Instruction sequences and stack usage
単純に二つの命令列を連結するのがappend-instruction-sequences。
preservingは二つ目の命令列が必要とするレジスタを一つ目の命令列が変更してしまう場合に、一つ目の命令列の前後にsaveとrestoreを挿入してから二つの命令列を連結する。レジスタのハンドリングはこのpreservingに任せる。
ただ、preservingだけで命令を連結してゆくと、一度レジスタ使用を走査した命令列を何度も走査する事になり非効率なので、命令列には入力として初期化される必要があるレジスタ、命令列で変更されるレジスタの情報が添付される。
Exercise 5.31
preservingの内容というよりは、ev-applicationエントリポイントに相当する命令がどう生成されるのかに依存するので、ここでは予測に過ぎないが、ポイントは評価は左から行うものの右側から評価に何が必要かを考える。
- (f 'x 'y) ：オペランドは全て定数なのでenvは使用しないし、fが保存されているprocや、引数を保存するarglを別用途で書き換える事もないので、レジスタの退避は一切必要なし。
- ((f) 'x 'y) ：オペランドの評価にはenv、procは必要ないし、arglも別の用途で使われる事もないので(f)の評価時にレジスタの退避は一切必要なし。
- (f (g 'x) y) ：最後のyを評価するのにenvが必要だし、procには既にfが入っているので(g 'x)評価時にenvとprocは退避が必要。arglは(g 'x)評価前に初期化されているなら退避が必要。
- (f (g 'x) 'y) ：前問に比べて最後のyの評価にenvは必要ないので(g 'x)評価時にはprocのみを退避すれば良い。arglについては前問と同様。
Exercise 5.32
a) オペレータがシンボルの場合、すなわち変数の場合は結局以下の部分に飛んで戻って来る。
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(test (op bound?) (reg val))
(branch (label bound-variable))
(goto (label unbound-variable))
bound-variable
(assign val (op bound-value) (reg val))
(goto (reg continue))
val以外には書き換えない。expにオペレータ部を入れてこれが変数だった場合には、ev-variableに飛んで戻って来れば良い。
ev-application
(save continue)
(assign unev (op operands) (reg exp))
(save unev)
(assign continue (label ev-appl-did-operator))
(assign exp (op operator) (reg exp))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(save env)
(save unev)
(assign continue (label ev-appl-operator-evaluated))
(goto (label eval-dispatch))
ev-appl-operator-evaluated
(restore unev)
(restore env)
ev-appl-did-operator
…
実行してみる
;;; EC-Eval input: (define (double x) (* x 2)) ;;; EC-Eval value: ok ;;; EC-Eval input: (double 3) ;;; EC-Eval value: 6 ;;; EC-Eval input:
トレースを出してみると：
… ev-application (save continue) (assign unev (op operands) (reg exp)) (assign continue (label ev-appl-did-operator)) (assign exp (op operator) (reg exp)) (test (op variable?) (reg exp)) (branch (label ev-variable)) ev-variable (assign val (op lookup-variable-value) (reg exp) (reg env)) (test (op bound?) (reg val)) (branch (label bound-variable)) bound-variable (assign val (op bound-value) (reg val)) (goto (reg continue)) ev-appl-did-operator (assign argl (op empty-arglist)) (assign proc (reg val)) …
b) インタープリタをどこまで最適化しても、eval-dispatchでの全ての条件判断、今回追加した様なvariable?の様な条件判断（つまりソースコードを解釈する部分）が残っている限りコンパイラの速度に追い付く事はない。
SICP 5.4.4 Running the Evaluator
ノート
ここに書いてあるドライバーループは既に実装として使っている。しかもExcersese 5.25では少し変更もしている。
Exercise 5.25の結果でもちゃんと例は動作する。
(define (append x y) (if (null? x) y (cons (car x) (append (cdr x) y)))) ;;; EC-Eval value: ok ;;; EC-Eval input: (append '(a b c) '(d e f)) ;;; EC-Eval value: (a b c d e f) ;;; EC-Eval input:
ここでは、Racketで実装されたSchemeインタープリータでSchemeプログラムを実行しているので、Racketに直接プログラムを実行させるのよりはパーフォーマンスが劣る。
Monitoring the performance of the evaluator
テキストの通りスタックの状況をプリントしてみる。
;;; EC-Eval input: (define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) (total-pushes = 3 maximum-depth = 3) ;;; EC-Eval value: ok ;;; EC-Eval input: (factorial 5) (total-pushes = 144 maximum-depth = 28) ;;; EC-Eval value: 120 ;;; EC-Eval input:
Exercise 5.26
| n | n! | total-pushes | maximum-depth |
|---|---|---|---|
| 3 | 6 | 134 | 10 |
| 4 | 24 | 169 | 10 |
| 5 | 120 | 204 | 10 |
| 6 | 720 | 239 | 10 |
a)
と言う訳で、maximum-depthは常に10。
b)
3!と4!の差が35、4!と5!の差も35、以下同文。また、35×3=105なので134との差は29。と言う訳で
Exercise 5.27
| n | n! | total-pushes | maximum-depth |
|---|---|---|---|
| 3 | 6 | 80 | 18 |
| 4 | 24 | 112 | 23 |
| 5 | 120 | 144 | 28 |
| 6 | 720 | 176 | 33 |
プッシュ回数は32ずつ、深さは5ずつ増えていく。
| 実装方法 | maximum-depth | toal-pushes |
|---|---|---|
| 再帰 | 5n+3 | 32n+16 |
| 反復 | 10 | 35n+29 |
Exercise 5.28
再帰的実装から：
| n | n! | total-pushes | maximum-depth |
|---|---|---|---|
| 3 | 6 | 86 | 27 |
| 4 | 24 | 120 | 35 |
| 5 | 120 | 154 | 43 |
| 6 | 720 | 188 | 51 |
次に反復的実装。
| n | n! | total-pushes | maximum-depth |
|---|---|---|---|
| 3 | 6 | 144 | 23 |
| 4 | 24 | 181 | 26 |
| 5 | 120 | 218 | 29 |
| 6 | 720 | 255 | 32 |
| 実装方法 | maximum-depth | toal-pushes |
|---|---|---|
| 再帰 | 8n+3 | 34n-16 |
| 反復 | 3n+14 | 37n+33 |
Exercise 5.29
| n | fib(n) | total-pushes | maximum-depth |
|---|---|---|---|
| 2 | 1 | 72 | 13 |
| 3 | 2 | 128 | 18 |
| 4 | 3 | 240 | 23 |
| 5 | 5 | 408 | 28 |
| 6 | 8 | 688 | 33 |
a)
5ずつ増えて、n=0を仮定すると3になるので
b)
S(4)=240、S(3)=128、S(2)=72から考えるとS(4)=S(3)+S(2)+40。
この式からS(5)を予想すると、S(5)=240+128+40=408。合ってる。
S(6)を予想すると、S(6)=408+240+40=688。合っていそう。
と言う訳で、
S(2)をで表す。72=2a+b。S(3)から128=3a+b。
連立方程式を解くとa=56、b=-40。つまり
S(4)を予測すると、
S(5)を予測すると、
Exercise 5.30
a)
インタープリタのコードがエラーで止まる箇所は以下の通り。
| make-register/dispatch | レジスタに対する未定義のメッセージを送った |
| make-stack/pop | 既にからのスタックからポップしようとした |
| make-stack/dispatch | スタックに対する未定義のメッセージを送った |
| make-new-machine/allocate-register | 既に定義されたレジスタ名を再定義しようとした |
| make-new-machine/dispatch | マシンに対する未定義のメッセージを送った |
| lookup-label | 未定義のラベルを参照した |
| make-execution-procedure | 未定義の命令を実行しようとした |
| make-test | test命令の文法が間違っている |
| make-branch | branch命令の文法が間違っている |
| make-goto | goto命令の文法が間違っている |
| make-perform | perform命令の文法が間違っている |
| make-primitive-exp | プリミティブ命令の文法が間違っている |
| lookup-prim | 未定義のプリミティブを実行しようとした |
| extend-evaluation | 環境に登録する名前と値の数が一致しない |
| lookup-variable-value | 未定義の名前を参照しようとした |
| set-variable-value | 未定義の名前の値を変更しようとした |
lookup-variable-valueでのエラーだけはユーザーの入力によって起こり得るが、それ以外は全てインタープリタのコードのバグでしか起こり得ない。インタープリタのバグの場合はREPLから抜けるのは適切な対応と言えるので、対応すべきはlookup-variable-valueでのエラーへの対処のみと言って良い。
まずはlookup-variable-valueがerrorで停止している部分を改造。
Racketのdictionaryを使った現在の実装。
(define (lookup-variable-value var env) (define (env-loop env) (if (eq? env the-empty-environment) (error "Unbound variable" var) (dict-ref (first-frame env) var (lambda () (env-loop (enclosing-environment env)))))) (env-loop env))
変数の値としては何でも取り得るので、Maybe型の様な（タグ＋値）と言うタプルを返したい所。そうすると変数が見つかった時に直ぐに戻ってしまう今の形では無理。これを以下の様に変更して、更に補助関数も用意。
(define (lookup-variable-value var env) (define (env-loop env) (cond ((eq? env the-empty-environment) (cons 'unbound '())) ((dict-has-key? (first-frame env) var) (cons 'bound (dict-ref (first-frame env) var))) (else (env-loop (enclosing-environment env))))) (env-loop env)) (define (bound? result) (eq? (car result) 'bound)) (define (bound-value result) (cdr result))
動作確認
> (lookup-variable-value 'x (list #hash((x . 1) (y . 2)) #hash((a . "a") (b . "b")) '())) '(bound . 1) > (lookup-variable-value 'z (list #hash((x . 1) (y . 2)) #hash((a . "a") (b . "b")) '())) '(unbound) > (lookup-variable-value 'b (list #hash((x . 1) (y . 2)) #hash((a . "a") (b . "b")) '())) '(bound . "b") > (bound? (lookup-variable-value 'x (list #hash((x . 1) (y . 2)) #hash((a . "a") (b . "b")) '()))) #t > (bound? (lookup-variable-value 'z (list #hash((x . 1) (y . 2)) #hash((a . "a") (b . "b")) '()))) #f > (bound-value (lookup-variable-value 'x (list #hash((x . 1) (y . 2)) #hash((a . "a") (b . "b")) '()))) 1 > (bound-value (lookup-variable-value 'b (list #hash((x . 1) (y . 2)) #hash((a . "a") (b . "b")) '()))) "b" >
補助関数をオペレータとして追加
(define eceval-operations (list (list 'self-evaluating? self-evaluating?) … (list 'bound? bound?) (list 'bound-value bound-value) ))
ev-variableの部分は以下のように変更
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(test (op bound?) (reg val))
(branch (label bound-variable))
(goto (label unbound-variable))
bound-variable
(assign val (op bound-value) (reg val))
(goto (reg continue))
エラー処理部分は
unbound-variable
(assign val (const unbound-variable-error))
(goto (label signal-error))
動作させてみる。
;;; EC-Eval input: (define x 1) ;;; EC-Eval value: ok ;;; EC-Eval input: x ;;; EC-Eval value: 1 ;;; EC-Eval input: y unbound-variable-error ;;; EC-Eval input:
REPLに戻っている。
b)
;;; EC-Eval input: (/ 1 0) . . /: division by zero >
現状ではプリミティブのエラーはインタープリタの実行が止まってしまう。
ベースのSchemeとして使用しているRacketではwith-handlersと言う関数を使って例外処理ができるので、プリミティブのエラーは例外を補足する事で取り敢えず実現できる。
> (with-handlers ([exn:fail? (lambda (exn) exn)]) (/ 1 0)) (exn:fail:contract:divide-by-zero "/: division by zero" #<continuation-mark-set>) >
これを使ってapply-primitive-procedureからwith-handlersを呼び出す様に変更する。結果はタプルで成否を示す#t/#fと、成功した時には戻り値を、失敗のときには飛ばされた例外のペアにする。またこのタプルにアクセスする補助関数を用意する。
(define (apply-primitive-procedure proc args) (with-handlers ([exn:fail? (lambda (exn) (cons #f exn))]) (cons #t (apply-in-underlying-scheme (primitive-implementation proc) args)))) (define (primitive-apply-succeeded? result) (car result)) (define (primitive-apply-result result) (cdr result)) … (define eceval-operations (list (list 'self-evaluating? self-evaluating?) … (list 'primitive-apply-succeeded? primitive-apply-succeeded?) (list 'primitive-apply-result primitive-apply-result) ))
primitive-applyはapply-primitive-procedureを呼び出した後に成否をチェックする。
primitive-apply
(assign val (op apply-primitive-procedure)
(reg proc)
(reg argl))
(test (op primitive-apply-succeeded?) (reg val))
(branch (label primitive-apply-succeeded))
(goto (label primitive-apply-failed))
primitive-apply-succeeded
(assign val (op primitive-apply-result) (reg val))
(restore continue)
(goto (reg continue))
エラーハンドリングでも投げられた例外を表示するようにする。
primitive-apply-failed
(assign val (op primitive-apply-result) (reg val))
(goto (label signal-error))
実行してみる。
;;; EC-Eval input: (/ 10 5) ;;; EC-Eval value: 2 ;;; EC-Eval input: (/ 1 0) #(struct:exn:fail:contract:divide-by-zero /: division by zero #<continuation-mark-set>) ;;; EC-Eval input: (car 'a) #(struct:exn:fail:contract car: contract violation expected: pair? given: 'a #<continuation-mark-set>) ;;; EC-Eval input: (cons 'a) #(struct:exn:fail:contract:arity cons: arity mismatch; the expected number of arguments does not match the given number expected: 2 given: 1 arguments...: 'a #<continuation-mark-set>) ;;; EC-Eval input:
もう少し気の利いた出力が出来ると良いが、取り敢えずこれで目的は達成している。
SICP 5.4 The Explicit-Control Evaluator
ノート
第４章のMetacircular evaluatorをレジスタマシンで実現する。
Registers and operations
第４章で実装した各シンタックスに対応する手続きをそのままレジスタマシンに移植する事も出来るが、ポイントがズレてしまうので各シンタックスに対応する処理を直接レジスタマシンに書き下す。
5.4.1 The Core of the Explicit-Control Evaluator
まずディスパッチャ。シンタックスの解釈は全てプリミティブとして実装されている。
Evaluating simple expressions
シンプルな式の評価。レジスタvalに結果を保存して、レジスタcontinueに保存されたラベルにジャンプする。ここでもかなりのプリミティブが用いられている。
ev-self-evalはリテラルの処理。expは数値か文字列なので、それをそのままvalに保存してcontinueに飛ぶ。
ev-variableはexpが示す変数の値を環境から探して来てvalに保存する。変数の値を探すのはプリミティブのlookup-variable-value。
ev-quotedはシンボルの処理。プリミティブtext-of-quotationでシンボル名をvalに保存。
ev-lambdaはラムダ式の処理。unevに引数のリスト、expに本体を入れてプリミティブmake-procedureで手続きを作ってvalに保存。
Evaluating procedure applications
Metacircular evaluaterでは式の各要素を再帰的に評価して、その結果をapplyに渡していたが、explicit-control evaluatorでも同様に実装する。
ev-applicationは関数呼び出し。オペレータ部分をexpに入れてeval-dispatchを呼び出し、帰って来たらev-appl-did-operatorに進む。
ev-appl-did-opertorでは実引数の評価。procに評価が終わったオペレータを設定して、引数が無ければ直ぐにapply-dispatchに進む。引数がある場合には一旦procをスタックに保存して、ev-appl-operand-loopに進む。
ev-appl-operand-loopは順番に引数を評価する。expに最初の引数を保存してeval-dispatchに飛ぶ。戻り先はev-appl-accumulate-arg。最後の引数の場合にはev-appl-last-argに進む。
ここの実装方法により引数の評価順序が決まる。ここではfirst-operandがcarで、rest-operandsがcdrなので左側の引数から評価される事になる。
ev-appl-accumulate-argでは、arglに評価が終わった引数を追加し、unevから評価が終わった引数を取り除き、ev-appl-operand-loopに戻る。
ev-appl-last-argは最後の引数の評価。最後なのでレジスタはスタックに保存しておく必要が無い。eval-dispatchに飛んで、ev-appl-accum-last-argに戻る。
ev-appl-accum-last-argでは最後の引数をarglに追加。スタックにセーブしてあったオペレータをprocに戻してapply-dispatchに飛ぶ。
Procedure application
apply-dispatchに飛んで来た時点で、procには手続きが、arglには評価が終わった実引数が入っている。continueに入っていた戻り場所はスタックにセーブされている。手続きの適用が終わった段階ではvalに評価が終わった値を入れて、スタックにセーブされていたcontinueの場所に飛ぶ。
procの手続きがプリミティブであればprimitive-applyに、そうでない手続きであればcompound-applyに、それ以外はunknown-procedure-typeに飛ぶ。
primitive-applyではレジスタマシンのプリミティブapply-primitive-procedureにprocとarglを渡して、結果をvalに保存して、continueをリストアして、そのラベルにジャンプする。
compound-applyでは、プリミティブprocedure-parametersでフレームを作りunevに保存、プリミティブprocedure-environmentで環境を救ってenvに保存、unev、argl、envから環境を拡張。unevには手続きの本体を保存して、ev-sequenceにジャンプ。
5.4.2 Sequence Evaluation and Tail Recursion
ev-beginは明示的にbeginで始まるシーケンスを評価する。これから評価するシーケンスexpをunevに保存して、戻る場所continueをスタックに保存してからシーケンスを評価するev-sequenceにジャンプする。
ev-sequenceとev-sequence-continueでループを形成。compound-applyから呼ばれる時は手続きの本体の評価、ev-beginから呼ばれる時はbeginで始まるシーケンスの評価。評価する前のシーケンスはunevに保存される。
ev-sequenceではexpにシーケンスの最初の式を取り出し、それが最後の式でなければunevとenvを保存、戻り場所としてcontinueにev-sequence-continueを保存して、eval-dispatchにジャンプして式を評価する。最後の式の場合にはev-sequence-last-expにジャンプ。
ev-sequence-continueではeval-dispatchから戻って来た所なので、envとunevを戻して、unevを更新、ev-sequenceに戻る。
ev-sequence-last-expではcontinueを戻して、最後の式をev-sequenceで評価する。
Tail recursion
ev-sequence-last-expでは最後の式を評価する時にunevもenvもスタックに保存せずにev-sequenceに飛ぶので、末尾再帰で余計なスタックは使わない様になっている。
5.4.3 Conditionals, Assignments, and Definitions
スペシャルフォームの評価。
ev-ifはifを評価。exp（if節全体）、env、continueをセーブ。continueに分岐部分のラベルを代入して、条件部分をexpに入れてeval-dispatchにジャンプ。
ev-if-decideはレジスタを戻してレジスタvalの値がtrueであればev-if-consequentにジャンプ。そうでなければev-if-alternativeに抜ける。
ev-if-consequentとev-if-altanativeはそれぞれ真の場合、偽の場合の手続きをexpに入れてeval-dispatchにジャンプ。
Assignments and definitions
ev-assignment変数への代入。unevに変数を、expに値部分の式を保存してeval-dispatchを呼ぶ。戻って来る所はev-assignment-1。マシンのオペレーションset-variable-value!を使ってenvの変数に値を設定する。
ev-definitionも同様。
Exercise 5.23
ちょっと先まで読んで、まずはマシンが動く状態にしないと動作確認が出来ない。
5.4.4に書いてあるREPLの部分、4.1.2節、4.1.3節、4.1.4節、Exercise 4.11での実装、脚注に書いてある定義を取り込んで、eceval-operationsにopで使用している手続きを登録する。
(define eceval-operations (list (list 'self-evaluating? self-evaluating?) (list 'variable? variable?) (list 'quoted? quoted?) (list ' assignment? assignment?) (list 'definition? definition?) (list 'if? if?) (list 'lambda? lambda?) (list 'begin? begin?) (list 'application? application?) (list 'lookup-variable-value lookup-variable-value) (list 'text-of-quotation text-of-quotation) (list 'lambda-parameters lambda-parameters) (list 'lambda-body lambda-body) (list 'make-procedure make-procedure) (list 'operands operands) (list 'operator operator) (list 'empty-arglist empty-arglist) (list 'no-operands? no-operands?) (list 'first-operand first-operand) (list 'last-operand? last-operand?) (list 'adjoin-arg adjoin-arg) (list 'rest-operands rest-operands) (list 'primitive-procedure? primitive-procedure?) ; (list 'compound-procedure? compound-procedure?) (list 'apply-primitive-procedure apply-primitive-procedure) (list 'procedure-parameters procedure-parameters) (list 'procedure-environment procedure-environment) (list 'extend-environment extend-environment) (list 'procedure-body procedure-body) (list 'begin-actions begin-actions) (list 'first-exp first-exp) (list 'last-exp? last-exp?) (list 'rest-exps rest-exps) (list 'no-more-exps? no-more-exps?) (list 'if-predicate if-predicate) (list 'true? true?) (list 'if-alternative if-alternative) (list 'if-consequent if-consequent) (list 'assignment-variable assignment-variable) (list 'assignment-value assignment-value) (list 'set-variable-value! set-variable-value!) (list 'definition-variable definition-variable) (list 'definition-value definition-value) (list 'define-variable! define-variable!) (list 'prompt-for-input prompt-for-input) (list 'read read) (list 'get-global-environment get-global-environment) (list 'announce-output announce-output) (list 'user-print user-print) ))
動作確認。
> (start eceval) ;;; EC-Eval input: (define (append x y) (if (null? x) y (cons (car x) (append (cdr x) y)))) ;;; EC-Eval value: ok ;;; EC-Eval input: (append '(a b c) '(d e f)) ;;; EC-Eval value: (a b c d e f) ;;; EC-Eval input: .
4.1.2節とそこのExerciseで拡張した構文はcond、and、or、let、let*、named-let（Exercis 4.8）とdo（Exercise 4.9）。その時に実装した手続きを取り込む。
その際にself-evaluating?にbooleanを加えないと、valに帰って来た#t等が処理出来ずにunknown-expression-type-errorとなってしまう。
(define (self-evaluating? exp) (cond ((number? exp) true) ((string? exp) true) ((boolean? exp) true) (else false)))
プリミティブの追加。
(define eceval-operations (list (list 'self-evaluating? self-evaluating?) … (list 'cond? cond?) (list 'cond->if cond->if) (list 'and? and?) (list 'and->if and->if) (list 'or? or?) (list 'or->if or->if) (list 'let? let?) (list 'let->combination let->combination) (list 'let*? let*?) (list 'let*->nested-lets let*->nested-lets) (list 'do? do?) (list 'do->named-let do->named-let) ))
マシンを拡張
… eval-dispatch … (test (op cond?) (reg exp)) (branch (label ev-cond)) (test (op and?) (reg exp)) (branch (label ev-and)) (test (op or?) (reg exp)) (branch (label ev-or)) (test (op let?) (reg exp)) (branch (label ev-let)) (test (op let*?) (reg exp)) (branch (label ev-nested-let)) (test (op do?) (reg exp)) (branch (label ev-do)) (test (op application?) (reg exp)) (branch (label ev-application)) (goto (label unknown-expression-type)) … ev-cond (assign exp (op cond->if) (reg exp)) (goto (label eval-dispatch)) ev-and (assign exp (op and->if) (reg exp)) (goto (label eval-dispatch)) ev-or (assign exp (op or->if) (reg exp)) (goto (label eval-dispatch)) ev-let (assign exp (op let->combination) (reg exp)) (goto (label eval-dispatch)) ev-nested-let (assign exp (op let*->nested-lets) (reg exp)) (goto (label eval-dispatch)) ev-do (assign exp (op do->named-let) (reg exp)) (goto (label eval-dispatch)) …
テストの為に少しオペレータを追加
(define primitive-procedures (list (list 'car car) (list 'cdr cdr) (list 'cons cons) (list 'null? null?) (list 'list list) (list 'map map) (list '> >) (list '= =) (list '+ +) (list '- -) (list 'display display) (list 'newline newline) ; <more primitives> ))
condのテスト。
;;; EC-Eval input: (define x 0) ;;; EC-Eval value: ok ;;; EC-Eval input: (cond ((> x 0) x) ((= x 0) (display 'zero) 0) (else (- x))) zero ;;; EC-Eval value: 0 ;;; EC-Eval input: (define x 100) ;;; EC-Eval value: ok ;;; EC-Eval input: (cond ((> x 0) x) ((= x 0) (display 'zero) 0) (else (- x))) ;;; EC-Eval value: 100 ;;; EC-Eval input:
andのテスト
;;; EC-Eval input: (define a 1) ;;; EC-Eval value: ok ;;; EC-Eval input: (define b 2) ;;; EC-Eval value: ok ;;; EC-Eval input: (and (= a 1) (= b 2)) ;;; EC-Eval value: #t ;;; EC-Eval input: (and (= a 1) (= b 1)) ;;; EC-Eval value: #f ;;; EC-Eval input:
orのテスト
;;; EC-Eval input: (or (= a 1) (= b 1)) ;;; EC-Eval value: #t ;;; EC-Eval input: (or (= a 2) (= b 2)) ;;; EC-Eval value: #t ;;; EC-Eval input: (or (= a 2) (= b 1)) ;;; EC-Eval value: #f ;;; EC-Eval input:
letのテスト
;;; EC-Eval input: (let ((a 2)) (+ a 3)) ;;; EC-Eval value: 5 ;;; EC-Eval input:
let*のテスト
;;; EC-Eval input: (let ((a 2)) (+ a 3)) ;;; EC-Eval value: 5 ;;; EC-Eval input: (let* ((a 2) (c (+ a 3))) (+ c 4)) ;;; EC-Eval value: 9 ;;; EC-Eval input:
nemed-letのテスト。Exercise 4.8から。
;;; EC-Eval input: (define (fib n) (let fib-iter ((a 1) (b 0) (count n)) (if (= count 0) b (fib-iter (+ a b) a (- count 1))))) ;;; EC-Eval value: ok ;;; EC-Eval input: (fib 6) ;;; EC-Eval value: 8 ;;; EC-Eval input:
doのテスト
;;; EC-Eval input: (do ((x 1 (+ x 1)) (y 2 (+ y 1))) ((> x 10) x) (display x)(display ":")(display y)(newline)) 1:2 2:3 3:4 4:5 5:6 6:7 7:8 8:9 9:10 10:11 ;;; EC-Eval value: 11 ;;; EC-Eval input:
Exercise 5.24
condを直接評価する命令群を作成する。andとかorとか後で使えそうだからExercise 5.23の結果をベースにcondの部分を入れ替える事にする。
condの処理はifの評価をベースに、条件にマッチした時には問題文で提案されている通りsequenceの処理を利用する。
- 必要な式はunevに全て保存するのでexpを退避する必要はなし
- なので条件を評価するときにはunevは退避する必要がある
- 条件部を評価するのにenvを退避する必要があるのか疑問。ここでは退避しない
- continueは最初に退避してsequenceの処理のジャンプするときには復元せずにそのままジャンプ（sequenceの最後で復元される）
- else部が無くてそのまま抜けてしまう場合にはcontinueを復元して、そこにジャンプする必
- 条件があった場合にはsequenceの処理に合わせてunevに式を保存してev-sequenceにジャンプ
- 条件が合わなかった場合には評価した条件とそれに対応するシーケンンスの部分を取り除いて条件評価部分に戻る
プリミティブとして以下を定義する。
(define (cond-clauses exp) (cdr exp)) (define (cond-predicate clause) (caar clause)) (define (cond-actions clause) (let ((actions (cdar clause))) (if (eq? (car actions) '=>) (cdr actions) actions))) (define (cond-alternative exp) (cdr exp))
一応、cond-actionsの動作確認
> (cond-actions '( ((eq? (car clause) '=) (display "a")(newline)) ((eq? (car clause '>) (display "b")(newline))))) '((display "a") (newline)) > (cond-actions '( ((eq? (car clause) '=) => (display "a")(newline)) ((eq? (car clause '>) => (display "b")(newline))))) '((display "a") (newline)) >
これらとリストの空判定のためにnull?を登録して
(define eceval-operations (list (list 'self-evaluating? self-evaluating?) … (list 'cond-clauses cond-clauses) (list 'cond-predicate cond-predicate) (list 'cond-actions cond-actions) (list 'cond-alternative cond-alternative) (list 'null? null?) …
で、実行部分。
ev-cond
(assign unev (op cond-clauses) (reg exp))
(save continue)
ev-conditions
(test (op null?) (reg unev))
(branch (label ev-cond-no-match))
(assign continue (label ev-cond-decide))
(assign exp (op cond-predicate) (reg unev))
(save unev)
(goto (label eval-dispatch))
ev-cond-decide
(restore unev)
(test (op true?) (reg val))
(branch (label ev-cond-actions))
ev-cond-alternative
(assign unev (op cond-alternative) (reg unev))
(goto (label ev-conditions))
ev-cond-actions
(assign unev (op cond-actions) (reg unev))
(goto (label ev-sequence))
ev-cond-no-match
(restore continue)
(goto (reg continue))
動作確認
;;; EC-Eval input: (define else #t) ;;; EC-Eval value: ok ;;; EC-Eval input: (define x 0) ;;; EC-Eval value: ok ;;; EC-Eval input: (cond ((> x 0) x) ((= x 0) (display 'zero) 0) (else (+ x x))) zero ;;; EC-Eval value: 0 ;;; EC-Eval input: (define x 100) ;;; EC-Eval value: ok ;;; EC-Eval input: (cond ((> x 0) x) ((= x 0) (display 'zero) 0) (else (+ x x))) ;;; EC-Eval value: 100 ;;; EC-Eval input: (define x -100) ;;; EC-Eval value: ok ;;; EC-Eval input: (cond ((> x 0) x) ((= x 0) (display 'zero) 0) (else (+ x x))) ;;; EC-Eval value: -200 ;;; EC-Eval input: (cond ((> x 0) => x) ((= x 0) => (display 'zero) 0) (else => (+ x x))) ;;; EC-Eval value: -200 ;;; EC-Eval input:
elseが無くて抜けてしまうパターン
;;; EC-Eval input: (define x 1) ;;; EC-Eval value: ok ;;; EC-Eval input: (cond ((= x 0) 'zero)) ;;; EC-Eval value: #f ;;; EC-Eval input: (define x 0) ;;; EC-Eval value: ok ;;; EC-Eval input: (cond ((= x 0) 'zero)) ;;; EC-Eval value: zero ;;; EC-Eval input:
とりあえずは動いていそう。
Exercise 5.25
今の実装をざっくり書き下すと：
- オペレータを評価する
- オペランドを一つ一つ評価してarglに溜める
- オペレータがプリミティブならば
- プリミティブ手続きの適用を呼び出す
- 合成手続きならば
- 新しい環境を作る
- 手続きの内容をシーケンスとして評価する
4.2の実装を参考にすると、これを：
- オペレータを評価する
- オペレータがプリミティブならば
- オペランドを一つ一つactual-valueで評価してarglに溜める
- プリミティブ手続きの適用を呼び出す
- 合成手続きらば
- オペランドを一つ一つdelay-itしてarglに溜める
- 新しい環境を作る
- 手続きの内容をシーケンスとして評価する
とするのかな。メモ化は実装しない。
まず「オペレータを評価する」については従来と同じ。
「オペランドを一つ一つ評価してarglに溜める」の部分が「オペレータがプリミティブならば、オペランドを一つ一つactual-valueで評価してarglに溜める」に変化する。オペランドを評価した後の部分を以下のように変更する。
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))
(test (op primitive-procedure?) (reg proc)) ; Ex 5.25
(branch (label apply-primitive-procedure)) ; Ex 5.25
apply-primitive-procedure ; Ex 5.25
(save proc)
ev-appl-operand-loop
…
それから、引数の評価が終わった後、オペーレタを適用する部分に直接元のprimitive-applyの部分に接続する。
ev-appl-accum-last-arg
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc)
(assign val (op apply-primitive-procedure)
(reg proc)
(reg argl))
(restore continue)
(goto (reg continue))
これに伴って、元のapply-dispatchからprimitive-applyへのジャンプの部分は削除しておく。
apply-dispatch
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
(goto (label unknown-procedure-type))
ここまでのところを動作確認。プリミティブに*と/も追加しておく。
(define primitive-procedures (list (list 'car car) … (list '* *) (list '/ /) … ))
実行
;;; EC-Eval input: (* (+ 1 2) (- 6 4)) ;;; EC-Eval value: 6
この後、delay-itを実装するとなると、プリミティブの引数は単にeval-dispatchに飛んではダメで、actual-valueで評価する必要がある。元々のactual-valueはforce-itを使って以下のように定義されていた。
(define (actual-value exp env) (force-it (eval exp env))) (define (force-it obj) (if (thunk? obj) (actual-value (thunk-exp obj) (thunk-env obj)) obj))
この部分を翻訳すると。
actual-value
(save continue)
(assign continue (label force-it))
(goto (label eval-dispatch))
force-it
(restore continue)
(test (op thunk?) (reg val))
(branch (label eval-thunk))
(goto (reg continue))
eval-thunk
(assign env (op thunk-env) (reg val))
(assign exp (op thunk-exp) (reg val))
(goto (label actual-value))
thnk?、thunk-exp、thunk-envをオペレーションとして定義。
(define (thunk? obj) (tagged-list? obj 'thunk)) (define (thunk-exp thunk) (cadr thunk)) (define (thunk-env thunk) (caddr thunk)) … (define eceval-operations (list (list 'self-evaluating? self-evaluating?) … (list 'delay-it delay-it) (list 'thunk? thunk?) (list 'thunk-exp thunk-exp) (list 'thunk-env thunk-env) ))
ev-appl-operand-loopではeval-dispatchに飛ぶ代わりにactual-valueに飛ぶように変更。
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 actual-value)) ; Ex 5.25
ev-appl-last-argも同様。
ev-appl-last-arg
(assign continue (label ev-appl-accum-last-arg))
(goto (label actual-value)) ; Ex 5.25
この時点ではdelay-itが無いので、thunkが来ることはなく、valの値はそのまま返る事になる。
操作確認
;;; EC-Eval input: (* (+ 1 2) (- 6 4)) ;;; EC-Eval value: 6
次にオペレータがプリミティブではなかった場合。それぞれの引数についてループする部分は同じだが、引数をeval-dispatchで評価するのではなくdelay-itでサンクにするだけで引数リストに追加する。
ev-delay-operand-loop
(assign exp (op first-operand) (reg unev))
(assign val (op delay-it) (reg exp) (reg env))
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(goto (label ev-delay-operand-loop))
apply-dispatch部分は、プリミティブの手続きが来ることはないので、その処理を取り除いて元のまま。
apply-dispatch
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
(goto (label unknown-procedure-type))
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))
delay-itはオペレータとして登録。
(define (delay-it exp env) (list 'thunk exp env)) (define eceval-operations (list (list 'self-evaluating? self-evaluating?) … (list 'delay-it delay-it) ))
ここまでを動作確認。
;;; EC-Eval input: (define (inc x) (+ x 1)) ;;; EC-Eval value: ok ;;; EC-Eval input: (inc 2) ;;; EC-Eval value: 3 ;;; EC-Eval input: (define (try a b) (if (= a 0) 1 b)) ;;; EC-Eval value: ok ;;; EC-Eval input: (try 0 (/ 1 0)) ;;; EC-Eval value: 1
tryの引数の評価で割り算は実行されていない。
ただ、このままでは式の値としてサンクが返る場合にはサンクを表示してしまう。
;;; EC-Eval input: (try 1 (/ 1 0)) ;;; EC-Eval value: (thunk (/ 1 0) #0=(#hash((map . (primitive #<procedure:map>)) (= . (primitive #<procedure:=>)) (try . (procedure (a b) ((if (= a 0) 1 b)) #0#)) (true . #t) (/ . (primitive #<procedure:/>)) (* . (primitive #<procedure:*>)) (- . (primitive #<procedure:->)) (+ . (primitive #<procedure:+>)) (null? . (primitive #<procedure:null?>)) (list . (primitive #<procedure:list>)) (cdr . (primitive #<procedure:cdr>)) (car . (primitive #<procedure:car>)) (cons . (primitive #<procedure:cons>)) (false . #f) (inc . (procedure (x) ((+ x 1)) #0#)) (newline . (primitive #<procedure:newline>)) (display . (primitive #<procedure:display>)) (> . (primitive #<procedure:>>))))) ;;; EC-Eval input:
なので、メインループでeval-dispatchを呼ぶ代わりにacual-valueを呼ぶ。actual-valueは取り敢えずeval-dispatchを呼び出すので、この呼び出しの間は必要に応じて遅延される。最後に返って来た値をforce-itする。
(assign continue (label print-result)) (goto (label actual-value)) ; Ex 5.25 print-result …
動作確認
;;; EC-Eval input: (define (try a b) (if (= a 0) 1 b)) ;;; EC-Eval value: ok ;;; EC-Eval input: (try 0 (/ 1 0)) ;;; EC-Eval value: 1 ;;; EC-Eval input: (try 1 (/ 1 0)) . . /: division by zero >
ちゃんと実行しようとした。
最後にifの条件式は遅延せずに評価しなければならないので以下のように変更する。
ev-if
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(goto (label actual-value)) ; Ex 5.25
4.2.1のunlessを動作させてみる。
;;; EC-Eval input: (define (unless condition usual-value exceptional-value) (if condition exceptional-value usual-value)) ;;; EC-Eval value: ok ;;; EC-Eval input: (define a 6) ;;; EC-Eval value: ok ;;; EC-Eval input: (define b 3) ;;; EC-Eval value: ok ;;; EC-Eval input: (unless (= b 0) (/ a b) (begin (display "exception: returning 0") 0)) ;;; EC-Eval value: 2 ;;; EC-Eval input: (define b 0) ;;; EC-Eval value: ok ;;; EC-Eval input: (unless (= b 0) (/ a b) (begin (display "exception: returning 0") 0)) exception: returning 0 ;;; EC-Eval value: 0 ;;; EC-Eval input:
取り敢えず、こんなところか。本当はcondとかも対応しなければならないけど省略。
