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