Serendip

Web Studio

問題5.38

a. 及び b.

(define (compile exp target linkage)
  ;; 省略
        ((memq (car exp) '(+ - * / =))
         (compile-open-code exp target linkage))
  ;; 省略
        (else
          (error "Unknown expression type -- COMPILE" exp))))

(define (spread-arguments a1 a2)
  (let ((ca1 (compile a1 'arg1 'next))
        (ca2 (compile a2 'arg2 'next)))
       (list ca1 ca2)))

(define (compile-open-code exp target linkage)
  (if (= (length exp) 3)
      (let ((op (car exp)) ; 演算子
            (args (spread-arguments (cadr exp) (caddr exp)))) ; 被演算子をコンパイル
           (end-with-linkage linkage
                             (append-instruction-sequences
                               (car args)
                               (preserving '(arg1)
                                           (cadr args)
                                           (make-instruction-sequence '(arg1 arg2) (list target)
                                                                      `((assign ,target (op ,op) (reg arg1) (reg arg2))))))))
      (error "Require 3 elements -- COMPILE-OPEN-CODE" exp)))

(parse-compiled-code
  (compile
    '(+ x 1)
    'val
    'next))

元のコンパイラでの翻訳結果

(env)
(env proc argl continue val)
  (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 x) (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

新しいコンパイラでの翻訳結果

(env)
(arg1 arg2 val)
  (assign arg1 (op lookup-variable-value) (const x) (reg env))
  (assign arg2 (const 1))
  (assign val (op +) (reg arg1) (reg arg2))

c.

元のコードによる factorial

(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)
  (assign val (op lookup-variable-value) (const n) (reg env))
  (assign argl (op list) (reg val))
  (save argl)
  (assign proc (op lookup-variable-value) (const factorial) (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
  (restore argl)
  (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) (reg val) (reg env))
  (assign val (const ok))

新しい翻訳系での factorial

(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 arg1 (op lookup-variable-value) (const n) (reg env))
  (assign arg2 (const 1))
  (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 proc (op lookup-variable-value) (const factorial) (reg env))
  (assign arg1 (op lookup-variable-value) (const n) (reg env))
  (assign arg2 (const 1))
  (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))
after-call8
  (assign arg2 (op lookup-variable-value) (const n) (reg env))
  (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))

計算機プログラムの構造と解釈

posted with amazlet at 08.11.07

ジェラルド・ジェイ サスマン ジュリー サスマン ハロルド エイブルソン
ピアソンエデュケーション
売り上げランキング: 6542

Amazon.co.jp で詳細を見る