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