be504c5764cc5523685d7b3320871c0d8ffa8f95
[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)
27 import Data.Map (Map)
28 import qualified Data.Map as Map
29 import Data.Maybe (fromMaybe, maybe)
30 import Data.Set (Set)
31 import qualified Data.Set as Set
32
33 import Numeric (showHex)
34
35 import qualified SockeyeAST as AST
36 import qualified SockeyeASTDecodingNet as NetAST
37
38 import Text.Groom (groom)
39 import Debug.Trace
40
41 type NetNodeDecl = (NetAST.NodeId, NetAST.NodeSpec)
42 type NetList = [NetNodeDecl]
43 type PortList = [NetAST.NodeId]
44 type PortMap = [(NetAST.NodeId, NetAST.NodeId)]
45
46 data FailedCheck
47     = ModuleInstLoop [String]
48     | DuplicateInPort String NetAST.NodeId
49     | UndefinedInPort String NetAST.NodeId
50     | DuplicateOutPort String NetAST.NodeId
51     | UndefinedOutPort String NetAST.NodeId
52     | DuplicateIdentifer NetAST.NodeId
53     | UndefinedReference NetAST.NodeId
54
55 instance Show FailedCheck where
56     show (ModuleInstLoop loop) = concat ["Module instantiation loop :'", intercalate "' -> '" $ loop, "'"]
57     show (DuplicateInPort  modName ident) = concat ["Multiple declarations of input port '", NetAST.name ident, "' in '", modName, "'"]
58     show (UndefinedInPort  modName ident) = concat ["'", NetAST.name ident, "' is not an input port in '", modName, "'"]
59     show (DuplicateOutPort modName ident) = concat ["Multiple declarations of output port '", NetAST.name ident, "' in '", modName, "'"]
60     show (UndefinedOutPort modName ident) = concat ["'", NetAST.name ident, "' is not an output port in '", modName, "'"]
61     show (DuplicateIdentifer ident)   = concat ["Multiple declarations of node '", show ident, "'"]
62     show (UndefinedReference ident)   = concat ["Reference to undefined node '", show ident, "'"]
63
64 newtype CheckFailure = CheckFailure
65     { failures :: [FailedCheck] }
66
67 instance Show CheckFailure where
68     show (CheckFailure fs) = unlines $ "":(map show fs)
69
70 data Context = Context
71     { spec         :: AST.SockeyeSpec
72     , modulePath   :: [String]
73     , curNamespace :: NetAST.Namespace
74     , paramValues  :: Map String Word
75     , varValues    :: Map String Word
76     }
77
78 sockeyeBuildNet :: AST.SockeyeSpec -> Either CheckFailure NetAST.NetSpec
79 sockeyeBuildNet ast = do
80     let
81         context = Context
82             { spec         = AST.SockeyeSpec Map.empty
83             , modulePath   = []
84             , curNamespace = NetAST.Namespace []
85             , paramValues  = Map.empty
86             , varValues    = Map.empty
87             }        
88     net <- transform context ast
89     trace (groom net) $ return ()
90     check Set.empty net
91     return net
92 --            
93 -- Build net
94 --
95 class NetTransformable a b where
96     transform :: Context -> a -> Either CheckFailure b
97
98 instance NetTransformable AST.SockeyeSpec NetAST.NetSpec where
99     transform context ast = do
100         let
101             rootInst = AST.ModuleInst
102                 { AST.namespace  = AST.SimpleIdent ""
103                 , AST.moduleName = "@root"
104                 , AST.arguments  = Map.empty
105                 , AST.inPortMap  = []
106                 , AST.outPortMap = []
107                 }
108             specContext = context
109                 { spec = ast }
110         netList <- transform specContext rootInst
111         let
112             nodeIds = map fst netList
113         checkDuplicates nodeIds DuplicateIdentifer
114         let
115             nodeMap = Map.fromList netList
116         return $ NetAST.NetSpec nodeMap
117
118 instance NetTransformable AST.Module NetList where
119     transform context ast = do
120         let
121             inPorts = AST.inputPorts ast
122             outPorts = AST.outputPorts ast
123             nodeDecls = AST.nodeDecls ast
124             moduleInsts = AST.moduleInsts ast
125             name = last $ modulePath context
126         -- checkDuplicates inPorts $ DuplicateInPort name
127         -- checkDuplicates outPorts $ DuplicateOutPort name
128         netDecls <- transform context nodeDecls
129         netInsts <- transform context moduleInsts
130         return $ concat (netDecls ++ netInsts :: [NetList])
131
132 instance NetTransformable AST.ModuleInst NetList where
133     transform context (AST.MultiModuleInst for) = do
134         net <- transform context for
135         return $ concat (net :: [NetList])
136     transform context ast = do
137         let
138             namespace = AST.namespace ast
139             name = AST.moduleName ast
140             args = AST.arguments ast
141             inPortMap = AST.inPortMap ast
142             outPortMap = AST.outPortMap ast
143             mod = getModule context name
144         checkSelfInst name
145         netNamespace <- transform context namespace
146         netArgs <- transform context args
147         let
148             modContext = moduleContext name netNamespace netArgs
149         transform modContext mod
150             where
151                 moduleContext name namespace args =
152                     let
153                         path = modulePath context
154                         base = NetAST.ns $ NetAST.namespace namespace
155                         newNs = case NetAST.name namespace of
156                             "" -> NetAST.Namespace base
157                             n  -> NetAST.Namespace $ n:base
158                     in context
159                         { modulePath   = name:path
160                         , curNamespace = newNs
161                         , paramValues  = args
162                         , varValues    = Map.empty
163                         }
164                 checkSelfInst name = do
165                     let
166                         path = modulePath context
167                     case loop path of
168                         [] -> return ()
169                         l  -> Left $ CheckFailure [ModuleInstLoop (reverse $ name:l)]
170                         where
171                             loop [] = []
172                             loop path@(p:ps)
173                                 | name `elem` path = p:(loop ps)
174                                 | otherwise = []
175
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 [(netMappedId, netMappedPort)]
188
189 instance NetTransformable AST.ModuleArg Word where
190     transform context (AST.AddressArg value) = return value
191     transform context (AST.NaturalArg value) = return value
192     transform context (AST.ParamArg name) = return $ getParamValue context name
193
194 instance NetTransformable AST.Identifier NetAST.NodeId where
195     transform context ast = do
196         let
197             namespace = curNamespace context
198             name = identName ast
199         return NetAST.NodeId
200             { NetAST.namespace = namespace
201             , NetAST.name      = name
202             }
203             where
204                 identName (AST.SimpleIdent name) = name
205                 identName ident =
206                     let
207                         prefix = AST.prefix ident
208                         varName = AST.varName ident
209                         suffix = AST.suffix ident
210                         varValue = show $ getVarValue context varName
211                         suffixName = case suffix of
212                             Nothing -> ""
213                             Just s  -> identName s
214                     in prefix ++ varValue ++ suffixName
215
216 instance NetTransformable AST.NodeDecl NetList where
217     transform context (AST.MultiNodeDecl for) = do
218         ts <- transform context for
219         return $ concat (ts :: [NetList])
220     transform context ast = do
221         let
222             ident = AST.nodeId ast
223             nodeSpec = AST.nodeSpec ast
224         nodeId <- transform context ident
225         netNodeSpec <- transform context nodeSpec
226         return [(nodeId, netNodeSpec)]
227
228 instance NetTransformable AST.NodeSpec NetAST.NodeSpec where
229     transform context ast = do
230         let
231             nodeType = AST.nodeType ast
232             accept = AST.accept ast
233             translate = AST.translate ast
234             overlay = AST.overlay ast
235         netNodeType <- maybe (return NetAST.Other) (transform context) nodeType
236         netAccept <- transform context accept
237         netTranslate <- transform context translate
238         netOverlay <- case overlay of
239                 Nothing -> return Nothing
240                 Just o  -> do 
241                     t <- transform context o
242                     return $ Just t
243         return NetAST.NodeSpec
244             { NetAST.nodeType  = netNodeType
245             , NetAST.accept    = netAccept
246             , NetAST.translate = netTranslate
247             , NetAST.overlay   = netOverlay
248             }
249
250 instance NetTransformable AST.NodeType NetAST.NodeType where
251     transform _ AST.Memory = return NetAST.Memory
252     transform _ AST.Device = return NetAST.Device
253
254 instance NetTransformable AST.BlockSpec NetAST.BlockSpec where
255     transform context (AST.SingletonBlock address) = do
256         netAddress <- transform context address
257         return NetAST.BlockSpec
258             { NetAST.base  = netAddress
259             , NetAST.limit = netAddress
260             }
261     transform context (AST.RangeBlock base limit) = do
262         netBase <- transform context base
263         netLimit <- transform context limit
264         return NetAST.BlockSpec
265             { NetAST.base  = netBase
266             , NetAST.limit = netLimit
267             }
268     transform context (AST.LengthBlock base bits) = do
269         netBase <- transform context base
270         let
271             baseAddress = NetAST.address netBase
272             limit = baseAddress + 2^bits - 1
273             netLimit = NetAST.Address limit
274         return NetAST.BlockSpec
275             { NetAST.base  = netBase
276             , NetAST.limit = netLimit
277             }
278
279 instance NetTransformable AST.MapSpec NetAST.MapSpec where
280     transform context ast = do
281         let
282             block = AST.block ast
283             destNode = AST.destNode ast
284             destBase = fromMaybe (AST.base block) (AST.destBase ast)
285         netBlock <- transform context block
286         netDestNode <- transform context destNode
287         netDestBase <- transform context destBase
288         return NetAST.MapSpec
289             { NetAST.srcBlock = netBlock
290             , NetAST.destNode = netDestNode
291             , NetAST.destBase = netDestBase
292             }
293
294 instance NetTransformable AST.Address NetAST.Address where
295     transform _ (AST.LiteralAddress value) = do
296         return $ NetAST.Address value
297     transform context (AST.ParamAddress name) = do
298         let
299             value = getParamValue context name
300         return $ NetAST.Address value
301
302 instance NetTransformable a b => NetTransformable (AST.For a) [b] where
303     transform context ast = do
304         let
305             body = AST.body ast
306             varRanges = AST.varRanges ast
307         concreteRanges <- transform context varRanges
308         let
309             valueList = Map.foldWithKey iterations [] concreteRanges
310             iterContexts = map iterationContext valueList
311             ts = map (\c -> transform c body) iterContexts
312             fs = lefts ts
313             bs = rights ts
314         case fs of
315             [] -> return $ bs
316             _  -> Left $ CheckFailure (concat $ map failures fs)
317         where
318             iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
319             iterations k vs ms = concat $ map (f ms k) vs
320                 where
321                     f ms k v = map (Map.insert k v) ms
322             iterationContext varMap =
323                 let
324                     values = varValues context
325                 in context
326                     { varValues = values `Map.union` varMap }
327
328 instance NetTransformable AST.ForRange [Word] where
329     transform context ast = do
330         let
331             start = AST.start ast
332             end = AST.end ast
333         startVal <- transform context start
334         endVal <- transform context end
335         return [startVal..endVal]
336
337 instance NetTransformable AST.ForLimit Word where
338     transform _ (AST.LiteralLimit value) = return value
339     transform context (AST.ParamLimit name) = return $ getParamValue context name
340
341 instance NetTransformable a b => NetTransformable [a] [b] where
342     transform context ast = do
343         let
344             ts = map (transform context) ast
345             fs = lefts ts
346             bs = rights ts
347         case fs of
348             [] -> return bs
349             _  -> Left $ CheckFailure (concat $ map failures fs)
350
351 instance (Ord k, NetTransformable a b) => NetTransformable (Map k a) (Map k b) where
352     transform context ast = do
353         let
354             ks = Map.keys ast
355             es = Map.elems ast
356         ts <- transform context es
357         return $ Map.fromList (zip ks ts)
358
359 --
360 -- Checks
361 --
362 class NetCheckable a where
363     check :: Set NetAST.NodeId -> a -> Either CheckFailure ()
364
365 instance NetCheckable NetAST.NetSpec where
366     check context (NetAST.NetSpec net) = do
367         let
368             specContext = Map.keysSet net
369         check specContext $ Map.elems net
370
371 instance NetCheckable NetAST.NodeSpec where
372     check context (NetAST.AliasSpec alias) = do
373         case alias of
374             Nothing -> return ()
375             Just ident -> check context ident
376     check context net = do
377         let
378             translate = NetAST.translate net
379             overlay = NetAST.overlay net
380         check context translate
381         maybe (return ()) (check context) overlay
382
383 instance NetCheckable NetAST.MapSpec where
384     check context net = do
385         let
386            destNode = NetAST.destNode net
387         check context destNode
388
389 instance NetCheckable NetAST.NodeId where
390     check context net = do
391         if net `Set.member` context
392             then return ()
393             else Left $ CheckFailure [UndefinedReference net]
394
395 instance NetCheckable a => NetCheckable [a] where
396     check context net = do
397         let
398             checked = map (check context) net
399             fs = lefts $ checked
400         case fs of
401             [] -> return ()
402             _  -> Left $ CheckFailure (concat $ map failures fs)
403
404 getModule :: Context -> String -> AST.Module
405 getModule context name =
406     let
407         modules = AST.modules $ spec context
408     in modules Map.! name
409
410 getParamValue :: Context -> String -> Word
411 getParamValue context name =
412     let
413         params = paramValues context
414     in params Map.! name
415
416 getVarValue :: Context -> String -> Word
417 getVarValue context name =
418     let
419         vars = varValues context
420     in vars Map.! name
421
422 checkDuplicates :: [NetAST.NodeId] -> (NetAST.NodeId -> FailedCheck) -> Either CheckFailure ()
423 checkDuplicates nodeIds fail = do
424     let
425         duplicates = duplicateNames nodeIds
426     case duplicates of
427         [] -> return ()
428         _  -> Left $ CheckFailure (map fail duplicates)
429     where
430         duplicateNames [] = []
431         duplicateNames (x:xs)
432             | x `elem` xs = nub $ [x] ++ duplicateNames xs
433             | otherwise = duplicateNames xs