root/hiersort/sim/DFLSystem.hs

-- | DFLSystem.hs
--
-- A whole sorting DFL system assembler and executor with auxiliary circuit.
--
-- Copytight (C) 2007, 2008 Serguey Zefirov
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 3, or (at your option)
-- any later version.
-- See file COPYING or visit http://www.gnu.org/licenses for details.


module DFLSystem(
                dflSystemRunner
        ) where

import System.IO

import qualified Que as Q
import Info
import S
import Presorter
import Config

-------------------------------------------------------------------------------
-- Infinite FIFO with two inputs.
--
-- This is the only part of sorting DFL system which does not limit the size
-- of data contained within.

fifoF outWidth (maxql,que) ((token1,token2),cts) =
#ifdef  DEBUG
        ((max maxql queLen,nextQue),(out,debinfo))
#else
        ((max maxql queLen,nextQue),out)
#endif
        where
                addQ xs = Q.appends xs
                (out,que0)
                        | cts = Q.take outWidth que
                        | otherwise = ([],que)
                que1 = addQ token1 que0
                que2 = addQ token2 que1
                queLen = Q.size que
                nextQue = que2
                noinfo = ""
                debinfo = "FIFO"
                        !# ("input tokens",(token1,token2))
                        ## ("cts",cts)
                        ## ("out token",out)
--                      ## ("start que",que)
--                      ## ("end que",nextQue)
                        ## ("que length",queLen)
                        #! ("maxql",maxql)

fifo outWidth tokens1 tokens2 cts =
#ifdef  DEBUG
        (out,info)
#else
        out
#endif
        where
#ifdef  DEBUG
                (out,info) = unzipS $
                        loopS (0,Q.empty) (fifoF outWidth) $ zipS (zipS tokens1 tokens2) cts
#else
                out = loopS (0,Q.empty) (fifoF outWidth) $ zipS (zipS tokens1 tokens2) cts
#endif

-------------------------------------------------------------------------------
-- DFL system compiled into single block.
-- Parametrized by processor used.

dflSystem procWidth proc inTokens =
#ifdef  DEBUG
        (hostTokens,info)
#else
        (hostTokens)
#endif
        where
                hostTokens = mapS onlyHost procOutTokens
                procTokens = mapS onlyProc procOutTokens
                onlyHost' (t)
                        | isNotToHost t = []
                        | otherwise     = [t]
                onlyProc' (t)
                        | isNotToHost t = [t]
                        | otherwise     = []
                onlyHost ts = concatMap onlyHost' ts
                onlyProc ts = concatMap onlyProc' ts
#ifdef  DEBUG
                (procInTokens,fifoInfo) = fifo procWidth inTokens procTokens procCTS
                (procOutTokens,procCTS,procInfo) = proc procInTokens (constS True)
                info = combineInfos [
                                 fifoInfo
                                ,procInfo
                        ]
#else
                (procInTokens) = fifo procWidth inTokens procTokens procCTS
                (procOutTokens,procCTS,procInfo) = proc procInTokens (constS True)
#endif

-------------------------------------------------------------------------------
-- Runner of the DFL system.

dflSystemRunner config proc (matcher,tokens,hostTokensCount) =
        run 0 maxWait hostTokensCount (toList hostTokens) (toList info)
        where
                debFlag = cfgDebug config
                debShow
                        | debFlag = putStrLn
                        | otherwise = const $ return ()
                maxWait = cfgMaxWait config
                parametrizedProc = proc matcher
                procWidth = getHierProcWidth config
                takeBy n [] = []
                takeBy n xs = let (h,t) = splitAt n xs in h:takeBy n t
                fromHost = fromListS []         $ takeBy procWidth tokens
#ifdef  DEBUG
                (hostTokens,info) = dflSystem procWidth parametrizedProc fromHost
#else
                hostTokens = dflSystem procWidth parametrizedProc fromHost
                info = constS ""
#endif
                run tc _    0        _      _ = putStrLn $ "Total "++show tc++" ticks."
                run tc 0    _        _      _ = putStrLn "Timeout!"
                run tc wait tokCount (t:ts) (i:is) = do
                        putStrLn $ "Tick "++show tc++"(remains "++show tokCount++")"++": "++show t
                        debShow    i
--                      hFlush stdout
                        run (tc+1) wait' tokCount' ts is
                        where
                                wait' = wait - 1
                                tokCount' = case t of
                                        [] -> tokCount
                                        _  -> tokCount-length t