(module jvm_peephole
   (import engine_param)
   (static
    (class peep-env
       handlers
       params
       locals
       code )
    )
   (export (jvm_peephole m) ))

;;
;; Main functions
;;
(define (jvm_peephole m)
   (if (> *optim-jvm-peephole* 0)
       (peep-method m)
       m ))

(define (peep-method defm)
   (match-case defm
      ((method ?gname ?params ?locals . ?code)
       (set-cdr! (cddr defm) (peep-all params locals code)) )
      (else (error "peephole" "bad method definition" defm)) ))

(define (peep-all params locals code)
   (let ( (env (make-env params locals code)) )
      (removebranch env)
      (removesequence env)
      (peep-result env) ))

;;
;; Globals
;;
(define *kind-of-goto*
   '(athrow goto tableswitch lookupswitch
	    ireturn lreturn freturn dreturn areturn return ))

(define *single-lab-cop*
   '(ifnull ifnonnull 
     ifeq ifne iflt ifge ifgt ifle 
     if_icmpeq if_icmpne if_icmplt if_icmpge if_icmpgt if_icmple
     if_acmpeq if_acmpne 
     goto jsr ))

(define *huge-cop*
   '(lookupswitch tableswitch) )

;;
;; Environment
;;
(define (make-env params locals code)
   (instantiate::peep-env
      (handlers (get-handlers code))
      (params params)
      (locals locals)
      (code (remove-handlers code)) ))

(define (peep-result env)
   (with-access::peep-env env (handlers params locals code)
      `(,locals ,@handlers ,@code) ))

(define (get-handlers l)
   (define (walk l)
      (match-case l
	 (() '())
	 (((handler . ?-) . ?rest)
	  (cons (car l) (walk rest)) )
	 (else (walk (cdr l))) ))
   (walk l) )

(define (remove-handlers.old l)
   (define (walk l)
      (match-case l
	 (() '())
	 (((handler . ?-) . ?rest)
	  (walk rest) )
	 (else (cons (car l) (walk (cdr l)))) ))
   (walk l) )
(define (remove-handlers l)
   (define (walk l p hook)
      (if (null? l)
	  (cdr hook)
	  (if (and (pair? (car l)) (eq? (caar l) 'handler))
	      (walk (cdr l) p hook)
	      (begin
	       (set-cdr! p (cons (car l) '()))
	       (walk (cdr l) (cdr p) hook) ))))
   (let ( (hook (cons '() '())) )
      (walk l hook hook) ))

;;
;; Aliasing
;;
(define (alias env)
   (with-access::peep-env env (params locals code handlers)
      (define (make-var-env)
	 (append
	  (map (lambda (v) (cons* v 1 0)) params)
	  (map (lambda (v) (cons* v 0 0)) locals) ))
      (let ( (env (make-var-env)) )
	 env )))

;;
;; Branch tensioning
;;
(define (removebranch env)
   (let ( (code (peep-env-code env)) (done '()) )
      (define (collect l from r n)
	 (cond ((or (null? l) (>fx n 5) (eq? (car l) from)) #f)
	       ((symbol? (car l)) (collect (cdr l) from r n))
	       ((memq (caar l) *huge-cop*) #f)
	       ((memq (caar l) *kind-of-goto*) (reverse! (cons (car l) r)))
	       (else (collect (cdr l) from (cons (car l) r) (+fx n 1))) ))
      (define (walk-at-lab lab)
	 (walk-from lab (cdr (memq lab code))) )
      (define (walk-from from l)
	 (if (memq from done)
	     'done
	     (begin (set! done (cons from done))
		    (walk from l) )))
      (define (walk from l)
	 (cond ((null? l) 'done)
	       ((symbol? (car l))
		(walk-from (car l) (cdr l)) )
	       ((eq? (caar l) 'goto)
		(let ( (lab (cadar l)) )
		   ;; insure lab is done to avoid loop
		   (walk-at-lab lab)
		   (let ( (dup (collect (memq lab code) from '() 0)) )
		      (if dup
			  (let ( (next (cdr l)) )
			     (set-car! l (car dup))
			     (set-cdr! l (append (cdr dup) next))
			     (walk from next) )))))
	       (else (walk from (cdr l))) ))
      (walk 'begin code) ))

;;
;; Dead code elimination
;;
(define (removesequence env)
   (with-access::peep-env env (code handlers)
      (define (make-labenv code)
	 (cond ((null? code) '())
 	       ((symbol? (car code)) (cons (cons (car code) 0)
					   (make-labenv (cdr code)) ))
	       (else (make-labenv (cdr code))) ))
      (define (count-lab lab env)
	 (let ( (slot (assq lab env)) )
	    (if slot
		(set-cdr! slot (+ 1 (cdr slot)))
		(error 'count-lab "unknown label" lab) )))
      (define (count-ins ins env)
	 (if (and (pair? ins) (memq (car ins) *single-lab-cop*))
	     (count-lab (cadr ins) env)
	     (match-case ins
		((localvar ?beg ?end . ?-)
		 (count-lab beg env)
		 (count-lab end env) )
		((tableswitch ?def ?- . ?labs)
		 (count-lab def env)
		 (for-each (lambda (lab) (count-lab lab env)) labs) )
		((lookupswitch ?def . ?table)
		 (count-lab def env)
		 (for-each (lambda (slot) (count-lab (cdr slot) env))
			   table )))))
      (define (count-handler h env)
	 (match-case h
	    ((handler ?beg ?end ?lab ?-)
	     (count-lab beg env)
	     (count-lab end env)
	     (count-lab lab env) )))
      (let ( (env (make-labenv code)) )
	 (define (dead-code prev code)
	    (cond ((null? code)
		   (set-cdr! prev '()) )
		  ((symbol? (car code))
		   (if (= 0 (cdr (assq (car code) env)))
		       (dead-code prev (cdr code))
		       (begin (set-cdr! prev code)
			      (walk code (cdr code)) )))
		  (else (dead-code prev (cdr code))) ))
	 (define (walk prev code)
	    (cond ((null? code) 'ok)
		  ((and (symbol? (car code))
			(= 0 (cdr (assq (car code) env))) )
		   (set-cdr! prev (cdr code))
		   (walk prev (cdr code)) )
		  ((and (pair? (car code)) (memq (caar code) *kind-of-goto*))
		   (dead-code code (cdr code)) )
		  (else (walk code (cdr code))) ))
	 (for-each (lambda (ins) (count-ins ins env)) code)
	 (for-each (lambda (h) (count-handler h env)) handlers)
	 (walk code code) )))
