読者です 読者をやめる 読者になる 読者になる

(wat-aro)

無職から有職者にランクアップしました

SICP 問題 5.47

scheme SICP

コンパイルした手続きから積極制御評価器で定義した手続きを使えるようにする.

(define (compile-procedure-call target linkage)
  (let ((primitive-branch (make-label 'primitive-branch))
        (compiled-branch (make-label 'compiled-branch))
        (compound-branch (make-label 'compound-branch)) ;; compound-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))))
       ;; compiled-branchへの分岐を追加
       (make-instruction-sequence
        '(proc) '()
        `((test (op compiled-procedure?) (reg proc))
          (branch (label ,compiled-branch))))
       ;; primitiveでもcompiledでもなかったらcompoundとして処理.
       (parallel-instruction-sequences
        (append-instruction-sequences
         compound-branch
         ;; compiledと同じようにcompound-proc-applで命令を作る
         (compound-proc-appl target compiled-linkage))
        (parallel-instruction-sequences
            (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))))

;; ほとんどcompile-proc-applと同じで,continueをセーブしてからcompappにジャンプする.
;; compappには(label procedure-apply)が入っている.
(define (compound-proc-appl target linkage)
  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
         (make-instruction-sequence
          '() all-regs
          `((assign continue (label ,linkage))
            (save continue)
            (goto (reg compapp)))))
        ((and (not (eq? target 'val))
              (not (eq? linkage 'return)))
         (let ((proc-return (make-label 'proc-return)))
           (make-instruction-sequence
            '(proc) all-regs
            `((assign continue (label ,proc-return))
              (save continue)
              (goto (reg compapp))
              ,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))))

;; ec-evalの命令の先頭でcompappを初期化する.
   '((assign compapp (label compound-apply)) ;追加
     (branch (label external-entry))
     read-eval-print-loop
     (perform (op initialize-stack))

 
test

gosh> (compile-and-go
       '(begin
          (define (f x) (+ (g x) 1))
          (define (g x) (+ x 10))))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(f 1)

(total-pushes = 7 maximum-depth = 3)
;;; EC-Eval value:
12

;;; EC-Eval input:
(define (g x) (+ x 20))

(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(f 1)

(total-pushes = 16 maximum-depth = 7)
;;; EC-Eval value:
22

gosh> (compile-and-go
       '(define (f x) (* (g x) 2)))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(define (g x) (+ x 1))

(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(g 1)

(total-pushes = 13 maximum-depth = 5)
;;; EC-Eval value:
2

;;; EC-Eval input:
(f 1)

(total-pushes = 16 maximum-depth = 7)
;;; EC-Eval value:
4

コンパイルした定義の上書き,コンパイルしていない定義へのアクセスの両方がうまくいっている.