{-# OPTIONS -fglasgow-exts -optc-O3 -funbox-strict-fields -O2 -optc-march=pentium4 #-}
--
-- ugly, fast code, based on sjannsen's.
-- tries to unbox and go as low-level as possible
--

import GHC.Ptr
import GHC.Base
import GHC.Word
import GHC.IOBase

import Data.Char
import System.IO
import System.Environment
import Control.Monad

import Foreign
import Foreign.Ptr

import Data.Array.IO hiding (newArray)
import qualified Data.Array.Base as A
import Data.Array.Base (unsafeRead,unsafeWrite)

import qualified Data.ByteString      as B
import qualified Data.ByteString.Base as B

import qualified Data.HashTable as H

chunk :: Int
chunk = 32

zeroes :: [Word32]
zeroes = replicate chunk 0

type Platter = Ptr Word32
type Heap    = IOUArray Word32 Platter
type Sizes   = H.HashTable Int Int     -- size of each platter array, cached seperately

main :: IO ()
main = do
    ps <- getArgs >>= B.readFile . head
    let (fp,_,s) = B.toForeignPtr ps
    withForeignPtr fp $ \ptr -> do

        -- tweak the endianess
        let l = s `div` 4
        flip mapM_ [0.. l-1] $ \i -> do
            let i4 = fromIntegral $ i * 4 :: Int
            w1 <- peekElemOff ptr i4
            w2 <- peekElemOff ptr (i4+1)
            w3 <- peekElemOff ptr (i4+2)
            w4 <- peekElemOff ptr (i4+3)
            pokeElemOff (castPtr ptr :: Ptr Word32) i $!
                    (fromIntegral w1 `shiftL` 24) .|.
                    (fromIntegral w2 `shiftL` 16) .|.
                    (fromIntegral w3 `shiftL`  8) .|.
                    (fromIntegral w4)

        (Ptr regs#) <- newArray (replicate 8 0) :: IO (Ptr Word32)

        arr1 <- newArray zeroes :: IO (Ptr Word32)
        heap <- newArray_ (0, 1)               :: IO Heap
        unsafeWrite heap 0 (castPtr ptr)
        unsafeWrite heap 1 arr1

        sizes <- H.fromList (fromIntegral) [(0,l), (1,chunk)] :: IO Sizes
        let Ptr a# = ptr
        eval [1] sizes heap a# regs# 0#

eval :: [Int] -> Sizes -> Heap -> Addr# -> Addr# -> Int# -> IO ()
eval us sizes heap text regs pc = do
    let w  = text `indexWordOffAddr#` pc :: Word#
        op = w `uncheckedShiftRL#` 28#
        c  = int2Word# 7# `and#` w
        b  = int2Word# 7# `and#` (w `uncheckedShiftRL#` 3#)
        a  = int2Word# 7# `and#` (w `uncheckedShiftRL#` 6#)

    case word2Int# op of
        13# -> set (int2Word# 7# `and#` (w `uncheckedShiftRL#` 25#))
                   (w `and#` int2Word# 0x1ffffff#)

        0# -> unless (eq0 (reg c)) $ set a (reg b)
        1# -> getArr (reg b) >>= \(Ptr arr) ->
                set a (arr `indexWordOffAddr#` (word2Int# (reg c)))
        2# -> writeArr (reg a) (reg b) (reg c)
        3# -> set a (reg b `plusWord#`  reg c)
        4# -> set a (reg b `timesWord#` reg c)
        6# -> set a (not# (reg b `and#` reg c))
        -- ghc codegen bug: !
        -- set a (reg b `quotWord#`  reg c)
        5# -> let W# z = W# (reg b) `quot` W# (reg c) in set a z
        7# -> error "Halt"
        10# -> putChar (C# (chr# (word2Int# (reg c))))
        11# -> do eof <- isEOF
                  if eof then set c (int2Word# 0xffffffff#)
                         else do C# i <- getChar
                                 set c (int2Word# (ord# i))
        _   -> return ()
    case word2Int# op of
        8# -> case us of
                [] -> {-# SCC "8 branch 1" #-}
                 do let s0@(W32# s0#) = snd $ bounds heap
                        n = I# (word2Int# (reg c))
                        sz = max n chunk
                    heap' <- newArray_ (0, s0 * 2) :: IO Heap

                    flip mapM_ [0..s0] $ \i -> do
                        e <- unsafeRead heap (fromIntegral i)
                        unsafeWrite heap' (fromIntegral i) e

                    na <- newArray (replicate sz 0) :: IO (Ptr Word32)

                    unsafeWrite heap' (fromIntegral s0 +1) na
                    H.insert sizes (fromIntegral s0 + 1) sz

                    flip mapM_ [s0+2 .. s0*2] $ \i -> do
                        e <- newArray zeroes :: IO (Ptr Word32)
                        unsafeWrite heap' (fromIntegral i) e
                        H.insert sizes (fromIntegral i) chunk

                    set b (int2Word# (word2Int# s0# +# 1#))
                    eval [fromIntegral s0+2..fromIntegral s0*2] sizes heap' text regs (pc +# 1#)

                (x@(I# x#):xs) -> {-# SCC "8 branch 2" #-}  do
                    let m = I# (word2Int# (reg c))
                    ptr <- getArr (int2Word# x#)
                    n'  <- H.lookup sizes x >>= return . maybe undefined id
                    if (n'-1) >= m
                         then do B.memset (castPtr ptr) 0 (fromIntegral m * 4)
                                 return ()

                         else do arr <- newArray (replicate m 0) :: IO (Ptr Word32)
                                 unsafeWrite heap (fromIntegral x) arr
                                 H.insert sizes (fromIntegral x) m
                    set b (int2Word# x#)
                    eval xs sizes heap text regs (pc+#1#)

        9#  -> {-# SCC "9" #-}
               do let i = I# (word2Int# (reg c))
                  n <- H.lookup sizes i >>= return .maybe undefined id
                  when (n-1 > chunk) $ do
                        arr <- newArray zeroes :: IO (Ptr Word32)
                        unsafeWrite heap i arr
                        H.insert sizes   i chunk

                  eval (i : us) sizes heap text regs (pc +# 1#)

        12# -> {-# SCC "12" #-}
           case reg b of
             x -> if eq0 (reg b)
                    then eval us sizes heap text regs (word2Int# (reg c))
                    else do
                        arr0 <- getArr x
                        n    <- H.lookup sizes (I# (word2Int# x))>>= return .maybe undefined id
                        arr1@(Ptr a#) <- mallocBytes (n*4) :: IO (Ptr Word32)
                        copyArray arr1 arr0 n
                        unsafeWrite heap 0 arr1
                        H.insert sizes 0 n
                     -- free arr0
                        eval us sizes heap a# regs (word2Int# (reg c))

        n  -> (assert (n <=# 13#) $ eval us sizes heap text regs (pc +# 1#))


  where
      reg x   = regs ! (word2Int# x)
      {-# INLINE reg #-}

      set a b = IO $ \s -> case writeWordOffAddr# regs (word2Int# a) b s of
                                s' -> (# s', () #)
      {-# INLINE set #-}

      writeArr k o x = do (Ptr a) <- getArr k
                          IO $ \s -> case writeWordOffAddr# a (word2Int# o) x s of
                                            s' -> (# s', () #)
      {-# INLINE writeArr #-}

      getArr i = heap `unsafeRead` (I# (word2Int# i)) -- array read
      {-# INLINE getArr #-}

eq0 :: Word# -> Bool
eq0 x = x `eqWord#` (int2Word# 0#)
{-# INLINE eq0 #-}

(!) :: Addr# -> Int# -> Word#
(!) = indexWordOffAddr#
{-# INLINE (!) #-}