Sockeye: Start reimplementing net builder on top of instantiator
[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 ( sockeyeBuildNet ) 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 NetBuildFails
41     = UndefinedOutPort   !String !String
42     | UndefinedInPort    !String !String
43     | UndefinedReference !String !String
44
45 instance Show NetBuildFails where
46     show (UndefinedInPort  inst port)    = concat ["Mapping to undefined input port '",   port, "' in module instantiation '", inst, "'"]
47     show (UndefinedOutPort inst port)    = concat ["Mapping to undefined output port '",  port, "' in module instantiation '", inst, "'"]
48     show (UndefinedReference decl ident) = concat ["Reference to undefined node '", ident, "' in declaration of node '", decl, "'"]
49
50 data Context = Context
51     { modules      :: Map String InstAST.Module
52     , curNamespace :: [String]
53     -- , inPortMaps   :: Map String NetAST.NodeId
54     -- , outPortMaps  :: Map String NetAST.NodeId
55     , mappedBlocks :: [InstAST.BlockSpec]
56     }
57
58 sockeyeBuildNet :: InstAST.SockeyeSpec -> Either (FailedChecks NetBuildFails) NetAST.NetSpec
59 sockeyeBuildNet ast = do
60     let
61         context = Context
62             { modules      = Map.empty
63             , curNamespace = []
64             -- , inPortMaps   = Map.empty
65             -- , outPortMaps  = Map.empty
66             , mappedBlocks = []
67             }        
68     net <- runChecks $ transform context ast
69     -- check Set.empty net
70     return net
71 --            
72 -- Build net
73 --
74 class NetTransformable a b where
75     transform :: Context -> a -> Checks NetBuildFails b
76
77 instance NetTransformable InstAST.SockeyeSpec NetAST.NetSpec where
78     transform context ast = do
79         let
80             rootInst = InstAST.root ast
81             mods = InstAST.modules ast
82             specContext = context
83                 { modules = mods }
84         transform specContext rootInst
85
86 instance NetTransformable InstAST.Module NetAST.NetSpec where
87     transform context ast = do
88         let inPorts = InstAST.inputPorts ast
89             outPorts = InstAST.outputPorts ast
90             nodeDecls = InstAST.nodeDecls ast
91             moduleInsts = InstAST.moduleInsts ast
92         -- inDecls <- transform context inPorts
93         -- outDecls <- transform context outPorts
94         -- TODO check mappings to non existing port
95         netDecls <- transform context nodeDecls
96         netInsts <- transform context moduleInsts
97         -- return $ concat (inDecls:outDecls:netDecls ++ netInsts)            
98         return $ Map.unions [netDecls, netInsts]
99
100 -- instance NetTransformable InstAST.Port NetList where
101 --     transform context (AST.MultiPort for) = do
102 --         netPorts <- transform context for
103 --         return $ concat (netPorts :: [NetList])
104 --     transform context (AST.InputPort portId portWidth) = do
105 --         netPortId <- transform context portId
106 --         let
107 --             portMap = inPortMaps context
108 --             name = NetAST.name netPortId
109 --             mappedId = Map.lookup name portMap
110 --         case mappedId of
111 --             Nothing    -> return []
112 --             Just ident -> do
113 --                 let
114 --                     node = portNode netPortId portWidth
115 --                 return [(ident, node)]
116 --     transform context (AST.OutputPort portId portWidth) = do
117 --         netPortId <- transform context portId
118 --         let
119 --             portMap = outPortMaps context
120 --             name = NetAST.name netPortId
121 --             mappedId = Map.lookup name portMap
122 --         case mappedId of
123 --             Nothing    -> return [(netPortId, portNodeTemplate)]
124 --             Just ident -> do
125 --                 let
126 --                     node = portNode ident portWidth
127 --                 return [(netPortId, node)]
128
129 -- portNode :: NetAST.NodeId -> Integer -> NetAST.NodeSpec
130 -- portNode destNode width =
131 --     let
132 --         base = NetAST.Address 0
133 --         limit = NetAST.Address $ 2^width - 1
134 --         srcBlock = NetAST.BlockSpec
135 --             { NetAST.base  = base
136 --             , NetAST.limit = limit
137 --             }
138 --         map = NetAST.MapSpec
139 --                 { NetAST.srcBlock = srcBlock
140 --                 , NetAST.destNode = destNode
141 --                 , NetAST.destBase = base
142 --                 }
143 --     in portNodeTemplate { NetAST.translate = [map] }
144
145 -- portNodeTemplate :: NetAST.NodeSpec
146 -- portNodeTemplate = NetAST.NodeSpec
147 --     { NetAST.nodeType  = NetAST.Other
148 --     , NetAST.accept    = []
149 --     , NetAST.translate = []
150 --     }
151
152 instance NetTransformable InstAST.ModuleInstMap NetAST.NetSpec where
153         transform context ast = do
154             let namespaces = Map.keys ast
155                 modInsts = Map.elems ast
156             let
157                 contexts = map addNamespace namespaces
158             netModInsts <- mapM (uncurry transform) $ zip contexts modInsts
159             return $ Map.unions netModInsts
160             where
161                 addNamespace n =
162                     let ns = curNamespace context
163                     in context
164                         { curNamespace = n:ns }
165
166
167 instance NetTransformable InstAST.ModuleInst NetAST.NetSpec where
168     transform context ast = do
169         let name = InstAST.moduleName ast
170             inPortMap = InstAST.inPortMap ast
171             outPortMap = InstAST.outPortMap ast
172             mod = getModule context name
173         -- netInMap <- transform context inPortMap
174         -- netOutMap <- transform context outPortMap
175         transform context mod
176
177 -- instance NetTransformable AST.PortMap PortMap where
178 --     transform context (AST.MultiPortMap for) = do
179 --         ts <- transform context for
180 --         return $ concat (ts :: [PortMap])
181 --     transform context ast = do
182 --         let
183 --             mappedId = AST.mappedId ast
184 --             mappedPort = AST.mappedPort ast
185 --         netMappedId <- transform context mappedId
186 --         netMappedPort <- transform context mappedPort
187 --         return [(NetAST.name netMappedPort, netMappedId)]
188
189 -- instance NetTransformable AST.ModuleArg Integer where
190 --     transform _ (AST.AddressArg value) = return value
191 --     transform _ (AST.NaturalArg value) = return value
192 --     transform context (AST.ParamArg name) = return $ getParamValue context name
193
194 instance NetTransformable InstAST.NodeDeclMap NetAST.NetSpec where
195     transform context ast = do
196         let
197             idents = Map.keys ast
198             nodeSpecs = Map.elems ast
199         netNodeIds <- transform context idents
200         netNodeSpec <- transform context nodeSpecs
201         return $ Map.fromList (zip netNodeIds netNodeSpec)
202
203 instance NetTransformable InstAST.Identifier NetAST.NodeId where
204     transform context ast = do
205         let
206             namespace = curNamespace context
207         return NetAST.NodeId
208             { NetAST.namespace = namespace
209             , NetAST.name      = ast
210             }
211
212 instance NetTransformable InstAST.NodeSpec NetAST.NodeSpec where
213     transform context ast = do
214         let
215             nodeType = InstAST.nodeType ast
216             accept = InstAST.accept ast
217             translate = InstAST.translate ast
218             reserved = InstAST.reserved ast
219             overlay = InstAST.overlay ast
220         netTranslate <- transform context translate
221         let
222             mapBlocks = map NetAST.srcBlock netTranslate
223             nodeContext = context
224                 { mappedBlocks = accept ++ mapBlocks ++ reserved }
225         netOverlay <- case overlay of
226                 Nothing -> return []
227                 Just o  -> transform nodeContext o
228         return NetAST.NodeSpec
229             { NetAST.nodeType  = nodeType
230             , NetAST.accept    = accept
231             , NetAST.translate = netTranslate ++ netOverlay
232             }
233
234 instance NetTransformable InstAST.MapSpec NetAST.MapSpec where
235     transform context ast = do
236         let
237             srcBlock = InstAST.srcBlock ast
238             destNode = InstAST.destNode ast
239             destBase = InstAST.destBase ast
240         netDestNode <- transform context destNode
241         return NetAST.MapSpec
242             { NetAST.srcBlock = srcBlock
243             , NetAST.destNode = netDestNode
244             , NetAST.destBase = destBase
245             }
246
247 instance NetTransformable InstAST.OverlaySpec [NetAST.MapSpec] where
248     transform context ast = do
249         let
250             over = InstAST.over ast
251             width = InstAST.width ast
252             blocks = mappedBlocks context
253         netOver <- transform context over
254         let
255             maps = overlayMaps netOver width blocks
256         return maps
257
258 overlayMaps :: NetAST.NodeId -> Integer -> [NetAST.BlockSpec] -> [NetAST.MapSpec]
259 overlayMaps destId width blocks =
260     let
261         blockPoints = concat $ map toScanPoints blocks
262         maxAddress = 2^width
263         overStop  = BlockStart $ maxAddress
264         scanPoints = filter ((maxAddress >=) . address) $ sort (overStop:blockPoints)
265         startState = ScanLineState
266             { insideBlocks    = 0
267             , startAddress    = 0
268             }
269     in evalState (scanLine scanPoints []) startState
270     where
271         toScanPoints (NetAST.BlockSpec base limit) =
272                 [ BlockStart base
273                 , BlockEnd   limit
274                 ]
275         scanLine [] ms = return ms
276         scanLine (p:ps) ms = do
277             maps <- pointAction p ms
278             scanLine ps maps
279         pointAction (BlockStart a) ms = do
280             s <- get       
281             let
282                 i = insideBlocks s
283                 base = startAddress s
284                 limit = a - 1
285             maps <- if (i == 0) && (base <= limit)
286                 then
287                     let
288                         baseAddress = startAddress s
289                         limitAddress = a - 1
290                         srcBlock = NetAST.BlockSpec baseAddress limitAddress
291                         m = NetAST.MapSpec srcBlock destId baseAddress
292                     in return $ m:ms
293                 else return ms
294             modify (\s -> s { insideBlocks = i + 1})
295             return maps
296         pointAction (BlockEnd a) ms = do
297             s <- get
298             let
299                 i = insideBlocks s
300             put $ ScanLineState (i - 1) (a + 1)
301             return ms
302
303 data StoppingPoint
304     = BlockStart { address :: !NetAST.Address }
305     | BlockEnd   { address :: !NetAST.Address }
306     deriving (Eq, Show)
307
308 instance Ord StoppingPoint where
309     (<=) (BlockStart a1) (BlockEnd   a2)
310         | a1 == a2 = True
311         | otherwise = a1 <= a2
312     (<=) (BlockEnd   a1) (BlockStart a2)
313         | a1 == a2 = False
314         | otherwise = a1 <= a2
315     (<=) sp1 sp2 = (address sp1) <= (address sp2)
316
317 data ScanLineState
318     = ScanLineState
319         { insideBlocks :: !Integer
320         , startAddress :: !NetAST.Address
321         } deriving (Show)
322
323 instance NetTransformable a b => NetTransformable [a] [b] where
324     transform context as = mapM (transform context) as
325
326 -- instance (Ord k, NetTransformable a b) => NetTransformable (Map k a) (Map k b) where
327 --     transform context ast = do
328 --         let
329 --             ks = Map.keys ast
330 --             es = Map.elems ast
331 --         ts <- transform context es
332 --         return $ Map.fromList (zip ks ts)
333
334 -- --
335 -- -- Checks
336 -- --
337 -- class NetCheckable a where
338 --     check :: Set NetAST.NodeId -> a -> Either CheckFailure ()
339
340 -- instance NetCheckable NetAST.NetSpec where
341 --     check _ (NetAST.NetSpec net) = do
342 --         let
343 --             specContext = Map.keysSet net
344 --         check specContext $ Map.elems net
345
346 -- instance NetCheckable NetAST.NodeSpec where
347 --     check context net = do
348 --         let
349 --             translate = NetAST.translate net
350 --         check context translate
351
352 -- instance NetCheckable NetAST.MapSpec where
353 --     check context net = do
354 --         let
355 --            destNode = NetAST.destNode net
356 --         check context destNode
357
358 -- instance NetCheckable NetAST.NodeId where
359 --     check context net = do
360 --         if net `Set.member` context
361 --             then return ()
362 --             else Left $ CheckFailure [UndefinedReference $ show net]
363
364 -- instance NetCheckable a => NetCheckable [a] where
365 --     check context net = do
366 --         let
367 --             checked = map (check context) net
368 --             fs = lefts $ checked
369 --         case fs of
370 --             [] -> return ()
371 --             _  -> Left $ CheckFailure (concat $ map failures fs)
372
373 getModule :: Context -> String -> InstAST.Module
374 getModule context name = (modules context) Map.! name