SICP 問題 5.37

preservingを修正して常にsaveとrestoreをさせ，修正前と後を比較する．

修正前

(define (preserving regs seq1 seq2)
  (if (null? regs)
      (append-instruction-sequences seq1 seq2)
      (let ((first-reg (car regs)))     ;first-regが
        (if (and (needs-register? seq2 first-reg) ;seq2に必要なレジスタで
                 (modifies-register? seq1 first-reg)) ;seq1が変更するレジスタなら
            (preserving
             (cdr regs)
             (make-instruction-sequence
              ;; needs ここでsaveするのでfirst-regが必要になるのでlist-union
              (list-union (list first-reg)
                          (registers-needed seq1))
              ;; modify saveしてのseq2の前にrestoreするのでseq2から見ればfirst-reg変更無し
              (list-difference (registers-modified seq1)
                               (list first-reg))
              ;; statements 条件を満たすfirst-regの場合はseq1をsaveとrestoreで挟む
              (append `((save ,first-reg))
                      (statements seq1)
                      `((restore ,first-reg))))
             seq2)
            (preserving (cdr regs) seq1 seq2)))))

必要ないsaveやrestoreは一切されない，賢いpreserving．

gosh> (compile
       '(define (f a b)
          (+ a b))
       'val 'next)
((env)
 (val)
 ((assign val (op make-compiled-procedure) (label entry34) (reg env))
  (goto (label after-lambda35))
  entry34
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (a b)) (reg argl) (reg env))
  (assign proc (op lookup-variable-value) (const +) (reg env))
  (assign val (op lookup-variable-value) (const a) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const b) (reg env))
  (assign val (op list) (reg val))
  (assign argl (op append) (reg argl) (reg val))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch36))
  compiled-branch37
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch36
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
  after-call38
  after-lambda35
  (perform (op define-variable!) (const f) (reg val) (reg env))
  (assign val (const ok))
  ))

修正後

(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))))

gosh> (compile
       '(define (f a b)
          (+ a b))
       'val 'next)
((continue env)                         ;まずcontinueを必要とするようになっている．
 (val)
 ((save continue)                       ;ここでsave continueするから
  (save env)
  (save continue)                       ;ここでさらにsave continueしている．
  (assign val (op make-compiled-procedure) (label entry41) (reg env))
  (restore continue)                    ;ここで復帰．
  (goto (label after-lambda42))         ;ここまでで無駄なsave 3. 無駄なrestore 1
  entry41
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (a b)) (reg argl) (reg env))
  (save continue)                       ;ここでまたsave continue
  (save env)                            ;env
  (save continue)                       ;continue
  (assign proc (op lookup-variable-value) (const +) (reg env))
  (restore continue)                    ;restore c
  (restore env)                         ;restore e
  (restore continue)                    ;restore c
  (save continue)                       ;save c
  (save proc)                           ;save p
  (save env)                            ;save e
  (save continue)                       ;save c
  (assign val (op lookup-variable-value) (const a) (reg env))
  (restore continue)                    ;restore c
  (assign argl (op list) (reg val))
  (restore env)                         ;restore e
  (save argl)                           ;save a
  (save continue)                       ;save c
  (assign val (op lookup-variable-value) (const b) (reg env))
  (restore continue)                    ;restore c
  (restore argl)                        ;restore a
  (assign val (op list) (reg val))
  (assign argl (op append) (reg argl) (reg val))
  (restore proc)                        ;restore p
  (restore continue)                    ;restore c
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch43))
  compiled-branch44
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch43
  (save continue)                       ;save c
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (restore continue)                    ;restore c
  (goto (reg continue))
  after-call45
  after-lambda42
  (restore env)                         ;restore e 最初のenv
  (perform (op define-variable!) (const f) (reg val) (reg env))
  (assign val (const ok))
  (restore continue)                    ;最初のcontinue
  ))