Sockeye: Start implementing port mappings
[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 Data.Either
24 import Data.List (nub, intersperse)
25 import Data.Map (Map)
26 import qualified Data.Map as Map
27 import Data.Maybe (fromMaybe, maybe)
28 import Data.Set (Set)
29 import qualified Data.Set as Set
30
31 import qualified SockeyeAST as AST
32 import qualified SockeyeASTDecodingNet as NetAST
33
34 type NetNodeDecl = (NetAST.NodeId, NetAST.NodeSpec)
35 type NetList = [NetNodeDecl]
36 type PortList = [NetAST.NodeId]
37 type PortMap = [(NetAST.NodeId, NetAST.NodeId)]
38
39 data FailedCheck
40     = UndefinedPort String String
41     | DuplicateIdentifer NetAST.NodeId
42     | UndefinedReference NetAST.NodeId
43
44 instance Show FailedCheck where
45     show (UndefinedPort modName name) = concat ["'", name, "' is not a port of module '", modName, "'"]
46     show (DuplicateIdentifer ident) = concat ["Multiple declarations of node '", show ident, "'"]
47     show (UndefinedReference ident) = concat ["Reference to undefined node '", show ident, "'"]
48
49 newtype CheckFailure = CheckFailure
50     { failures :: [FailedCheck] }
51
52 instance Show CheckFailure where
53     show (CheckFailure fs) = unlines $ map show fs
54
55 data Context = Context
56     { spec         :: AST.SockeyeSpec
57     , curNamespace :: NetAST.Namespace
58     , paramValues  :: Map String Word
59     , varValues    :: Map String Word
60     }
61
62 sockeyeBuildNet :: AST.SockeyeSpec -> Either CheckFailure NetAST.NetSpec
63 sockeyeBuildNet ast = do
64     let
65         emptySpec = AST.SockeyeSpec Map.empty
66         context = Context
67             { spec         = emptySpec
68             , curNamespace = NetAST.Namespace []
69             , paramValues  = Map.empty
70             , varValues    = Map.empty
71             }
72         net = transform context ast
73         nodeIds = map fst net
74     checkDuplicates nodeIds
75     let
76         nodeMap = Map.fromList net
77         symbols = Map.keysSet nodeMap
78         netSpec = NetAST.NetSpec $ nodeMap
79     check symbols netSpec
80     return netSpec
81
82 class NetTransformable a b where
83     transform :: Context -> a -> Either CheckFailure b
84
85 instance NetTransformable AST.SockeyeSpec NetList where
86     transform context ast = do
87         let
88             rootInst = AST.ModuleInst
89                 { AST.namespace  = AST.SimpleIdent ""
90                 , AST.moduleName = "@root"
91                 , AST.arguments  = Map.empty
92                 , AST.inPortMap  = []
93                 , AST.outPortMap = []
94                 }
95             specContext = context
96                 { spec = ast }
97         transform specContext rootInst
98
99 instance NetTransformable AST.Port PortList where
100     transform context (AST.MultiPort for) = transform context for
101     transform context (AST.Port ident) = do
102         let
103             netPort = transform context ident
104         return [netPort]
105
106 instance NetTransformable AST.ModuleInst NetList where
107     transform context (AST.MultiModuleInst for) = transform context for
108     transform context ast = do
109         let
110             namespace = AST.namespace ast
111             name = AST.moduleName ast
112             args = AST.arguments ast
113             mod = getModule context name
114             nodeDecls = AST.nodeDecls mod
115             modInsts = AST.moduleInsts mod
116         argValues <- transform context args
117         let
118             netNamespace = identToName context namespace
119             modContext = moduleContext netNamespace argValues
120         declNet = transform modContext nodeDecls
121         instNet <- transform modContext modInsts
122         return $ declNet ++ instNet
123         where
124             moduleContext namespace paramValues =
125                 let
126                     curNS = NetAST.ns $ curNamespace context
127                     newNS = case namespace of
128                         "" -> NetAST.Namespace curNS
129                         _  -> NetAST.Namespace $ namespace:curNS
130                 in context
131                     { curNamespace = newNS
132                     , paramValues  = paramValues
133                     , varValues    = Map.empty
134                     }
135
136 instance NetTransformable AST.PortMap PortMap where
137     transform context (AST.MultiPortMap for) = transform context for
138     transform context ast = do
139         let
140             mappedId = AST.mappedId ast
141             mappedPort = AST.mappedPort ast
142         netMappedId <- transform context mappedId
143         netMappedPort <- transform context mappedPort
144         return [(netMappedId, netMappedPort)]
145
146 instance NetTransformable AST.ModuleArg Word where
147     transform context (AST.AddressArg value) = return value
148     transform context (AST.NaturalArg value) = return value
149     transform context (AST.ParamArg name) = return $ getParamValue context name
150
151 instance NetTransformable AST.Identifier NetAST.NodeId where
152     transform context ast = do
153         let
154             namespace = curNamespace context
155             name = identToName context ast
156         return NetAST.NodeId
157             { NetAST.namespace = namespace
158             , NetAST.name      = name
159             }
160
161 instance NetTransformable AST.NodeDecl NetList where
162     transform context (AST.MultiNodeDecl for) = transform context for
163     transform context ast = do
164         let
165             ident = AST.nodeId ast
166             nodeSpec = AST.nodeSpec ast
167         nodeId <- transform context ident
168         netNodeSpec <- transform context nodeSpec
169         return [(nodeId, netNodeSpec)]
170
171 instance NetTransformable AST.NodeSpec NetAST.NodeSpec where
172     transform context ast = do
173         let
174             nodeType = AST.nodeType ast
175             accept = AST.accept ast
176             translate = AST.translate ast
177             overlay = AST.overlay ast
178         netNodeType <- maybe (return NetAST.Other) (transform context) nodeType
179         netAccept <- fmap (transform context) accept
180         netTranslate <- fmap (transform context) translate
181         netOverlay <- fmap (transform context) overlay
182         return NetAST.NodeSpec
183             { NetAST.nodeType  = netNodeType
184             , NetAST.accept    = netAccept
185             , NetAST.translate = netTranslate
186             , NetAST.overlay   = netOverlay
187             }
188
189 instance NetTransformable AST.NodeType NetAST.NodeType where
190     transform _ AST.Memory = return NetAST.Memory
191     transform _ AST.Device = return NetAST.Device
192
193 instance NetTransformable AST.BlockSpec NetAST.BlockSpec where
194     transform context (AST.SingletonBlock address) = do
195         netAddress <- transform context address
196         return NetAST.BlockSpec
197             { NetAST.base  = netAddress
198             , NetAST.limit = netAddress
199             }
200     transform context (AST.RangeBlock base limit) = do
201         netBase <- transform context base
202         netLimit <- transform context limit
203         return NetAST.BlockSpec
204             { NetAST.base  = netBase
205             , NetAST.limit = netLimit
206             }
207     transform context (AST.LengthBlock base bits) = do
208         netBase <- transform context base
209         let
210             baseAddress = NetAST.address netBase
211             limit = baseAddress + 2^bits - 1
212             netLimit = NetAST.Address limit
213         return NetAST.BlockSpec
214             { NetAST.base  = netBase
215             , NetAST.limit = netLimit
216             }
217
218 instance NetTransformable AST.MapSpec NetAST.MapSpec where
219     transform context ast = do
220         let
221             block = AST.block ast
222             destNode = AST.destNode ast
223             destBase = fromMaybe (AST.base block) (AST.destBase ast)
224         netBlock <- transform context block
225         netDestNode <- transform context destNode
226         netDestBase <- transform context destBase
227         return NetAST.MapSpec
228             { NetAST.srcBlock = netBlock
229             , NetAST.destNode = netDestNode
230             , NetAST.destBase = netDestBase
231             }
232
233 instance NetTransformable AST.Address NetAST.Address where
234     transform _ (AST.LiteralAddress value) = return NetAST.Address value
235     transform context (AST.ParamAddress name) = do
236         let
237             value = getParamValue context name
238         return $ NetAST.Address value
239
240 instance NetTransformable a [b] => NetTransformable (AST.For a) [b] where
241     transform context ast =
242         let
243             body = AST.body ast
244             varRanges = AST.varRanges ast
245             concreteRanges = Map.map (transform context) varRanges
246             valueList = Map.foldWithKey iterations [] concreteRanges
247             iterContexts = map iterationContext valueList
248         in concat $ map (\c -> transform c body) iterContexts
249         where
250             iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
251             iterations k vs ms = concat $ map (f ms k) vs
252                 where
253                     f ms k v = map (Map.insert k v) ms
254             iterationContext varMap =
255                 let
256                     values = varValues context
257                 in context
258                     { varValues = values `Map.union` varMap }
259
260 instance NetTransformable AST.ForRange [Word] where
261     transform context ast = do
262         let
263             start = AST.start ast
264             end = AST.end ast
265         startVal <- transform context start
266         endVal <- transform context end
267         return [startVal..endVal]
268
269 instance NetTransformable AST.ForLimit Word where
270     transform _ (AST.LiteralLimit value) = return value
271     transform context (AST.ParamLimit name) = return $ getParamValue context name
272
273 instance NetTransformable a b => NetTransformable (Map k a) (Map k b) where
274     transform context ast = Map.map (transform context) ast
275
276 instance NetTransformable a [b] => NetTransformable [a] [b] where
277     transform context ast = concat $ map (transform context) ast
278
279 class NetCheckable a where
280     check :: Set NetAST.NodeId -> a -> Either CheckFailure ()
281
282 instance NetCheckable NetAST.NetSpec where
283     check context (NetAST.NetSpec net) = do
284         check context $ Map.elems net
285
286 instance NetCheckable NetAST.NodeSpec where
287     check context (NetAST.AliasSpec alias) = do
288         case alias of
289             Nothing -> return ()
290             Just ident -> check context ident
291     check context net = do
292         let
293             translate = NetAST.translate net
294             overlay = NetAST.overlay net
295         check context translate
296         maybe (return ()) (check context) overlay
297
298 instance NetCheckable NetAST.MapSpec where
299     check context net = do
300         let
301            destNode = NetAST.destNode net
302         check context destNode
303
304 instance NetCheckable NetAST.NodeId where
305     check context net = do
306         if net `Set.member` context
307             then return ()
308             else Left $ CheckFailure [UndefinedReference net]
309
310 instance NetCheckable a => NetCheckable [a] where
311     check context net = do
312         let
313             checked = map (check context) net
314             fs = lefts $ checked
315         case fs of
316             [] -> return ()
317             _  -> Left $ CheckFailure (concat $ map failures fs)
318
319 getModule :: Context -> String -> AST.Module
320 getModule context name =
321     let
322         modules = AST.modules $ spec context
323     in modules Map.! name
324
325 getParamValue :: Context -> String -> Word
326 getParamValue context name =
327     let
328         params = paramValues context
329     in params Map.! name
330
331 getVarValue :: Context -> String -> Word
332 getVarValue context name =
333     let
334         vars = varValues context
335     in vars Map.! name
336
337 identToName :: Context -> AST.Identifier -> String
338 identToName _ (AST.SimpleIdent name) = name
339 identToName context ident =
340     let
341         prefix = AST.prefix ident
342         varName = AST.varName ident
343         suffix = AST.suffix ident
344         varValue = show $ getVarValue context varName
345         suffixName = case suffix of
346             Nothing -> ""
347             Just s  -> identToName context s
348     in prefix ++ varValue ++ suffixName
349
350 checkDuplicates :: [NetAST.NodeId] -> Either CheckFailure ()
351 checkDuplicates nodeIds = do
352     let
353         duplicates = duplicateNames nodeIds
354     case duplicates of
355         [] -> return ()
356         _  -> Left $ CheckFailure (map DuplicateIdentifer duplicates)
357     where
358         duplicateNames [] = []
359         duplicateNames (x:xs)
360             | x `elem` xs = nub $ [x] ++ duplicateNames xs
361             | otherwise = duplicateNames xs
362         msg (NetAST.NodeId namespace name) =
363             let
364                 m = concat ["Multiple declarations of node '", name, "'"]
365             in case NetAST.ns namespace of
366                 [] -> m
367                 _  -> m ++ concat [" in namespace '", show namespace, "'"]