root/hiersort/sim/Proc.hs

-- | Proc.hs
-- A processor 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.

-- It executes pair programs delivered from matcher circuit.
-- Main role of that circuit is to resolve processor resource
-- allocation conflicts and perform a little scheduling of threads.
--

module Proc where

import InterfaceTypes

import Info

import S

import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Bits

-------------------------------------------------------------------------------
-- Execution devices set configuration.

devSet chaninfos = Map.fromList $ map chan chaninfos++otherDevices
        where
                chan (ch,enabled,width)
                        | enabled   = (MessageChannel ch,width)
                        | otherwise = (MessageChannel ch,0)
                otherDevices = map (\(r,w) -> (OtherResource r,w)) [
                                 (IAdder,6)
                                ,(ILogic,6)
                                ,(IMultiplier,1)
                                ,(FAdder,1)
                                ,(FMultiplier,1)
                                ,(FDivider,1)
                        ]

-------------------------------------------------------------------------------
-- Processor state change function.

processorF execWindow maxProgs shedPolicy
        sendChanWidth
        progTrans
        mask ourindex
        progStates (pair,matcherCTS) =
        (nextProgStates,((tokenMatch,rtr),debInfo))
        where
                -- Can we receive another pair?
                rtr = max 0 (maxProgs - length progStates)
                -- Split programs into working and idle set.
                (workSet,idleSet) = splitAt execWindow progStates
                -- Perform update in work set.
                resourceSet =
                        devSet [
                                        (MsgChannelMatch,matcherCTS,sendChanWidth)
                                ]
                (workSetDelayed,workSetSheduled,tokenMatch) =
                        workCycle [] [] [] workSet resourceSet
                -- expand arguments for progTrans
                expandProgTrans (pair,order) = progTrans pair order
                -- Pair program.
                pairProgram = map expandProgTrans pair
                -- Next program states.
                nextProgStates = case shedPolicy of
                        SheduleAllWorkBack ->
                                   idleSet
                                ++ workSetDelayed
                                ++ workSetSheduled
                                ++ pairProgram
                        SheduleSheduledBack ->
                                   workSetDelayed
                                ++ idleSet
                                ++ workSetSheduled
                                ++ pairProgram
                        SheduleWindow ->
                                   workSetSheduled
                                ++ workSetDelayed
                                ++ idleSet
                                ++ pairProgram
                tripDistMatch = fmap (\msg -> distance mask ourindex (msgModuleAddr msg)) tokenMatch

                isProcMessage (ProcMessage _) = True
                isProcMessage _               = False
                isHeadProcMessage [] = False
                isHeadProcMessage (h:_) = isProcMessage h
                anyProcMessage = or $ map isHeadProcMessage workSet
                anySent = (length tokenMatch) > 0

                procBlocked
                        | anyProcMessage && not anySent = "processor is blocked."
                        | otherwise = "processor isn't blocked."
                procIdle
                        | length progStates < 1 = "processor is idle."
                        | otherwise = "processor isn't idle."

                noInfo = ""
                debInfo = "proc info"
                        !#      procBlocked
                        ?#      procIdle
                        ?#      ("matcherCTS",matcherCTS)
--                      ##      ("pair",pair)
--                      ##      ("pairProgram",pairProgram)
--                      ##      ("resourceSet",resourceSet)
--                      ##      ("sendChanWidth",sendChanWidth)
--                      ##      ("progStates",progStates)
--                      ##      ("workSet",workSet)
--                      ##      ("idleSet",idleSet)
--                      ##      ("nextProgStates",nextProgStates)
                        ##      ("tokenMatch",tokenMatch)
--                      ##      ("length tokenMatch",length tokenMatch)
--                      ##      ("mask",mask)
--                      ##      ("ourindex",ourindex)
--                      ##      ("map upPred tokenMatch",map upPred tokenMatch)
--                      ##      ("workSetLen",length workSet)
--                      ##      ("execWindow",execWindow)
--                      ##      ("tripDistMatch",tripDistMatch)
                        #!      ("procRTR",rtr)

distance mask src dest = case dest of
        HostTok -> ("to host",highest mask)
        ModTok x -> ("to module",2*highest (mask .&. (xor src x)))
        where
                highest 0 = 0
                highest n = 1+highest (shiftR n 1)

hasHeadMsg [] = False
hasHeadMsg (p:ps) = headMsg p || hasHeadMsg ps
headMsg (c:cs) = case c of
        ProcMessage _ -> True
        _             -> False
headMsg _ = False

-- No more programs to update.
workCycle sheduled delayed messageMatch [] _ = (
                 reverse delayed
                ,reverse sheduled
                ,messageMatch
                )
-- Has at least one program to update.
workCycle sheduled delayed messageMatch (p:ps) resSet
        | notBlocked = workCycle (advanced++sheduled) delayed newMatch ps remainingResources
        | otherwise = workCycle sheduled (p:delayed) messageMatch ps resSet
        where
                (pcommand,advanced) = case p of
                        []     -> (ProcNop,[])
                        [c]    -> (c,[])
                        (c:cs) -> (c,[cs])
                allocResource r = case Map.lookup r resSet of
                        Just 0 -> (False,resSet)
                        Just c -> (True,Map.adjust (\x -> x - 1) r resSet)
                        Nothing -> error $ unwords ["Can't allocate resource out of the set:",show r,", resources",show resSet]
                (notBlocked,remainingResources) = case pcommand of
                        ProcMessage msg -> allocResource $ MessageChannel MsgChannelMatch
                        ProcResource r  -> allocResource $ OtherResource r
                        ProcNop         -> (True,resSet)
                newMatch = case pcommand of
                        ProcMessage msg -> checkMsg messageMatch msg
                        _ -> messageMatch
                checkMsg old new = old++[new]

-------------------------------------------------------------------------------
-- Processor circuit

processor execWindow maxProg shedPolicy sendChanWidth progTrans mask ourindex pair matcherCTS =
        (matcherTokens,rtr,info)
        where
                procF = processorF execWindow maxProg shedPolicy sendChanWidth progTrans mask ourindex
                (bus,info) = unzipS $ loopS [] procF $ zipS pair matcherCTS
                (matcherTokens,rtr) = unzipS bus