;;; -*- Mode:Common-Lisp; Package:L; Base:10 -*-
;;
;; chunkify il code
;;
;;

(defvar *il-code-vector*)

(defvar *op-is-imm* 1)
(defvar *op-is-reg* 0)

(defvar *label-table*)
(defvar *label-count*)

(defvar *lab-number* 0)
(defvar *lab-present* 1)
(defvar *lab-not-present* 0)
(defvar *il-opcode-bs* (byte 13 19))
(defvar *il-op1-bs* (byte 5 10))
(defvar *il-op1-type-bs* (byte 1 18))
(defvar *il-op2-bs* (byte 5 5))
(defvar *il-op2-type-bs* (byte 1 17))
(defvar *il-dest-bs* (byte 5 0))
(defvar *il-dest-type-bs* (byte 1 16))
(defvar *il-target-type-bs* *il-op1-type-bs*)
(defvar *il-lab1-type-bs* *il-op2-type-bs*)
(defvar *il-lab2-type-bs* *il-dest-type-bs*)
(defvar *il-ccreg-bs* *il-op1-bs*)

(defvar *il-ops*
	'(
	  (NOP           0)
	  (RETURN        1)
	  (FUNDEF        2)
	  (TMPDEF        3)
	  (VARDEF        4)
	  (RESERVE       5)
	  (LABEL         6)
	  (GOTO          7)
	  (ELT           8)
	  (SET-ELT       9)
	  (UNKNOWN      10)
	  (MOVE         11)
	  (BLT          12)
	  (LOAD         13)
	  (STORE        14)
	  (LDB          15)
	  (STB          16)
	  (ADD          17)
	  (SUB          18)
	  (MULT         19)
	  (DIV          20)
	  (MOD          21)
	  (AND          22)
	  (OR           23)
	  (XOR          24)
	  (NOT          25)
	  (NEG          26)
	  (LSH          27)
	  (ASH          28)
	  (ROT          29)
	  (ALLOC        30)
	  (SELF         31)
	  (SXHASH       32)
	  (CMP          33)
	  (TEST         34)
	  (CALL         35)
	  (SCALL        36)
	  (TR-CALL      37)
	  (RESULTS      38)
	  (LOCK         39)
	  (UNLOCK       40)
	  (S-LOAD       41)
	  (S-STORE      42)
	  (IF           43)
	  (STATIC       44)
	  (ARGDEF       45)
	  (IF-C0	#x80)
	  (IF-V0	#x81)
	  (IF-Z0	#x82)
	  (IF-CZ0	#x83)
	  (IF-N0	#x84)
	  (IF-R0	#x85)
	  (IF-X0	#x86)
	  (IF-XZ0	#x87)
	  (IF-C1	#x88)
	  (IF-V1	#x89)
	  (IF-Z1	#x8A)
	  (IF-CZ1	#x8B)
	  (IF-N1	#x8C)
	  (IF-R1	#x8D)
	  (IF-X1	#x8E)
	  (IF-XZ1	#x8F)
	  (IF-HS	#x80)
	  (IF-NE	#x82)
	  (IF-HI	#x83)
	  (IF-PL	#x84)
	  (IF-GE	#x86)
	  (IF-GT	#x87)
	  (IF-LO	#x88)
	  (IF-EQ	#x8A)
	  (IF-LS	#x8B)
	  (IF-MI	#x8C)
	  (IF-LT	#x8E)
	  (IF-LE	#x8F)))

(defvar *ignore-these-il-insts* '(STATIC ARGDEF TEMPDEF VARDEF COMMENT))

(defun il-op-type-is-reg? (il-op-type)
  (= *op-is-reg* il-op-type))

(defun il-op-type-is-imm? (il-op-type)
  (= *op-is-imm* il-op-type))

(defun new-code-vector ()
  (make-chunk-from 0))

(defstruct (code-vector)
  (first-code-chunk)
  (current-code-chunk)
  (pc))

(defun init-il-code-vector ()
  (setq *il-code-vector* (make-code-vector :first-code-chunk (new-code-vector) :pc 0))
  (setf (code-vector-current-code-chunk  *il-code-vector*)
	(code-vector-first-code-chunk  *il-code-vector*)))

(defun update-code-vector ()
  (let ((code (chunk-elt (current-code-chunk) (current-pc))))
    (format t "~&New code: ~8,48x  ~5d ~b~b~b ~2d ~2d ~2d"
	    code
	    (ldb *il-opcode-bs* code)
	    (ldb *il-op1-type-bs* code)
	    (ldb *il-op2-type-bs* code)
	    (ldb *il-dest-type-bs* code)
	    (ldb *il-op1-bs* code)
	    (ldb *il-op2-bs* code)
	    (ldb *il-dest-bs* code)))
  (if (> 6 (current-pc))
      (incf (code-vector-pc *il-code-vector*))
      (let ((new-cv (new-code-vector)))
	(setf (chunk-reference (current-code-chunk) 7) new-cv)
	(setf (code-vector-pc *il-code-vector*) 0)
	(setf (code-vector-current-code-chunk *il-code-vector*) new-cv))))

(defun current-code-chunk ()
  (code-vector-current-code-chunk *il-code-vector*))

(defun current-pc ()
  (code-vector-pc *il-code-vector*))

(defun deposit-instruction (inst)
  (setf (chunk-scalar (current-code-chunk) (current-pc)) inst)
  (update-code-vector))

(defun deposit-imm-ref (imm-ref)
  (setf (chunk-reference (current-code-chunk) (current-pc)) imm-ref)
  (update-code-vector))

(defun deposit-imm-scalar (imm-scalar)
  (setf (chunk-scalar (current-code-chunk) (current-pc)) imm-scalar)
  (update-code-vector))

(defun init-label-table ()
  (setq *label-table* (make-hash-table :size 100))
  (setq *label-count* 0))

(defun next-label-value ()
 (incf *label-count*))

(defun store-label (label)
  (setf (gethash label *label-table*) (next-label-value)))

(defun get-label (label)
  (gethash label *label-table*))

(defun chunkify-il (il-nodes)
  ;; chunkify intermediate language according to opcode/operand
  ;; encoding specified above, and return a pointer to the first
  ;; IL code chunk
  (init-il-code-vector)
  (init-label-table)
  ;; pass 1 : look for labels
  (mapcar #'store-labels il-nodes)
  ;; pass 2 : encode instructions
  (mapcar #'encode-il-node-for-transfer il-nodes)
  (code-vector-first-code-chunk *il-code-vector*))

(defun store-labels (node)
  (let ((name (il-instruction-name (il-node-op node))))
    (when  (and (get-il-opcode name) (eq name 'LABEL))
      (store-label (declaration-symbol (first (il-node-defined node)))))))

(defun init-il-opcodes ()
  (mapcar #'set-il-opcode *il-ops*)
  (mapcar #'set-ignore-il-opcode *ignore-these-il-insts*))

(defun set-il-opcode (il-op)
  (setf (get (first il-op) :il-opcode) (second il-op)))

(defvar *il-branches* '((LT GE) (GT LE)))

(defun init-il-branches ()
  (mapcar #'set-il-branch-opp *il-branches*))

(defun set-il-branch-opp (il-branch)
  (setf (get (first il-branch) :opposite) (list (second il-branch)))
  (setf (get (second il-branch) :opposite) (list (first il-branch))))

(defun set-ignore-il-opcode (il-inst)
  (setf (get il-inst :il-opcode) nil))

(defun get-il-opcode (il-inst)
  (get il-inst :il-opcode))

(defun encode-il-node-for-transfer (node)
  (let ((name (il-instruction-name (il-node-op node))))
    (when (get name :il-opcode)
      (format t "~&Encoding IL instruction ~a" name)
    (case name
      ('LABEL     (encode-label  name node))
      ('GOTO      (encode-goto   name node))
      ('IF        (encode-if     name node))
      ('CALL      (encode-call   name node))
      ('SCALL     (encode-call   name node))
      ('ARGDEF    (encode-argdef name node))
      ('RESULTS   (encode-results name node))
      ('RETURN    (encode-return name node))
      ('ELT       (encode-elt    name node))
      ('ENTER     (encode-enter name node))      
      ('SET-ELT   (encode-setelt name node))
      (t          (encode-generic-il-instruction name node))))))

(defun produce-il-format-operands (&rest operands)
  (apply #'append
	 (mapcar #'produce-il-format-operand operands)))

(defun produce-il-format-operand (op)
  ;; Hack for registers like %R0
  (if (symbolp op)
      (list (register-value op)
	    *op-is-reg*
	    0)
      (list
	;; value
	(if (eq 'CONST (declaration-kind op))
	    (let  ((imm-op (declaration-value op)))
	      (if (numberp imm-op) 
		  imm-op
		  (cond ((typep imm-op 'FN) (fn-translated-fn imm-op)))))
	    (declaration-allocation op))
	;; imm or register
	(if (eq 'CONST (declaration-kind op))
	    *op-is-imm*
	    *op-is-reg*)
	;; ref bit
	(if (eq 'CONST (declaration-kind op))
	    (let  ((imm-op (declaration-value op)))
	      (if (numberp imm-op) 
		  0
		  (cond ((typep imm-op 'FN) 1))))
	    0))))

(defun build-il-instruction (opcode &key (op1 0) (op1T 0) (op2 0) (op2T 0) (dest 0) (destT 0))
  (let ((il-inst 0))
    (setq il-inst (dpb opcode         *il-opcode-bs* il-inst))
    (setq il-inst (dpb op1T           *il-op1-type-bs* il-inst))
    (setq il-inst (dpb op2T           *il-op2-type-bs* il-inst))
    (setq il-inst (dpb destT          *il-dest-type-bs* il-inst))
    (setq il-inst (dpb op1            *il-op1-bs* il-inst))
    (setq il-inst (dpb op2            *il-op2-bs* il-inst))
    (setq il-inst (dpb dest           *il-dest-bs* il-inst)) 
    il-inst))


;;; encode-call
;;;
;;; This has been hacked to expand CALL instructions to include a series of MOVE instructions to position
;;; the arguments appropriately.  The sources of the move instructions are the arguments to the CALL, the
;;; targets are registers starting from %R24.  7/11/88, pz.

(defun encode-call (name node)
  (let* ((opcode  (get name :il-opcode))
	 (read    (il-node-read node))
	 (written (il-node-written node))
	 (link-reg (declaration-allocation (second read)))
	 (dest-reg (declaration-allocation (first written))))

    ;; Expand the argument moves as necessary.
    (loop for arg in (cdr read)			; ignore the first one, it's the function header
	   as num upfrom 26			; args start at %R26.
	   as reg in '(%R26 %R27 %R28 %R29 %R30 %R31)
	   do (when (neq num (declaration-allocation arg))
		(apply #'make-il-inst (cons (get 'move :il-opcode)
					    (apply #'produce-il-format-operands `(,arg ,reg))))))

    ;; Create the CALL
    (deposit-instruction (build-il-instruction opcode
				:op1 link-reg :op1T *op-is-reg*
				:op2 dest-reg :op2T *op-is-reg*))

  ))


;;; encode-argdef
;;;
;;; This attempts to expand the argdef instruction as necessary.  Because of allocation constraints, it is entirely
;;; possible that arguments do not appear in the proper locations, and must be moved out of the argument chunk.
;;; In the unlikely event that this is the case, this will emit the appropriate move instructions.  7/12/88, pz.

(defun encode-argdef (name node)
  (ignore name)
  (let* ((written (il-node-written node)))

    ;; Expand the argument moves as necessary.
    (loop for arg in written
	   as num upfrom 0			; args start at %R0.
	   as reg in '(%R0 %R1 %R2 %R3 %R4 %R5 %R6 %R7)
	   do (when (neq num (declaration-allocation arg))
		(apply #'make-il-inst (cons (get 'move :il-opcode)
					    (apply #'produce-il-format-operands `(,reg ,arg))))))

  ))


;;; encode-results
;;;
;;; This is a similar function to expand a RESULTS instruction into the appropriate list of MOVEs.  7/12/88, pz.

(defun encode-results (name node)
  (ignore name)
  (let* ((written (il-node-written node)))

    ;; Expand the result moves as necessary.
    (loop for res in written
	   as num upfrom 26
	   as reg in '(%R26 %R27 %R28 %R29 %R30 %R31)
	   do (format t "~&move?: ~a ~a" res reg)
	   do (when (neq num (declaration-allocation res))
		(apply #'make-il-inst (cons (get 'move :il-opcode)
					    (apply #'produce-il-format-operands `(,reg ,res))))))
    ))


;;; encode-return
;;;
;;; This is a similar function to expand a RETURN instruction into the appropriate list of MOVEs.  7/12/88, pz.

(defun encode-return (name node)
  (ignore name)
  (let* ((read (il-node-read node)))

    ;; Expand the result moves as necessary.
    (loop for res in read
	   as num upfrom 0
	   as reg in '(%R0 %R1 %R2 %R3 %R4 %R5 %R6 %R7)
	   do (when (neq num (declaration-allocation res))
		(apply #'make-il-inst (cons (get 'move :il-opcode)
					    (apply #'produce-il-format-operands `(,res ,reg))))))

  ))



(defun lookup-field-mn-in-structure-template (field st)
  ;; maybe I can write this as a binary search
  (dolist (decl (structure-template-declaration-list st))
    (when (eq field (declaration-symbol decl))
      (return (first (declaration-allocation decl))))))

(defun encode-elt (name node)
  (let* ((opcode  (get name :il-opcode))
	 (struct (declaration-allocation (first (il-node-read node))))
	 (dest   (declaration-allocation (first (il-node-written node))))
	 (quoted (il-node-quoted node))
	 ;; make the field being looked up in the structure
	 ;; an L string in order to pack it into chunkified IL
	 (field  (first quoted))
	 (lisp-template (second quoted)))
    ;; FOR NOW I HAVE HACKED THINGS SO THAT WE CHEAT HERE AND LOOK UP
    ;; THE FIELD IN THE STRUCTURE TEMPLATE DURING THE IL ENCODING PHASE
    ;; I SUPPOSE THIS SHOULD REALLY BE DONE ELSEWHERE, BUT WE CAN DO IT
    ;; HERE FOR NOW , AND PASS A NUMERIC METANAME OVER TO THE IL TRANSLATOR.
    (deposit-instruction
      (build-il-instruction opcode :op1 struct :op1T *op-is-reg* :op2T *op-is-imm* :dest dest))
    (deposit-imm-scalar (lookup-field-mn-in-structure-template field lisp-template))))

(defun get-setelt-value (decl)
  (if (eq (declaration-kind decl) 'CONSTANT)
      (declaration-value decl)
      (declaration-allocation decl)))

(defun get-setelt-value-type (decl)
  (if (eq (declaration-kind decl) 'CONSTANT)
      *op-is-imm*
      *op-is-reg*))

(defun encode-setelt (name node)
  (let* ((opcode  (get name :il-opcode))
	 (read (il-node-read node))
	 (struct  (declaration-allocation (first read)))
	 (value-type (get-setelt-value-type  (second read)))
	 (value   (get-setelt-value  (second read)))
	 (value-is-ref?  (if (il-op-type-is-imm? value-type) (if (numberp value) nil t)))
	 (quoted (il-node-quoted node))
	 ;; make the field being looked up in the structure
	 ;; an L string in order to pack it into chunkified IL
	 (field  (first quoted))
	 (lisp-template (second quoted)))
    ;; FOR NOW I HAVE HACKED THINGS SO THAT WE CHEAT HERE AND LOOK UP
    ;; THE FIELD IN THE STRUCTURE TEMPLATE DURING THE IL ENCODING PHASE
    ;; I SUPPOSE THIS SHOULD REALLY BE DONE ELSEWHERE, BUT WE CAN DO IT
    ;; HERE FOR NOW , AND PASS A NUMERIC METANAME OVER TO THE IL TRANSLATOR.
    (format t "~&ELT info ~a ~a ~a ~a ~a ~a" opcode struct value quoted field lisp-template)
    (deposit-instruction
      (build-il-instruction opcode :op1 struct :op1T *op-is-reg* :op2T *op-is-imm*
			    :destT value-type :dest value))
    (deposit-imm-scalar (lookup-field-mn-in-structure-template field lisp-template))
    (if  (il-op-type-is-imm? value-type)
	 (if value-is-ref?
	     (deposit-imm-ref (translate-compiler-object value))
	     (deposit-imm-scalar value)))))


(defun encode-label (name node)
  (ignore node)
  (deposit-instruction (build-il-instruction (get name :il-opcode) :op1T *op-is-imm*))
  (deposit-imm-scalar (get-label (declaration-symbol (first (il-node-defined node))))))

(defun encode-goto (name node)
  (let* ((opcode (get name :il-opcode))
	(label-name (declaration-symbol (first (il-node-targets node))))
	(label-value (get-label label-name)))
    (deposit-instruction (build-il-instruction opcode :op1T *op-is-imm*))
    (deposit-imm-scalar label-value)))

(defun encode-if (name node)
  (ignore name)
  (let* ((cc-reg   (declaration-allocation (first (il-node-read   node))))
	 (cdx    (car (il-node-cdx node)))
	 (if-type (intern (string-append "IF-" (string cdx))))
	 (opcode (get if-type :il-opcode))
	 (labs (il-node-targets node))
	 (lab1 (get-label (declaration-symbol (first labs))))
	 (lab1-type (if lab1 *lab-present* *lab-not-present*))
	 (lab2 (when (second labs) (get-label (declaration-symbol (second labs)))))
	 (lab2-type (if lab2 *lab-present* *lab-not-present*)))
    (deposit-instruction (build-il-instruction opcode :op1 cc-reg :op2T  lab1-type :dest  lab2-type))
    (when lab1 (deposit-imm-scalar lab1))
    (when lab2 (deposit-imm-scalar lab2))))

(defun encode-generic-il-instruction (name node)
  (let* ((opcode (get name :il-opcode))
	 (read   (il-node-read node))
	 (written (il-node-written node))
	 (ops    (apply #'produce-il-format-operands (append read written))))
    (apply #'make-il-inst (cons opcode ops))))

(defun make-il-inst  (opcode op1 op1-type op1-is-ref 
		      &optional (op2 0) (op2-type 0) (op2-is-ref 0) (dest 0) (dest-type 0) (dest-is-ref 0))
  (ignore dest-type dest-is-ref)
  (let ((il-inst 0))
    (setq il-inst (build-il-instruction opcode :op1T op1-type :op2T op2-type :dest dest))
    (when (il-op-type-is-reg? op1-type) (setq il-inst (dpb op1      *il-op1-bs* il-inst)))
    (when (il-op-type-is-reg? op2-type) (setq il-inst (dpb op2      *il-op2-bs* il-inst)))
    (deposit-instruction il-inst)
    (when (il-op-type-is-imm? op1-type)
      (if (= op1-is-ref 1)
	  (deposit-imm-ref op1)
	  (deposit-imm-scalar op1)))
    (when (il-op-type-is-imm? op2-type)
      (if (= op2-is-ref 1)
	  (deposit-imm-ref op2)
	  (deposit-imm-scalar op2)))    
    il-inst))