;;;
;;; icfp2006.lisp
;;;
;;; implementation of the icfp2006 VM
;;;

(cl:defpackage :icfp2006 (:use :cl))

(in-package :icfp2006)

(declaim (type (simple-array (unsigned-byte 32) (8)) *registers*))
(defparameter *registers* (make-array 8 :element-type '(unsigned-byte 32)))

(defvar *arrays*)

(declaim (type (simple-array (unsigned-byte 32) (*)) *array-0*))
(defvar *array-0*)

(defparameter *machine-halted* nil)

(defparameter *instruction-pointer* 0)

(defparameter *next-array* 1)

(declaim (inline find-array))
(defun find-array (index)
  (if (zerop index)
      *array-0*
      (gethash index *arrays*)))

(defun alloc-array (size)
  (loop
     while (find-array *next-array*)
     do (setf *next-array* (logand #xffffffff (1+ *next-array*))))
  (setf (gethash *next-array* *arrays*)
	(make-array size :element-type '(unsigned-byte 32)))
  *next-array*)

(defun free-array (index)
  (remhash index *arrays*))

(defun load-file (filename)
  (with-open-file (in filename :direction :input
		      :element-type '(unsigned-byte 8))
    (let ((data (make-array (truncate (file-length in) 4)
			    :element-type '(unsigned-byte 32))))
      (dotimes (i (length data))
	(let ((b0 (read-byte in))
	      (b1 (read-byte in))
	      (b2 (read-byte in))
	      (b3 (read-byte in)))
	  (setf (aref data i)
		(dpb b0 (byte 8 24)
		     (dpb b1 (byte 8 16)
			  (dpb b2 (byte 8 8)
			       b3))))))
      (setf *array-0* data)))
  (values))

(defun reset-machine ()
  (setf *arrays* (make-hash-table))
  (setf *registers* (make-array 8
				:element-type '(unsigned-byte 32)
				:initial-element 0))
  (setf *instruction-pointer* 0))

(defun machine-step ()
  ;; FIXME: May want to special-case array 0.
  (let ((instruction (aref *array-0* *instruction-pointer*)))
    (incf *instruction-pointer*)
    
    (let ((opcode (ldb (byte 4 28) instruction))
	  (%reg-a (ldb (byte 3 6) instruction))
	  (%reg-b (ldb (byte 3 3) instruction))
	  (%reg-c (ldb (byte 3 0) instruction)))
      
      (symbol-macrolet
	  ((reg-a (aref *registers* %reg-a))
	   (reg-b (aref *registers* %reg-b))
	   (reg-c (aref *registers* %reg-c)))

	(case opcode
	  (0 ;; conditional move
	   #+(or)(format t "~4,'0X: cmov ~A ~A (#x~X) ~A (#x~X)~%" (1- *instruction-pointer*) %reg-a %reg-b reg-b %reg-c reg-c)
	   (unless (zerop reg-c)
	     (setf reg-a reg-b)))

	  (1 ;; array index
	   (let ((array (find-array reg-b)))
	     (if array
		 (setf reg-a (aref array reg-c))
		 (progn
		   (format t "aset of inactive array #x~X~%" reg-b)
		   (setf *machine-halted* t)))))

	  (2 ;; array ammendment
	   #+(or)(format t "~4,'0X: aset ~A (#x~X) ~A (#x~X) ~A (#x~X)~%" (1- *instruction-pointer*) %reg-a reg-a %reg-b reg-b %reg-c reg-c)
	   (let ((array (find-array reg-a)))
	     (if array
		 (setf (aref array reg-b) reg-c)
		 (progn
		   (format t "aset of inactive array #x~X~%" reg-a)
		   (setf *machine-halted* t)))))

	  (3 ;; addition
	   #+(or)(format t "~4,'0X: add ~A ~A (#x~X) ~A #x~X)~%" (1- *instruction-pointer*) %reg-a %reg-b reg-b %reg-c reg-c)
	   (setf reg-a (logand #xffffffff (+ reg-b reg-c))))

	  (4 ;; multiplication
	   (setf reg-a (logand #xffffffff (* reg-b reg-c))))

	  (5 ;; division
	   (if (zerop reg-c)
	       (progn
		 (format t "division by zero~%")
		 (setf *machine-halted* t))
	       (setf reg-a (logand #xffffffff (truncate reg-b reg-c)))))

	  (6 ;; not-and
	   #+(or)(format t "~4,'0X: nand ~A ~A (#x~X) ~A (#x~X)~%" (1- *instruction-pointer*) %reg-a %reg-b reg-b %reg-c reg-c)
	   (setf reg-a (logand #xffffffff (lognand reg-b reg-c))))

	  (7 ;; halt
	   #+(or)(format t "~4,'0X: halt~%" (1- *instruction-pointer*))
	   (setf *machine-halted* t))

	  (8 ;; allocation
	   #+(or)(format t "~4,'0X: aloc ~A ~A (#x~X)~%" (1- *instruction-pointer*) %reg-b %reg-c reg-c)
	   (setf reg-b (alloc-array reg-c)))

	  (9 ;; abandonment
	   #+(or)(format t "~4,'0X: aban ~A (#x~X)~%" (1- *instruction-pointer*) %reg-c reg-c)
	   (free-array reg-c))

	  (10 ;; output
	   #+(or)(format t "~4,'0X: outp ~A~%" (1- *instruction-pointer*) %reg-c)
	   #+(or)(format t "output: #x~X (~S)~%" reg-c (code-char reg-c))
	   (write-char (code-char reg-c)))

	  (12 ;; load program
	   #+(or)(format t "~4,'0X: load ~A (#x~X) ~A (#x~X)~%" (1- *instruction-pointer*) %reg-b reg-b %reg-c reg-c)
	   #+(or)
	   (unless (zerop reg-b)
	     (format t "loading array not handled")
	     (setf *machine-halted* t))
	   (unless (zerop reg-b)
	     (setf *array-0* (copy-seq (find-array reg-b))))
	   (setf *instruction-pointer* reg-c))

	  (13 ;; orthography
	   #+(or)(format t "~4,'0X: li ~A #x~X~%" (1- *instruction-pointer*) (ldb (byte 3 25) instruction)
		   (ldb (byte 25 0) instruction))
	   (setf (aref *registers* (ldb (byte 3 25) instruction))
		 (ldb (byte 25 0) instruction)))

	  (otherwise
	   (format t "~4,'0X: unknown opcode ~A~%" (1- *instruction-pointer*) opcode)
	   (decf *instruction-pointer*)
	   (setf *machine-halted* t))))))

  (values))

(defun machine-run ()
  (let ((*machine-halted* nil))
    (loop
       while (not *machine-halted*)
       do (machine-step))))

(defun reload-machine (filename)
  (reset-machine)
  (load-file filename))

#|

(reload-machine "sandmark.umz")
(time (machine-run))

|#

;;; EOF