forked.hs

{-# LANGUAGE BangPatterns #-}
module Main where

import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.IntMap as M
import Data.Maybe
import Data.Bits
import Data.Char
import System.Environment
import Text.Printf
import Control.Concurrent
import Control.Monad

type AllocMap = M.IntMap (Int, [Int])

readHex :: BS.ByteString -> Int
readHex = BS.foldl' digit 0
    where
    digit i c = shiftL i 4 + toVal c
    toVal v | isDigit v = ord v - ord '0'
    toVal v = ord v - ord 'a' + 10

printStack :: (Int, [Int]) -> String
printStack (p, stack) = printf "%d:" p ++ concatMap (printf " %x") stack

counter :: MVar (Char, Int, [BS.ByteString]) -> MVar (Int, Int, AllocMap) -> Int -> Int -> AllocMap -> Int -> Int -> AllocMap -> IO ()
counter chunk result !maxb !maxc maxallocs !b !c allocs = do
    (op, addr, params) <- takeMVar chunk
    case op of
        '-' -> putMVar result (maxb, maxc, maxallocs)
        'f' -> if addr == 0 then counter chunk result maxb maxc maxallocs b c allocs
                            else let size = fst $ fromJust $ M.lookup addr allocs
                                     in counter chunk result maxb maxc maxallocs (b - size) (c - 1) (M.delete addr allocs)
        'a' -> let (ssize:stack) = params
                   size = readHex ssize
                   newallocs = M.insert addr (size, map readHex stack) allocs
                   newmaxc = max maxc (c + 1)
                   in if maxb < b + size then counter chunk result (b + size) newmaxc newallocs (b + size) (c + 1) newallocs
                                         else counter chunk result maxb newmaxc maxallocs (b + size) (c + 1) newallocs

main :: IO()
main = do
    filename <- head `fmap` getArgs
    src <- BS.readFile filename
    chunk <- newEmptyMVar
    result <- newEmptyMVar
    _ <- forkIO $ counter chunk result 0 0 M.empty 0 0 M.empty

    forM_ (BS.lines src) $ \l -> do
            let (op:addr:params) = BS.words l
            let !opch = BS.head op
            let !addrval = readHex addr
            let !paramval = params
            putMVar chunk (opch, addrval, paramval)
    putMVar chunk ('-', 0, [])
    (maxbytes, maxchunks, allocs) <- takeMVar result
    print maxbytes
    print maxchunks
    let total = sum $ map fst (M.elems allocs)
    print total
--    mapM_ (printf "%s\n" . printStack) (M.elems allocs)