8602bdef276a66bc1a1cf5d5460ecbfd00820ea4
[barrelfish] / tools / sockeye / SockeyeInstantiator.hs
1 {-
2     SockeyeModuleInstantiator.hs: Module instantiator 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 SockeyeInstantiator
21 ( sockeyeInstantiate ) where
22
23 import Control.Monad.State
24
25 import Data.List (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 SockeyeASTInstantiator as InstAST
38
39 import Text.Groom (groom)
40 import Debug.Trace
41
42 data InstFails
43     = ModuleInstLoop     [String]
44     | DuplicateNamespace !String
45     | DuplicateIdentifer !String
46     | DuplicateInPort    !String
47     | DuplicateOutPort   !String
48     | DuplicateInMap     !String !String
49     | DuplicateOutMap    !String !String
50     | UndefinedOutPort   !String !String
51     | UndefinedInPort    !String !String
52     | UndefinedReference !String !String
53
54 instance Show InstFails where
55     show (ModuleInstLoop     loop)       = concat ["Module instantiation loop: '", intercalate "' -> '" loop, "'"]
56     show (DuplicateInPort    port)       = concat ["Multiple declarations of input port '", port, "'"]
57     show (DuplicateOutPort   port)       = concat ["Multiple declarations of output port '", port, "'"]
58     show (DuplicateNamespace ident)      = concat ["Multiple usage of namespace '", ident, "'"]
59     show (DuplicateIdentifer ident)      = concat ["Multiple declarations of node '", ident, "'"]
60     show (DuplicateInMap   inst port)    = concat ["Multiple mappings for input port '",  port, "' in module instantiation '", inst, "'"]
61     show (DuplicateOutMap  inst port)    = concat ["Multiple mappings for output port '", port, "' in module instantiation '", inst, "'"]
62     show (UndefinedInPort  inst port)    = concat ["Mapping to undefined input port '",   port, "' in module instantiation '", inst, "'"]
63     show (UndefinedOutPort inst port)    = concat ["Mapping to undefined output port '",  port, "' in module instantiation '", inst, "'"]
64     show (UndefinedReference decl ident) = concat ["Reference to undefined node '", ident, "' in declaration of node '", decl, "'"]
65
66 type Port = (InstAST.Identifier, Integer)
67 type NodeDecl = (InstAST.Identifier, InstAST.NodeSpec)
68 type ModuleInst = (InstAST.Identifier, InstAST.ModuleInst)
69 type PortMapping = (InstAST.Identifier, InstAST.Identifier)
70
71 data Context = Context
72     { spec        :: AST.SockeyeSpec
73     , modulePath  :: [String]
74     , paramValues :: Map String Integer
75     , varValues   :: Map String Integer
76     }
77
78 sockeyeInstantiate :: AST.SockeyeSpec -> Either (FailedChecks InstFails) InstAST.SockeyeSpec
79 sockeyeInstantiate ast = do
80     let
81         emptySpec = AST.SockeyeSpec Map.empty
82         context = Context
83             { spec        = emptySpec
84             , modulePath  = []
85             , paramValues = Map.empty
86             , varValues   = Map.empty
87             }
88     runChecks $ evalStateT (instantiate context ast) Map.empty
89
90 --
91 -- Instantiate Module Templates
92 --
93 class Instantiatable a b where
94     instantiate :: Context -> a -> StateT (Map String InstAST.Module) (Checks InstFails) b
95
96 instance Instantiatable AST.SockeyeSpec InstAST.SockeyeSpec where
97     instantiate context ast = do
98         let
99             rootInst = AST.ModuleInst
100                 { AST.namespace  = AST.SimpleIdent ""
101                 , AST.moduleName = "@root"
102                 , AST.arguments  = Map.empty
103                 , AST.inPortMap  = []
104                 , AST.outPortMap = []
105                 }
106             specContext = context
107                 { spec = ast }
108         [("", instRoot)] <- instantiate specContext rootInst
109         modules <- get
110         return InstAST.SockeyeSpec
111             { InstAST.root = instRoot
112             , InstAST.modules = modules
113             }
114
115 instance Instantiatable AST.Module InstAST.Module where
116     instantiate context ast = do
117         let
118             inPorts = AST.inputPorts ast
119             outPorts = AST.outputPorts ast
120             nodeDecls = AST.nodeDecls ast
121             moduleInsts = AST.moduleInsts ast
122             modName = head $ modulePath context
123         modules <- get
124         if modName `Map.member` modules
125             then do
126                 return $ modules Map.! modName
127             else do
128                 let sentinel = InstAST.Module
129                         { InstAST.inputPorts   = Map.empty
130                         , InstAST.outputPorts  = Map.empty
131                         , InstAST.nodeDecls    = Map.empty
132                         , InstAST.moduleInsts  = Map.empty
133                         }
134                 modify $ Map.insert modName sentinel
135                 instInPorts <- do
136                     instPorts <- instantiate context inPorts
137                     return $ concat (instPorts :: [[Port]])
138                 instOutPorts <- do
139                     instPorts <- instantiate context outPorts
140                     return $ concat (instPorts :: [[Port]])
141                 instDecls <- do
142                     decls <- instantiate context nodeDecls
143                     return $ concat (decls :: [[NodeDecl]])
144                 instInsts <- do
145                     insts <- instantiate context moduleInsts
146                     return $ concat (insts :: [[ModuleInst]])
147                 lift $ checkDuplicates modName DuplicateInPort    $ (map fst instInPorts)
148                 lift $ checkDuplicates modName DuplicateOutPort   $ (map fst instOutPorts)
149                 lift $ checkDuplicates modName DuplicateIdentifer $ (map fst instDecls)
150                 lift $ checkDuplicates modName DuplicateNamespace $ (map fst instInsts)
151                 return InstAST.Module
152                     { InstAST.inputPorts   = Map.fromList instInPorts
153                     , InstAST.outputPorts  = Map.fromList instOutPorts
154                     , InstAST.nodeDecls    = Map.fromList instDecls
155                     , InstAST.moduleInsts  = Map.fromList instInsts
156                     }
157
158 instance Instantiatable AST.Port [Port] where
159     instantiate context (AST.MultiPort for) = do
160         instFor <- instantiate context for
161         return $ concat (instFor :: [[Port]])
162     instantiate context ast = do
163         let
164             ident = AST.portId ast
165             width = AST.portWidth ast
166         instIdent <- instantiate context ident
167         return [(instIdent, width)]
168
169 instance Instantiatable AST.ModuleInst [ModuleInst] where
170     instantiate context (AST.MultiModuleInst for) = do 
171         simpleFor <- instantiate context for
172         return $ concat (simpleFor :: [[ModuleInst]])
173     instantiate context ast = do
174         let
175             namespace = AST.namespace ast
176             name = AST.moduleName ast
177             args = AST.arguments ast
178             inPortMap = AST.inPortMap ast
179             outPortMap = AST.outPortMap ast
180             modPath = modulePath context
181             mod = getModule context name
182         instNs <- instantiate context namespace
183         instInMap <- do
184             inMaps <- instantiate context inPortMap
185             return $ concat (inMaps :: [[PortMapping]])
186         instOutMap <- do
187             outMaps <- instantiate context outPortMap
188             return $ concat (outMaps :: [[PortMapping]])
189         instArgs <- instantiate context args
190         let
191             instName = concat [name, "(", intercalate ", " $ argStrings instArgs mod, ")"]
192             moduleContext = context
193                     { modulePath  = instName:modPath
194                     , paramValues = instArgs
195                     , varValues   = Map.empty
196                     }
197         lift $ checkSelfInst modPath instName
198         lift $ checkDuplicates name (DuplicateInMap  instName) $ map fst instInMap
199         lift $ checkDuplicates name (DuplicateOutMap instName) $ map fst instOutMap
200         let
201             simplified = InstAST.ModuleInst
202                 { InstAST.moduleName = instName
203                 , InstAST.inPortMap  = Map.fromList instInMap
204                 , InstAST.outPortMap = Map.fromList instOutMap
205                 }
206         instModule <- instantiate moduleContext mod
207         modify $ Map.insert instName instModule
208         return [(instNs, simplified)]
209         where
210             argStrings args mod =
211                 let
212                     paramNames = AST.paramNames mod
213                     paramTypes = AST.paramTypeMap mod
214                     params = map (\p -> (p, paramTypes Map.! p)) paramNames
215                 in map showValue params
216                     where
217                         showValue (name, AST.AddressParam)  = "0x" ++ showHex (args Map.! name) ""
218                         showValue (name, AST.NaturalParam) = show (args Map.! name)
219             checkSelfInst path name = do
220                 case loop path of
221                     [] -> return ()
222                     l  -> failCheck "" $ ModuleInstLoop (reverse $ name:l)
223                     where
224                         loop [] = []
225                         loop path@(p:ps)
226                             | name `elem` path = p:(loop ps)
227                             | otherwise = []
228
229 instance Instantiatable AST.ModuleArg Integer where
230     instantiate _ (AST.AddressArg v) = return v
231     instantiate _ (AST.NaturalArg v) = return v
232     instantiate context (AST.ParamArg name) = return $ getParamValue context name
233
234 instance Instantiatable AST.PortMap [PortMapping] where
235     instantiate context (AST.MultiPortMap for) = do
236         instFor <- instantiate context for
237         return $ concat (instFor :: [[PortMapping]])
238     instantiate context ast = do
239         let
240             mappedId = AST.mappedId ast
241             mappedPort = AST.mappedPort ast
242         instId <- instantiate context mappedId
243         instPort <- instantiate context mappedPort
244         return [(instPort, instId)]
245
246 instance Instantiatable AST.NodeDecl [NodeDecl] where
247     instantiate context (AST.MultiNodeDecl for) = do
248         instFor <- instantiate context for
249         return $ concat (instFor :: [[NodeDecl]])
250     instantiate context ast = do
251         let
252             nodeId = AST.nodeId ast
253             nodeSpec = AST.nodeSpec ast
254         instNodeId <- instantiate context nodeId
255         instNodeSpec <- instantiate context nodeSpec
256         return [(instNodeId, instNodeSpec)]
257
258 instance Instantiatable AST.Identifier InstAST.Identifier where
259     instantiate context (AST.SimpleIdent name) = do
260         return name
261     instantiate context ast = do
262         let
263             prefix = AST.prefix ast
264             varName = AST.varName ast
265             suffix = AST.suffix ast
266             varValue = show $ getVarValue context varName
267         suffixName <- case suffix of
268             Nothing -> return ""
269             Just s  -> instantiate context s
270         return $ prefix ++ varValue ++ suffixName
271
272 instance Instantiatable AST.NodeSpec InstAST.NodeSpec where
273     instantiate context ast = do
274         let
275             nodeType = AST.nodeType ast
276             accept = AST.accept ast
277             translate = AST.translate ast
278             reserved = AST.reserved ast
279             overlay = AST.overlay ast
280         instAccept <- instantiate context accept
281         instTranslate <- instantiate context translate
282         instReserved <- instantiate context reserved
283         instOverlay <- maybe (return Nothing) (\o -> instantiate context o >>= return . Just) overlay
284         return InstAST.NodeSpec
285             { InstAST.nodeType  = nodeType
286             , InstAST.accept    = instAccept
287             , InstAST.translate = instTranslate
288             , InstAST.reserved  = instReserved
289             , InstAST.overlay   = instOverlay
290             }
291
292 instance Instantiatable AST.NodeType InstAST.NodeType where
293     instantiate _ AST.Memory = return InstAST.Memory
294     instantiate _ AST.Device = return InstAST.Device
295     instantiate _ AST.Other  = return InstAST.Other
296
297 instance Instantiatable AST.BlockSpec InstAST.BlockSpec where
298     instantiate context (AST.SingletonBlock base) = do
299         instBase <- instantiate context base
300         return InstAST.BlockSpec
301             { InstAST.base  = instBase
302             , InstAST.limit = instBase
303             }
304     instantiate context (AST.RangeBlock base limit) = do
305         instBase <- instantiate context base
306         instLimit <- instantiate context limit
307         return InstAST.BlockSpec
308             { InstAST.base  = instBase
309             , InstAST.limit = instLimit
310             }
311     instantiate context (AST.LengthBlock base bits) = do
312         instBase <- instantiate context base
313         let
314             instLimit = instBase + 2^bits - 1
315         return InstAST.BlockSpec
316             { InstAST.base  = instBase
317             , InstAST.limit = instLimit
318             }
319
320 instance Instantiatable AST.MapSpec InstAST.MapSpec where
321     instantiate context ast = do
322         let
323             block = AST.block ast
324             destNode = AST.destNode ast
325             destBase = fromMaybe (AST.base block) (AST.destBase ast)
326         instBlock <- instantiate context block
327         instDestNode <- instantiate context destNode
328         instDestBase <- instantiate context destBase
329         return InstAST.MapSpec
330             { InstAST.srcBlock    = instBlock
331             , InstAST.destNode = instDestNode
332             , InstAST.destBase = instDestBase
333             }
334
335 instance Instantiatable AST.OverlaySpec InstAST.OverlaySpec where
336     instantiate context ast = do
337         let
338             over = AST.over ast
339             width = AST.width ast
340         instOver <- instantiate context over
341         return InstAST.OverlaySpec
342             { InstAST.over  = instOver
343             , InstAST.width = width
344             }
345
346 instance Instantiatable AST.Address InstAST.Address where
347     instantiate context (AST.ParamAddress name) = do
348         let value = getParamValue context name
349         return value
350     instantiate _ (AST.LiteralAddress value) = return value
351
352 instance Instantiatable a b => Instantiatable (AST.For a) [b] where
353     instantiate context ast = do
354         let
355             body = AST.body ast
356             varRanges = AST.varRanges ast
357         concreteRanges <- instantiate context varRanges
358         let
359             valueList = Map.foldWithKey iterations [] concreteRanges
360             iterContexts = map iterationContext valueList
361         mapM (\c -> instantiate c body) iterContexts
362         where
363             iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
364             iterations k vs ms = concat $ map (f ms k) vs
365                 where
366                     f ms k v = map (Map.insert k v) ms
367             iterationContext varMap =
368                 let
369                     values = varValues context
370                 in context
371                     { varValues = values `Map.union` varMap }
372
373 instance Instantiatable AST.ForRange [Integer] where
374     instantiate context ast = do
375         let
376             start = AST.start ast
377             end = AST.end ast
378         simpleStart <- instantiate context start
379         simpleEnd <- instantiate context end
380         return [simpleStart..simpleEnd]
381
382 instance Instantiatable AST.ForLimit Integer where
383     instantiate _ (AST.LiteralLimit value) = return value
384     instantiate context (AST.ParamLimit name) = return $ getParamValue context name
385
386 instance (Traversable t, Instantiatable a b) => Instantiatable (t a) (t b) where
387     instantiate context ast = mapM (instantiate context) ast
388
389
390 getModule :: Context -> String -> AST.Module
391 getModule context name =
392     let
393         modules = AST.modules $ spec context
394     in modules Map.! name
395
396 getParamValue :: Context -> String -> Integer
397 getParamValue context name =
398     let
399         params = paramValues context
400     in params Map.! name
401
402 getVarValue :: Context -> String -> Integer
403 getVarValue context name =
404     let
405         vars = varValues context
406     in vars Map.! name