root/lang/scheme/3imp/post-opt.scm @ 31674

#!/usr/local/bin/gosh

(use util.match)

(define-macro (replace-rule code . ls)
  `(match ,code
          ,@(map (lambda (e)
                   `((,@(car e) . %rest) (values ,(caddr e) %rest)))
                 ls)
          (else (values #f code))))


;;;; �u���������[��
(define (get-replace-rule code)
  (replace-rule code
                (('GREF f 'APPLY n) => `(GREF-APPLY ,f ,n))
                (('GREF f 'SHIFT m 'APPLY n) => `(GREF-SHIFT-APPLY ,f ,n))
                (('SHIFT m 'APPLY n) => `(SHIFT-APPLY ,n))
                (('CONST obj 'ARG) => `(CONST-ARG ,obj))
                ))


(define optbl
  '((HALT ())
    (LREF (n . $x))
    (FREF (n . $x))
    (GREF (sym . $x))
    (UNBOX $x)
    (CONST (obj . $x))
    (CLOSE (argnum n $body . $x))
    (BOX (n . $x))
    (TEST ($then . $else))
    (LSET (n . $x))
    (FSET (n . $x))
    (GSET (sym . $x))
    (CONTI (tail$ . $x))
    (NUATE (stack . $x))
    (FRAME ($x . $ret))
    (ARG $x)
    (SHIFT (n . $x))
    (APPLY (argnum))
    (RET ())
    (EXPAND (argnum . $x))
    (SHRINK (n . $x))
    ))

(define *h* (make-hash-table))

(dolist (e optbl)
  (let ((sym (car e))
        (args (cadr e)))
    (hash-table-put! *h* sym args)))

(define (next-ops code)
  (define (op? sym)
    (eq? (string-ref (symbol->string sym) 0)
         #\$))
  (define (check sym x f)
    (if (op? sym)
        (f x)
      (f #f)))
  (define (scons x xs)
    (if x (cons x xs) xs))
  
  (let* ((op (car code))
         (e (and (hash-table-exists? *h* op)
                 (hash-table-get *h* op))))
    (if e
        (reverse!
         (let loop ((p e)
                    (q (cdr code))
                    (acc '()))
           (cond ((pair? p)
                  (check (car p) (car q)
                         (lambda (x) (loop (cdr p) (cdr q) (scons x acc)))))
                 ((null? p) acc)
                 (else
                  (check p q
                         (lambda (x) (scons x acc)))))))
      '())))

(define (replace pair newpair)
  (set-car! pair (car newpair))
  (set-cdr! pair (cdr newpair)))

(define (optimize! code)
  (when (not (null? code))
    (receive (rep rest) (get-replace-rule code)
             (if rep
                 (replace code (append rep (optimize! rest)))
               (begin
                 (dolist (x (next-ops code))
                   (optimize! x))))))
  code)

(define (main args)
  (until (read) eof-object? => code
    (optimize! code)
    (write/ss code)
    (newline)))