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