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