root/hiersort/sim/HierProc.hs

-- | HierProc.hs
-- Hierarchical (combined) processor.
--
-- 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.

-- Here we have a hierProcLeaf for bottom nodes with processing elements
-- and hierProcNode which combines two subhierarchies into one bigger.
--
-- hierProc governs them.
--
-- The main challenge here is to properly connect subparts in hierProcNode.

module HierProc(hierProc) where

import Config

import S
import SQ3
import Proc
import Info
import Matcher
import MatcherProc
import Presorter
import UpBuf
import InterfaceTypes

import Data.Bits

-------------------------------------------------------------------------------
-- Hierarchical processor leaf (bottom level).

hierProcLeaf config mask procIndex procTransFunc inTokens cts = (outTokens,rtr,info)
        where
                -- configuration parameters.
                chanWidth = mkWidth "chanWidth" $ getProcessorChanWidth config

                thisTokenF' HostTok = False
                thisTokenF' (ModTok addr) = (addr .&. mask) == procIndex
                thisTokenF msg = thisTokenF' $ msgModuleAddr msg
                (outTokens,rtr,procInfo) =
                        matcherProc config procTransFunc thisTokenF
                        chanWidth mask procIndex inTokens cts
                
                info = combineInfos [
                                 constS $ infoLineWords ["Processor",show procIndex]
                                ,procInfo
                        ]

-------------------------------------------------------------------------------
-- Hierarchical processor node (intermediate and top levels).

ourAddrF mask (low,high) msg = case msgModuleAddr msg of
        HostTok -> False
        ModTok a' -> let a = a' .&. mask in a >= low && a <= high

leftAddrF mask (low,high) msg = case msgModuleAddr msg of
        HostTok -> False
        ModTok a' -> let a = a' .&. mask in a >= low && a < mid
        where
                mid = (`div` 2) $ low+high+1

hierProcNode config nodeParams mask procNRange leftProc rightProc inTokens cts =
        (outTokens,rtr,info)
        where
                -- configuration parameters.
                upWidth = mkWidth "upWidth" $ nodeCfgUpChanWidth nodeParams
                dnWidth = mkWidth "dnWidth" $ nodeCfgDownChanWidth nodeParams
                presorterSortWidth =
                        -- mkWidth "presorterSortWidth" $ nodeCfgPreSortChanWidth nodeParams
                        mkWidth "presorterSortWidth" $ nodeCfgDownChanWidth nodeParams*2
                presorterUpWidth =
                        -- mkWidth "presorterUpWidth" $ nodeCfgPreUpChanWidth nodeParams
                        mkWidth "presorterUpWidth" $ nodeCfgDownChanWidth nodeParams*2
                sorterUpWidth = mkWidth "sorterUpWidth" $ fromWidth presorterSortWidth - fromWidth dnWidth
                sorterDnWidth = dnWidth
                -- Instance circuits.
                (leftProcOutTokens,leftProcRTR,leftProcInfo) =
                        leftProc leftProcInTokens leftProcCTS
                (rightProcOutTokens,rightProcRTR,rightProcInfo) =
                        rightProc rightProcInTokens rightProcCTS
                (leftSorterRTR,leftSorterUpTokens,leftSorterDownTokens,leftSorterInfo) =
                        sorter leftSorterInTokens leftSorterDownCTS leftSorterUpCTS
                (rightSorterRTR,rightSorterUpTokens,rightSorterDownTokens,rightSorterInfo) =
                        sorter rightSorterInTokens rightSorterDownCTS rightSorterUpCTS
#ifdef  DEBUG
                (upTokens,upBufRTR,upBufInfo) =
#else
                upBufInfo = constS ""
                (upTokens,upBufRTR) =
#endif
                        upstreamBuffer
                                (cfgUpBufMaxLen config)
                                upWidth
                                upForwardedTokens leftSorterUpTokens rightSorterUpTokens
                                cts
#ifdef  DEBUG
                (leftForwardedTokens,rightForwardedTokens,upForwardedTokens,presorterUpRTR,presorterDnRTR,presorterInfo) =
#else
                presorterInfo = constS ""
                (leftForwardedTokens,rightForwardedTokens,upForwardedTokens,presorterUpRTR,presorterDnRTR) =
#endif
                        presorterInstance
                                presorterSortWidth
                                presorterUpWidth
                                inTokens
                                leftProcOutTokens rightProcOutTokens
                                presorterUpCTS
                                presorterLeftCTS
                                presorterRightCTS
                                
                -- Sorter circuit.
                sorter input dncts upcts = sq3chain
                        (nodeCfgSortSize nodeParams)
                        (nodeCfgSortHeight nodeParams)
                        (nodeCfgSortForceUp nodeParams)
                        sorterUpWidth
                        sorterDnWidth
                        compareOrders
                        input dncts upcts
                compareOrders msga msgb =
                        compare (msgOrder msga) (msgOrder msgb)

                -- Presorter circuit.
                presorterInstance =
                        presorter
                                (ourAddrF mask procNRange)
                                (leftAddrF mask procNRange)
                                maxlen
                                
                        where
                                maxlen = (cfgPresorterMaxLen config)
                -- Connect wires.
                leftProcInTokens = leftSorterDownTokens
                rightProcInTokens = rightSorterDownTokens
                leftSorterDownCTS = leftProcRTR
                rightSorterDownCTS = rightProcRTR
                leftProcCTS = presorterDnRTR
                rightProcCTS = presorterDnRTR
                presorterUpCTS = upBufRTR
                presorterLeftCTS = leftSorterRTR
                presorterRightCTS = rightSorterRTR
                leftSorterInTokens = leftForwardedTokens
                rightSorterInTokens = rightForwardedTokens
                leftSorterUpCTS = upBufRTR
                rightSorterUpCTS = upBufRTR
                outTokens = upTokens
                rtr = presorterUpRTR
                -- generate info.
                (low,high) = procNRange
                nodeHeader = constS $ infoLineWords ["Node",show low++".."++show high]
                procInfos = [leftProcInfo,rightProcInfo]
                sorterInfos = [
                                 constS "left sorter\n"
                                ,leftSorterInfo
                                ,constS "right sorter\n"
                                ,rightSorterInfo
                        ]
                allInfos = nodeHeader:presorterInfo:upBufInfo:sorterInfos++procInfos
                onlyProcInfos = nodeHeader:procInfos
                info = combineInfos allInfos --onlyProcInfos

-------------------------------------------------------------------------------
-- Run a construction of hierarchical processor.

hierProc config procTransFunc
        | depth < 0 = error "Invalid construction depth."
        | otherwise = construct startMask startRange params
        where
                depth = length params
                np = shiftL (1::Int) depth
                startMask = np-1
                startRange = (0,np-1)
                procIndexFromRange range@(start,end)
                        | start==end = start
                        | otherwise = error $ "start /= end: "++show range
                params = getHierParams config
                construct mask procNRange [] inTokens cts =
                        hierProcLeaf
                                config
                                mask
                                (procIndexFromRange procNRange)
                                procTransFunc
                                inTokens
                                cts
                construct mask procNRange (nodeParams:paramss) inTokens cts =
                        hierProcNode
                                config
                                nodeParams
                                mask procNRange
                                leftProc
                                rightProc
                                inTokens
                                cts
                        where
                                nextMask = mask .|. shiftR mask 1       -- expand one bit further
                                (start,end) = procNRange
                                mid = div (start+end+1) 2
                                leftRange = (start,mid-1)
                                rightRange = (mid,end)
                                leftProc =
                                        construct
                                                nextMask
                                                leftRange
                                                paramss
                                rightProc =
                                        construct
                                                nextMask
                                                rightRange
                                                paramss