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