A-normal form 再学習 その5 - Scheme VM

scheme

ここに書いてある内容は古いです。A正規形まとめをご参照ください。

以前通った道に戻ります。
前回は Core Scheme の A-reduction を理解しコードを書きました。次は現実の Scheme に対する A-reduction を考えます。基本的には Core Scheme と同じで良いはずですが考慮すべき点がいくつかあります。

let や lambda の body

Core Scheme と違い body には複数の式があることが許されます。例えば

(let1 a 3
  (+ (+ 1 2))
  (+ (+ 3 4)))

など。

これは Core Scheme からの類推で

(let1 a 2
  (let1 t1 (+ 1 2)
    (+ t1))
  (let1 t2 (+ 3 4)
    (+ t2)))

と normalize されるのが良いと考えました。

set!

set! は代入を行い、返す値は不定です。

(set! a (+ (+ 1 2)))
=> (let1 t1 (+ 1 2) (let1 t2 (+ t1) (set! a t2)))

と normalize するには意味がありそうです。（let1 が括りだされれるわけですから）

set-car!や set-cdr! なども同様。

define

set! と同様で良さそうです。

begin

(begin (+ (+ 1 2)) (+ (+ 3 4)))
=>
(begin (let1 t1 (+ 1 2) (+ t1)) (let1 t2 (+ 3 3) (+ t2)))

となるのが良さそうです。begin の中身が begin の外に出ると評価順序とかが難しくなりそうです。（ちょっと自信なし）

コード

(load "./lib/test.scm")

;;--------------------------------------------------------------------
;;
;; A-normalization for Scheme, not for Core Scheme.
;;
;;   Based on A linear time A-normalization alogrithm,
;;   in The Essence of Compiling with Continuations.
;;
;;
(define (a-normalize m)
  (a-normalize-with-k m (lambda (x) x)))

(define (a-normalize-with-k m k)
  (define (primitive-op? f)
    (eq? f '+))
  (match m
    ;; normalization of lambda is not in Figure 7, but Figure 9.
    [('lambda params . body)
     (k `(lambda
             ,params
             ,@(let loop ([body body] [nbody '()])
                 (if (null? body)
                     nbody
                     (append nbody (loop (cdr body) (list (a-normalize (car body)))))))))]
    [('let1 x m1 . m2*)
     (a-normalize-with-k m1 (lambda (normalized-m1)
                              (let loop ([body m2*]
                                         [m2n '()])
                                (if (null? body)
                                    `(let1 ,x , normalized-m1 ,@m2n)
                                    (loop (cdr body) (append m2n (list (a-normalize-with-k (car body) k))))))))]
;;     [('if m1 m2 m3)
;;      (a-normalize-with-k m1 (lambda (normalized-m1)
;;                               `(if ,normalized-m1
;;                                    ,(a-normalize-with-k m2 k)
;;                                    ,(a-normalize-with-k m3 k))))]
    ;; To prevent possible exponential growth in code size,
    ;; the algorithm avoids duplicating the evaluation context enclosing a conditional expression.
    [('if m1 m2 m3)
     (a-normalize-name m1 (lambda (normalized-m1)
                              (k
                               `(if ,normalized-m1
                                    ,(a-normalize m2)
                                    ,(a-normalize m3)))))]
    [('set! a b)
     (a-normalize-name b (lambda (bn) (k `(set! ,a ,bn))))]
    [('set-car! a b)
     (a-normalize-name b (lambda (bn) (k `(set-car! ,a ,bn))))]
    [('set-cdr! a b)
     (a-normalize-name b (lambda (bn) (k `(set-cdr! ,a ,bn))))]
    [('define a b)
     (a-normalize-name b (lambda (bn) (k `(define ,a ,bn))))]
    [(fn . m*)
     (if (primitive-op? fn)
         (a-normalize-name* m* (lambda (t*) (k `(,fn . ,t*)))))
         (a-normalize-name fn (lambda (t) (a-normalize-name* m* (lambda (t*) (k `(,t . ,t*))))))]
    [else
     (k m)]))

(define (a-normalize-name m k)
  ;;
  ;;  Values
  ;;     constant or variables.
  (define (value? v)
    (not (pair? v)))
  (a-normalize-with-k m
             (lambda (n) (if (value? n)
                             (k n)
                             (let1 t (gensym)
                               `(let1 ,t, n ,(k t)))))))

(define (a-normalize-name* m* k)
  (if (null? m*)
      (k '())
      (a-normalize-name (car m*)
                      (lambda (t)
                        (a-normalize-name* (cdr m*)
                                           (lambda  (t*) (k `(,t . ,t*))))))))

;;--------------------------------------------------------------------
;;
;; Tests
;;

;; one body
(with-gensym
 (a-normalize '(let1 a 3 (+ (+ 1 2)))))
(eqt '(let1 a 3 (let1 G4 (+ 1 2) (+ G4))) (with-gensym (a-normalize '(let1 a 3 (+ (+ 1 2))))))

;; two bodies
(with-gensym
 (a-normalize '(let1 a 3 (+ (+ 1 2)) (+ (+ 3 3)))))
(eqt '(let1 a 3 (let1 G4 (+ 1 2) (+ G4)) (let1 G8 (+ 3 3) (+ G8))) (with-gensym (a-normalize '(let1 a 3 (+ (+ 1 2)) (+ (+ 3 3))))))

;; one body
(with-gensym
 (a-normalize '(lambda () (+ (+ 1 2)))))
(eqt '(lambda () (let1 G4 (+ 1 2) (+ G4))) (with-gensym (a-normalize '(lambda () (+ (+ 1 2))))))

;; two body
(with-gensym
 (a-normalize '(lambda () (+ (+ 1 2)) (+ (+ 3 4)))))
(eqt '(lambda () (let1 G4 (+ 1 2) (+ G4)) (let1 G8 (+ 3 4) (+ G8))) (with-gensym (a-normalize '(lambda () (+ (+ 1 2)) (+ (+ 3 4))))))

;; set!
(with-gensym
 (a-normalize '(set! a (+ (+ 1 2)))))
(eqt '(let1 G7 (+ 1 2) (let1 G8 (+ G7) (set! a G8))) (with-gensym (a-normalize '(set! a (+ (+ 1 2))))))

;; let1
(a-normalize '(if (let1 x 3 x) 4 5))
(eqt '(let1 x 3 (if x 4 5)) (a-normalize '(if (let1 x 3 x) 4 5)))

;; let1
(with-gensym
 (a-normalize '(+ (+ 2 2) (let1 x 1 (f x)))))
(eqt '(let1 G7 (+ 2 2) (let1 x 1 (let1 G8 (f x) (+ G7 G8)))) (with-gensym (a-normalize '(+ (+ 2 2) (let1 x 1 (f x))))))

;; let1
(with-gensym
 (a-normalize '(+ (let1 a 0 (+ a 3)) 2)))
(eqt '(let1 a 0 (let1 G4 (+ a 3) (+ G4 2))) (with-gensym (a-normalize '(+ (let1 a 0 (+ a 3)) 2))))

;; let1
(with-gensym
 (a-normalize '(let1 a (let1 b 3 (+ b 2))
                 (+ a 2))))
(eqt '(let1 b 3 (let1 a (+ b 2) (+ a 2))) (with-gensym (a-normalize '(let1 a (let1 b 3 (+ b 2)) (+ a 2)))))

;; lambda
(with-gensym
 (a-normalize '(lambda () (+ (+ 1 2) 3))))
(eqt '(lambda () (let1 G4 (+ 1 2) (+ G4 3))) (with-gensym (a-normalize '(lambda () (+ (+ 1 2) 3)))))

(a-normalize '(if (+ 2) 3 4))
(eqt '(let1 G1117 (+ 2) (if G1117 3 4)) (a-normalize '(if (+ 2) 3 4)))

(test-end)