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