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