Scheme - レジスタ計算機での計算(翻訳系(翻訳したコードの例(オープンコード基本手続き, 任意の個数の引数, 二項演算に翻訳)))

計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著)ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著)Julie Sussman (原著)
Gerald Jay Sussman (原著)和田 英一 (翻訳)

開発環境

• OS X Yosemite - Apple (OS)
• Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
• Scheme (プログラミング言語)
• Gauche (処理系)

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の5(レジスタ計算機での計算)、5.5(翻訳系)、5.5.5(翻訳したコードの例)、問題 5.38-d.を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
• プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
• Scheme手習い

問題 5.38-d.

コード(BBEdit, Emacs)

compiler38_d.scm

;; -*- coding;: utf-8 -*-

(load "./operations38_d.scm")

(define (compile exp target linkage)
  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage))
        ((assignment? exp)
         (compile-assignment exp target linkage))
        ((definition? exp)
         (compile-definition exp target linkage))
        ((open-code? exp)
         (compile-open-code exp target linkage))
        ((if? exp) (compile-if exp target linkage))
        ((lambda? exp) (compile-lambda exp target linkage))
        ((begin? exp)
         (compile-sequence (begin-actions exp)
                           target
                           linkage))
        ((cond? exp) (compile (cond->if exp) target linkage))
        ((application? exp)
         (compile-application exp target linkage))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

(define (make-instruction-sequence needs modifies statements)
  (list needs modifies statements))

(define (empty-instruction-sequence)
  (make-instruction-sequence '() '() '()))

(define (compile-linkage linkage)
  (cond ((eq? linkage 'return)
         (make-instruction-sequence '(continue) '()
                                    '((goto (reg continue)))))
        ((eq? linkage 'next)
         (empty-instruction-sequence))
        (else
         (make-instruction-sequence '() '()
                                    `((goto (label ,linkage)))))))

(define (end-with-linkage linkage instruction-sequence)
  (preserving '(continue)
              instruction-sequence
              (compile-linkage linkage)))

(define (compile-self-evaluating exp target linkage)
  (end-with-linkage linkage
                    (make-instruction-sequence
                     '()
                     (list target)
                     `((assign ,target (const ,exp))))))

(define (compile-quoted exp target linkage)
  (end-with-linkage linkage
                    (make-instruction-sequence
                     '()
                     (list target)
                     `((assign ,target (const ,(text-of-quotation exp)))))))

(define (compile-variable exp target linkage)
  (end-with-linkage linkage
                    (make-instruction-sequence
                     '(env)
                     (list target)
                     `((assign ,target
                               (op lookup-variable-value)
                               (const ,exp)
                               (reg env))))))

(define (compile-assignment exp target list)
  (let ((var (assignment-variable exp))
        (get-value-code
         (compile (assignment-value exp) 'val 'next)))
    (end-with-linkage
     linkage
     (preserving '(env)
                 get-value-code
                 (make-instruction-sequence
                  '(env val)
                  (list target)
                  `((perform (op set-variable-value!)
                             (const ,var)
                             (reg val)
                             (reg env))
                    (assign ,target (const ok))))))))

(define (compile-definition exp target linkage)
  (let ((var (definition-variable exp))
        (get-value-code
         (compile (definition-value exp) 'val 'next)))
    (end-with-linkage
     linkage
     (preserving '(env)
                 get-value-code
                 (make-instruction-sequence
                  '(env val)
                  (list target)
                  `((perform (op define-variable!)
                             (const ,var)
                             (reg val)
                             (reg env))
                    (assign ,target (const ok))))))))

(define (compile-open-code exp target linkage)
  (let ((proc (operator exp))
        (operand-codes
         (map (lambda (operand) (compile operand 'val 'next))
              (operands exp))))
    (preserving
     '(proc continue)
     (spread-arguments operand-codes)
     (compile-open-code-call proc target linkage))))
  
(define (spread-arguments operand-codes)
  (let ((operand-codes (reverse 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 arg1 arg2)
                          code-to-get-last-arg
                          (code-to-get-rest-args
                           (cdr operand-codes))))))))

(define (compile-open-code-call proc target linkage)
  (let ((entry (make-label 'entry))
        (last-branch (make-label 'last-branch))
        (after-call (make-label 'after-call)))
    (let ((compiled-linkage
           (if (eq? linkage 'next) after-call linkage)))
      (append-instruction-sequences
       entry
       (make-instruction-sequence
        '(argl)
        (list target)
        `((assign ,target (op length) (reg argl))
          (test (op =) (reg argl) (const 2))
          (branch (label ,last-branch))))
       (make-instruction-sequence
        '(argl arg1 arg2)
        (list 'arg1 'arg2 target 'argl)
        `((assign arg1 (op car) (reg argl))
          (assign arg2 (op cadr) (reg argl))
          (assign ,target (op ,proc) (reg arg1) (reg arg2))
          (assign argl (op cdr) (reg argl))
          (assign argl (op cons) (reg ,target) (reg argl))
          (branch (label ,entry))))
       last-branch
       (end-with-linkage
        linkage
        (make-instruction-sequence
         '(argl arg1 arg2)
         (list target 'arg1 'arg2)
         `((assign arg1 (op car) (reg argl))
           (assign arg2 (op cadr) (reg argl))
           (assign ,target (op ,proc) (reg arg1) (reg arg2)))))           
       after-call))))
  
(define (compile-if exp target linkage)
  (let ((t-branch (make-label 'true-branch))
        (f-branch (make-label 'false-branch))
        (after-if (make-label 'after-if)))
    (let ((consequent-linkage
           (if (eq? linkage 'next) after-if linkage)))
      (let ((p-code (compile (if-predicate exp) 'val 'next))
            (c-code
             (compile
              (if-consequent exp) target consequent-linkage))
            (a-code
             (compile (if-alternative exp) target linkage)))
        (preserving
         '(env continue)
         p-code
         (append-instruction-sequences
          (make-instruction-sequence
           '(val)
           '()
           `((test (op false?) (reg val))
             (branch (label ,f-branch))))
          (parallel-instruction-sequences
           (append-instruction-sequences t-branch c-code)
           (append-instruction-sequences f-branch a-code))
          after-if))))))

(define (compile-sequence seq target linkage)
  (if (last-exp? seq)
      (compile (first-exp seq) target linkage)
      (preserving '(env continue)
                  (compile (first-exp seq) target 'next)
                  (compile-sequence (rest-exps seq) target linkage))))

(define (compile-lambda exp target linkage)
  (let ((proc-entry (make-label 'entry))
        (after-lambda (make-label 'after-lambda)))
    (let ((lambda-linkage
           (if (eq? linkage 'next) after-lambda linkage)))
      (append-instruction-sequences
       (tack-on-instruction-sequence
        (end-with-linkage
         lambda-linkage
         (make-instruction-sequence
          '(env)
          (list target)
          `((assign ,target
                    (op make-compiled-procedure)
                    (label ,proc-entry)
                    (reg env)))))
        (compile-lambda-body exp proc-entry))
       after-lambda))))

(define (compile-lambda-body exp proc-entry)
  (let ((formals (lambda-parameters exp)))
    (append-instruction-sequences
     (make-instruction-sequence
      '(env proc argl)
      '(env)
      `(,proc-entry
        (assign env (op compiled-procedure-env) (reg proc))
        (assign env
                (op extend-environment)
                (const ,formals)
                (reg argl)
                (reg env))))
     (compile-sequence (lambda-body exp) 'val 'return))))

(define (compile-application exp target linkage)
  (let ((proc-code (compile (operator exp) 'proc 'next))
        (operand-codes
         (map (lambda (operand) (compile operand 'val 'next))
              (operands exp))))
    (preserving '(env continue)
                proc-code
                (preserving '(proc continue)
                            (construct-arglist operand-codes)
                            (compile-procedure-call target linkage)))))

(define (construct-arglist operand-codes)
  (let ((operand-codes (reverse 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 cons) (reg val) (reg argl)))))))
    (if (null? (cdr operand-codes))
        code-for-next-arg
        (preserving '(env)
                    code-for-next-arg
                    (code-to-get-rest-args (cdr operand-codes))))))

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

(define (compile-proc-appl target linkage)
  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
         (make-instruction-sequence
          '(proc)
          all-regs
          `((assign continue (label ,linkage))
            (assign val
                    (op compiled-procedure-entry)
                    (reg proc))
            (goto (reg val)))))
        ((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))
              (assign val
                      (op compiled-procedure-entry)
                      (reg proc))
              (goto (reg val))
              ,proc-return
              (assign ,target (reg val))
              (goto (label ,linkage))))))
        ((and (eq? target 'val) (eq? linkage 'return))
         (make-instruction-sequence
          '(proc continue)
          all-regs
          '((assign val
                    (op compiled-procedure-entry)
                    (reg proc))
            (goto (reg val)))))
        ((and (not (eq? target 'val)) (eq? linkage 'return))
         (error "return linkage, target not val -- COMPILE" target))))

(define (registers-needed s)
  (if (symbol? s) '() (car s)))

(define (registers-modified s)
  (if (symbol? s) '() (cadr s)))

(define (statements s)
  (if (symbol? s) (list s) (caddr s)))

(define (needs-register? seq reg)
  (memq reg (registers-needed seq)))

(define (modifies-register? seq reg)
  (memq reg (registers-modified seq)))

(define (append-instruction-sequences . seqs)
  (define (append-2-sequences seq1 seq2)
    (make-instruction-sequence
     (list-union (registers-needed seq1)
                 (list-difference (registers-needed seq2)
                                  (registers-needed seq1)))
     (list-union (registers-modified seq1)
                 (registers-modified seq2))
     (append (statements seq1) (statements seq2))))
  (define (append-seq-list seqs)
    (if (null? seqs)
        (empty-instruction-sequence)
        (append-2-sequences (car seqs)
                            (append-seq-list (cdr seqs)))))
  (append-seq-list seqs))

(define (list-union s1 s2)
  (cond ((null? s1) s2)
        ((memq (car s1) s2) (list-union (cdr s1) s2))
        (else (cons (car s1) (list-union (cdr s1) s2)))))

(define (list-difference s1 s2)
  (cond ((null? s1) '())
        ((memq (car s1) s2) (list-difference (cdr s1) s2))
        (else (cons (car s1)
                    (list-difference (cdr s1) s2)))))

(define (preserving regs seq1 seq2)
  (if (null? regs)
      (append-instruction-sequences seq1 seq2)
      (let ((first-reg (car regs)))
        (if (and (needs-register? seq2 first-reg)
                 (modifies-register? seq1 first-reg))
            (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)
            (preserving (cdr regs) seq1 seq2)))))

(define (tack-on-instruction-sequence seq body-seq)
  (make-instruction-sequence
   (registers-needed seq)
   (registers-modified seq)
   (append (statements seq) (statements body-seq))))

(define (parallel-instruction-sequences seq1 seq2)
  (make-instruction-sequence
   (list-union (registers-needed seq1)
               (registers-needed seq2))
   (list-union (registers-modified seq1)
               (registers-modified seq2))
   (append (statements seq1) (statements seq2))))

sample38_d.scm

#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-

(load "./compiler38_d.scm")

(print  (compile
         '(+ 1 2 (+ 3 4) 5)
         'val
         'next))

入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))

$ ./sample38_d.scm
((val argl arg1 arg2) (argl val arg1 arg2) ((assign val (const 5)) (assign argl (op list) (reg val)) (save argl) (assign val (const 4)) (assign argl (op list) (reg val)) (assign val (const 3)) (assign argl (op cons) (reg val) (reg argl)) entry1 (assign val (op length) (reg argl)) (test (op =) (reg argl) (const 2)) (branch (label last-branch2)) (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) (assign argl (op cdr) (reg argl)) (assign argl (op cons) (reg val) (reg argl)) (branch (label entry1)) last-branch2 (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) after-call3 (restore argl) (assign argl (op cons) (reg val) (reg argl)) (assign val (const 2)) (assign argl (op cons) (reg val) (reg argl)) (assign val (const 1)) (assign argl (op cons) (reg val) (reg argl)) entry4 (assign val (op length) (reg argl)) (test (op =) (reg argl) (const 2)) (branch (label last-branch5)) (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) (assign argl (op cdr) (reg argl)) (assign argl (op cons) (reg val) (reg argl)) (branch (label entry4)) last-branch5 (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) after-call6))
$

見やすくするため、改行を挿入して修正。

レジスタ計算機。

(assign val (const 5))
(assign argl (op list) (reg val)) 
(save argl) 
(assign val (const 4)) 
(assign argl (op list) (reg val)) 
(assign val (const 3)) 
(assign argl (op cons) (reg val) (reg argl))
entry1 
(assign val (op length) (reg argl)) 
(test (op =) (reg argl) (const 2)) 
(branch (label last-branch2)) 
(assign arg1 (op car) (reg argl)) 
(assign arg2 (op cadr) (reg argl)) 
(assign val (op +) (reg arg1) (reg arg2)) 
(assign argl (op cdr) (reg argl)) 
(assign argl (op cons) (reg val) (reg argl)) 
(branch (label entry1))
last-branch2 
(assign arg1 (op car) (reg argl)) 
(assign arg2 (op cadr) (reg argl)) 
(assign val (op +) (reg arg1) (reg arg2))
after-call3 
(restore argl) 
(assign argl (op cons) (reg val) (reg argl)) 
(assign val (const 2)) 
(assign argl (op cons) (reg val) (reg argl)) 
(assign val (const 1)) 
(assign argl (op cons) (reg val) (reg argl))
entry4 
(assign val (op length) (reg argl)) 
(test (op =) (reg argl) (const 2)) 
(branch (label last-branch5)) 
(assign arg1 (op car) (reg argl)) 
(assign arg2 (op cadr) (reg argl)) 
(assign val (op +) (reg arg1) (reg arg2)) 
(assign argl (op cdr) (reg argl)) 
(assign argl (op cons) (reg val) (reg argl)) 
(branch (label entry4))
last-branch5 
(assign arg1 (op car) (reg argl)) 
(assign arg2 (op cadr) (reg argl)) 
(assign val (op +) (reg arg1) (reg arg2))
after-call6