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