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