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