646028df76f17c299146c78d18554b10617fa68b
[barrelfish] / tools / sockeye / SockeyeNetBuilder.hs
1 {-
2     SockeyeNetBuilder.hs: Decoding net builder for Sockeye
3
4     Part of Sockeye
5
6     Copyright (c) 2017, ETH Zurich.
7
8     All rights reserved.
9
10     This file is distributed under the terms in the attached LICENSE file.
11     If you do not find this file, copies can be found by writing to:
12     ETH Zurich D-INFK, CAB F.78, Universitaetstr. 6, CH-8092 Zurich,
13     Attn: Systems Group.
14 -}
15
16 {-# LANGUAGE MultiParamTypeClasses #-}
17 {-# LANGUAGE FlexibleInstances #-}
18 {-# LANGUAGE FlexibleContexts #-}
19
20 module SockeyeNetBuilder
21 ( buildSockeyeNet ) where
22
23 import Control.Monad.State
24
25 import Data.List (sort)
26 import Data.Map (Map)
27 import qualified Data.Map as Map
28 import Data.Set (Set)
29 import qualified Data.Set as Set
30
31 import SockeyeChecks
32
33 import qualified SockeyeASTInstantiator as InstAST
34 import qualified SockeyeASTDecodingNet as NetAST
35
36 data NetBuildFail
37     = UndefinedOutPort   !String !String
38     | UndefinedInPort    !String !String
39     | UndefinedReference !String !String
40
41 instance Show NetBuildFail where
42     show (UndefinedInPort  inst port)  = concat ["Undefined input port '",   port, "' in module instantiation '", inst, "'"]
43     show (UndefinedOutPort inst port)  = concat ["Undefined output port '",  port, "' in module instantiation '", inst, "'"]
44     show (UndefinedReference context ident) = concat ["Reference to undefined node '", ident, "' in ", context]
45
46 type PortMap = Map InstAST.Identifier NetAST.NodeId
47
48 data Context = Context
49     { modules      :: Map InstAST.Identifier InstAST.Module
50     , curModule    :: !String
51     , curNamespace :: [String]
52     , curNode      :: !String
53     , inPortMap    :: PortMap
54     , outPortMap   :: PortMap
55     , nodes        :: Set String
56     , mappedBlocks :: [InstAST.BlockSpec]
57     }
58
59 buildSockeyeNet :: InstAST.SockeyeSpec -> Either (FailedChecks NetBuildFail) NetAST.NetSpec
60 buildSockeyeNet ast = do
61     let
62         context = Context
63             { modules      = Map.empty
64             , curModule    = ""
65             , curNamespace = []
66             , curNode      = ""
67             , inPortMap    = Map.empty
68             , outPortMap   = Map.empty
69             , nodes        = Set.empty
70             , mappedBlocks = []
71             }        
72     net <- runChecks $ transform context ast
73     return net
74
75 --            
76 -- Build net
77 --
78 class NetTransformable a b where
79     transform :: Context -> a -> Checks NetBuildFail b
80
81 instance NetTransformable InstAST.SockeyeSpec NetAST.NetSpec where
82     transform context ast = do
83         let
84             rootInst = InstAST.root ast
85             mods = InstAST.modules ast
86             specContext = context
87                 { modules = mods }
88         transform specContext rootInst
89
90 instance NetTransformable InstAST.Module NetAST.NetSpec where
91     transform context ast = do
92         let inPorts = InstAST.inputPorts ast
93             outPorts = InstAST.outputPorts ast
94             moduleInsts = InstAST.moduleInsts ast
95             nodeDecls = InstAST.nodeDecls ast
96             outPortIds = map InstAST.portId outPorts
97             inMapIds = concatMap Map.elems $ map InstAST.inPortMap moduleInsts
98             declIds = map InstAST.nodeId nodeDecls
99             modContext = context
100                 { nodes = Set.fromList $ outPortIds ++ inMapIds ++ declIds }
101         inPortDecls <- transform modContext inPorts
102         outPortDecls <- transform modContext outPorts
103         netDecls <- transform modContext nodeDecls
104         netInsts <- transform modContext moduleInsts     
105         return $ Map.unions (inPortDecls ++ outPortDecls ++ netDecls ++ netInsts)
106
107 instance NetTransformable InstAST.Port NetAST.NetSpec where
108     transform context ast@(InstAST.InputPort {}) = do
109         let portId = InstAST.portId ast
110             portWidth = InstAST.portWidth ast
111             portMap = inPortMap context
112             mappedId = Map.lookup portId portMap
113             errorContext = "input port declaration"
114         checkReference context (UndefinedReference errorContext) portId
115         netPortId <- transform context portId
116         case mappedId of
117             Nothing    -> return Map.empty
118             Just ident -> do
119                 let node = portNode netPortId portWidth
120                 return $ Map.fromList [(ident, node)]
121     transform context ast@(InstAST.OutputPort {}) = do
122         let portId = InstAST.portId ast
123             portWidth = InstAST.portWidth ast
124             portMap = outPortMap context
125             mappedId = Map.lookup portId portMap
126         netPortId <- transform context portId
127         case mappedId of
128             Nothing    -> return $ Map.fromList [(netPortId, portNodeTemplate)]
129             Just ident -> do
130                 let node = portNode ident portWidth
131                 return $ Map.fromList $ [(netPortId, node)]
132
133 portNode :: NetAST.NodeId -> Integer -> NetAST.NodeSpec
134 portNode destNode width =
135     let base = 0
136         limit = 2^width - 1
137         srcBlock = NetAST.BlockSpec
138             { NetAST.base  = base
139             , NetAST.limit = limit
140             }
141         map = NetAST.MapSpec
142                 { NetAST.srcBlock = srcBlock
143                 , NetAST.destNode = destNode
144                 , NetAST.destBase = base
145                 }
146     in portNodeTemplate { NetAST.translate = [map] }
147
148 portNodeTemplate :: NetAST.NodeSpec
149 portNodeTemplate = NetAST.NodeSpec
150     { NetAST.nodeType  = NetAST.Other
151     , NetAST.accept    = []
152     , NetAST.translate = []
153     }
154
155 instance NetTransformable InstAST.ModuleInst NetAST.NetSpec where
156     transform context ast = do
157         let name = InstAST.moduleName ast
158             namespace = InstAST.namespace ast
159             inPortMap = InstAST.inPortMap ast
160             outPortMap = InstAST.outPortMap ast
161             mod = (modules context) Map.! name
162             inPortIds = Set.fromList $ map InstAST.portId (InstAST.inputPorts mod)
163             outPortIds = Set.fromList $ map InstAST.portId (InstAST.outputPorts mod)
164             instString = concat [name, maybe  "" (" as " ++ ) namespace]
165             errorContext = concat ["port mapping for '", instString, "'"]
166         mapM_ (checkReference context $ UndefinedReference errorContext) $ (Map.elems inPortMap) ++ (Map.elems outPortMap)
167         checkAllExist (UndefinedInPort instString) inPortIds $ Map.keysSet inPortMap
168         checkAllExist (UndefinedOutPort instString) outPortIds $ Map.keysSet outPortMap
169         netInMap <- transform context inPortMap
170         netOutMap <- transform context outPortMap
171         let curNs = curNamespace context
172             instContext = context
173                 { curModule    = name
174                 , curNamespace = maybe curNs (:curNs) namespace
175                 , inPortMap    = netInMap
176                 , outPortMap   = netOutMap
177                 }
178         transform instContext mod
179         where
180             checkAllExist fail existing xs = do
181                 let undef = xs Set.\\ existing
182                 if Set.null undef
183                     then return ()
184                     else mapM_ (failCheck (curModule context) . fail) undef
185
186 instance NetTransformable InstAST.NodeDecl NetAST.NetSpec where
187     transform context ast = do
188         let nodeId = InstAST.nodeId ast
189             nodeSpec = InstAST.nodeSpec ast
190             nodeContext = context
191                 { curNode = nodeId }
192         netNodeId <- transform context nodeId
193         netNodeSpec <- transform nodeContext nodeSpec
194         return $ Map.fromList [(netNodeId, netNodeSpec)]
195
196 instance NetTransformable InstAST.Identifier NetAST.NodeId where
197     transform context ast = do
198         let namespace = curNamespace context
199         return NetAST.NodeId
200             { NetAST.namespace = namespace
201             , NetAST.name      = ast
202             }
203
204 instance NetTransformable InstAST.NodeSpec NetAST.NodeSpec where
205     transform context ast = do
206         let
207             nodeType = InstAST.nodeType ast
208             accept = InstAST.accept ast
209             translate = InstAST.translate ast
210             reserved = InstAST.reserved ast
211             overlay = InstAST.overlay ast
212         netTranslate <- transform context translate
213         let
214             mapBlocks = map NetAST.srcBlock netTranslate
215             nodeContext = context
216                 { mappedBlocks = accept ++ mapBlocks ++ reserved }
217         netOverlay <- case overlay of
218                 Nothing -> return []
219                 Just o  -> transform nodeContext o
220         return NetAST.NodeSpec
221             { NetAST.nodeType  = nodeType
222             , NetAST.accept    = accept
223             , NetAST.translate = netTranslate ++ netOverlay
224             }
225
226 instance NetTransformable InstAST.MapSpec NetAST.MapSpec where
227     transform context ast = do
228         let
229             srcBlock = InstAST.srcBlock ast
230             destNode = InstAST.destNode ast
231             destBase = InstAST.destBase ast
232             errorContext = "tranlate set of node '" ++ curNode context ++ "'"
233         checkReference context (UndefinedReference errorContext) destNode
234         netDestNode <- transform context destNode
235         return NetAST.MapSpec
236             { NetAST.srcBlock = srcBlock
237             , NetAST.destNode = netDestNode
238             , NetAST.destBase = destBase
239             }
240
241 instance NetTransformable InstAST.OverlaySpec [NetAST.MapSpec] where
242     transform context ast = do
243         let
244             over = InstAST.over ast
245             width = InstAST.width ast
246             blocks = mappedBlocks context
247             errorContext = "overlay of node '" ++ curNode context ++ "'"
248         checkReference context (UndefinedReference errorContext) over
249         netOver <- transform context over
250         let maps = overlayMaps netOver width blocks
251         return maps
252
253 overlayMaps :: NetAST.NodeId -> Integer -> [NetAST.BlockSpec] -> [NetAST.MapSpec]
254 overlayMaps destId width blocks =
255     let
256         blockPoints = concat $ map toScanPoints blocks
257         maxAddress = 2^width
258         overStop  = BlockStart $ maxAddress
259         scanPoints = filter ((maxAddress >=) . address) $ sort (overStop:blockPoints)
260         startState = ScanLineState
261             { insideBlocks    = 0
262             , startAddress    = 0
263             }
264     in evalState (scanLine scanPoints []) startState
265     where
266         toScanPoints (NetAST.BlockSpec base limit) =
267                 [ BlockStart base
268                 , BlockEnd   limit
269                 ]
270         scanLine [] ms = return ms
271         scanLine (p:ps) ms = do
272             maps <- pointAction p ms
273             scanLine ps maps
274         pointAction (BlockStart a) ms = do
275             s <- get       
276             let
277                 i = insideBlocks s
278                 base = startAddress s
279                 limit = a - 1
280             maps <- if (i == 0) && (base <= limit)
281                 then
282                     let
283                         baseAddress = startAddress s
284                         limitAddress = a - 1
285                         srcBlock = NetAST.BlockSpec baseAddress limitAddress
286                         m = NetAST.MapSpec srcBlock destId baseAddress
287                     in return $ m:ms
288                 else return ms
289             modify (\s -> s { insideBlocks = i + 1})
290             return maps
291         pointAction (BlockEnd a) ms = do
292             s <- get
293             let
294                 i = insideBlocks s
295             put $ ScanLineState (i - 1) (a + 1)
296             return ms
297
298 data StoppingPoint
299     = BlockStart { address :: !NetAST.Address }
300     | BlockEnd   { address :: !NetAST.Address }
301     deriving (Eq, Show)
302
303 instance Ord StoppingPoint where
304     (<=) (BlockStart a1) (BlockEnd   a2)
305         | a1 == a2 = True
306         | otherwise = a1 <= a2
307     (<=) (BlockEnd   a1) (BlockStart a2)
308         | a1 == a2 = False
309         | otherwise = a1 <= a2
310     (<=) sp1 sp2 = (address sp1) <= (address sp2)
311
312 data ScanLineState
313     = ScanLineState
314         { insideBlocks :: !Integer
315         , startAddress :: !NetAST.Address
316         } deriving (Show)
317
318 instance (Traversable t, NetTransformable a b) => NetTransformable (t a)  (t b) where
319     transform context as = mapM (transform context) as
320
321 checkReference :: Context -> (String -> NetBuildFail) -> String -> (Checks NetBuildFail) ()
322 checkReference context fail name =
323     if name `Set.member` (nodes context)
324         then return ()
325         else failCheck (curModule context) (fail name)