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