Sockeye: Start implementing new simplification approach for 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 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     = DuplicateInPort AST.ModuleInst NetAST.NodeId
48     | UndefinedInPort AST.ModuleInst NetAST.NodeId
49     | DuplicateOutPort AST.ModuleInst NetAST.NodeId
50     | UndefinedOutPort AST.ModuleInst NetAST.NodeId
51     | DuplicateIdentifer NetAST.NodeId
52     | UndefinedReference NetAST.NodeId
53
54 instance Show FailedCheck where
55     show (DuplicateInPort modInst ident) = concat ["Multiple declarations of input port '", NetAST.name ident, "' in '", show modInst, "'"]
56     show (UndefinedInPort modInst ident) = concat ["'", NetAST.name ident, "' is not an input port in '", show modInst, "'"]
57     show (DuplicateOutPort modInst ident) = concat ["Multiple declarations of output port '", NetAST.name ident, "' in '", show modInst, "'"]
58     show (UndefinedOutPort modInst ident) = concat ["'", NetAST.name ident, "' is not an output port in '", show modInst, "'"]
59     show (DuplicateIdentifer ident)   = concat ["Multiple declarations of node '", show ident, "'"]
60     show (UndefinedReference ident)   = concat ["Reference to undefined node '", show ident, "'"]
61
62 newtype CheckFailure = CheckFailure
63     { failures :: [FailedCheck] }
64
65 instance Show CheckFailure where
66     show (CheckFailure fs) = unlines $ map show fs
67
68 data Context = Context
69     { spec         :: AST.SockeyeSpec
70     , curNamespace :: NetAST.Namespace
71     , paramValues  :: Map String Word
72     , varValues    :: Map String Word
73     }
74
75 sockeyeBuildNet :: AST.SockeyeSpec -> Either CheckFailure NetAST.NetSpec
76 sockeyeBuildNet ast = do
77     let
78         context = Context
79             { spec         = ast
80             , curNamespace = NetAST.Namespace []
81             , paramValues  = Map.empty
82             , varValues    = Map.empty
83             }
84         emptySpec = AST.SockeyeSpec Map.empty
85         rootInst = AST.ModuleInst
86             { AST.namespace  = AST.SimpleIdent ""
87             , AST.moduleName = "@root"
88             , AST.arguments  = Map.empty
89             , AST.inPortMap  = []
90             , AST.outPortMap = []
91             }
92         (netRoots, simpleAST) = runState (simplify context rootInst) emptySpec
93     traceShow (groom (netRoots :: [AST.ModuleInst])) $ return ()
94     traceShow (groom simpleAST) $ return ()
95     return NetAST.NetSpec
96         { NetAST.net = Map.empty }
97     -- let
98     --     nodeIds = map fst net
99     -- checkDuplicates nodeIds DuplicateIdentifer
100     -- let
101     --     nodeMap = Map.fromList net
102     --     symbols = Map.keysSet nodeMap
103     --     netSpec = NetAST.NetSpec $ nodeMap
104     -- check symbols netSpec
105     -- return netSpec
106
107 --
108 -- Simplify AST (instantiate module templates, expand for constructs)
109 --
110 class ASTSimplifiable a b where
111     simplify :: Context -> a -> State AST.SockeyeSpec b
112
113 instance ASTSimplifiable AST.ModuleInst [AST.ModuleInst] where
114     simplify context (AST.MultiModuleInst for) = do 
115         simpleFor <- simplify context for
116         return $ concat (simpleFor :: [[AST.ModuleInst]])
117     simplify context ast = do
118         let
119             namespace = AST.namespace ast
120             name = AST.moduleName ast
121             args = AST.arguments ast
122             inPortMap = AST.inPortMap ast
123             outPortMap = AST.outPortMap ast
124             mod = getModule context name
125         simpleNS <- simplify context namespace
126         simpleInMap <- simplify context inPortMap
127         simpleOutMap <- simplify context outPortMap
128         simpleArgs <- simplify context args
129         simpleModule <- simplify (moduleContext simpleArgs) mod
130         let
131             simpleName = concat [name, " (", intercalate ", " $ argValues simpleArgs mod, ")"]
132             simplified = AST.ModuleInst
133                 { AST.namespace = simpleNS
134                 , AST.moduleName = simpleName
135                 , AST.arguments = Map.empty
136                 , AST.inPortMap = concat (simpleInMap :: [[AST.PortMap]])
137                 , AST.outPortMap = concat (simpleOutMap :: [[AST.PortMap]])
138                 }
139         modify $ addModule simpleName simpleModule
140         return [simplified]
141         where
142             moduleContext paramValues = context
143                     { paramValues = paramValues
144                     , varValues   = Map.empty
145                     }
146             argValues args mod =
147                 let
148                     paramNames = AST.paramNames mod
149                     paramTypes = AST.paramTypeMap mod
150                     params = map (\p -> (p, paramTypes Map.! p)) paramNames
151                 in map showValue params
152                     where
153                         showValue (name, AST.AddressParam)  = "0x" ++ showHex (args Map.! name) ""
154                         showValue (name, AST.NaturalParam) = show (args Map.! name)
155             addModule k m spec =
156                 let
157                     prevMods = AST.modules spec
158                     newMods = Map.insert k m prevMods
159                 in spec
160                     { AST.modules = newMods }
161
162 instance ASTSimplifiable AST.ModuleArg Word where
163     simplify _ (AST.AddressArg v) = return v
164     simplify _ (AST.NaturalArg v) = return v
165     simplify context (AST.ParamArg name) = return $ getParamValue context name
166
167 instance ASTSimplifiable AST.PortMap [AST.PortMap] where
168     simplify context (AST.MultiPortMap for) = do
169         simpleFor <- simplify context for
170         return $ concat (simpleFor :: [[AST.PortMap]])
171     simplify context ast = do
172         let
173             mappedId = AST.mappedId ast
174             mappedPort = AST.mappedPort ast
175         simpleId <- simplify context mappedId
176         simplePort <- simplify context mappedPort
177         let
178             simplePortMap = AST.PortMap
179                 { AST.mappedId   = simpleId
180                 , AST.mappedPort = simplePort
181                 }
182         return [simplePortMap]
183
184 instance ASTSimplifiable AST.NodeDecl [AST.NodeDecl] where
185     simplify context (AST.MultiNodeDecl for) = do
186         simpleFor <- simplify context for
187         return $ concat (simpleFor :: [[AST.NodeDecl]])
188     simplify context ast = do
189         let
190             nodeId = AST.nodeId ast
191             nodeSpec = AST.nodeSpec ast
192         simpleNodeId <- simplify context nodeId
193         simpleNodeSpec <- simplify context nodeSpec
194         let
195             simpleNodeDecl = AST.NodeDecl
196                 { AST.nodeId   = simpleNodeId
197                 , AST.nodeSpec = simpleNodeSpec
198                 }
199         return [simpleNodeDecl]
200
201 instance ASTSimplifiable AST.Identifier AST.Identifier where
202     simplify context ast = do
203         let
204             name = simpleName ast
205         return $ AST.SimpleIdent name
206         where
207             simpleName (AST.SimpleIdent name) = name
208             simpleName ident =
209                 let
210                     prefix = AST.prefix ident
211                     varName = AST.varName ident
212                     suffix = AST.suffix ident
213                     varValue = show $ getVarValue context varName
214                     suffixName = case suffix of
215                         Nothing -> ""
216                         Just s  -> simpleName s
217                 in prefix ++ varValue ++ suffixName
218
219 instance ASTSimplifiable a b => ASTSimplifiable (AST.For a) [b] where
220     simplify context ast = do
221         let
222             body = AST.body ast
223             varRanges = AST.varRanges ast
224         concreteRanges <- simplify context varRanges
225         let
226             valueList = Map.foldWithKey iterations [] concreteRanges
227             iterContexts = map iterationContext valueList
228         mapM (\c -> simplify c body) iterContexts
229             where
230                 iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
231                 iterations k vs ms = concat $ map (f ms k) vs
232                     where
233                         f ms k v = map (Map.insert k v) ms
234                 iterationContext varMap =
235                     let
236                         values = varValues context
237                     in context
238                         { varValues = values `Map.union` varMap }
239
240 instance ASTSimplifiable AST.ForRange [Word] where
241     simplify context ast = do
242         let
243             start = AST.start ast
244             end = AST.end ast
245         simpleStart <- simplify context start
246         simpleEnd <- simplify context end
247         return [simpleStart..simpleEnd]
248
249 instance ASTSimplifiable AST.ForLimit Word where
250     simplify _ (AST.LiteralLimit value) = return value
251     simplify context (AST.ParamLimit name) = return $ getParamValue context name
252
253 instance ASTSimplifiable a b => ASTSimplifiable [a] [b] where
254     simplify context ast = mapM (simplify context) ast
255
256 instance (Ord k, ASTSimplifiable a b) => ASTSimplifiable (Map k a) (Map k b) where
257     simplify context ast = do
258         let
259             ks = Map.keys ast
260             es = Map.elems ast
261         ts <- simplify context es
262         return $ Map.fromList (zip ks ts)
263
264 --            
265 -- Build net
266 --
267 -- class NetTransformable a b where
268 --     transform :: Context -> a -> Either CheckFailure b
269
270 -- instance NetTransformable AST.SockeyeSpec NetList where
271 --     transform context ast = do
272 --         let
273 --             rootInst = AST.ModuleInst
274 --                 { AST.namespace  = AST.SimpleIdent ""
275 --                 , AST.moduleName = "@root"
276 --                 , AST.arguments  = Map.empty
277 --                 , AST.inPortMap  = []
278 --                 , AST.outPortMap = []
279 --                 }
280 --             specContext = context
281 --                 { spec = ast }
282 --         transform specContext rootInst
283
284 -- instance NetTransformable AST.Port PortList where
285 --     transform context (AST.MultiPort for) = do
286 --         ts <- transform context for
287 --         return $ concat (ts :: [PortList])
288 --     transform context (AST.Port ident) = do
289 --         netPort <- transform context ident
290 --         return [netPort]
291
292 -- instance NetTransformable AST.ModuleInst NetList where
293 --     transform context (AST.MultiModuleInst for) = do
294 --         ts <- transform context for
295 --         return $ concat (ts :: [NetList])
296 --     transform context ast = do
297 --         let
298 --             namespace = AST.namespace ast
299 --             name = AST.moduleName ast
300 --             args = AST.arguments ast
301 --             inPortMap = AST.inPortMap ast
302 --             outPortMap = AST.outPortMap ast
303 --             mod = getModule context name
304 --             inPorts = AST.inputPorts mod
305 --             outPorts = AST.outputPorts mod
306 --             nodeDecls = AST.nodeDecls mod
307 --             modInsts = AST.moduleInsts mod
308 --         argValues <- transform context args
309 --         let
310 --             netNamespace = identToName context namespace
311 --             modContext = moduleContext netNamespace argValues
312 --         netInPorts <- do
313 --             ts <- transform modContext inPorts
314 --             return $ concat (ts :: [PortList])
315 --         netOutPorts <- do
316 --             ts <- transform modContext outPorts
317 --             return $ concat (ts :: [PortList])
318 --         checkDuplicates netInPorts (DuplicateInPort ast)
319 --         checkDuplicates netOutPorts (DuplicateOutPort ast)
320 --         declNet <- transform modContext nodeDecls
321 --         instNet <- transform modContext modInsts
322 --         return . concat $ declNet ++ instNet
323 --         where
324 --             moduleContext namespace paramValues =
325 --                 let
326 --                     curNS = NetAST.ns $ curNamespace context
327 --                     newNS = case namespace of
328 --                         "" -> NetAST.Namespace curNS
329 --                         _  -> NetAST.Namespace $ namespace:curNS
330 --                 in context
331 --                     { curNamespace = newNS
332 --                     , paramValues  = paramValues
333 --                     , varValues    = Map.empty
334 --                     }
335
336 -- instance NetTransformable AST.PortMap PortMap where
337 --     transform context (AST.MultiPortMap for) = do
338 --         ts <- transform context for
339 --         return $ concat (ts :: [PortMap])
340 --     transform context ast = do
341 --         let
342 --             mappedId = AST.mappedId ast
343 --             mappedPort = AST.mappedPort ast
344 --         netMappedId <- transform context mappedId
345 --         netMappedPort <- transform context mappedPort
346 --         return [(netMappedId, netMappedPort)]
347
348 -- instance NetTransformable AST.ModuleArg Word where
349 --     transform context (AST.AddressArg value) = return value
350 --     transform context (AST.NaturalArg value) = return value
351 --     transform context (AST.ParamArg name) = return $ getParamValue context name
352
353 -- instance NetTransformable AST.Identifier NetAST.NodeId where
354 --     transform context ast = do
355 --         let
356 --             namespace = curNamespace context
357 --             name = identToName context ast
358 --         return NetAST.NodeId
359 --             { NetAST.namespace = namespace
360 --             , NetAST.name      = name
361 --             }
362
363 -- instance NetTransformable AST.NodeDecl NetList where
364 --     transform context (AST.MultiNodeDecl for) = do
365 --         ts <- transform context for
366 --         return $ concat (ts :: [NetList])
367 --     transform context ast = do
368 --         let
369 --             ident = AST.nodeId ast
370 --             nodeSpec = AST.nodeSpec ast
371 --         nodeId <- transform context ident
372 --         netNodeSpec <- transform context nodeSpec
373 --         return [(nodeId, netNodeSpec)]
374
375 -- instance NetTransformable AST.NodeSpec NetAST.NodeSpec where
376 --     transform context ast = do
377 --         let
378 --             nodeType = AST.nodeType ast
379 --             accept = AST.accept ast
380 --             translate = AST.translate ast
381 --             overlay = AST.overlay ast
382 --         netNodeType <- maybe (return NetAST.Other) (transform context) nodeType
383 --         netAccept <- transform context accept
384 --         netTranslate <- transform context translate
385 --         netOverlay <- case overlay of
386 --                 Nothing -> return Nothing
387 --                 Just o  -> do 
388 --                     t <- transform context o
389 --                     return $ Just t
390 --         return NetAST.NodeSpec
391 --             { NetAST.nodeType  = netNodeType
392 --             , NetAST.accept    = netAccept
393 --             , NetAST.translate = netTranslate
394 --             , NetAST.overlay   = netOverlay
395 --             }
396
397 -- instance NetTransformable AST.NodeType NetAST.NodeType where
398 --     transform _ AST.Memory = return NetAST.Memory
399 --     transform _ AST.Device = return NetAST.Device
400
401 -- instance NetTransformable AST.BlockSpec NetAST.BlockSpec where
402 --     transform context (AST.SingletonBlock address) = do
403 --         netAddress <- transform context address
404 --         return NetAST.BlockSpec
405 --             { NetAST.base  = netAddress
406 --             , NetAST.limit = netAddress
407 --             }
408 --     transform context (AST.RangeBlock base limit) = do
409 --         netBase <- transform context base
410 --         netLimit <- transform context limit
411 --         return NetAST.BlockSpec
412 --             { NetAST.base  = netBase
413 --             , NetAST.limit = netLimit
414 --             }
415 --     transform context (AST.LengthBlock base bits) = do
416 --         netBase <- transform context base
417 --         let
418 --             baseAddress = NetAST.address netBase
419 --             limit = baseAddress + 2^bits - 1
420 --             netLimit = NetAST.Address limit
421 --         return NetAST.BlockSpec
422 --             { NetAST.base  = netBase
423 --             , NetAST.limit = netLimit
424 --             }
425
426 -- instance NetTransformable AST.MapSpec NetAST.MapSpec where
427 --     transform context ast = do
428 --         let
429 --             block = AST.block ast
430 --             destNode = AST.destNode ast
431 --             destBase = fromMaybe (AST.base block) (AST.destBase ast)
432 --         netBlock <- transform context block
433 --         netDestNode <- transform context destNode
434 --         netDestBase <- transform context destBase
435 --         return NetAST.MapSpec
436 --             { NetAST.srcBlock = netBlock
437 --             , NetAST.destNode = netDestNode
438 --             , NetAST.destBase = netDestBase
439 --             }
440
441 -- instance NetTransformable AST.Address NetAST.Address where
442 --     transform _ (AST.LiteralAddress value) = do
443 --         return $ NetAST.Address value
444 --     transform context (AST.ParamAddress name) = do
445 --         let
446 --             value = getParamValue context name
447 --         return $ NetAST.Address value
448
449 -- instance NetTransformable a b => NetTransformable (AST.For a) [b] where
450 --     transform context ast = do
451 --         let
452 --             body = AST.body ast
453 --             varRanges = AST.varRanges ast
454 --         concreteRanges <- transform context varRanges
455 --         let
456 --             valueList = Map.foldWithKey iterations [] concreteRanges
457 --             iterContexts = map iterationContext valueList
458 --             ts = map (\c -> transform c body) iterContexts
459 --             fs = lefts ts
460 --             bs = rights ts
461 --         case fs of
462 --             [] -> return $ bs
463 --             _  -> Left $ CheckFailure (concat $ map failures fs)
464 --         where
465 --             iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
466 --             iterations k vs ms = concat $ map (f ms k) vs
467 --                 where
468 --                     f ms k v = map (Map.insert k v) ms
469 --             iterationContext varMap =
470 --                 let
471 --                     values = varValues context
472 --                 in context
473 --                     { varValues = values `Map.union` varMap }
474
475 -- instance NetTransformable AST.ForRange [Word] where
476 --     transform context ast = do
477 --         let
478 --             start = AST.start ast
479 --             end = AST.end ast
480 --         startVal <- transform context start
481 --         endVal <- transform context end
482 --         return [startVal..endVal]
483
484 -- instance NetTransformable AST.ForLimit Word where
485 --     transform _ (AST.LiteralLimit value) = return value
486 --     transform context (AST.ParamLimit name) = return $ getParamValue context name
487
488 -- instance NetTransformable a b => NetTransformable [a] [b] where
489 --     transform context ast = do
490 --         let
491 --             ts = map (transform context) ast
492 --             fs = lefts ts
493 --             bs = rights ts
494 --         case fs of
495 --             [] -> return bs
496 --             _  -> Left $ CheckFailure (concat $ map failures fs)
497
498 -- instance (Ord k, NetTransformable a b) => NetTransformable (Map k a) (Map k b) where
499 --     transform context ast = do
500 --         let
501 --             ks = Map.keys ast
502 --             es = Map.elems ast
503 --         ts <- transform context es
504 --         return $ Map.fromList (zip ks ts)
505
506 --
507 -- Checks
508 --
509 class NetCheckable a where
510     check :: Set NetAST.NodeId -> a -> Either CheckFailure ()
511
512 instance NetCheckable NetAST.NetSpec where
513     check context (NetAST.NetSpec net) = do
514         check context $ Map.elems net
515
516 instance NetCheckable NetAST.NodeSpec where
517     check context (NetAST.AliasSpec alias) = do
518         case alias of
519             Nothing -> return ()
520             Just ident -> check context ident
521     check context net = do
522         let
523             translate = NetAST.translate net
524             overlay = NetAST.overlay net
525         check context translate
526         maybe (return ()) (check context) overlay
527
528 instance NetCheckable NetAST.MapSpec where
529     check context net = do
530         let
531            destNode = NetAST.destNode net
532         check context destNode
533
534 instance NetCheckable NetAST.NodeId where
535     check context net = do
536         if net `Set.member` context
537             then return ()
538             else Left $ CheckFailure [UndefinedReference net]
539
540 instance NetCheckable a => NetCheckable [a] where
541     check context net = do
542         let
543             checked = map (check context) net
544             fs = lefts $ checked
545         case fs of
546             [] -> return ()
547             _  -> Left $ CheckFailure (concat $ map failures fs)
548
549 getModule :: Context -> String -> AST.Module
550 getModule context name =
551     let
552         modules = AST.modules $ spec context
553     in modules Map.! name
554
555 getParamValue :: Context -> String -> Word
556 getParamValue context name =
557     let
558         params = paramValues context
559     in params Map.! name
560
561 getVarValue :: Context -> String -> Word
562 getVarValue context name =
563     let
564         vars = varValues context
565     in vars Map.! name
566
567 checkDuplicates :: [NetAST.NodeId] -> (NetAST.NodeId -> FailedCheck) -> Either CheckFailure ()
568 checkDuplicates nodeIds fail = do
569     let
570         duplicates = duplicateNames nodeIds
571     case duplicates of
572         [] -> return ()
573         _  -> Left $ CheckFailure (map fail duplicates)
574     where
575         duplicateNames [] = []
576         duplicateNames (x:xs)
577             | x `elem` xs = nub $ [x] ++ duplicateNames xs
578             | otherwise = duplicateNames xs
579         msg (NetAST.NodeId namespace name) =
580             let
581                 m = concat ["Multiple declarations of node '", name, "'"]
582             in case NetAST.ns namespace of
583                 [] -> m
584                 _  -> m ++ concat [" in namespace '", show namespace, "'"]