(comment "optimize code")

(declare (refs repeat changed) special)

(defun c:optimize (x)
   (setq refs nil)
   (setq repeat 0)
   (c:init-refc)
   (c:refcount x)
   (c:while-changed
      (incr repeat 1)
      (c:flatten x)
      (setq x (c:ass-opt x))
      (c:flatten x)
      (setq x (c:jump-opt x)))
   (c:flatten x)
   (comment lets ((standard-output terminal-output))
     (format "c:optimize -- repeat = /s/n" repeat))
   x)

(comment "reference count")

(defun c:init-refc nil
   (mapc '(catchval bstack bstacksave cstack cstacksave estack estacktop
	   estack->envtag estack->envobj estack->envbuf *--fp)
	 (function (lambda (x) (putprop x 9999 'refcount)))))

(defun c:refcount (x)
   (match x
      (('if cnd then) (mapc (cdr x) (function c:refcount)))
      (('if cnd then else) (mapc (cdr x) (function c:refcount)))
      (('for (inits test updates) . body)
       (mapc inits (function c:refcount))
       (c:refcount test)
       (mapc updates (function c:refcount))
       (mapc body (function c:refcount)))
      (('while cnd . body) (mapc (cdr x) (function c:refcount)))
      (('dowhile rep cnd) (mapc (cdr x) (function c:refcount)))
      (('block var . body) (mapc body (function c:refcount)))
      (('begin . body) (mapc body (function c:refcount)))
      (('label lab))
      (('goto lab) (and (= 1 (c:incr-refcount lab)) (push lab refs)))
      ((op ag1 ag2) (c:refcount ag1) (c:refcount ag2))
      ((op ag1) (c:refcount ag1))
      ((fn . args) (mapc args (function c:refcount)))
      (x (and (symbolp x) (= 1 (c:incr-refcount x)) (push x refs)))))

(defun c:incr-refcount (sym (n 1))
   (lets ((c (get sym 'refcount)))
    (cond ((fixp c) (putprop sym (incr c n) 'refcount) c)
          (t (putprop sym 1 'refcount) 1))))

(defun c:decr-refcount (sym (n 1))
   (lets ((c (get sym 'refcount)))
    (cond ((and (fixp c) (/0< (decr c n))) (putprop sym c 'refcount) c)
          (t (remprop sym 'refcount) 0))))

(defun c:cur-refcount (lab)
   (lets ((n (get lab 'refcount))) (cond ((fixp n) n) (t 0))))

(defun c:varcount (var val)
   (cond ((atom val) (cond ((eq var val) 1) (t 0)))
         ((null (cdr val)))
         ((null (cddr val)) (c:varcount var (second val)))
         (t (/+ (c:varcount var (second val)) (c:varcount var (third val))))))

(defun c:incr-refc-value (val delta)
   (cond ((/0= delta))
         ((symbolp val)
          (cond ((/0< delta) (c:incr-refcount val delta))
                (t (c:decr-refcount val (/- delta)))))
         ((atom val))
         (t (mapc (cdr val)
               (function (lambda (x) (c:incr-refc-value x delta)))))))

(defmacro c:decr-refc-value (val delta) `(c:incr-refc-value ,val (- ,delta)))

(defmacro c:labelp (x) `(and (consp ,x) (eq (car ,x) 'label)))

(defmacro c:referred (lab) `(get ,lab 'refcount))

(defmacro c:label-ll (lab . rest)
   (cond ((null rest) `(get ,lab 'll)) (t `(putprop ,lab ,(car rest) 'll))))

(defmacro c:label-l (lab . rest)
   (cond ((null rest) `(get ,lab 'l)) (t `(putprop ,lab ,(car rest) 'l))))

(comment "flatten block structure")

(defun c:flatten (x)
   (cond ((c:flatten-item x))
         (t (match x
               (('block var . body)
                (cond ((null body) nil)
                      ((null var) `(begin . ,(c:flatten-seq body)))
                      (t (setf (second x) (c:delete-var var))
			 (setf (cddr x) (c:flatten-seq body)))))
               (('begin . body) 
                (cond ((null body) nil)
                      (t (setf (cdr x) (c:flatten-seq body))))))))
   x)

(defmacro c:discard (ll l) `(rplacd ,ll (setq ,l (cdr ,l))))

(defmacro c:discard2 (ll l)
   `(progn (rplacd ,ll (setq ,l (cdr ,l)))
           (and (c:labelp (car ,l)) (c:label-ll ,ll))))

(defmacro c:advance (ll l) `(setq ,ll ,l ,l (cdr ,l)))

(defun c:flatten-seq (xs)
   (lets ((ys `(nil . ,xs)) (l xs) (ll ys) (x))
    (loop (and (atom l) (exit (cdr ys)))
          (setq x (car l))
          (cond ((c:flatten-item x) (c:advance ll l))
                (t (match x
                      (('block var . body)
                       (cond ((null body) (c:discard ll l))
                             ((null var)
                              (nconc body (cdr l))
                              (rplacd ll (setq l body)))
                             (t (setf (cddr x) (c:flatten-seq body))
				(setf (second x) (c:delete-var var))
                                (c:advance ll l))))
                      (('begin . body) 
                       (cond ((null body) (c:discard ll l))
                             (t (nconc body (cdr l))
                                (rplacd ll (setq l body)))))
                      (('label lab)
                       (cond ((c:referred lab)
                              (c:label-ll lab ll)
                              (c:label-l lab l)
                              (c:advance ll l))
                             (t (c:discard ll l))))
                      (('goto lab)
                       (c:advance ll l)
                       (loop (and (or (atom l)
                                      (and (c:labelp (car l)) 
                                       (c:referred (cadar l))))
                                  (exit))
                             (comment and (c:gotop (car l))
                                  (c:decr-refcount (cadar l)))
			     (c:decr-refc-value (car l) 1)
                             (c:discard ll l)))
                      (x (cond ((atom x) (c:discard ll l))
                               (t (c:advance ll l))))))))))

(defun c:flatten-item (x)
   (match x
      (('if cnd then) (setf (third x) (c:flatten then)))
      (('if cnd then else)
       (cond ((null then) (setf (cdr x) `((! ,cnd) ,(c:flatten else))))
             (t (setf (third x) (c:flatten then))
                (and else (setf (fourth x) (c:flatten else))))))
      (('for var . body) (setf (cddr x) (c:flatten-seq body)))
      (('while cnd . body) (setf (cddr x) (c:flatten-seq body)))
      (('dowhile rep cnd) (setf (second x) (c:flatten rep)))
      (x nil)))

(defun c:use-var (var x)
   (cond ((eq x var) t)
         ((atom x) nil)
         (t (some (cdr x) (function c:use-var)))))

(defun c:delete-var (var)
   (mapcan var
      (function (lambda (x)
	(cond ((0= (c:cur-refcount (cond ((consp x) (second x)) (t x)))) nil)
	      (t `(,x)))))))

(comment "jump optimize")

(macro c:changed (x) '(setq changed t))

(macro c:while-changed (x)
   `(loop (lets ((changed)) (progn . ,x) (or changed (exit)))))

(defmacro c:loop-jump-opt (x)
   `(progn (c:while-changed (setq ,x (c:jump-opt ,x))) ,x))

(defmacro c:loop-jump-opt-seq (x)
   `(progn (c:while-changed (setq ,x (c:jump-opt-seq ,x))) ,x))

(defun c:jump-opt (x)
   (match x
      (('if cnd then) (setf (third x) (c:jump-opt then)))
      (('if cnd then else)
       (setf (third x) (c:jump-opt then))
       (setf (fourth x) (c:jump-opt else)))
      (('for (inits test updates) . body)
       (setf (cddr x) (c:jump-opt-seq body)))
      (('while cnd . body) (setf (cddr x) (c:jump-opt-seq body)))
      (('dowhile rep cnd) (setf (second x) (c:jump-opt rep)))
      (('block var . body) (setf (cddr x) (c:jump-opt-seq body)))
      (('begin . body) (setf (cdr x) (c:jump-opt-seq body)))
      (('goto lab)
       (lets ((ll (c:label-ll lab)) (l (c:label-l lab)) 
              (next (c:next-goto (cdr l))))
        (cond ((null next))
              ((and (<= (c:cur-refcount lab) 1) (c:gotop (car ll)))
               (rplacd ll (cdr next))
               (and (cdr next)
                    (c:labelp (second next))
                    (c:label-ll (second (second next)) ll))
               (rplacd next nil)
               (c:decr-refcount lab)
               (setq x (c:fromto (cdr l)))
               (c:changed))
              ((eq next (cdr l))
               (c:decr-refcount lab)
               (cond ((eq (caar next) 'goto)
                      (setf (second x) (cadar next))
                      (c:incr-refcount (cadar next)))
                     (t (c:incr-refc-value (cadar next) 1)
			(setq x (copy (car next)))))
               (c:changed))))))
   x)

(defun c:jump-opt-seq (xs)
   (lets ((ys `(nil . ,xs)) (ll ys) (l xs) (x))
    (loop (and (atom l) (exit (cdr ys)))
          (loop (match l
                   ((('if cnd ('goto lab)) ('label lab2) . rest)
                    (cond ((eq lab lab2)
                           (rplaca l cnd)
                           (c:decr-refcount lab)
                           (c:advance ll l)
                           (c:changed))
                          (t (exit))))
                   ((('if cnd then else) ('label lab) . rest)
		    (comment lets ((printlevel 3) (printlength 3)
			   (standard-output terminal-output))
		     (format "then = /s, else = /s, lab = /s/n"
		       then else lab))
		    (cond ((and (consp then)
				(eq (car then) 'goto)
				(eq (second then) lab))
			   (setf (second (car l)) `(! ,(second (car l))))
                           (setf (cddr (car l)) (cdddr (car l)))
                           (c:decr-refcount lab)
                           (c:changed))
			  ((and (consp else)
				(eq (car else) 'goto)
				(eq (second else) lab))
                           (setf (cdddr (car l)) nil)
                           (c:decr-refcount lab)
                           (c:changed))
                          (t (exit))))
                   ((('goto lab) ('label lab2) . rest)
                    (cond ((eq lab lab2)
                           (setf (car l) nil)
                           (c:decr-refcount lab)
                           (c:advance ll l)
                           (c:changed))
                          (t (exit))))
                   (x (exit))))
          (setq x (c:jump-opt (car l)))
          (cond ((neq x (car l)) (rplaca l x) (c:changed))
                (t (c:advance ll l))))))

(defun c:fromto (x) (cond ((cdr x) `(begin . ,x)) (t (car x))))

(defun c:gotop (x)
   (and (consp x) (or (eq (car x) 'goto) (eq (car x) 'return))))

(defun c:next-goto (from)
   (loop (cond ((atom from) (exit))
               ((c:gotop (car from)) (exit from))
               (t (pop from)))))

(comment "assignment optimize")

(defun c:ass-opt (x)
   (match x
      (('if cnd then) (setf (third x) (c:ass-opt then)))
      (('if cnd then else)
       (setf (third x) (c:ass-opt then))
       (setf (fourth x) (c:ass-opt else)))
      (('for (inits test updates) . body) (setf (cddr x) (c:ass-opt-seq body)))
      (('while cnd . body) (setf (cddr x) (c:ass-opt-seq body)))
      (('dowhile rep cnd) (setf (second x) (c:ass-opt rep)))
      (('block var . body) (setf (cddr x) (c:ass-opt-seq body)))
      (('begin . body) (setf (cdr x) (c:ass-opt-seq body))))
   x)

(defun c:ass-opt-seq (xs)
   (lets ((l xs) (x))
    (loop (and (atom l) (exit xs))
          (match l
             ((('= var1 val1) ('= var2 val2) . rest)
	      (and (symbolp var1)
	           (lets ((rm (c:removable val1)) (n (c:varcount var1 val2)))
		    (cond ((or (and (eq var1 var2) rm)
                               (and (= (c:cur-refcount var1) (/1+ n))
				    (or (= n 1) (c:simple val1))))
                           (setf (car l) nil)
                           (or (/0= n)
                               (setf (third (second l))
				     (subst val1 var1 val2)))
                           (c:decr-refcount var1 (/1+ n))
                           (c:incr-refc-value val1 (/1- n))
                           (c:changed))))))
             ((('= var1 val1) ('return val2) . rest)
	      (and (symbolp var1)
	           (lets ((n (c:varcount var1 val2)))
		    (cond ((or (and (/0= n) (c:removable val1))
			       (= n 1)
			       (c:simple val1))
                           (setf (car l) nil)
			   (or (/0= n)
                               (setf (second (second l))
			             (subst val1 var1 val2)))
                           (c:decr-refcount var1 (1+ n))
                           (c:incr-refc-value val1 (/1- n))
                           (c:changed)))))))
          (c:ass-opt (pop l)))))

(defun c:removable (val)
   (not (and (consp val) (memq (car val) '(cfunc-call predef-call)))))

(comment "kore wa inchiki, local variable de aru koto")

(defun c:simple (x) (symbolp x))

(comment "debug")

(defun show-refs nil
   (mapc refs '(lambda (s) (format "/s  /s/n" s (get s 'refcount)))))

(defun clear-refs nil (mapc refs '(lambda (x) (remprop x 'refcount))))

(defun refs nil (setq refs nil))

