;;;;
;;;; assembler.stk	-- Assember stuff
;;;; 
;;;; Copyright  2000-2002 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
;;;; USA.
;;;; 
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 14-Mar-2001 13:49 (eg)
;;;; Last file update: 27-Dec-2002 09:17 (eg)
;;;;

;;;
;;; The VM instructions. The list is formed of 3-uples 
;;;		(<mnemonic> <code> <#of parameters>)
;;; where <code> is automatically computed 
;;;
(define INSTRUCTION-SET
  (let ((cpt 0))
    (map (lambda (x)
	   (let ((r (list (car x) cpt (cadr x))))
	     (set! cpt (+ cpt 1))
	     r))
	 '(
	   ;; Mnemonic		params
	   (NOP			0)
	   
	   (IM-FALSE		0)
	   (IM-TRUE		0)
	   (IM-NIL		0)
	   (IM-MINUS1		0)
	   (IM-ZERO		0)	
	   (IM-ONE		0)
	   (IM-VOID		0)
	   (SMALL-INT		1)	
	   (CONSTANT		1)
	   
	   (GLOBAL-REF		1)
	   (UGLOBAL-REF		1)	;; Never generated
	   (LOCAL-REF0		0)
	   (LOCAL-REF1		0)
	   (LOCAL-REF2		0)
	   (LOCAL-REF3		0)
	   (LOCAL-REF4		0)
	   (LOCAL-REF		1)
	   (DEEP-LOCAL-REF	1)

	   (GLOBAL-SET		1)
	   (UGLOBAL-SET		1)	;; Never generated
	   (LOCAL-SET0		0)
	   (LOCAL-SET1		0)
	   (LOCAL-SET2		0)
	   (LOCAL-SET3		0)
	   (LOCAL-SET4		0)
	   (LOCAL-SET		1)
	   (DEEP-LOCAL-SET	1)
	   
	   (GOTO		1)
	   (JUMP-FALSE		1)
	   (JUMP-TRUE		1)
	   
	   (DEFINE-SYMBOL	1)
	   
	   (POP			0)
	   (PUSH		0)
	   (PUSH-R1		0)

	   (CREATE-CLOSURE	2)
	   (RETURN		0)

	   (PREPARE-CALL	0)
	   
	   (INVOKE		1)
	   (TAIL-INVOKE		1)
	   (ENTER-LET-STAR	1)
	   (ENTER-LET		1)
	   (ENTER-TAIL-LET-STAR 1)
	   (ENTER-TAIL-LET	1)
	   (LEAVE-LET		0)

	   (PUSH-HANDLER	1)
	   (POP-HANDLER		0)

	   (END-OF-CODE		0)

	   ;; INLINED FUNCTIONS
	   (IN-ADD2		0)
	   (IN-SUB2		0)
	   (IN-MUL2		0)
	   (IN-DIV2		0)

	   (IN-NUMEQ		0)
	   (IN-NUMLT		0)
	   (IN-NUMGT		0)
	   (IN-NUMLE		0)
	   (IN-NUMGE		0)

	   (IN-INCR		0)
	   (IN-DECR		0)

	   (IN-CONS		0)
	   (IN-NULLP		0)
	   (IN-CAR		0)
	   (IN-CDR		0)
	   (IN-LIST		1)
	   (IN-NOT		0)
	   (IN-VREF		0)
	   (IN-VSET		0)
	   (IN-SREF		0)
	   (IN-SSET		0)
	   (IN-EQ		0)
	   (IN-EQV		0)
	   (IN-EQUAL		0)
	   (IN-APPLY		2)
	   (MAKE-EXPANDER	1)
	   (SET-CUR-MOD		0)
	   (EXEC-HANDLER	0)
	   (EVAL-CODE		0)

	   ;; The following instructions are not generated by the compiler 
	   ;; but by the peephole optimizer
	   (FALSE-PUSH		0)	;; peephole: IM-FALSE  + PUSH
	   (TRUE-PUSH		0)	;; peephole: IM-TRUE   + PUSH
	   (NIL-PUSH		0)	;; peephole: IM-NIL    + PUSH
	   (MINUS1-PUSH		0)	;; peephole: IM-MINUS1 + PUSH
	   (ZERO-PUSH		0)	;; peephole: IM-ZERO   + PUSH
	   (ONE-PUSH		0)	;; peephole: IM-ONE    + PUSH
	   (VOID-PUSH		0)	;; peephole: IM-VOID   + PUSH

	   (INT-PUSH		1)	;; peephole: SMALL-INT + PUSH
	   (CONSTANT-PUSH	1)	;; peephole: CONSTANT  + PUSH

	   (GREF-INVOKE		2)	;; peephole: GLBAL_REF + INVOKE
	   (UGREF-INVOKE	2)	;; Never produced by the compiler
	   (IN-NUMDIFF		0)	;; peephole: IN-NUMEQ + NOT
	   (IN-NOT-EQ		0)	;; peephole: IN-EQ    + NOT
	   (IN-NOT-EQV		0)	;; peephole: IN-EQV   + NOT
	   (IN-NOT-EQUAL	0)	;; peephole: IN-EQUAL + NOT

	   (JUMP-NUMDIFF	1)	;; peephole: IN-NUMEQ   + JUMP-FALSE
	   (JUMP-NUMEQ		1)	;; peephole: IN-NUMDIFF + JUMP-FALSE
	   (JUMP-NUMLT		1)	;; peephole: IN-NUMGE   + JUMP-FALSE
	   (JUMP-NUMLE		1)	;; peephole: IN-NUMGT   + JUMP-FALSE
	   (JUMP-NUMGT		1)	;; peephole: IN-NUMLE   + JUMP-FALSE
	   (JUMP-NUMGE		1)	;; peephole: IN-NUMLT   + JUMP-FALSE

	   (JUMP-NOT-EQ		1)	;; peephole: IN-EQ	+ JUMP-FALSE
	   (JUMP-NOT-EQV	1)	;; peephole: IN-EQV	+ JUMP-FALSE
	   (JUMP-NOT-EQUAL	1)	;; peephole: IN-EQUAL	+ JUMP-FALSE

	   ;; Misc opcodes

	   (APPLY-C-FUNC	1)	;; Never generated by the compiler
))))

;;;;
;;;; Utilities
;;;;
(define *lab-equiv* '())   ;FIXME: virer? 

(define (info-opcode name)
  (let ((v (assq name INSTRUCTION-SET)))
    (if v
	(cdr v)
	(panic "non existent opcode ~S" name))))


(define use-address?
  (let ((instr-with-address (map (lambda (x) (car (info-opcode x)))
				 '(GOTO JUMP-FALSE JUMP-TRUE 
				   JUMP-NUMDIFF JUMP-NUMGE
				   JUMP-NUMGT JUMP-NUMGE
				   JUMP-NUMLT JUMP-NUMLE
				   JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL
				   CREATE-CLOSURE PUSH-HANDLER))))
    (lambda (instr)
      (memq instr instr-with-address))))

(define (pretty-mnemonic mnemonic)
  (let* ((m      (string-upcase (symbol->string mnemonic)))
	 (filler (make-string (- 20 (string-length m)) #\space)))
    (string-append m filler)))


;;;;======================================================================
;;;;
;;;; ASSEMBLE
;;;;
;;;;======================================================================

(define old+ +)    ;;// A virer des que le code est bien protg contre les redef


(define (assemble code)
  (let ((pc    0)
	(labs '())
	(code  (peephole code)))

    ;;
    ;; Pass 1
    ;;
    (for-each 
      (lambda (x)
	(if (integer? x)
	    ;; We have a label
	    (set! labs (cons (cons x pc) labs))
	    ;; We have an instruction
	    (let* ((token (car x))
		   (info  (info-opcode token)))
	      ;//(format (current-error-port) "~S: ~S" pc x)
	      ;; Replace the op-code in (car x) by its code
	      (set-car! x (car info))
	      ;//(format (current-error-port) "==> ~S\n" x)
	      ;; Compute new PC
	      (set! pc (+ pc (length x))))))
      code)
    		   
    ;//(DEBUG "A l'issue de la passe 1 pc=~S labs=~S\n" pc labs)

    ;;
    ;; Pass2
    ;; 
    (let ((vect (make-vector pc))
	  (pos  0))
      (for-each
         (lambda (x)
	   (when (pair? x)	     ;; This is an instruction
	     (let ((len (length x)))
	       ;; Place the op-code in the code vector
	       (vector-set! vect pos (car x))

	       ;; Place (eventually) the first parameter in the code vector
	       (when (> len 1)
		 (let ((instr  (car x))
		       (param1 (cadr x)))
		   ;; If this instruction has a parameter which is an label,
		   ;; replace it with the offset to the destination
		   (when (use-address? instr)
;;//		     (format #t "~S ~S ~S\n" 
;;//			    (cdr (assq param1 labs))
;;//			    pos
;;//			    (- (cdr (assq param1 labs)) pos 2))

		     (set! param1 (- (cdr (assq param1 labs)) pos 2))
;//		     (set! param1 `((etiq ,param1) 
;//				    (real ,(cdr (assq param1 labs)))
;//				    (pos = ,pos)
;//				    (offset ,(- (cdr (assq param1 labs)) pos 2))))
		     )
		   (vector-set! vect (+ pos 1) param1)))

	       ;; Place (eventually) the second parameter in the code vector
	       (when (> len 2)
		 (vector-set! vect (+ pos 2) (caddr x)))
	       
	       (when (> len 3) 
		 (panic "Instruction with more than 2 parameters ~S" x))
	       (set! pos (+ pos len))))
;//	   (DEBUG "A LA FIN pos=~S vector=~S" pos vect)
	   )
	 code)
      vect)))








      
(define (display-code c)
  (for-each (lambda (x)
	      (if (integer? x)
		  (format #t "L~A:" x)
		  (format #t "\t~A\n" x)))
	    c)
  (newline))

;;;; ======================================================================
;;;;
;;;; DISASSEMBLE
;;;;
;;;; ======================================================================
(define (find-opcode opcode)
  (let Loop ((l INSTRUCTION-SET))
    (cond 
       ((null? l) 	     (panic "Cannot decode ~S opcode" opcode))
       ((= (cadar l) opcode) (car l))
       (else		     (loop (cdr l))))))


(define (disassemble-code v out)
  (define (show x)
    (format #f "~A~A~A" 
	    (quotient x 100)
	    (quotient (remainder x 100) 10)
	    (remainder x 10)))

  (define (show-dest mnemonic pos)
    (when (use-address? mnemonic)
      (format out "\t;; ==> ~A" (show (+ pos (vector-ref v pos) 1)))))

  (let ((len (vector-length v)))
    (let Loop ((pos 0))
      (if (< pos len)
	  ;; Disassemble an instruction
	  (let* ((instr    (find-opcode (vector-ref v pos)))
		 (mnemonic (car instr))
		 (params   (caddr instr)))
	    (format out "\n~A:  ~A" (show pos) (pretty-mnemonic mnemonic))
	    (case params
	      ((0) (Loop (+ pos 1)))
	      ((1) (format out " ~A" 
			   (vector-ref v (+ pos 1)))
	           (show-dest  (vector-ref v pos) (+ pos 1))
	           (Loop  (+ pos 2)))
	      ((2) (format out " ~S ~S" 
			   (vector-ref v (+ pos 1))
			   (vector-ref v (+ pos 2)))
	           (show-dest (vector-ref v pos) (+ pos 1))
	           (Loop  (+ pos 3)))
	      (else (panic "cannot disassemble instruction (~S)" mnemonic))))
	  ;; Last instruction
	  (format out "\n~A:\n" (show pos))))))

(define (disassemble proc)
  (let ((code (%procedure-code proc)))
    (if code
	(disassemble-code code (current-output-port))
	(error 'disassemble "cannot disassemble ~S" proc))))