diff --git a/bs/Bus/Bus.bs b/bs/Bus/Bus.bs index 4a8bb31..d409b29 100644 --- a/bs/Bus/Bus.bs +++ b/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 -> diff --git a/bs/Bus/Client.bs b/bs/Bus/Client.bs new file mode 100644 index 0000000..4d3d10a --- /dev/null +++ b/bs/Bus/Client.bs @@ -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 \ No newline at end of file