; Copyright (c) 2004, 2005 by Juliusz Chroboczek.
; Experimental; do not redistribute.

(in-package cpc)

(defun definition-is-trivial (definition)
  (assert (eql 'definition (car definition)))
  (let ((specifiers (cadr definition)))
    (if (member 'cps specifiers)
        (let ((names
               (mapcar #'car (definition-arglist-environment definition))))
          (block-is-trivial (cdr (fifth definition)) names))
        nil)))

(defun block-is-trivial (l names)
  (cond
    ((null l) '(:return))
    ((equal (car l) '(statement (expression nil)))
     (block-is-trivial (cdr l) names))
    ((equal (car l) '(statement (return nil)))
     '(:return))
    ((and (statement-cps-apply-p (car l))
          (equal (cadr l) '(statement (return nil)))
          (null (set-difference (caddr (car l)) names :test #'equal)))
     (list :logical (cadr (cadr (cadr (car l))))
           (compute-permutation (caddr (cadr (cadr (car l)))) names)))
    (t nil)))

(defun compute-permutation (from to)
  (mapcar #'(lambda (x) (position x to :test #'equal)) from))

(defun compose-permutations (p1 p2)
  (mapcar #'(lambda (n) (if (null n) 'nil (elt p2 n))) p1))

(defun apply-permutation (p l)
  (mapcar #'(lambda (n) (nth n l)) p))

(defun transitive-trivial-definitions (trivial)
  (mapcar #'(lambda (tr)
              (transitive-trivial-definition tr trivial (list (car tr))))
          trivial))

(defun transitive-trivial-definition (tr trivial &optional seen)
  (ecase (cadr tr)
    ((nil) 'nil)
    ((:return) tr)
    ((:logical)
     (if (member (caddr tr) seen :test #'equal)
         '()
         (let ((tr2
                (transitive-trivial-definition
                 (assoc (caddr tr) trivial :test #'equal)
                 trivial (cons (caddr tr) seen))))
           (ecase (cadr tr2)
             ((nil) tr)
             ((:return)
              (list (car tr) :return))
             ((:logical)
              (list (car tr) :logical (caddr tr2)
                    (compose-permutations (fourth tr) (fourth tr2))))))))))

(defun block-collect-trivial-definitions (l)
  (if (null l)
      '()
      (append
       (let ((s (car l)))
         (ecase (car s)
           ((definition)
            (let ((trivial (definition-is-trivial s)))
              (if trivial
                  (list (cons (function-definition-name s) trivial))
                  '())))
           ((statement declaration) '())))
       (block-collect-trivial-definitions (cdr l)))))

(defun beta-reduce (d trivial)
  (ecase (car d)
    ((statement) (beta-reduce-statement d trivial))
    ((definition)
     (list (car d) (cadr d) (caddr d) (fourth d)
           (beta-reduce-statement-no-head (fifth d) trivial)))
    ((declaration) d)))

(defun beta-reduce-statement (s trivial)
  (assert (eql 'statement (car s)))
  (let* ((snh (cadr s))
         (snh* (beta-reduce-statement-no-head snh trivial)))
    (cond
      ((eq snh snh*) s)
      ((null snh*) nil)
      (t `(statement ,snh*)))))

(defun beta-reduce-statement-no-head (snh trivial)
  (case (car snh)
    ((block) (cons 'block (beta-reduce-block (cdr snh) trivial)))
    ((if)
     (list (car snh) (cadr snh)
           (beta-reduce-statement (caddr snh) trivial)
           (and (fourth snh) (beta-reduce-statement (fourth snh) trivial))))
    ((while)
     (list (car snh) (cadr snh) (beta-reduce-statement (caddr snh) trivial)))
    ((do-while)
     (list (car snh) (beta-reduce-statement (cadr snh) trivial) (caddr snh)))
    ((for)
     (list (car snh) (cadr snh) (caddr snh) (fourth snh)
           (beta-reduce-statement (fifth snh) trivial)))
    ((expression)
     (let ((e (cadr snh)))
       (cond
         ((eql (car e) 'cps-apply)
           (let ((tr (assoc (cadr e) trivial :test #'equal)))
             (ecase (cadr tr)
               ((:logical)
               `(expression (cps-apply ,(caddr tr)
                             ,(apply-permutation (fourth tr) (caddr e)))))
               ((:return)
                nil)
               ((nil) snh))))
         (t snh))))
    (t snh)))

(defun beta-reduce-block (l trivial)
  (if (null l) '()
      (let ((s (beta-reduce (car l) trivial)))
        (if (null s)
            (beta-reduce-block (cdr l) trivial)
            (cons s (beta-reduce-block (cdr l) trivial))))))

(defun optimise-translation-unit (tu)
  (let* ((trivial (block-collect-trivial-definitions tu))
         (trivial* (transitive-trivial-definitions trivial)))
    (mapcar #'(lambda (d) (beta-reduce d trivial*)) tu)))