;;; ICFPC2006 UM Implementation <http://icfpcontest.org/um-spec.txt>
;;; Michael Weber <michaelw@foldr.org>, 2006-07-30, 2006-08-14
;;; Tested with: SBCL 0.9.15, CMUCL 19a, LispWorks 4.4

(defpackage #:mw-um
  (:use #:cl))

(in-package #:mw-um)

(deftype platter () '(unsigned-byte 32))
(deftype array-index () '(integer 0 #.(min #xFFFFFFFF array-total-size-limit)))

(defconstant +free-list-size+ 50000)
(defconstant +initial-active-arrays+ 2000000) ; 50000 is enough for SANDmark

(defmacro ecase/tree (keyform &body cases)
  (labels ((%case/tree (keyform cases)
             (if (<= (length cases) 4)
                 `(ecase ,keyform ,@cases)
                 (loop for rest-cases on cases
                       repeat (truncate (length cases) 2)
                       collect (first rest-cases) into first-half
                       finally (return `(if (< ,keyform ,(caar rest-cases))
                                            ,(%case/tree keyform first-half)
                                            ,(%case/tree keyform rest-cases)))))))
    (let (($keyform (gensym "CASE/TREE-")))
      `(let ((,$keyform ,keyform))
         ,(%case/tree $keyform (sort (copy-list cases) #'< :key #'first))))))

(defun execute (program)
  (let ((registers (make-array 8 :element-type 'platter :initial-element 0))
        (arrays (make-array +initial-active-arrays+))
        (free-list (make-array +free-list-size+ :element-type 'array-index))
        (free-list-last 0) (max-array-id 0)
        (pc 0) (insn 0) (opcode 0) (a 0) (b 0) (c 0))
    (declare (optimize (speed 3) #+(or sbcl cmu) (safety 0) #+(or sbcl cmu) (debug 0))
             (type (simple-array platter (*)) program)
             (type (simple-array t (*)) arrays)
             (type array-index pc max-array-id free-list-last))
    (macrolet ((reg (index) `(aref registers ,index))
               (offset (index) `(the array-index ,index)))
      (labels ((platter-array (index)
                 (let ((index (offset index)))
                   (the (simple-array platter (*))
                     (if (zerop index) program (aref arrays index)))))
               ((setf platter-array) (array index) ; (assert (plusp index))
                 (setf (aref arrays (offset index)) array))
               (platter-array-allocate (size)
                 (let ((idx (if (plusp free-list-last)
                                (aref free-list (shiftf free-list-last (1- free-list-last)))
                                (prog1 (incf max-array-id)
                                  (when (>= max-array-id (length arrays))
                                    (format *debug-io* "~&;[UM: Adjusting active arrays to ~D]~%"
                                            (* 2 (length arrays)))
                                    (setf arrays (adjust-array arrays (* 2 (length arrays)))))))))
                   (setf (platter-array idx) (make-array size :element-type 'platter :initial-element 0))
                   idx))
               (platter-array-free (index)
                 (setf (platter-array index) nil)
                 (when (< free-list-last +free-list-size+)
                   (setf (aref free-list (incf free-list-last)) (offset index))))) 
        (declare (inline platter-array (setf platter-array)
                         platter-array-allocate platter-array-free))
        (loop
          (setf insn (aref program (offset pc))
                opcode (ldb (byte 4 28) insn))
          (incf pc)
          (cond ((= opcode #xD) (setf (reg (ldb (byte 3 25) insn))
                                      (ldb (byte 25 0) insn)))
                (t (setf a (ldb (byte 3 6) insn)
                         b (ldb (byte 3 3) insn)
                         c (ldb (byte 3 0) insn))
                   (ecase/tree opcode
                     (#x0 (unless (zerop (reg c)) (setf (reg a) (reg b))))
                     (#x1 (setf (reg a) (aref (platter-array (reg b)) (offset (reg c)))))
                     (#x2 (setf (aref (platter-array (reg a)) (offset (reg b))) (reg c)))
                     (#x3 (setf (reg a) (logand #xFFFFFFFF (+ (reg b) (reg c)))))
                     (#x4 (setf (reg a) (logand #xFFFFFFFF (* (reg b) (reg c)))))
                     (#x5 (setf (reg a) (logand #xFFFFFFFF (truncate (reg b) (reg c)))))
                     (#x6 (setf (reg a) (logand #xFFFFFFFF (lognand (reg b) (reg c)))))
                     (#x7 (return))
                     (#x8 (setf (reg b) (platter-array-allocate (reg c))))
                     (#x9 (platter-array-free (reg c)))           
                     (#xA (write-char (code-char (logand #xFF (reg c))))
                          (when (= (reg c) #.(char-code #\Newline))
                            (finish-output)))
                     (#xB (setf (reg c) (handler-case (char-code (read-char))
                                          (end-of-file () #xFFFFFFFF))))
                     (#xC (when (plusp (reg b))
                            (setf program (copy-seq (platter-array (reg b)))))
                          (setf pc (reg c)))))))))))

(defun run (filename)
  (let (program end)
    (with-open-file (in filename :element-type 'platter)
      (setf program (make-array (file-length in) :element-type 'platter)
            end (read-sequence program in))
      #-(or ppc big-endian) ;; swap byte-order, pinched from Frederic Jolliton <icfp@frederic.jolliton.com>
      (loop for i from 0 below end
            do (rotatef (ldb (byte 8 16) (aref program i))
                        (ldb (byte 8  8) (aref program i)))
            do (rotatef (ldb (byte 8 24) (aref program i))
                        (ldb (byte 8  0) (aref program i)))))
    (execute program)))