{-# OPTIONS -fglasgow-exts -funbox-strict-fields -O2 -optc-O3 #-}

import Data.Array.IO
import Data.Array.Base (unsafeRead, unsafeWrite)
import Control.Monad
import Data.Word
import Data.Bits
import System.Environment
import System
import System.IO
import GHC.Base
import GHC.Word
import qualified Data.ByteString as B

type Reg = IOUArray Word Word
type Mem = IOArray Word Reg

unsafeShiftR (W# w) (W# s) = W# (uncheckedShiftRL# w (word2Int# s))

copyArray :: MArray a e m => a Word e -> a Word e -> m (a Word e)
copyArray orig copy = do
    let (_, h) = bounds orig
    flip mapM_ [0..fromIntegral h] $ \i ->
        unsafeRead orig i >>= unsafeWrite copy i
    return copy

exec :: [Word] -> Word -> Word -> Reg -> Mem -> IO ()
exec av ms fg reg mem | fg `seq` reg `seq` mem `seq` False = undefined
exec av ms fg reg mem = do
    let rarr a i   = unsafeRead  a (fromIntegral i)
        warr a i v = unsafeWrite a (fromIntegral i) v
        rmem m i   = rarr mem m >>= \mem' -> rarr mem' i
        wmem m i v = rarr mem m >>= \mem' -> warr mem' i v
        rreg r     = rarr reg r
        wreg r   v = warr reg r v
        cont       = exec av ms (fg+1) reg mem
        nand a b   = complement (a .&. b)
    op <- rmem 0 fg
    let a = unsafeShiftR op 6 .&. 7
        b = unsafeShiftR op 3 .&. 7
        c = op .&. 7
        
    case op `unsafeShiftR` 28 of
      00 -> rreg c >>= \c' -> when (c' /= 0) (rreg b >>= wreg a) >> cont
      01 -> join (liftM2 rmem (rreg b) (rreg c)) >>= wreg a >> cont
      02 -> join (liftM3 wmem (rreg a) (rreg b) (rreg c)) >> cont
      03 -> liftM2 (+)  (rreg b) (rreg c) >>= wreg a >> cont
      04 -> liftM2 (*)  (rreg b) (rreg c) >>= wreg a >> cont
      05 -> liftM2 div  (rreg b) (rreg c) >>= wreg a >> cont
      06 -> liftM2 nand (rreg b) (rreg c) >>= wreg a >> cont
      07 -> exitWith ExitSuccess
      08 -> do
          c' <- rreg c
          let (a:av') = av
          (mem', ms') <- if a < ms then return (mem, ms) else do
              mem' <- newArray (0, 2*ms-1) undefined >>= copyArray mem
              return (mem', 2*ms)
          p <- newArray (0, c'-1) 0
          warr mem' a p
          wreg b a
          exec av' ms' (fg+1) reg mem'
      09 -> do
          c' <- rreg c
          warr mem c' undefined
          exec (c':av) ms (fg+1) reg mem
      10 -> rreg c >>= putChar . toEnum . fromIntegral >> cont
      11 -> catch (fmap fromEnum getChar) (\_ -> return (-1)) >>=
            wreg c . fromIntegral >> cont
      12 -> do
          b' <- rreg b
          c' <- rreg c
          when (b' /= 0) $ do
              prog <- rarr mem b'
              newArray (bounds prog) 0 >>= copyArray prog >>= warr mem 0
          exec av ms c' reg mem
      13 -> wreg (unsafeShiftR op 25 .&. 7) (op .&. 0x1FFFFFF) >> cont
      _  -> exitWith (ExitFailure 1)

run p = do
   let l = fromIntegral $ B.length p `div` 4
   reg <- newArray (0, 7) 0
   prog <- newArray (0, l-1) 0
   flip mapM_ [0..l-1] $ \i -> do
       let i' = fromIntegral i
           a = fromIntegral $ B.index p (i'*4)
           b = fromIntegral $ B.index p (i'*4+1)
           c = fromIntegral $ B.index p (i'*4+2)
           d = fromIntegral $ B.index p (i'*4+3)
       unsafeWrite prog i' (((a*256 + b)*256 + c)*256 + d)
   mem <- newArray (0, 63) undefined
   writeArray mem 0 prog
   exec [1..] 64 0 reg mem

main = do
   hSetBuffering stdout LineBuffering
   [f] <- getArgs
   p <- B.readFile f
   run p