(module saw_jvm_code
   (import type_type ast_var ast_node
	   type_env
	   engine_param
	   module_module
	   object_class
	   object_slots
	   read_jvm
	   backend_backend
	   backend_lib
	   backend_cplib
	   saw_defs
	   saw_jvm_names
	   saw_jvm_out
	   saw_jvm_funcall
	   saw_jvm_inline
	   )
   (export (module-code me::jvm params l)
	   (gen-expr me::jvm ins))
   (static (wide-class lreg::rtl_reg id)) )

(define *hasprotect* #f)
(define *protectresult* #f)
(define *bexitreg* #f)

;;
;; Main function
;;
(define (module-code me params l)
   (let ( (locs (get-locals params l)) )
      (define (double l)
	 (if (null? l)
	     l
	     (let ( (reg (car l)) (r (double (cdr l))) )
		(let ( (type (type-name (lreg-type reg))) )
		   (if (or (eq? type 'double) (eq? type 'long))
		       (cons (lreg-id reg) (cons '_ r))
		       (cons (lreg-id reg) r) )))))
      (declare-locals me (double params) (double locs)) )
   (when *hasprotect*
      ;; The "from" label is generated by protect
      (code! me '(handler from catch catch bexception)) )
   (for-each (lambda (b)
		(label me (block-label b))
		(for-each (lambda (i) (gen-ins me i)) (block-first b)) )
	     l )
   ;; Special code for protected functions
   (when *hasprotect*
      (code! me 'catch)
      (load-reg me *bexitreg*)
      (code! me '(checkcast exit))
      (code! me '(invokestatic debug_handler))
      (code! me '(areturn)) ))

;;
;; Scan the code to retrieve local variable
;; Update all reg to lreg and return all regs not parameters
;;
(define (get-locals params l) ;()
   (set! *hasprotect* #f)
   (let ( (n 0) (regs '()) )
      (define (name p n)
	 (string->symbol (string-append p (integer->string n))) )
      (define (reg->lreg r)
	 ;; Update a register.
	 (unless (lreg? r)
	    (widen!::lreg r (id (name "V" n)))
	    (set! n (+fx n 1))
	    (set! regs (cons r regs)) ))
      (define (nr t)
	 ;; Create a new register for specific use.
	 (let ( (r (instantiate::rtl_reg (type t) (var #f))) )
	    (reg->lreg r)
	    r ))
      (define (check_fun e)
	 ;; Check if something must be done for specific instructions.
	 (let ( (fun (rtl_ins-fun e)) )
	    (cond
	       ((rtl_protect? fun)
		(set! *hasprotect* #t)
		(set! *bexitreg* (rtl_ins-dest e)) )
	       ((rtl_switch? fun) ))))
      (define (expr e)
	 (if (rtl_reg? e)
	     (reg->lreg e)
	     (begin (check_fun e)
		    (for-each expr (rtl_ins-args e)) )))
      (define (instruction e)
	 (let ( (dest (rtl_ins-dest e)) )
	    (if dest (reg->lreg dest))
	    (check_fun e)
	    (for-each expr (rtl_ins-args e)) ))
      (let loop ( (l params) )
	 (unless (null? l)
	    (widen!::lreg (car l) (id (name "P" n)))
	    (set! n (+fx n 1))
	    (loop (cdr l)) ))
      (for-each (lambda (b) (for-each instruction (block-first b))) l)
;      (print "After-building-tree : " n " registers.")
      (reverse! regs) ))

;;
;; Instruction generation
;;
(define (gen-ins me ins)
   (with-access::rtl_ins ins (dest fun args)
      ;; Call the generic method and check for existing value on stack
      (if (eq? (gen-args-gen-fun fun me args) 'no-value)
	  (when dest
	     (code! me '(getstatic *unspecified*))
	     (store-reg me dest) )
	  (if dest
	      (store-reg me dest)
	      ;; Prove that test is always false
	      (unless (or (rtl_last? fun)
			  (rtl_notseq? fun)
			  (rtl_effect? fun) )
		 ;; CARE can be pop2
		 (code! me '(pop)) )))
      (when (rtl_protect? fun)
	 (code! me 'from) )))

(define (gen-expr me::jvm ins)
   (if (rtl_reg? ins)
       (load-reg me ins)
       (with-access::rtl_ins ins (fun args)
	  (when (eq? (gen-args-gen-fun fun me args) 'no-value)
	     (code! me '(getstatic *unspecified*)) ))))

(define (load-reg me r)
   (code! me
	  `(,(case (type-name (lreg-type r))
		((boolean byte char short int) 'iload)
		((long) 'lload)
		((float) 'fload)
		((double) 'dload)
		(else 'aload) )
	    ,(lreg-id r) )))

(define (store-reg me r)
   (code! me
	  `(,(case (type-name (lreg-type r))
		((boolean byte char short int) 'istore)
		((long) 'lstore)
		((float) 'fstore)
		((double) 'dstore)
		(else 'astore) )
	    ,(lreg-id r) )))

;;
;; Main entry for instruction generation (argument not generated)
;; Specific for predicates and some inlined functions
;;
(define-generic (gen-args-gen-fun fun::rtl_fun me args);
   ;; Default case : generate arguments and call another generic method.
   (for-each (lambda (a) (gen-expr me a)) args)
   (gen-fun-with-args fun me args) )

;;
;; Entry for instruction who needs the (already generated) argument.
;; Specific for instruction with no specific arity
;;
(define-generic (gen-fun-with-args fun::rtl_fun me args);
   ;; Default case: forget arguments and call another generic method.
   (gen-fun fun me) )

;;
;; Last entry for generating instructions
;;
(define-generic (gen-fun fun::rtl_fun me));

;;
;; Simple one
;;
(define-method (gen-fun fun::rtl_nop me);
   'no-value )

(define-method (gen-fun fun::rtl_mov me);
   'ok )

;;
;; Constants
;;
(define-method (gen-fun fun::rtl_loadi me);
   (let ( (constant (rtl_loadi-constant fun)) )
      (let ( (value (atom-value constant)) )
	 (cond
	    ((number? value)
	     (push-num me value (type-name (node-type constant))) )
	    ((null? value)
	     (code! me '(getstatic *nil*)) )
	    ((boolean? value)
	     (push-int me (if value 1 0)) )
	    ((char? value)
	     (push-int me (char->integer value)) )
	    ((string? value)
	     (push-string me value)
	     ;; CARE do the creation at clinit time
	     (code! me '(invokevirtual getbytes)) )
	    ((eof-object? value)
	     (code! me '(getstatic *eof*)) )
	    ((eq? value '#!optional)
	     (code! me '(getstatic *optional*)) )
	    ((eq? value '#!rest)
	     (code! me '(getstatic *rest*)) )
	    ((eq? value '#!key)
	     (code! me '(getstatic *key*)) )
	    ((eq? value #unspecified)
	     (code! me '(getstatic *unspecified*)) )
	    ((ucs2? value)
	     ;; CARE do the creation at clinit time
	     (code! me '(new bucs2))
	     (code! me '(dup))
	     (push-int me (ucs2->integer value))
	     (code! me '(invokespecial init_bucs2)) )
	    ((elong? value)
	     ;; CARE do the creation at clinit time
	     (push-string me (elong->string value))
	     (code! me '(invokestatic make_elong)) )
	    ((llong? value)
	     ;; CARE do the creation at clinit time
	     (push-string me (llong->string value))
	     (code! me '(invokestatic make_llong)) )
	    (else (error "loadi" "bad atom value" value)) ))))

;;
;; Accessing globals
;;
(define-method (gen-fun fun::rtl_loadg me);
   (code! me `(getstatic ,(declare-global me (rtl_loadg-var fun)))) )

(define-method (gen-fun fun::rtl_storeg me);
   (code! me `(putstatic ,(declare-global me (rtl_storeg-var fun))))
   'no-value )

(define-method (gen-fun fun::rtl_globalref me);
   (let ( (var (rtl_globalref-var fun)) )
      (code! me '(new me))
      (code! me '(dup))
      (code! me '(invokespecial init))
      (code! me '(dup))
      (push-int me (indexed-index var))
      (code! me '(putfield procindex)) ))

;;
;; Control
;;
(define-method (gen-args-gen-fun fun::rtl_ifeq me args);
   (let ( (arg (car args)) (lab (block-label (rtl_ifeq-then fun))) )
      (if (rtl_reg? arg)
	  (begin (load-reg me arg)
		 (branch me 'ifeq lab) )
	  (with-access::rtl_ins arg (fun args)
	     (gen-args-gen-predicate fun me args #f lab) ))
      'no-value ))

(define-method (gen-args-gen-fun fun::rtl_ifne me args);
   (let ( (arg (car args)) (lab (block-label (rtl_ifne-then fun))) )
      (if (rtl_reg? arg)
	  (begin (load-reg me arg)
		 (branch me 'ifne lab) )
	  (with-access::rtl_ins arg (fun args)
	     (gen-args-gen-predicate fun me args #t lab) ))
      'no-value ))

(define-method (gen-fun fun::rtl_go me);
   (branch me 'goto (block-label (rtl_go-to fun)))
   'no-value )

(define-method (gen-fun fun::rtl_switch me);
   (with-access::rtl_switch fun (type patterns labels)
      ;; CARE do we have to make a coercion from "type" to int ??
      (let ( (ldef #unspecified) (num2lab '()) )
	 (define (L n)
	    (string->symbol (string-append "L" (integer->string n))) )
	 (define (add n lab)  (set! num2lab (cons (cons n (L lab)) num2lab)))
	 (for-each (lambda (pat lab)
		      (if (eq? pat 'else)
			  (set! ldef (L lab))
			  (for-each (lambda (n) (add n lab)) pat) ))
		   patterns
		   (map block-label labels) )
	 (cond
	    ((null? (cdr num2lab))
	     (push-int me (caar num2lab))
	     (branch me 'if_icmpne ldef)
	     (branch me 'goto (cdar num2lab)) )
	    (else
	     (set! num2lab (sort num2lab (lambda (x y) (<fx (car x) (car y)))))
	     (let* ( (nums (map car num2lab))
		     (min (car nums))
		     (max (car (last-pair nums)))
		     (n (length nums)) )
		(if (< (/ n (+fx 1 (-fx max min))) 0.75)
		    (code! me `(lookupswitch ,ldef ,@num2lab))
		    (code! me `(tableswitch ,ldef ,min
					    ,@(flat num2lab ldef) ))))))
	 'no-value )))

(define (flat al ldef)
   (define (walk al i r)
      (cond
	 ((null? al) (reverse! r))
	 ((=fx i (caar al)) (walk (cdr al) (+fx i 1) (cons (cdar al) r)))
	 ((>fx i (caar al)) (walk (cdr al) i r))
	 (else (walk al (+fx i 1) (cons ldef r))) ))
   (walk al (caar al) '()) )

;;
;; Call
;;
(define-method (gen-args-gen-fun fun::rtl_call me args);
   (let ( (r (inline-call-with-args? me (rtl_call-var fun) args)) )
      (if (eq? r  'not-inlined)
	  (begin (for-each (lambda (a) (gen-expr me a)) args)
		 (gen-fun fun me) )
	  r )))

(define-method (gen-fun fun::rtl_call me);
   (let ( (var (rtl_call-var fun)) )
      (let ( (r (inline-call? me var)) )
	 (if (eq? r  'not-inlined)
	     (with-access::global var (type)
		(call-global me var)
		(if (eq? (type-name type) 'void)
		    'no-value
		    'ok ))
	     r ))))

(define-method (gen-fun-with-args fun::rtl_lightfuncall me args);
   (gen-funcall me args) )

(define-method (gen-fun-with-args fun::rtl_funcall me args);
   (gen-funcall me args) )

(define (gen-funcall me args)
   (let ( (n (-fx (length args) 1)) )
      (case n
	 ((0) (code! me '(invokevirtual pfuncall0)))
	 ((1) (code! me '(invokevirtual pfuncall1)))
	 ((2) (code! me '(invokevirtual pfuncall2)))
	 ((3) (code! me '(invokevirtual pfuncall3)))
	 ((4) (code! me '(invokevirtual pfuncall4)))
	 (else ;; CARE Why not putting args in a global vector
	     (code! me '(getstatic *nil*))
	     (for-each (lambda (a) (code! me '(invokestatic cons))) (cdr args))
	     (code! me '(invokevirtual papply)) ))))

(define-method (gen-fun-with-args fun::rtl_return me args);
   (let ( (a (car args)) )
      (let ( (reg (if (rtl_reg? a) a (rtl_ins-dest a))) )
	 (code! me 
		(case (type-name (rtl_reg-type reg))
		   ((void) '(return))
		   ((boolean byte char short int) '(ireturn))
		   ((long) '(lreturn))
		   ((float) '(freturn))
		   ((double) '(dreturn))
		   (else '(areturn)) ))
	 'no-value )))

(define-method (gen-fun fun::rtl_loadfun me);
   (let ( (var (rtl_loadfun-var fun)) )
      (push-int me (indexed-index var)) ))

(define-method (gen-fun fun::rtl_apply me);
   (code! me '(invokevirtual papply)) )

;;
;; Vectors
;;
(define-method (gen-fun fun::rtl_vref me);
   (let ( (type (compile-type me (rtl_vref-type fun))) )
      (code! me (case type
		   ((boolean byte) '(baload))
		   ((char) '(caload))
		   ((short) '(saload))
		   ((int) '(iaload))
		   ((long) '(laload))
		   ((float) '(faload))
		   ((double) '(daload))
		   (else '(aaload)) ))))

(define-method (gen-fun fun::rtl_vset me);
   (let ( (type (compile-type me (rtl_vset-type fun))) )
      (code! me (case type
		   ((boolean byte) '(bastore))
		   ((char) '(castore))
		   ((short) '(sastore))
		   ((int) '(iastore))
		   ((long) '(lastore))
		   ((float) '(fastore))
		   ((double) '(dastore))
		   (else '(aastore)) ))
      'no-value ))

(define-method (gen-fun fun::rtl_vlength me);
   (code! me '(arraylength)) )

(define-method (gen-fun fun::rtl_valloc me);
   (let ( (type (compile-type me (rtl_valloc-type fun))) )
      (code! me `(,(case type
		      ((boolean byte char short int long float double)
		       'newarray )
		      (else 'anewarray) )
		  ,type ))))

;;
;; Objects
;;
(define-method (gen-args-gen-fun fun::rtl_new me args);
   ;; CARE MANU I don'thave the real type of the constructor
   ;; Inferred from arguments but can be wrong (subtyped)
   (newobj me (rtl_new-type fun)
	   (lambda () (for-each (lambda (a) (gen-expr me a)) args))
	   (map (lambda (a)
		   (rtl_reg-type
		    (if (rtl_reg? a) a (rtl_ins-dest a)) ))
		args )))

(define-method (gen-fun fun::rtl_getfield me);
   (with-access::rtl_getfield fun (name objtype type)
      ;; CARE MANU
      (if (wide-class? objtype) (set! objtype (wide->chunk objtype)))
      (load-field me type objtype name) ))

(define-method (gen-fun fun::rtl_setfield me);
   (with-access::rtl_setfield fun (name objtype type)
      ;; CARE MANU
      (if (wide-class? objtype) (set! objtype (wide->chunk objtype)))
      (store-field me type objtype name)
      'no-value ))

(define-method (gen-fun fun::rtl_isa me);
   (code! me `(instanceof ,(compile-type me (rtl_isa-type fun))))
   (let ( (l1 (gensym "I")) (l2 (gensym "I")) )
      (branch me 'ifeq l1)
      (push-int me 1)
      (branch me 'goto l2)
      (label me l1)
      (push-int me 0)
      (label me l2) ))

(define-method (gen-fun fun::rtl_cast me);
   (when *jvm-purify*
      (code! me `(checkcast ,(compile-type me (rtl_cast-type fun)))) ))

;;
;; Box
;;
(define-method (gen-args-gen-fun fun::rtl_makebox me args);
   (code! me '(new cell))
   (code! me '(dup))
   (gen-expr me (car args))
   (code! me '(invokespecial init_cell)) )

(define-method (gen-fun fun::rtl_boxref me);
   (code! me '(getfield ccar)) )

(define-method (gen-fun fun::rtl_boxset me);
   (code! me '(putfield ccar))
   'no-value )

;;
;; Exceptions
;;
(define-method (gen-fun fun::rtl_jumpexit me);
   (code! me '(invokestatic jumpexit))
   ;; CARE Dead code !!
   (code! me '(checkcast throwable))
   (code! me '(athrow))
   'no-value )

(define-method (gen-fun fun::rtl_fail me);
   (code! me '(invokestatic fail))
   (code! me '(athrow))
   'no-value )

(define-method (gen-fun fun::rtl_protect me);
   (code! me '(invokestatic setexit)) )

(define-method (gen-fun fun::rtl_protected me);
   ;; CARE Strange nothing to do...
   'ok )

;;
;; Main entry for predicate generation (arguments generated)
;; Drop args and call another generic function.
;; Currently not used by inlined functions
;;
(define-generic (gen-args-gen-predicate fun::rtl_fun me args on? lab);
   ;; Default case
   (for-each (lambda (a) (gen-expr me a)) args)
   (gen-predicate fun me on? lab) )

;;
;; Last entry for generating predicate
;;
(define-generic (gen-predicate fun::rtl_fun me on? lab);
   (default-gen-predicate fun me on? lab) )

(define (default-gen-predicate fun me on? lab);
   ;; Default case
   (gen-fun fun me)
   (branch me (if on? 'ifne 'ifeq) lab) )

;; Call
(define-method (gen-predicate fun::rtl_call me on? lab);
   (let ( (r (inline-predicate? me (rtl_call-var fun) on? lab)) )
      (if (eq? r  'not-inlined)
	  (default-gen-predicate fun me on? lab)
	  r )))

;;CARE isa

