1{-
2    SockeyeNetBuilder.hs: Decoding net builder 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 SockeyeNetBuilder
21( buildSockeyeNet ) where
22
23import Data.Map (Map)
24import qualified Data.Map as Map
25import Data.Set (Set)
26import qualified Data.Set as Set
27
28import SockeyeChecks
29
30import qualified SockeyeASTInstantiator as InstAST
31import qualified SockeyeASTDecodingNet as NetAST
32
33data NetBuildFail
34    = UndefinedOutPort   !String !String
35    | UndefinedInPort    !String !String
36    | UndefinedReference !String !String
37
38instance Show NetBuildFail where
39    show (UndefinedInPort  inst port)  = concat ["Undefined input port '",   port, "' in module instantiation '", inst, "'"]
40    show (UndefinedOutPort inst port)  = concat ["Undefined output port '",  port, "' in module instantiation '", inst, "'"]
41    show (UndefinedReference context ident) = concat ["Reference to undefined node '", ident, "' in ", context]
42
43type PortMap = Map InstAST.Identifier NetAST.NodeId
44
45data Context = Context
46    { modules      :: Map InstAST.Identifier InstAST.Module
47    , curModule    :: !String
48    , curNamespace :: [String]
49    , curNode      :: !String
50    , inPortMap    :: PortMap
51    , outPortMap   :: PortMap
52    , nodes        :: Set String
53    }
54
55buildSockeyeNet :: InstAST.SockeyeSpec -> Maybe String -> Either (FailedChecks NetBuildFail) NetAST.NetSpec
56buildSockeyeNet ast rootNs = do
57    let
58        context = Context
59            { modules      = Map.empty
60            , curModule    = ""
61            , curNamespace = initNs
62            , curNode      = ""
63            , inPortMap    = Map.empty
64            , outPortMap   = Map.empty
65            , nodes        = Set.empty
66            }
67    net <- runChecks $ transform context ast
68    return net
69    where
70      initNs = case rootNs of
71        Just ns -> [ns]
72        Nothing -> []
73
74--
75-- Build net
76--
77class NetTransformable a b where
78    transform :: Context -> a -> Checks NetBuildFail b
79
80instance NetTransformable InstAST.SockeyeSpec NetAST.NetSpec where
81    transform context ast = do
82        let
83            rootInst = InstAST.root ast
84            mods = InstAST.modules ast
85            specContext = context
86                { modules = mods }
87        transform specContext rootInst
88
89instance NetTransformable InstAST.Module NetAST.NetSpec where
90    transform context ast = do
91        let inPorts = InstAST.inputPorts ast
92            outPorts = InstAST.outputPorts ast
93            moduleInsts = InstAST.moduleInsts ast
94            nodeDecls = InstAST.nodeDecls ast
95            outPortIds = map InstAST.portId outPorts
96            inMapIds = concatMap Map.elems $ map InstAST.inPortMap moduleInsts
97            declIds = map InstAST.nodeId nodeDecls
98            modContext = context
99                { nodes = Set.fromList $ outPortIds ++ inMapIds ++ declIds }
100        inPortDecls <- transform modContext inPorts
101        outPortDecls <- transform modContext outPorts
102        netDecls <- transform modContext nodeDecls
103        netInsts <- transform modContext moduleInsts
104        return $ Map.unions (inPortDecls ++ outPortDecls ++ netDecls ++ netInsts)
105
106instance NetTransformable InstAST.Port NetAST.NetSpec where
107    transform context ast@(InstAST.InputPort {}) = do
108        let portId = InstAST.portId ast
109            portWidth = InstAST.portWidth ast
110            portMap = inPortMap context
111            mappedId = Map.lookup portId portMap
112            errorContext = "input port declaration"
113        checkReference context (UndefinedReference errorContext) portId
114        netPortId <- transform context portId
115        case mappedId of
116            Nothing    -> return Map.empty
117            Just ident -> do
118                let node = portNode netPortId portWidth
119                return $ Map.fromList [(ident, node)]
120    transform context ast@(InstAST.OutputPort {}) = do
121        let portId = InstAST.portId ast
122            portWidth = InstAST.portWidth ast
123            portMap = outPortMap context
124            mappedId = Map.lookup portId portMap
125        netPortId <- transform context portId
126        case mappedId of
127            Nothing    -> return $ Map.fromList [(netPortId, portNodeTemplate)]
128            Just ident -> do
129                let node = portNode ident portWidth
130                return $ Map.fromList $ [(netPortId, node)]
131
132portNode :: NetAST.NodeId -> Integer -> NetAST.NodeSpec
133portNode destNode width =
134    let base = 0
135        limit = 2^width - 1
136        props = NetAST.PropSpec {NetAST.identifiers = [] } {- TODO: LH what is this? -}
137        srcBlock = NetAST.BlockSpec
138            { NetAST.base  = base
139            , NetAST.limit = limit
140            , NetAST.props = props
141            }
142        map = NetAST.MapSpec
143                { NetAST.srcBlock = srcBlock
144                , NetAST.destNode = destNode
145                , NetAST.destBase = base
146                , NetAST.destProps = props {- TODO: LH what is this? -}
147                }
148    in portNodeTemplate { NetAST.translate = [map] }
149
150portNodeTemplate :: NetAST.NodeSpec
151portNodeTemplate = NetAST.NodeSpec
152    { NetAST.nodeType  = NetAST.Other
153    , NetAST.accept    = []
154    , NetAST.translate = []
155    , NetAST.reserved  = []
156    , NetAST.overlay   = Nothing
157    }
158
159instance NetTransformable InstAST.ModuleInst NetAST.NetSpec where
160    transform context ast = do
161        let name = InstAST.moduleName ast
162            namespace = InstAST.namespace ast
163            inPortMap = InstAST.inPortMap ast
164            outPortMap = InstAST.outPortMap ast
165            mod = (modules context) Map.! name
166            inPortIds = Set.fromList $ map InstAST.portId (InstAST.inputPorts mod)
167            outPortIds = Set.fromList $ map InstAST.portId (InstAST.outputPorts mod)
168            instString = concat [name, maybe  "" (" as " ++ ) namespace]
169            errorContext = concat ["port mapping for '", instString, "'"]
170        mapM_ (checkReference context $ UndefinedReference errorContext) $ (Map.elems inPortMap) ++ (Map.elems outPortMap)
171        checkAllExist (UndefinedInPort instString) inPortIds $ Map.keysSet inPortMap
172        checkAllExist (UndefinedOutPort instString) outPortIds $ Map.keysSet outPortMap
173        netInMap <- transform context inPortMap
174        netOutMap <- transform context outPortMap
175        let curNs = curNamespace context
176            instContext = context
177                { curModule    = name
178                , curNamespace = maybe curNs (:curNs) namespace
179                , inPortMap    = netInMap
180                , outPortMap   = netOutMap
181                }
182        transform instContext mod
183        where
184            checkAllExist fail existing xs = do
185                let undef = xs Set.\\ existing
186                if Set.null undef
187                    then return ()
188                    else mapM_ (failCheck (curModule context) . fail) undef
189
190instance NetTransformable InstAST.NodeDecl NetAST.NetSpec where
191    transform context ast = do
192        let nodeId = InstAST.nodeId ast
193            nodeSpec = InstAST.nodeSpec ast
194            nodeContext = context
195                { curNode = nodeId }
196        netNodeId <- transform context nodeId
197        netNodeSpec <- transform nodeContext nodeSpec
198        return $ Map.fromList [(netNodeId, netNodeSpec)]
199
200instance NetTransformable InstAST.Identifier NetAST.NodeId where
201    transform context ast = do
202        let namespace = curNamespace context
203        return NetAST.NodeId
204            { NetAST.namespace = namespace
205            , NetAST.name      = ast
206            }
207
208instance NetTransformable InstAST.NodeSpec NetAST.NodeSpec where
209    transform context ast = do
210        let
211            nodeType = InstAST.nodeType ast
212            accept = InstAST.accept ast
213            translate = InstAST.translate ast
214            reserved = InstAST.reserved ast
215            overlay = InstAST.overlay ast
216        netTranslate <- transform context translate
217        netOverlay <- case overlay of
218            Nothing -> return Nothing
219            Just o  -> do
220                over <- transform context o
221                return $ Just over
222        return NetAST.NodeSpec
223            { NetAST.nodeType  = nodeType
224            , NetAST.accept    = accept
225            , NetAST.translate = netTranslate
226            , NetAST.reserved  = reserved
227            , NetAST.overlay   = netOverlay
228            }
229
230instance NetTransformable InstAST.MapSpec NetAST.MapSpec where
231    transform context ast = do
232        let
233            srcBlock = InstAST.srcBlock ast
234            destNode = InstAST.destNode ast
235            destBase = InstAST.destBase ast
236            destProps = InstAST.destProps ast
237            errorContext = "tranlate set of node '" ++ curNode context ++ "'"
238        checkReference context (UndefinedReference errorContext) destNode
239        netDestNode <- transform context destNode
240        return NetAST.MapSpec
241            { NetAST.srcBlock = srcBlock
242            , NetAST.destNode = netDestNode
243            , NetAST.destBase = destBase
244            , NetAST.destProps = destProps
245            }
246
247instance NetTransformable InstAST.OverlaySpec NetAST.OverlaySpec where
248    transform context ast = do
249        let
250            over = InstAST.over ast
251            width = InstAST.width ast
252            errorContext = "overlay of node '" ++ curNode context ++ "'"
253        checkReference context (UndefinedReference errorContext) over
254        netOver <- transform context over
255        return NetAST.OverlaySpec
256            { NetAST.over = netOver
257            , NetAST.width = width
258            }
259
260instance (Traversable t, NetTransformable a b) => NetTransformable (t a)  (t b) where
261    transform context as = mapM (transform context) as
262
263
264---
265--- Helpers
266---
267checkReference :: Context -> (String -> NetBuildFail) -> String -> (Checks NetBuildFail) ()
268checkReference context fail name =
269    if name `Set.member` (nodes context)
270        then return ()
271        else failCheck (curModule context) (fail name)
272