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