refactored client rules
This commit is contained in:
Yehowshua Immanuel
parent
1557cf9cc9
commit
2fee6a3bd8
116
bs/Bus/Bus.bs
116
bs/Bus/Bus.bs
|
|
@ -2,6 +2,7 @@ package Bus(mkBus, Bus(..)) where
|
|||
|
||||
import Types
|
||||
import BusTypes
|
||||
import Client
|
||||
import TagEngine
|
||||
import Vector
|
||||
import Util
|
||||
|
|
@ -76,97 +77,32 @@ mkBus serverMap = do
|
|||
|
||||
let clientRules :: Vector numClients (Rules)
|
||||
clientRules = genWith $ \clientIdx ->
|
||||
let
|
||||
selectedClientRequestQueue :: FIFOF (TaggedBusRequest inFlightTransactions)
|
||||
selectedClientRequestQueue = (select clientRequestQueues clientIdx)
|
||||
let selectedClientReqQueue :: FIFOF (TaggedBusRequest inFlightTransactions)
|
||||
selectedClientReqQueue = select clientRequestQueues clientIdx
|
||||
|
||||
selectedClientRespQueue :: FIFOF (TaggedBusResponse inFlightTransactions)
|
||||
selectedClientRespQueue = select clientResponseQueues clientIdx
|
||||
|
||||
selectedClientRespArbiter :: Arbiter.Arbiter_IFC (TAdd numServers 1)
|
||||
selectedClientRespArbiter = select responseArbiterByClient clientIdx
|
||||
|
||||
clientRouterRule :: Rules
|
||||
clientRouterRule = clientRouteRequest
|
||||
clientIdx
|
||||
selectedClientReqQueue
|
||||
requestArbiterByServer
|
||||
responseArbiterByClient
|
||||
serverMap
|
||||
|
||||
clientArbiterRule :: Rules
|
||||
clientArbiterRule = clientArbitSubmission
|
||||
clientIdx
|
||||
selectedClientReqQueue
|
||||
selectedClientRespQueue
|
||||
selectedClientRespArbiter
|
||||
submitResponseQueues
|
||||
in
|
||||
rules
|
||||
(sprintf "client[%d] route request" clientIdx): when True ==> do
|
||||
let
|
||||
clientRequest :: TaggedBusRequest inFlightTransactions
|
||||
clientRequest = selectedClientRequestQueue.first
|
||||
|
||||
targetAddr :: Addr = busRequestToAddr |> clientRequest.busRequest
|
||||
targetServerIdx :: (Maybe (MkServerIdx numServers)) = serverMap targetAddr
|
||||
case targetServerIdx of
|
||||
Just serverIdx -> do
|
||||
let
|
||||
targetServerArbiter :: Arbiter.Arbiter_IFC numClients
|
||||
targetServerArbiter = (select requestArbiterByServer serverIdx)
|
||||
arbiterClientSlot :: Arbiter.ArbiterClient_IFC
|
||||
arbiterClientSlot = (select targetServerArbiter.clients clientIdx)
|
||||
arbiterClientSlot.request
|
||||
Nothing -> do
|
||||
let
|
||||
targetClientResponseArbiter :: Arbiter.Arbiter_IFC (TAdd numServers 1)
|
||||
targetClientResponseArbiter = (select responseArbiterByClient clientIdx)
|
||||
|
||||
clientResponseArbiterSlot :: Arbiter.ArbiterClient_IFC
|
||||
-- arbiters 0 to n-1 where `n:=numServer` are reserved
|
||||
-- for servers to make requests to. Arbiter n is reserved for
|
||||
-- when this rule needs to skip making a request to a server
|
||||
-- and should instead forward the `BusError UnMapped` response
|
||||
-- back to the client. Vector.last selects arbiter `n`
|
||||
clientResponseArbiterSlot = Vector.last targetClientResponseArbiter.clients
|
||||
let
|
||||
responseUnMapped = case clientRequest.busRequest of
|
||||
BusReadRequest _ -> BusReadResponse (Left UnMapped)
|
||||
BusWriteRequest _ -> BusWriteResponse (Left UnMapped)
|
||||
response :: TaggedBusResponse inFlightTransactions
|
||||
response = TaggedBusResponse {
|
||||
tag = clientRequest.tag;
|
||||
busResponse = responseUnMapped
|
||||
}
|
||||
clientResponseArbiterSlot.request
|
||||
|
||||
(sprintf "client[%d] arbit submission" clientIdx): when True ==> do
|
||||
let
|
||||
selectedClientResponseArbiter :: Arbiter.Arbiter_IFC (TAdd numServers 1)
|
||||
selectedClientResponseArbiter = (select responseArbiterByClient clientIdx)
|
||||
|
||||
selectedClientResponseQueue :: FIFOF (TaggedBusResponse inFlightTransactions)
|
||||
selectedClientResponseQueue = (select clientResponseQueues clientIdx)
|
||||
|
||||
-- `TAdd numServers 1` because we can receive request from all servers
|
||||
-- as well as a bypass requests from our one corresponding client request
|
||||
-- queue
|
||||
grantedIdx :: UInt (TLog (TAdd numServers 1))
|
||||
grantedIdx = unpack selectedClientResponseArbiter.grant_id
|
||||
|
||||
isClientRequest :: Bool
|
||||
isClientRequest = grantedIdx == fromInteger (valueOf numServers)
|
||||
if isClientRequest then do
|
||||
let
|
||||
clientRequest :: TaggedBusRequest inFlightTransactions
|
||||
clientRequest = selectedClientRequestQueue.first
|
||||
|
||||
responseUnMapped :: BusResponse
|
||||
responseUnMapped = case clientRequest.busRequest of
|
||||
BusReadRequest _ -> BusReadResponse (Left UnMapped)
|
||||
BusWriteRequest _ -> BusWriteResponse (Left UnMapped)
|
||||
|
||||
response :: TaggedBusResponse inFlightTransactions
|
||||
response = TaggedBusResponse {
|
||||
tag = clientRequest.tag;
|
||||
busResponse = responseUnMapped
|
||||
}
|
||||
selectedClientResponseQueue.enq response
|
||||
selectedClientRequestQueue.deq
|
||||
else do
|
||||
let
|
||||
grantedServerIdx :: MkServerIdx numServers
|
||||
grantedServerIdx = truncate grantedIdx
|
||||
|
||||
selectedSubmitResponseQueue :: FIFOF (
|
||||
MkClientTagType numClients,
|
||||
TaggedBusResponse inFlightTransactions
|
||||
)
|
||||
selectedSubmitResponseQueue = (select submitResponseQueues grantedServerIdx)
|
||||
|
||||
response :: (MkClientTagType numClients, TaggedBusResponse inFlightTransactions)
|
||||
response = selectedSubmitResponseQueue.first
|
||||
selectedClientResponseQueue.enq response.snd
|
||||
selectedSubmitResponseQueue.deq
|
||||
clientRouterRule <+> clientArbiterRule
|
||||
|
||||
let serverRules :: Vector numServers (Rules)
|
||||
serverRules = genWith $ \serverIdx ->
|
||||
|
|
|
|||
107
bs/Bus/Client.bs
Normal file
107
bs/Bus/Client.bs
Normal file
|
|
@ -0,0 +1,107 @@
|
|||
package Client(
|
||||
clientRouteRequest,
|
||||
clientArbitSubmission
|
||||
) where
|
||||
|
||||
import Types
|
||||
import BusTypes
|
||||
import TagEngine
|
||||
import Vector
|
||||
import Util
|
||||
import Arbiter
|
||||
import FIFO
|
||||
import FIFOF
|
||||
import SpecialFIFOs
|
||||
import Printf
|
||||
|
||||
busRequestToAddr :: BusRequest -> Addr
|
||||
busRequestToAddr req = case req of
|
||||
BusReadRequest (ReadRequest addr _) -> addr
|
||||
BusWriteRequest (WriteRequest addr _) -> addr
|
||||
|
||||
clientRouteRequest :: (Add n (TLog numServers) (TLog (TAdd numServers 1)))
|
||||
=> Integer
|
||||
-> FIFOF (TaggedBusRequest inFlightTransactions)
|
||||
-> Vector numServers (Arbiter.Arbiter_IFC numClients)
|
||||
-> Vector numClients (Arbiter.Arbiter_IFC (TAdd numServers 1))
|
||||
-> (Addr -> Maybe (MkServerIdx numServers))
|
||||
-> Rules
|
||||
clientRouteRequest clientIdx clientReqQueue requestArbiterByServer responseArbiterByClient serverMap =
|
||||
rules
|
||||
(sprintf "client[%d] route request" clientIdx): when True ==> do
|
||||
let clientRequest :: TaggedBusRequest inFlightTransactions
|
||||
clientRequest = clientReqQueue.first
|
||||
|
||||
targetAddr :: Addr
|
||||
targetAddr = busRequestToAddr |> clientRequest.busRequest
|
||||
|
||||
targetServerIdx :: Maybe (MkServerIdx numServers)
|
||||
targetServerIdx = serverMap targetAddr
|
||||
case targetServerIdx of
|
||||
Just serverIdx -> do
|
||||
let targetServerArbiter :: Arbiter.Arbiter_IFC numClients
|
||||
targetServerArbiter = select requestArbiterByServer serverIdx
|
||||
|
||||
arbiterClientSlot :: Arbiter.ArbiterClient_IFC
|
||||
arbiterClientSlot = select targetServerArbiter.clients clientIdx
|
||||
arbiterClientSlot.request
|
||||
Nothing -> do
|
||||
let targetClientResponseArbiter :: Arbiter.Arbiter_IFC (TAdd numServers 1)
|
||||
targetClientResponseArbiter = select responseArbiterByClient clientIdx
|
||||
|
||||
-- arbiters 0 to n-1 where `n:=numServer` are reserved
|
||||
-- for servers to make requests to. Arbiter n is reserved for
|
||||
-- when this rule needs to skip making a request to a server
|
||||
-- and should instead forward the `BusError UnMapped` response
|
||||
-- back to the client. Vector.last selects arbiter `n`
|
||||
clientResponseArbiterSlot :: Arbiter.ArbiterClient_IFC
|
||||
clientResponseArbiterSlot = Vector.last targetClientResponseArbiter.clients
|
||||
|
||||
responseUnMapped :: BusResponse
|
||||
responseUnMapped = case clientRequest.busRequest of
|
||||
BusReadRequest _ -> BusReadResponse (Left UnMapped)
|
||||
BusWriteRequest _ -> BusWriteResponse (Left UnMapped)
|
||||
|
||||
response :: TaggedBusResponse inFlightTransactions
|
||||
response = TaggedBusResponse { tag = clientRequest.tag; busResponse = responseUnMapped }
|
||||
clientResponseArbiterSlot.request
|
||||
|
||||
clientArbitSubmission :: (Add n (TLog numServers) (TLog (TAdd numServers 1)))
|
||||
=> Integer
|
||||
-> FIFOF (TaggedBusRequest inFlightTransactions)
|
||||
-> FIFOF (TaggedBusResponse inFlightTransactions)
|
||||
-> Arbiter.Arbiter_IFC (TAdd numServers 1)
|
||||
-> Vector numServers (FIFOF (MkClientTagType numClients, TaggedBusResponse inFlightTransactions))
|
||||
-> Rules
|
||||
clientArbitSubmission clientIdx clientReqQueue clientRespQueue clientRespArbiter submitRespQueues =
|
||||
rules
|
||||
(sprintf "client[%d] arbit submission" clientIdx): when True ==> do
|
||||
let grantedIdx :: UInt (TLog (TAdd numServers 1))
|
||||
grantedIdx = unpack clientRespArbiter.grant_id
|
||||
|
||||
isClientRequest :: Bool
|
||||
isClientRequest = grantedIdx == fromInteger (valueOf numServers)
|
||||
if isClientRequest then do
|
||||
let clientRequest :: TaggedBusRequest inFlightTransactions
|
||||
clientRequest = clientReqQueue.first
|
||||
|
||||
responseUnMapped :: BusResponse
|
||||
responseUnMapped = case clientRequest.busRequest of
|
||||
BusReadRequest _ -> BusReadResponse (Left UnMapped)
|
||||
BusWriteRequest _ -> BusWriteResponse (Left UnMapped)
|
||||
|
||||
response :: TaggedBusResponse inFlightTransactions
|
||||
response = TaggedBusResponse { tag = clientRequest.tag; busResponse = responseUnMapped }
|
||||
clientRespQueue.enq response
|
||||
clientReqQueue.deq
|
||||
else do
|
||||
let grantedServerIdx :: MkServerIdx numServers
|
||||
grantedServerIdx = truncate grantedIdx
|
||||
|
||||
selectedSubmitRespQueue :: FIFOF (MkClientTagType numClients, TaggedBusResponse inFlightTransactions)
|
||||
selectedSubmitRespQueue = select submitRespQueues grantedServerIdx
|
||||
|
||||
response :: (MkClientTagType numClients, TaggedBusResponse inFlightTransactions)
|
||||
response = selectedSubmitRespQueue.first
|
||||
clientRespQueue.enq response.snd
|
||||
selectedSubmitRespQueue.deq
|
||||
Loading…
Reference in a new issue