;;; -*- Mode:LISP; Package:SIM; Readtable:CL; Base:10 -*-

(defun new-proc (frame-size n-frames main-memory-size)
  (let ((proc (make-proc)))
    (setf (proc-frame-size proc) frame-size)
    (setf (proc-n-frames proc) n-frames)

    (setf (proc-frame-free-list proc) (make-array (proc-n-frames proc)))

    (setf (proc-h-active proc) (make-array (proc-n-frames proc)))
    (setf (proc-h-open proc) (make-array (proc-n-frames proc)))
    (setf (proc-h-pc proc) (make-array (proc-n-frames proc)))

    (setf (proc-frames proc) (make-array (* (proc-n-frames proc)
					    (proc-frame-size proc))))
    (setf (proc-main-memory proc) (make-array main-memory-size))

    (setf (proc-l1-map proc) (make-array 4096.))
    (setf (proc-l2-map-control proc) (make-array 4096.))
    (setf (proc-l2-map-physical-page proc) (make-array 4096.))

    (reset-proc proc)
    proc))

(defun reset-proc-all (&optional (proc *proc*))

  (array-initialize (proc-frames proc) 0)

  (array-initialize (proc-main-memory proc) 0)

  (array-initialize (proc-l1-map proc) 0)
  (array-initialize (proc-l2-map-control proc) 0)
  (array-initialize (proc-l2-map-physical-page proc) 0)

  (reset-proc proc)
  )

(defun reset-proc (&optional (proc *proc*))
  (dotimes (i (proc-n-frames proc))
    (setf (aref (proc-frame-free-list proc) i) i))
  (setf (proc-frame-free-list-ptr proc) 0)
    
  (array-initialize (proc-h-active proc) 0)
  (array-initialize (proc-h-open proc) 0)
  (array-initialize (proc-h-pc proc) 0)

  (setf (proc-return-frame proc) (free-frame-pop))
  (let ((frame (free-frame-pop)))
    (setf (proc-active-frame proc) frame)
    (setf (proc-open-frame proc) frame))

  (setf (proc-pc proc) 256.)
  (setf (proc-next-pc proc) (1+ (proc-pc proc)))

  (setf (proc-zero-bit proc) 0)
  (setf (proc-carry-bit proc) 0)
  (setf (proc-sign-bit proc) 0)
  (setf (proc-overflow-bit proc) 0)

  (setf (proc-noop-next-bit proc) 0)

  (setq *need-to-find-register-offsets* t)
  )

(defun run (&optional (check-for-type-in t))
  (do ()
      ((or (and check-for-type-in (read-char-no-hang))
	   (eq (single-step) :halt)))))


(defvar *need-to-find-register-offsets* t)

(defvar *number-of-instructions* 0)

(defun single-step ()
  (incf *number-of-instructions*)
  (let ((inst (aref (proc-main-memory *proc*)
		    (proc-pc *proc*)))
	(noop-this (proc-noop-next-bit *proc*)))
    (when *need-to-find-register-offsets*
      (find-next-register-offsets))
    (setf (proc-pc *proc*) (proc-next-pc *proc*))
    (setq *need-to-find-register-offsets* t)
    (incf (proc-next-pc *proc*))
    (setf (proc-noop-next-bit *proc*) 0)
    (when (zerop noop-this)
      (execute-inst inst))))


(defun execute-inst (inst)
  (select (ldb %%i-opcode inst)
    (%i-op-alu
     (execute-alu-op inst))
    (%i-op-jump
     (execute-jump-op inst))
    (%i-op-sim
     (execute-sim-op inst))
    (%i-op-open
     (execute-open-op inst))
    (%i-op-tail-recursive-open
     (execute-tail-recursive-open-op inst))
    (%i-op-call
     (execute-call-op inst))
    (%i-op-tail-recursive-call
     (execute-tail-recursive-call-op inst))
    (%i-op-return 
     (execute-return-op inst))
    (t
     (ferror nil "unknown op"))))

(defvar *src-1-offset*)
(defvar *src-2-offset*)
(defvar *dest-offset*)

(defun find-next-register-offsets (&aux inst)
  (setq inst (aref (proc-main-memory *proc*) (proc-pc *proc*)))
  (labels ((get-base (base-code)
		     (select base-code
		       (%i-base-open (proc-open-frame *proc*))
		       (%i-base-active (proc-active-frame *proc*))
		       (%i-base-return (proc-return-frame *proc*))
		       (%i-base-global (ldb %%i-immediate inst))
		       (t (ferror nil "unknown base")))))
    (setq *src-1-offset* (+ (* (get-base (ldb %%i-src-1-base inst)) (proc-frame-size *proc*))
			    (ldb %%i-src-1-offset inst)))
    (setq *src-2-offset* (+ (* (get-base (ldb %%i-src-2-base inst)) (proc-frame-size *proc*))
			    (ldb %%i-src-2-offset inst)))
    (setq *dest-offset* (+ (* (get-base (ldb %%i-dest-base inst)) (proc-frame-size *proc*))
			    (ldb %%i-dest-offset inst))))
  (setq *need-to-find-register-offsets* nil))

(defun execute-alu-op (inst)
  (let ((s1 (aref (proc-frames *proc*) *src-1-offset*))
	(s2 (aref (proc-frames *proc*) *src-2-offset*))
	result)
    (select (ldb %%i-aluf inst)
      (%i-aluf-setz
       (setq result 0))
      (%i-aluf-add
       (setq result (+ s1 s2)))
      (%i-aluf-set1 (setq result s1))
      (%i-aluf-sub
       (setq s2 (logxor #xffffffff s2))
       (incf s2)
       (setq result (+ s1 s2)))
      (%i-aluf-src1-minus-1
       (setq result (+ s1 #xffffffff)))
      (t
       (ferror nil "unknown aluf")))
    (setf (proc-carry-bit *proc*) (ldb (byte 1 32.) result))
    (setq result (logand #xffffffff result))
    (setf (proc-zero-bit *proc*) (if (zerop result) 1 0))
    (setf (proc-sign-bit *proc*) (ldb (byte 1 31.) result))
    (setf (proc-overflow-bit *proc*) (logxor (ldb (byte 1 31.) result)
					     (ldb (byte 1 32.) result)))
    (setf (aref (proc-frames *proc*) *dest-offset*) result)
    ))

(defun execute-jump-op (inst)
  (let ((jump-adr (ldb-big %%i-jump-adr inst))
	(n (ldb %%i-jump-n inst))
	(cond (ldb %%i-jump-cond inst))
	(s1 (aref (proc-frames *proc*) *src-1-offset*))
	(s2 (aref (proc-frames *proc*) *src-2-offset*))
	jump-p
	)
    s1 s2
    (select cond
      (%i-jump-cond-unc
       (setq jump-p t))
      (%i-jump-cond-less-than
       (setq jump-p (not (zerop (logior (proc-sign-bit *proc*)
					(proc-overflow-bit *proc*))))))
      (t
       (ferror nil "unknown jump cond")))
    (when jump-p
      (setf (proc-next-pc *proc*) jump-adr)
      (setf (proc-noop-next-bit *proc*) n))))

(defvar *sim-ops* (make-array 10. :fill-pointer 0))

(defun get-sim-op-index (name)
  (dotimes (i (array-active-length *sim-ops*)
	      (progn (array-push-extend *sim-ops* name)
		     (1- (array-active-length *sim-ops*))))
    (when (eq (aref *sim-ops* i) name)
      (return i))))

(defun execute-sim-op (inst)
  (let ((index (ldb %%i-immediate inst)))
    (when (>= index (array-length *sim-ops*))
      (ferror nil "bad sim op - index too big"))
    (when (null (aref *sim-ops* index))
      (ferror nil "unimplemented sim op ~s" index))
    (funcall (aref *sim-ops* index) inst)))

(defun sim-halt (ignore)
  :halt)

(defun next-free-frame ()
  (aref (proc-frame-free-list *proc*) (proc-frame-free-list-ptr *proc*)))

(defun free-frame-pop ()
  (when (> (proc-frame-free-list-ptr *proc*) (proc-n-frames *proc*))
    (ferror nil "out of free frames"))
  (let ((frame (next-free-frame)))
    (incf (proc-frame-free-list-ptr *proc*))
    frame))

(defun free-frame-push (frame)
  (do ((i (proc-frame-free-list-ptr *proc*) (1+ i)))
      ((= i (proc-n-frames *proc*)))
    (when (= frame (aref (proc-frame-free-list *proc*) i))
      (ferror nil "freeing a free frame")))
  
  (let ((new-ptr (decf (proc-frame-free-list-ptr *proc*))))
    (when (< new-ptr 0)
      (ferror nil "free frame list overflow"))
    (setf (aref (proc-frame-free-list *proc*) new-ptr) frame)))
		
    
    
(defun execute-open-op (inst)
  inst
  (psetf (aref (proc-h-active *proc*) (proc-frame-free-list-ptr *proc*)) (proc-active-frame *proc*)
	 (aref (proc-h-open *proc*) (proc-frame-free-list-ptr *proc*)) (proc-open-frame *proc*))
  (psetf (proc-open-frame *proc*) (free-frame-pop)))

(defun execute-tail-recursive-open-op (inst)
  inst
  (let ((open (aref (proc-h-open *proc*) (proc-active-frame *proc*)))
	(active-temp (aref (proc-h-active *proc*) (proc-active-frame *proc*)))
	(pc-temp (aref (proc-h-pc *proc*) (proc-active-frame *proc*))))
    (let ((frame (free-frame-pop)))
      (psetf (aref (proc-h-open *proc*) frame) open
	     (aref (proc-h-active *proc*) frame) active-temp
	     (aref (proc-h-pc *proc*) frame) pc-temp
	     (proc-open-frame *proc*) frame))))

(defvar *number-of-calls* 0)

(defun execute-call-op (inst)
  inst
  (incf *number-of-calls*)
  (when (zerop (mod *number-of-calls* 100.))
    (format t "<~d,~d;~7f>" *number-of-calls* *number-of-instructions*
	    (/ (float *number-of-instructions*) *number-of-calls*)))
  (find-next-register-offsets)
  (setf (aref (proc-h-pc *proc*) (proc-open-frame *proc*)) (proc-pc *proc*))
  (setf (proc-active-frame *proc*) (proc-open-frame *proc*))
  (setf (proc-next-pc *proc*) (ldb-big %%i-jump-adr inst))
  (setf (proc-noop-next-bit *proc*) (ldb %%i-jump-n inst)))

(defun execute-tail-recursive-call-op (inst)
  inst
  (incf *number-of-calls*)
  (when (zerop (mod *number-of-calls* 100.))
    (format t "<~d,~d;~7f>" *number-of-calls* *number-of-instructions*
	    (/ (float *number-of-instructions*) *number-of-calls*)))
  (find-next-register-offsets)
  (let ((old (proc-active-frame *proc*)))
    (setf (proc-active-frame *proc*) (proc-open-frame *proc*))
    (free-frame-push old))
  (setf (proc-next-pc *proc*) (ldb-big %%i-jump-adr inst))
  (setf (proc-noop-next-bit *proc*) (ldb %%i-jump-n inst)))

(defun execute-return-op (inst)
  inst
  (find-next-register-offsets)
  (let ((active (proc-active-frame *proc*)))
    (setf (proc-return-frame *proc*) active)
    (free-frame-push active)
    (psetf (proc-active-frame *proc*) (aref (proc-h-active *proc*) active)
	   (proc-open-frame *proc*) (aref (proc-h-open *proc*) active)
	   (proc-next-pc *proc*) (aref (proc-h-pc *proc*) active))
    (setf (proc-noop-next-bit *proc*) (ldb %%i-jump-n inst))))

(defun execute-recall (inst)
  inst
  (let ((frame (free-frame-pop)))
    (psetf (proc-active-frame *proc*) frame
	   (proc-open-frame *proc*) frame
	   (proc-h-pc *proc*) (proc-next-pc *proc*))
    (setf (proc-pc *proc*) 0)
    (setf (proc-noop-next-bit *proc*) 1)))