(module dotnet_compress
   (import type_type ast_var ast_node
	   object_class      ; tclass
	   dotnet_env
	   dotnet_vmemq
	   tools_shape
	   engine_param
	   effect_effect)
   (export (generic compile-compress::node e::node)) )

(define-generic (compile-compress::node e::node))

(define (compress* l)
   (if (not (null? l))
       (begin (set-car! l (compile-compress (car l)))
	      (compress* (cdr l)) )))

(define-method (compile-compress e::atom)
   e )

(define-method (compile-compress e::var)
   e )

(define *safe-functions* (make-hashtable))

(hashtable-put! *safe-functions* "LONG_TO_INT" #t)

(define-method (compile-compress e::let-var)
   (define (get x l)
      (if (var? x)
	  (let ( (v (var-variable x)) )
	     (let ( (slot (assq v l)) )
		(if slot (cdr slot) x) ))
	  x ))
   (define (eqv? v expr)
      (and (var? expr) (eq? (var-variable expr) v)) )
   (define (safe? fun)
      (let ( (v (var-variable fun)) )
	 (and (global? v)
	      (string? (global-name v))
	      (hashtable-get *safe-functions* (global-name v)) )))
   (define (simple? e)
      (or (atom? e)
	  (var? e)
	  (and (app? e) (every? simple? (app-args e)) (safe? (app-fun e)))
	  (and (vref? e) (every? simple? (vref-expr* e)))
	  (and (getfield? e) (every? simple? (getfield-expr* e))) ))
   (define (simple*? expr* bindings)
      (and (every? simple? expr*)
	   (every? (lambda (s) (any? (lambda (a) (eqv? (car s) a)) expr*))
		   bindings )))
   (define (filter pred lst)
      (cond
	 ((null? lst)
	  lst)
	 ((pred (car lst))
	  (cons (car lst) (filter pred (cdr lst))))
	 (else
	  (filter pred (cdr lst)))))
   (with-access::let-var e (bindings body)
      (define (getb x) (get x bindings))
      (set! body (compile-compress body))
      (for-each (lambda (c) (set-cdr! c (compile-compress (cdr c)))) bindings)
      (cond
	 ((null? bindings)
	  ;(print "compress (let () E)") 
	  body )
	 ((any? (lambda (b) (>fx (local-occurrence (car b)) 1)) bindings)
	  e )
	 ((and (var? body) (eqv? (caar bindings) body))
	  ;(print "compress (let ((x E)) x)")
	  (cdar bindings) )
	 ((and (app? body)
	       (simple*? (app-args body) bindings)
	       (or (=fx (length (app-args body)) 1)
		   (every? (lambda (b)
			      (not (side-effect? (cdr b))))
			   bindings)
		   (every? (lambda (a)
			      (or (not (var? a))
				  (eq? (variable-access (var-variable a))
				       'read)))
			   (app-args body))
		   (let ((args (filter var? (app-args body))))
		      (every? (lambda (b)
				 (not (vmemq? args (cdr b))))
			      bindings))))
	  ;; MANUEL SERRANO: 28 aug 2001: added the OR clause
	  (app-args-set! body (map getb (app-args body)))
	  body )
	 ((and (app? body) (simple*? (app-args body) bindings))
	  (let ((expr (shape `(let ,(map (lambda (b) (list (car b) (cdr b)))
					 bindings)
				 ,body))))
	     (if (and (number? *verbose*)
		      (>= *verbose* 2))
		 (warning "Jvm"
			  "Re-phrase this expression (beta-reduce) for better performance -- "
			  expr))
	     e))
	 ((and (extern? body) (simple*? (extern-expr* body) bindings))
	  ;(print "conpress (let ((x E)) (extern x))")
	  (extern-expr*-set! body (map getb (extern-expr* body)))
	  body )
	 ((and (conditional? body)
	       (null? (cdr bindings))
	       (eqv? (caar bindings) (conditional-test body)) )
	  ;(print "conpress (let ((x E)) (if x A B))")
	  (conditional-test-set! body (cdar bindings))
	  body )
	 (else e) )))

(define-method (compile-compress e::setq)
   (with-access::setq e (value)
      (set! value (compile-compress value))
      e ))

(define-method (compile-compress e::sequence)
   (with-access::sequence e (nodes)
      (if (and (pair? nodes) (null? (cdr nodes)))
	  (compile-compress (car nodes))
	  (begin
	     (compress* nodes)
	     e ))))

(define-method (compile-compress e::conditional)
   (with-access::conditional e (test true false)
      (set! test (compile-compress test))
      (set! true (compile-compress true))
      (set! false (compile-compress false))
      e ))

(define-method (compile-compress e::select)
   (with-access::select e (test clauses)
      (set! test (compile-compress test))
      (for-each (lambda (c) (set-cdr! c (compile-compress (cdr c)))) clauses)
      e ))

(define-method (compile-compress e::let-fun)
   (with-access::let-fun e (locals body)
      (for-each (lambda (v) 
		   (with-access::local v (value)
		      (with-access::sfun value (body)
			 (set! body (compile-compress body)) )))
		locals )
      (set! body (compile-compress body))
      e ))

(define-method (compile-compress e::app)
   (with-access::app e (fun args)
      (compress* args)
      e ))

(define-method (compile-compress e::app-ly)
   (with-access::app-ly e (fun arg)
      (set! fun (compile-compress fun))
      (set! arg (compile-compress arg))
      e ))
	  
(define-method (compile-compress e::funcall)
   (with-access::funcall e (fun args)
      (set! fun (compile-compress fun))
      (compress* args)
      e ))

(define-method (compile-compress e::extern)
   (with-access::extern e (expr*)
      (compress* expr*)
      e ))

(define-method (compile-compress e::cast)
   (with-access::cast e (arg)
      (set! arg (compile-compress arg))
      e ))

(define-method (compile-compress e::set-ex-it)
   (with-access::set-ex-it e (var body)
      (set! body (compile-compress body))
      e ))

(define-method (compile-compress e::jump-ex-it)
   (with-access::jump-ex-it e (exit value)
      (set! exit (compile-compress exit))
      (set! value (compile-compress value))
      e ))

(define-method (compile-compress e::fail)
   (with-access::fail e (proc msg obj)
      (set! proc (compile-compress proc))
      (set! msg (compile-compress msg))
      (set! obj (compile-compress obj))
      e ))

(define-method (compile-compress e::make-box)
   (with-access::make-box e (value)
      (set! value (compile-compress value))
      e ))

(define-method (compile-compress e::box-ref)
   e )

(define-method (compile-compress e::box-set!)
   (with-access::box-set! e (var value)
      (set! value (compile-compress value))
      e ))

      
