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
20module SockeyeInstantiator
21( instantiateSockeye ) where
22
23import Control.Monad.State
24
25import Data.List (intercalate)
26import Data.Map (Map)
27import qualified Data.Map as Map
28import Data.Maybe (catMaybes, fromMaybe)
29
30import Numeric (showHex)
31
32import SockeyeChecks
33
34import qualified SockeyeASTTypeChecker as CheckAST
35import qualified SockeyeASTInstantiator as InstAST
36
37data 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
46instance 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
55type PortMapping = (InstAST.Identifier, InstAST.Identifier)
56
57data Context = Context
58    { modules     :: Map String CheckAST.Module
59    , modulePath  :: [String]
60    , paramValues :: Map String Integer
61    , varValues   :: Map String Integer
62    }
63
64instantiateSockeye :: CheckAST.SockeyeSpec -> Either (FailedChecks InstFail) InstAST.SockeyeSpec
65instantiateSockeye 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--
77class Instantiatable a b where
78    instantiate :: Context -> a -> StateT (Map String InstAST.Module) (Checks InstFail) b
79
80instance 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
93instance 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
144instance 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
167instance 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
224instance Instantiatable CheckAST.ModuleArg Integer where
225    instantiate _ (CheckAST.NumericalArg value) = return value
226    instantiate context (CheckAST.ParamArg name) = return $ getParamValue context name
227
228instance Instantiatable CheckAST.PortMap [PortMapping] where
229    instantiate context (CheckAST.MultiPortMap for) = do
230        instFor <- instantiate context for
231        return $ concat (instFor :: [[PortMapping]])
232    instantiate context ast = do
233        let mappedId = CheckAST.mappedId ast
234            mappedPort = CheckAST.mappedPort ast
235        instId <- instantiate context mappedId
236        instPort <- instantiate context mappedPort
237        return [(instPort, instId)]
238
239instance Instantiatable CheckAST.NodeDecl [InstAST.NodeDecl] where
240    instantiate context (CheckAST.MultiNodeDecl for) = do
241        instFor <- instantiate context for
242        return $ concat (instFor :: [[InstAST.NodeDecl]])
243    instantiate context ast = do
244        let nodeId = CheckAST.nodeId ast
245            nodeSpec = CheckAST.nodeSpec ast
246        instNodeId <- instantiate context nodeId
247        instNodeSpec <- instantiate context nodeSpec
248        let instDecl = InstAST.NodeDecl
249                { InstAST.nodeId   = instNodeId
250                , InstAST.nodeSpec = instNodeSpec
251                }
252        return $ [instDecl]
253
254instance Instantiatable CheckAST.Identifier InstAST.Identifier where
255    instantiate _ (CheckAST.SimpleIdent name) = do
256        return name
257    instantiate context ast = do
258        let prefix = CheckAST.prefix ast
259            varName = CheckAST.varName ast
260            suffix = CheckAST.suffix ast
261            varValue = show $ getVarValue context varName
262        suffixName <- case suffix of
263            Nothing -> return ""
264            Just s  -> instantiate context s
265        return $ prefix ++ varValue ++ suffixName
266
267instance Instantiatable CheckAST.NodeSpec InstAST.NodeSpec where
268    instantiate context ast = do
269        let nodeType = CheckAST.nodeType ast
270            accept = CheckAST.accept ast
271            translate = CheckAST.translate ast
272            reserved = CheckAST.reserved ast
273            overlay = CheckAST.overlay ast
274        instAccept <- instantiate context accept
275        instTranslate <- instantiate context translate
276        instReserved <- instantiate context reserved
277        instOverlay <- maybe (return Nothing) (\o -> instantiate context o >>= return . Just) overlay
278        return InstAST.NodeSpec
279            { InstAST.nodeType  = nodeType
280            , InstAST.accept    = instAccept
281            , InstAST.translate = instTranslate
282            , InstAST.reserved  = instReserved
283            , InstAST.overlay   = instOverlay
284            }
285
286instance Instantiatable CheckAST.BlockSpec InstAST.BlockSpec where
287    instantiate context (CheckAST.SingletonBlock base props) = do
288        instBase <- instantiate context base
289        instProps <- instantiate context props
290        return InstAST.BlockSpec
291            { InstAST.base  = instBase
292            , InstAST.limit = instBase
293            , InstAST.props = instProps
294            }
295    instantiate context (CheckAST.RangeBlock base limit props) = do
296        instBase <- instantiate context base
297        instLimit <- instantiate context limit
298        instProps <- instantiate context props
299        return InstAST.BlockSpec
300            { InstAST.base  = instBase
301            , InstAST.limit = instLimit
302            , InstAST.props = instProps
303            }
304    instantiate context (CheckAST.LengthBlock base bits props) = do
305        instBase <- instantiate context base
306        instProps <- instantiate context props
307        let instLimit = instBase + 2^bits - 1
308        return InstAST.BlockSpec
309            { InstAST.base  = instBase
310            , InstAST.limit = instLimit
311            , InstAST.props = instProps
312            }
313
314instance Instantiatable CheckAST.MapSpec InstAST.MapSpec where
315    instantiate context ast = do
316        let block = CheckAST.block ast
317            destNode = CheckAST.destNode ast
318            destProps = CheckAST.destProps ast
319            destBase = fromMaybe (CheckAST.LiteralAddress 0) (CheckAST.destBase ast)
320        instBlock <- instantiate context block
321        instDestNode <- instantiate context destNode
322        instDestBase <- instantiate context destBase
323        instDestProps <- instantiate context destProps
324        return InstAST.MapSpec
325            { InstAST.srcBlock    = instBlock
326            , InstAST.destNode = instDestNode
327            , InstAST.destBase = instDestBase
328            , InstAST.destProps = instDestProps
329            }
330
331instance 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
341instance Instantiatable CheckAST.PropSpec InstAST.PropSpec where
342    instantiate _ (CheckAST.PropSpec ids) =
343      return InstAST.PropSpec { InstAST.identifiers = ids }
344
345instance Instantiatable CheckAST.Address InstAST.Address where
346    instantiate context (CheckAST.ParamAddress name) = do
347        let value = getParamValue context name
348        return value
349    instantiate _ (CheckAST.LiteralAddress value) = return value
350
351instance Instantiatable a b => Instantiatable (CheckAST.For a) [b] where
352    instantiate context ast = do
353        let body = CheckAST.body ast
354            varRanges = CheckAST.varRanges ast
355        concreteRanges <- instantiate context varRanges
356        let valueList = Map.foldWithKey iterations [] concreteRanges
357            iterContexts = map iterationContext valueList
358        mapM (\c -> instantiate c body) iterContexts
359        where
360            iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
361            iterations k vs ms = concat $ map (f ms k) vs
362                where
363                    f ms k v = map (Map.insert k v) ms
364            iterationContext varMap =
365                let
366                    values = varValues context
367                in context
368                    { varValues = values `Map.union` varMap }
369
370instance Instantiatable CheckAST.ForRange [Integer] where
371    instantiate context ast = do
372        let start = CheckAST.start ast
373            end = CheckAST.end ast
374        simpleStart <- instantiate context start
375        simpleEnd <- instantiate context end
376        return [simpleStart..simpleEnd]
377
378instance Instantiatable CheckAST.ForLimit Integer where
379    instantiate _ (CheckAST.LiteralLimit value) = return value
380    instantiate context (CheckAST.ParamLimit name) = return $ getParamValue context name
381
382instance (Traversable t, Instantiatable a b) => Instantiatable (t a) (t b) where
383    instantiate context ast = mapM (instantiate context) ast
384
385---
386--- Helpers
387---
388getModule :: Context -> String -> CheckAST.Module
389getModule context name = (modules context) Map.! name
390
391getParamValue :: Context -> String -> Integer
392getParamValue context name =
393    let params = paramValues context
394    in params Map.! name
395
396getVarValue :: Context -> String -> Integer
397getVarValue context name =
398    let vars = varValues context
399    in vars Map.! name
400