Sockeye: Start implementing port checks
[barrelfish] / tools / sockeye / SockeyeSimplifier.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 SockeyeSimplifier
21 ( sockeyeSimplify ) where
22
23 import Control.Monad.State
24
25 import Data.List (nub, intercalate)
26 import Data.Map (Map)
27 import qualified Data.Map as Map
28 import Data.Maybe (fromMaybe, maybe)
29 import Data.Set (Set)
30 import qualified Data.Set as Set
31
32 import Numeric (showHex)
33
34 import SockeyeChecks
35
36 import qualified SockeyeAST as AST
37 import qualified SockeyeASTDecodingNet as NetAST
38
39 import Text.Groom (groom)
40 import Debug.Trace
41
42 data FailedCheck
43     = ModuleInstLoop [String]
44     | DuplicateInPort !String !String
45     | DuplicateInMap !String !String
46     | UndefinedInPort !String !String
47     | DuplicateOutPort !String !String
48     | DuplicateOutMap !String !String
49     | UndefinedOutPort !String !String
50     | DuplicateIdentifer !String
51     | UndefinedReference !String
52
53 instance Show FailedCheck where
54     show (ModuleInstLoop loop) = concat ["Module instantiation loop:'", intercalate "' -> '" loop, "'"]
55     show (DuplicateInPort  modName port) = concat ["Multiple declarations of input port '", port, "' in '", modName, "'"]
56     show (DuplicateInMap   ns      port) = concat ["Multiple mappings for input port '", port, "' in '", ns, "'"]
57     show (UndefinedInPort  modName port) = concat ["'", port, "' is not an input port in '", modName, "'"]
58     show (DuplicateOutPort modName port) = concat ["Multiple declarations of output port '", port, "' in '", modName, "'"]
59     show (DuplicateOutMap   ns     port) = concat ["Multiple mappings for output port '", port, "' in '", ns, "'"]
60     show (UndefinedOutPort modName port) = concat ["'", port, "' is not an output port in '", modName, "'"]
61     show (DuplicateIdentifer ident) = concat ["Multiple declarations of node '", show ident, "'"]
62     show (UndefinedReference ident) = concat ["Reference to undefined node '", show ident, "'"]
63
64 data Context = Context
65     { spec         :: AST.SockeyeSpec
66     , curNamespace :: NetAST.Namespace
67     , curModule    :: !String
68     , paramValues  :: Map String Integer
69     , varValues    :: Map String Integer
70     }
71
72 sockeyeSimplify :: AST.SockeyeSpec -> Either (CheckFailure FailedCheck) AST.SockeyeSpec
73 sockeyeSimplify ast = do
74     let
75         emptySpec = AST.SockeyeSpec Map.empty
76         context = Context
77             { spec         = emptySpec
78             , curNamespace = NetAST.Namespace []
79             , curModule    = ""
80             , paramValues  = Map.empty
81             , varValues    = Map.empty
82             }
83     runChecks $ evalStateT (simplify context ast) Map.empty
84     -- let
85     --     nodeIds = map fst net
86     -- checkDuplicates nodeIds DuplicateIdentifer
87     -- let
88     --     nodeMap = Map.fromList net
89     --     symbols = Map.keysSet nodeMap
90     --     netSpec = NetAST.NetSpec $ nodeMap
91     -- check symbols netSpec
92     -- return netSpec
93
94 --
95 -- Simplify AST (instantiate module templates, expand for constructs)
96 --
97 class ASTSimplifiable a b where
98     simplify :: Context -> a -> StateT (Map String AST.Module) (Checks FailedCheck) b
99
100 instance ASTSimplifiable AST.SockeyeSpec AST.SockeyeSpec where
101     simplify context ast = do
102         let
103             rootInst = AST.ModuleInst
104                 { AST.namespace  = AST.SimpleIdent ""
105                 , AST.moduleName = "@root"
106                 , AST.arguments  = Map.empty
107                 , AST.inPortMap  = []
108                 , AST.outPortMap = []
109                 }
110             specContext = context
111                 { spec = ast }
112         inst <- simplify specContext rootInst
113         return (inst :: [AST.ModuleInst])
114         modules <- get
115         return AST.SockeyeSpec
116             { AST.modules = modules }
117
118 instance ASTSimplifiable AST.Module AST.Module where
119     simplify context ast = do
120         let
121             inPorts = AST.inputPorts ast
122             outPorts = AST.outputPorts ast
123             nodeDecls = AST.nodeDecls ast
124             moduleInsts = AST.moduleInsts ast
125             modName = curModule context
126         simpleInPorts <- do
127             simplePorts <- simplify context inPorts
128             return $ concat (simplePorts :: [[AST.Port]])
129         simpleOutPorts <- do
130             simplePorts <- simplify context outPorts
131             return $ concat (simplePorts :: [[AST.Port]])
132         checkDuplicates (map (AST.prefix . AST.portId) simpleInPorts) $ DuplicateInPort modName
133         checkDuplicates (map (AST.prefix . AST.portId) simpleOutPorts) $ DuplicateOutPort modName
134         simpleDecls <- simplify context nodeDecls
135         simpleInsts <- simplify context moduleInsts
136         return AST.Module
137             { AST.paramNames   = []
138             , AST.paramTypeMap = Map.empty
139             , AST.inputPorts   = simpleInPorts
140             , AST.outputPorts  = simpleOutPorts
141             , AST.nodeDecls    = concat (simpleDecls :: [[AST.NodeDecl]])
142             , AST.moduleInsts  = concat (simpleInsts :: [[AST.ModuleInst]])
143             }
144
145 instance ASTSimplifiable AST.Port [AST.Port] where
146     simplify context (AST.MultiPort for) = do
147         simpleFor <- simplify context for
148         return $ concat (simpleFor :: [[AST.Port]])
149     simplify context ast@(AST.InputPort {}) = do
150         let
151             ident = AST.portId ast
152             width = AST.portWidth ast
153         simpleIdent <- simplify context ident
154         return [AST.InputPort
155             { AST.portId    = simpleIdent
156             , AST.portWidth = width
157             }]
158     simplify context ast@(AST.OutputPort {}) = do
159         let
160             ident = AST.portId ast
161             width = AST.portWidth ast
162         simpleIdent <- simplify context ident
163         return [AST.OutputPort
164             { AST.portId    = simpleIdent
165             , AST.portWidth = width
166             }]
167
168 instance ASTSimplifiable AST.ModuleInst [AST.ModuleInst] where
169     simplify context (AST.MultiModuleInst for) = do 
170         simpleFor <- simplify context for
171         return $ concat (simpleFor :: [[AST.ModuleInst]])
172     simplify context ast = do
173         let
174             namespace = AST.namespace ast
175             name = AST.moduleName ast
176             args = AST.arguments ast
177             inPortMap = AST.inPortMap ast
178             outPortMap = AST.outPortMap ast
179             mod = getModule context name
180         simpleNS <- simplify context namespace
181         simpleInMap <- simplify context inPortMap
182         simpleOutMap <- simplify context outPortMap
183         simpleArgs <- simplify context args
184         let
185             simpleName = concat [name, "(", intercalate ", " $ argValues (simpleArgs :: Map String Integer) mod, ")"]
186         simpleModule <- simplify (moduleContext simpleName simpleArgs) mod
187         let
188             simplified = AST.ModuleInst
189                 { AST.namespace  = simpleNS
190                 , AST.moduleName = simpleName
191                 , AST.arguments  = Map.empty
192                 , AST.inPortMap  = concat (simpleInMap :: [[AST.PortMap]])
193                 , AST.outPortMap = concat (simpleOutMap :: [[AST.PortMap]])
194                 }
195         modify $ Map.insert simpleName simpleModule
196         return [simplified]
197         where
198             moduleContext name paramValues = context
199                     { curModule   = name
200                     , paramValues = paramValues
201                     , varValues   = Map.empty
202                     }
203             argValues args mod =
204                 let
205                     paramNames = AST.paramNames mod
206                     paramTypes = AST.paramTypeMap mod
207                     params = map (\p -> (p, paramTypes Map.! p)) paramNames
208                 in map showValue params
209                     where
210                         showValue (name, AST.AddressParam)  = "0x" ++ showHex (args Map.! name) ""
211                         showValue (name, AST.NaturalParam) = show (args Map.! name)
212             addModule k m spec =
213                 let
214                     prevMods = AST.modules spec
215                     newMods = Map.insert k m prevMods
216                 in spec
217                     { AST.modules = newMods }
218
219 instance ASTSimplifiable AST.ModuleArg Integer where
220     simplify _ (AST.AddressArg v) = return v
221     simplify _ (AST.NaturalArg v) = return v
222     simplify context (AST.ParamArg name) = return $ getParamValue context name
223
224 instance ASTSimplifiable AST.PortMap [AST.PortMap] where
225     simplify context (AST.MultiPortMap for) = do
226         simpleFor <- simplify context for
227         return $ concat (simpleFor :: [[AST.PortMap]])
228     simplify context ast = do
229         let
230             mappedId = AST.mappedId ast
231             mappedPort = AST.mappedPort ast
232         simpleId <- simplify context mappedId
233         simplePort <- simplify context mappedPort
234         let
235             simplePortMap = AST.PortMap
236                 { AST.mappedId   = simpleId
237                 , AST.mappedPort = simplePort
238                 }
239         return [simplePortMap]
240
241 instance ASTSimplifiable AST.NodeDecl [AST.NodeDecl] where
242     simplify context (AST.MultiNodeDecl for) = do
243         simpleFor <- simplify context for
244         return $ concat (simpleFor :: [[AST.NodeDecl]])
245     simplify context ast = do
246         let
247             nodeId = AST.nodeId ast
248             nodeSpec = AST.nodeSpec ast
249         simpleNodeId <- simplify context nodeId
250         simpleNodeSpec <- simplify context nodeSpec
251         let
252             simpleNodeDecl = AST.NodeDecl
253                 { AST.nodeId   = simpleNodeId
254                 , AST.nodeSpec = simpleNodeSpec
255                 }
256         return [simpleNodeDecl]
257
258 instance ASTSimplifiable AST.Identifier AST.Identifier where
259     simplify context ast = do
260         let
261             name = simpleName ast
262         return $ AST.SimpleIdent name
263         where
264             simpleName (AST.SimpleIdent name) = name
265             simpleName ident =
266                 let
267                     prefix = AST.prefix ident
268                     varName = AST.varName ident
269                     suffix = AST.suffix ident
270                     varValue = show $ getVarValue context varName
271                     suffixName = case suffix of
272                         Nothing -> ""
273                         Just s  -> simpleName s
274                 in prefix ++ varValue ++ suffixName
275
276 instance ASTSimplifiable AST.NodeSpec AST.NodeSpec where
277     simplify context ast = do
278         let
279             nodeType = AST.nodeType ast
280             accept = AST.accept ast
281             translate = AST.translate ast
282             reserved = AST.reserved ast
283             overlay = AST.overlay ast
284         simpleAccept <- simplify context accept
285         simpleTranslate <- simplify context translate
286         simpleReserved <- simplify context reserved
287         -- simpleOverlay <- maybe (return Nothing) simplifyOverlay overlay
288         return AST.NodeSpec
289             { AST.nodeType  = nodeType
290             , AST.accept    = simpleAccept
291             , AST.translate = simpleTranslate
292             , AST.reserved  = simpleReserved
293             , AST.overlay   = Nothing --simpleOverlay
294             }
295         -- where
296         --     simplifyOverlay ident = do
297         --         simpleIdent <- simplify context ident
298         --         return $ Just simpleIdent
299
300 instance ASTSimplifiable AST.BlockSpec AST.BlockSpec where
301     simplify context (AST.SingletonBlock base) = do
302         simpleBase <- simplify context base
303         return $ AST.SingletonBlock simpleBase
304     simplify context (AST.RangeBlock base limit) = do
305         simpleBase <- simplify context base
306         simpleLimit <- simplify context limit
307         return AST.RangeBlock
308             { AST.base  = simpleBase
309             , AST.limit = simpleLimit
310             }
311     simplify context (AST.LengthBlock base bits) = do
312         simpleBase <- simplify context base
313         return AST.LengthBlock
314             { AST.base = simpleBase
315             , AST.bits = bits
316             }
317
318 instance ASTSimplifiable AST.MapSpec AST.MapSpec where
319     simplify context ast = do
320         let
321             block = AST.block ast
322             destNode = AST.destNode ast
323             destBase = fromMaybe (AST.base block) (AST.destBase ast)
324         simpleBlock <- simplify context block
325         simpleDestNode <- simplify context destNode
326         simpleDestBase <- simplify context destBase
327         return AST.MapSpec
328             { AST.block    = simpleBlock
329             , AST.destNode = simpleDestNode
330             , AST.destBase = Just simpleDestBase
331             }
332
333 instance ASTSimplifiable AST.Address AST.Address where
334     simplify context (AST.ParamAddress name) = do
335         let value = getParamValue context name
336         return $ AST.LiteralAddress value
337     simplify _ ast = return ast
338
339 instance ASTSimplifiable a b => ASTSimplifiable (AST.For a) [b] where
340     simplify context ast = do
341         let
342             body = AST.body ast
343             varRanges = AST.varRanges ast
344         concreteRanges <- simplify context varRanges
345         let
346             valueList = Map.foldWithKey iterations [] concreteRanges
347             iterContexts = map iterationContext valueList
348         mapM (\c -> simplify c body) iterContexts
349         where
350             iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
351             iterations k vs ms = concat $ map (f ms k) vs
352                 where
353                     f ms k v = map (Map.insert k v) ms
354             iterationContext varMap =
355                 let
356                     values = varValues context
357                 in context
358                     { varValues = values `Map.union` varMap }
359
360 instance ASTSimplifiable AST.ForRange [Integer] where
361     simplify context ast = do
362         let
363             start = AST.start ast
364             end = AST.end ast
365         simpleStart <- simplify context start
366         simpleEnd <- simplify context end
367         return [simpleStart..simpleEnd]
368
369 instance ASTSimplifiable AST.ForLimit Integer where
370     simplify _ (AST.LiteralLimit value) = return value
371     simplify context (AST.ParamLimit name) = return $ getParamValue context name
372
373 instance (Traversable t, ASTSimplifiable a b) => ASTSimplifiable (t a) (t b) where
374     simplify context ast = mapM (simplify context) ast
375
376
377 getModule :: Context -> String -> AST.Module
378 getModule context name =
379     let
380         modules = AST.modules $ spec context
381     in modules Map.! name
382
383 getParamValue :: Context -> String -> Integer
384 getParamValue context name =
385     let
386         params = paramValues context
387     in params Map.! name
388
389 getVarValue :: Context -> String -> Integer
390 getVarValue context name =
391     let
392         vars = varValues context
393     in vars Map.! name
394
395 checkDuplicates :: (Eq a, Show a) => [a] -> (String -> FailedCheck) -> StateT (Map String AST.Module) (Checks FailedCheck) ()
396 checkDuplicates nodeIds fail = do
397     let
398         duplicates = duplicateNames nodeIds
399     case duplicates of
400         [] -> return ()
401         _  -> lift $ mapM_ (failure . fail . show) duplicates
402     where
403         duplicateNames [] = []
404         duplicateNames (x:xs)
405             | x `elem` xs = nub $ [x] ++ duplicateNames xs
406             | otherwise = duplicateNames xs