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