Sockeye: Implement module instantiator
authorDaniel Schwyn <schwyda@student.ethz.ch>
Fri, 28 Jul 2017 14:00:22 +0000 (16:00 +0200)
committerDaniel Schwyn <schwyda@student.ethz.ch>
Fri, 28 Jul 2017 14:00:22 +0000 (16:00 +0200)
Signed-off-by: Daniel Schwyn <schwyda@student.ethz.ch>

tools/sockeye/Main.hs
tools/sockeye/SockeyeAST.hs
tools/sockeye/SockeyeASTInstantiator.hs [new file with mode: 0644]
tools/sockeye/SockeyeASTParser.hs
tools/sockeye/SockeyeChecks.hs
tools/sockeye/SockeyeInstantiator.hs [new file with mode: 0644]
tools/sockeye/SockeyeNetBuilder.hs
tools/sockeye/SockeyeParser.hs
tools/sockeye/SockeyeSimplifier.hs [deleted file]

index 56e224b..dbd7b24 100644 (file)
@@ -27,14 +27,14 @@ import System.IO
 
 import qualified SockeyeASTParser as ParseAST
 import qualified SockeyeAST as AST
+import qualified SockeyeASTInstantiator as InstAST
 import qualified SockeyeASTDecodingNet as NetAST
 
 import SockeyeParser
 import SockeyeChecker
+import SockeyeInstantiator
 import SockeyeNetBuilder
 
-import SockeyeSimplifier
-
 import qualified SockeyeBackendProlog as Prolog
 
 import Debug.Trace
@@ -216,13 +216,13 @@ checkAST parsedAst = do
             exitWith checkError
         Right intermAst -> return intermAst
 
-simplifyAST :: AST.SockeyeSpec -> IO AST.SockeyeSpec
-simplifyAST ast = do
-        case sockeyeSimplify ast of 
-            Left fail -> do
-                hPutStr stderr $ show fail
-                exitWith buildError
-            Right simpleAST -> return simpleAST
+instanitateModules :: AST.SockeyeSpec -> IO InstAST.SockeyeSpec
+instanitateModules ast = do
+    case sockeyeInstantiate ast of 
+        Left fail -> do
+            hPutStr stderr $ show fail
+            exitWith buildError
+        Right simpleAST -> return simpleAST
 
 {- Builds the decoding net from the Sockeye AST -}
 buildNet :: AST.SockeyeSpec -> IO NetAST.NetSpec
@@ -264,8 +264,8 @@ main = do
             out <- dependencyFile outFile f deps
             output f out
     ast <- checkAST parsedAst
-    simpleAST <- simplifyAST ast
-    putStrLn $ groom simpleAST
+    instAST <- instanitateModules ast
+    putStrLn $ groom instAST
     netAst <- buildNet ast
     out <- compile (optTarget opts) netAst
     output outFile out
index d7b68e8..4856eb2 100644 (file)
@@ -95,7 +95,7 @@ data Identifier
     deriving (Show)
 
 data NodeSpec = NodeSpec
-    { nodeType  :: Maybe NodeType
+    { nodeType  :: NodeType
     , accept    :: [BlockSpec]
     , translate :: [MapSpec]
     , reserved  :: [BlockSpec]
@@ -105,6 +105,7 @@ data NodeSpec = NodeSpec
 data NodeType
     = Memory
     | Device
+    | Other
     deriving (Show)
 
 data BlockSpec 
diff --git a/tools/sockeye/SockeyeASTInstantiator.hs b/tools/sockeye/SockeyeASTInstantiator.hs
new file mode 100644 (file)
index 0000000..1b2954a
--- /dev/null
@@ -0,0 +1,71 @@
+{-
+  SockeyeASTInstantiator.hs: AST with instantiated modules for Sockeye
+
+  Part of Sockeye
+
+  Copyright (c) 2017, ETH Zurich.
+
+  All rights reserved.
+
+  This file is distributed under the terms in the attached LICENSE file.
+  If you do not find this file, copies can be found by writing to:
+  ETH Zurich D-INFK, CAB F.78, Universitaetstr. 6, CH-8092 Zurich,
+  Attn: Systems Group.
+-}
+
+module SockeyeASTInstantiator
+    ( module SockeyeASTInstantiator
+    , module SockeyeAST
+    ) where
+
+import Data.Map (Map)
+
+import SockeyeAST
+    ( NodeType(Other, Memory, Device) )
+
+data SockeyeSpec = SockeyeSpec
+    { root :: ModuleInst
+    , modules :: Map String Module
+    } deriving (Show)
+
+data Module = Module
+    { inputPorts   :: Map String Integer
+    , outputPorts  :: Map String Integer
+    , nodeDecls    :: Map String NodeSpec
+    , moduleInsts  :: Map String ModuleInst
+    } deriving (Show)
+
+data ModuleInst
+    = ModuleInst
+        { moduleName :: String
+        , inPortMap  :: Map String String
+        , outPortMap :: Map String String
+        } deriving (Show)
+
+data NodeSpec = NodeSpec
+    { nodeType  :: NodeType
+    , accept    :: [BlockSpec]
+    , translate :: [MapSpec]
+    , reserved  :: [BlockSpec]
+    , overlay   :: Maybe OverlaySpec
+    } deriving (Show)
+
+data BlockSpec 
+    = BlockSpec
+        { base  :: !Integer
+        , limit :: !Integer
+        } deriving (Show)
+
+data MapSpec 
+    = MapSpec
+        { block    :: BlockSpec
+        , destNode :: !String
+        , destBase :: !Integer
+        } deriving (Show)
+
+data OverlaySpec
+    = OverlaySpec
+        { over  :: !String
+        , width :: !Integer
+        } deriving (Show)
+
index 686f4ce..1483991 100644 (file)
@@ -25,7 +25,7 @@ import SockeyeAST
     , ModuleArg(AddressArg, NaturalArg, ParamArg)
     , NodeSpec(NodeSpec)
     , nodeType, accept, translate, reserved, overlay
-    , NodeType(Memory, Device)
+    , NodeType(Other, Memory, Device)
     , BlockSpec(SingletonBlock, RangeBlock, LengthBlock)
     , base, limit, bits
     , MapSpec(MapSpec)
index 5a5279b..65f38ac 100644 (file)
@@ -1,21 +1,72 @@
+{-
+    SockeyeChecks.hs: Helpers to run checks for Sockeye
+
+    Part of Sockeye
+
+    Copyright (c) 2017, ETH Zurich.
+
+    All rights reserved.
+
+    This file is distributed under the terms in the attached LICENSE file.
+    If you do not find this file, copies can be found by writing to:
+    ETH Zurich D-INFK, CAB F.78, Universitaetstr. 6, CH-8092 Zurich,
+    Attn: Systems Group.
+-}
+
 module SockeyeChecks where
 
 import Control.Monad.Writer
 
-type Checks f = Writer [f]
+import Data.List (nub)
 
-newtype CheckFailure f = CheckFailure [f]
+data FailedCheck t = FailedCheck
+    { inModule :: !String
+    , failed   :: t
+    }
 
-instance (Show f) => Show (CheckFailure f) where
-    show (CheckFailure fs) = unlines $ "":(map show fs)
+newtype FailedChecks t = FailedChecks [FailedCheck t]
 
-failure :: f -> Checks f ()
-failure f = tell [f]
+instance (Show t) => Show (FailedChecks t) where
+    show (FailedChecks fs) = 
+        let modules = nub $ map inModule fs
+        in unlines $ concat (map showFailsForModule modules)
+        where
+            showFailsForModule name =
+                let
+                    title = "\nIn module '" ++ name ++ "':"
+                    fails = filter (\f -> name == inModule f) fs
+                in case name of
+                    ""      -> "":showFails 0 fails
+                    ('@':_) -> "":showFails 0 fails
+                    _       -> title:showFails 1 fails
+            showFails indentLevel fs =
+                let
+                    indent = replicate (indentLevel * 4) ' '
+                in map ((indent ++) . showFail) fs
+            showFail f = (show $ failed f)
 
-runChecks :: Checks f a -> Either (CheckFailure f) a
+type Checks f = Writer [FailedCheck f]
+
+failCheck :: String -> t -> Checks t ()
+failCheck context f = tell [FailedCheck context f]
+
+runChecks :: Checks f a -> Either (FailedChecks f) a
 runChecks checks = do
     let
         (a, fs) = runWriter checks
     case fs of
         [] -> return a
-        _  -> Left $ CheckFailure fs
+        _  -> Left $ FailedChecks fs
+
+checkDuplicates :: (Eq a) => String  -> (a -> t) -> [a] -> (Checks t) ()
+checkDuplicates context fail xs = do
+    let
+        ds = duplicates xs
+    case ds of
+        [] -> return ()
+        _  -> mapM_ (failCheck context . fail) ds
+    where
+        duplicates [] = []
+        duplicates (x:xs)
+            | x `elem` xs = nub $ [x] ++ duplicates xs
+            | otherwise = duplicates xs
diff --git a/tools/sockeye/SockeyeInstantiator.hs b/tools/sockeye/SockeyeInstantiator.hs
new file mode 100644 (file)
index 0000000..c69d86d
--- /dev/null
@@ -0,0 +1,401 @@
+{-
+    SockeyeModuleInstantiator.hs: Module instantiator for Sockeye
+
+    Part of Sockeye
+
+    Copyright (c) 2017, ETH Zurich.
+
+    All rights reserved.
+
+    This file is distributed under the terms in the attached LICENSE file.
+    If you do not find this file, copies can be found by writing to:
+    ETH Zurich D-INFK, CAB F.78, Universitaetstr. 6, CH-8092 Zurich,
+    Attn: Systems Group.
+-}
+
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module SockeyeInstantiator
+( sockeyeInstantiate ) where
+
+import Control.Monad.State
+
+import Data.List (intercalate)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe, maybe)
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Numeric (showHex)
+
+import SockeyeChecks
+
+import qualified SockeyeAST as AST
+import qualified SockeyeASTInstantiator as InstAST
+
+import Text.Groom (groom)
+import Debug.Trace
+
+data InstFails
+    = ModuleInstLoop     [String]
+    | DuplicateNamespace !String
+    | DuplicateIdentifer !String
+    | DuplicateInPort    !String
+    | DuplicateOutPort   !String
+    | DuplicateInMap     !String !String
+    | DuplicateOutMap    !String !String
+    | UndefinedOutPort   !String !String
+    | UndefinedInPort    !String !String
+    | UndefinedReference !String !String
+
+instance Show InstFails where
+    show (ModuleInstLoop     loop)       = concat ["Module instantiation loop: '", intercalate "' -> '" loop, "'"]
+    show (DuplicateInPort    port)       = concat ["Multiple declarations of input port '", port, "'"]
+    show (DuplicateOutPort   port)       = concat ["Multiple declarations of output port '", port, "'"]
+    show (DuplicateNamespace ident)      = concat ["Multiple usage of namespace '", ident, "'"]
+    show (DuplicateIdentifer ident)      = concat ["Multiple declarations of node '", ident, "'"]
+    show (DuplicateInMap   inst port)    = concat ["Multiple mappings for input port '",  port, "' in module instantiation '", inst, "'"]
+    show (DuplicateOutMap  inst port)    = concat ["Multiple mappings for output port '", port, "' in module instantiation '", inst, "'"]
+    show (UndefinedInPort  inst port)    = concat ["Mapping to undefined input port '",   port, "' in module instantiation '", inst, "'"]
+    show (UndefinedOutPort inst port)    = concat ["Mapping to undefined output port '",  port, "' in module instantiation '", inst, "'"]
+    show (UndefinedReference decl ident) = concat ["Reference to undefined node '", ident, "' in declaration of node '", decl, "'"]
+
+data Context = Context
+    { spec        :: AST.SockeyeSpec
+    , modulePath  :: [String]
+    , paramValues :: Map String Integer
+    , varValues   :: Map String Integer
+    }
+
+sockeyeInstantiate :: AST.SockeyeSpec -> Either (FailedChecks InstFails) InstAST.SockeyeSpec
+sockeyeInstantiate ast = do
+    let
+        emptySpec = AST.SockeyeSpec Map.empty
+        context = Context
+            { spec        = emptySpec
+            , modulePath  = []
+            , paramValues = Map.empty
+            , varValues   = Map.empty
+            }
+    runChecks $ evalStateT (instantiate context ast) Map.empty
+
+--
+-- Instantiate Module Templates
+--
+class Instantiatable a b where
+    instantiate :: Context -> a -> StateT (Map String InstAST.Module) (Checks InstFails) b
+
+instance Instantiatable AST.SockeyeSpec InstAST.SockeyeSpec where
+    instantiate context ast = do
+        let
+            rootInst = AST.ModuleInst
+                { AST.namespace  = AST.SimpleIdent ""
+                , AST.moduleName = "@root"
+                , AST.arguments  = Map.empty
+                , AST.inPortMap  = []
+                , AST.outPortMap = []
+                }
+            specContext = context
+                { spec = ast }
+        [("", instRoot)] <- instantiate specContext rootInst
+        modules <- get
+        return InstAST.SockeyeSpec
+            { InstAST.root = instRoot
+            , InstAST.modules = modules
+            }
+
+instance Instantiatable AST.Module InstAST.Module where
+    instantiate context ast = do
+        let
+            inPorts = AST.inputPorts ast
+            outPorts = AST.outputPorts ast
+            nodeDecls = AST.nodeDecls ast
+            moduleInsts = AST.moduleInsts ast
+            modName = head $ modulePath context
+        modules <- get
+        if modName `Map.member` modules
+            then do
+                return $ modules Map.! modName
+            else do
+                let sentinel = InstAST.Module
+                        { InstAST.inputPorts   = Map.empty
+                        , InstAST.outputPorts  = Map.empty
+                        , InstAST.nodeDecls    = Map.empty
+                        , InstAST.moduleInsts  = Map.empty
+                        }
+                modify $ Map.insert modName sentinel
+                instInPorts <- do
+                    instPorts <- instantiate context inPorts
+                    return $ concat (instPorts :: [[(String, Integer)]])
+                instOutPorts <- do
+                    instPorts <- instantiate context outPorts
+                    return $ concat (instPorts :: [[(String, Integer)]])
+                instDecls <- do
+                    decls <- instantiate context nodeDecls
+                    return $ concat (decls :: [[(String, InstAST.NodeSpec)]])
+                instInsts <- do
+                    insts <- instantiate context moduleInsts
+                    return $ concat (insts :: [[(String, InstAST.ModuleInst)]])
+                lift $ checkDuplicates modName DuplicateInPort    $ (map fst instInPorts)
+                lift $ checkDuplicates modName DuplicateOutPort   $ (map fst instOutPorts)
+                lift $ checkDuplicates modName DuplicateIdentifer $ (map fst instDecls)
+                lift $ checkDuplicates modName DuplicateNamespace $ (map fst instInsts)
+                return InstAST.Module
+                    { InstAST.inputPorts   = Map.fromList instInPorts
+                    , InstAST.outputPorts  = Map.fromList instOutPorts
+                    , InstAST.nodeDecls    = Map.fromList instDecls
+                    , InstAST.moduleInsts  = Map.fromList instInsts
+                    }
+
+instance Instantiatable AST.Port [(String, Integer)] where
+    instantiate context (AST.MultiPort for) = do
+        instFor <- instantiate context for
+        return $ concat (instFor :: [[(String, Integer)]])
+    instantiate context ast = do
+        let
+            ident = AST.portId ast
+            width = AST.portWidth ast
+        instIdent <- instantiate context ident
+        return [(instIdent, width)]
+
+instance Instantiatable AST.ModuleInst [(String, InstAST.ModuleInst)] where
+    instantiate context (AST.MultiModuleInst for) = do 
+        simpleFor <- instantiate context for
+        return $ concat (simpleFor :: [[(String, InstAST.ModuleInst)]])
+    instantiate context ast = do
+        let
+            namespace = AST.namespace ast
+            name = AST.moduleName ast
+            args = AST.arguments ast
+            inPortMap = AST.inPortMap ast
+            outPortMap = AST.outPortMap ast
+            modPath = modulePath context
+            mod = getModule context name
+        instNs <- instantiate context namespace
+        instInMap <- do
+            inMaps <- instantiate context inPortMap
+            return $ concat (inMaps :: [[(String, String)]])
+        instOutMap <- do
+            outMaps <- instantiate context outPortMap
+            return $ concat (outMaps :: [[(String, String)]])
+        instArgs <- instantiate context args
+        let
+            instName = concat [name, "(", intercalate ", " $ argStrings instArgs mod, ")"]
+            moduleContext = context
+                    { modulePath  = instName:modPath
+                    , paramValues = instArgs
+                    , varValues   = Map.empty
+                    }
+        lift $ checkSelfInst modPath instName
+        lift $ checkDuplicates name (DuplicateInMap  instName) $ map fst instInMap
+        lift $ checkDuplicates name (DuplicateOutMap instName) $ map fst instOutMap
+        let
+            simplified = InstAST.ModuleInst
+                { InstAST.moduleName = instName
+                , InstAST.inPortMap  = Map.fromList instInMap
+                , InstAST.outPortMap = Map.fromList instOutMap
+                }
+        instModule <- instantiate moduleContext mod
+        modify $ Map.insert instName instModule
+        return [(instNs, simplified)]
+        where
+            argStrings args mod =
+                let
+                    paramNames = AST.paramNames mod
+                    paramTypes = AST.paramTypeMap mod
+                    params = map (\p -> (p, paramTypes Map.! p)) paramNames
+                in map showValue params
+                    where
+                        showValue (name, AST.AddressParam)  = "0x" ++ showHex (args Map.! name) ""
+                        showValue (name, AST.NaturalParam) = show (args Map.! name)
+            checkSelfInst path name = do
+                case loop path of
+                    [] -> return ()
+                    l  -> failCheck "" $ ModuleInstLoop (reverse $ name:l)
+                    where
+                        loop [] = []
+                        loop path@(p:ps)
+                            | name `elem` path = p:(loop ps)
+                            | otherwise = []
+
+instance Instantiatable AST.ModuleArg Integer where
+    instantiate _ (AST.AddressArg v) = return v
+    instantiate _ (AST.NaturalArg v) = return v
+    instantiate context (AST.ParamArg name) = return $ getParamValue context name
+
+instance Instantiatable AST.PortMap [(String, String)] where
+    instantiate context (AST.MultiPortMap for) = do
+        instFor <- instantiate context for
+        return $ concat (instFor :: [[(String, String)]])
+    instantiate context ast = do
+        let
+            mappedId = AST.mappedId ast
+            mappedPort = AST.mappedPort ast
+        instId <- instantiate context mappedId
+        instPort <- instantiate context mappedPort
+        return [(instPort, instId)]
+
+instance Instantiatable AST.NodeDecl [(String, InstAST.NodeSpec)] where
+    instantiate context (AST.MultiNodeDecl for) = do
+        instFor <- instantiate context for
+        return $ concat (instFor :: [[(String, InstAST.NodeSpec)]])
+    instantiate context ast = do
+        let
+            nodeId = AST.nodeId ast
+            nodeSpec = AST.nodeSpec ast
+        instNodeId <- instantiate context nodeId
+        instNodeSpec <- instantiate context nodeSpec
+        return [(instNodeId, instNodeSpec)]
+
+instance Instantiatable AST.Identifier String where
+    instantiate context (AST.SimpleIdent name) = do
+        return name
+    instantiate context ast = do
+        let
+            prefix = AST.prefix ast
+            varName = AST.varName ast
+            suffix = AST.suffix ast
+            varValue = show $ getVarValue context varName
+        suffixName <- case suffix of
+            Nothing -> return ""
+            Just s  -> instantiate context s
+        return $ prefix ++ varValue ++ suffixName
+
+instance Instantiatable AST.NodeSpec InstAST.NodeSpec where
+    instantiate context ast = do
+        let
+            nodeType = AST.nodeType ast
+            accept = AST.accept ast
+            translate = AST.translate ast
+            reserved = AST.reserved ast
+            overlay = AST.overlay ast
+        instAccept <- instantiate context accept
+        instTranslate <- instantiate context translate
+        instReserved <- instantiate context reserved
+        instOverlay <- maybe (return Nothing) (\o -> instantiate context o >>= return . Just) overlay
+        return InstAST.NodeSpec
+            { InstAST.nodeType  = nodeType
+            , InstAST.accept    = instAccept
+            , InstAST.translate = instTranslate
+            , InstAST.reserved  = instReserved
+            , InstAST.overlay   = instOverlay
+            }
+
+instance Instantiatable AST.NodeType InstAST.NodeType where
+    instantiate _ AST.Memory = return InstAST.Memory
+    instantiate _ AST.Device = return InstAST.Device
+    instantiate _ AST.Other  = return InstAST.Other
+
+instance Instantiatable AST.BlockSpec InstAST.BlockSpec where
+    instantiate context (AST.SingletonBlock base) = do
+        instBase <- instantiate context base
+        return InstAST.BlockSpec
+            { InstAST.base  = instBase
+            , InstAST.limit = instBase
+            }
+    instantiate context (AST.RangeBlock base limit) = do
+        instBase <- instantiate context base
+        instLimit <- instantiate context limit
+        return InstAST.BlockSpec
+            { InstAST.base  = instBase
+            , InstAST.limit = instLimit
+            }
+    instantiate context (AST.LengthBlock base bits) = do
+        instBase <- instantiate context base
+        let
+            instLimit = instBase + 2^bits - 1
+        return InstAST.BlockSpec
+            { InstAST.base  = instBase
+            , InstAST.limit = instLimit
+            }
+
+instance Instantiatable AST.MapSpec InstAST.MapSpec where
+    instantiate context ast = do
+        let
+            block = AST.block ast
+            destNode = AST.destNode ast
+            destBase = fromMaybe (AST.base block) (AST.destBase ast)
+        instBlock <- instantiate context block
+        instDestNode <- instantiate context destNode
+        instDestBase <- instantiate context destBase
+        return InstAST.MapSpec
+            { InstAST.block    = instBlock
+            , InstAST.destNode = instDestNode
+            , InstAST.destBase = instDestBase
+            }
+
+instance Instantiatable AST.OverlaySpec InstAST.OverlaySpec where
+    instantiate context ast = do
+        let
+            over = AST.over ast
+            width = AST.width ast
+        instOver <- instantiate context over
+        return InstAST.OverlaySpec
+            { InstAST.over  = instOver
+            , InstAST.width = width
+            }
+
+instance Instantiatable AST.Address Integer where
+    instantiate context (AST.ParamAddress name) = do
+        let value = getParamValue context name
+        return value
+    instantiate _ (AST.LiteralAddress value) = return value
+
+instance Instantiatable a b => Instantiatable (AST.For a) [b] where
+    instantiate context ast = do
+        let
+            body = AST.body ast
+            varRanges = AST.varRanges ast
+        concreteRanges <- instantiate context varRanges
+        let
+            valueList = Map.foldWithKey iterations [] concreteRanges
+            iterContexts = map iterationContext valueList
+        mapM (\c -> instantiate c body) iterContexts
+        where
+            iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
+            iterations k vs ms = concat $ map (f ms k) vs
+                where
+                    f ms k v = map (Map.insert k v) ms
+            iterationContext varMap =
+                let
+                    values = varValues context
+                in context
+                    { varValues = values `Map.union` varMap }
+
+instance Instantiatable AST.ForRange [Integer] where
+    instantiate context ast = do
+        let
+            start = AST.start ast
+            end = AST.end ast
+        simpleStart <- instantiate context start
+        simpleEnd <- instantiate context end
+        return [simpleStart..simpleEnd]
+
+instance Instantiatable AST.ForLimit Integer where
+    instantiate _ (AST.LiteralLimit value) = return value
+    instantiate context (AST.ParamLimit name) = return $ getParamValue context name
+
+instance (Traversable t, Instantiatable a b) => Instantiatable (t a) (t b) where
+    instantiate context ast = mapM (instantiate context) ast
+
+
+getModule :: Context -> String -> AST.Module
+getModule context name =
+    let
+        modules = AST.modules $ spec context
+    in modules Map.! name
+
+getParamValue :: Context -> String -> Integer
+getParamValue context name =
+    let
+        params = paramValues context
+    in params Map.! name
+
+getVarValue :: Context -> String -> Integer
+getVarValue context name =
+    let
+        vars = varValues context
+    in vars Map.! name
index dee7e86..fe76bb2 100644 (file)
@@ -302,7 +302,7 @@ instance NetTransformable AST.NodeSpec NetAST.NodeSpec where
             translate = AST.translate ast
             reserved = AST.reserved ast
             overlay = AST.overlay ast
-        netNodeType <- maybe (return NetAST.Other) (transform context) nodeType
+        netNodeType <- transform context nodeType
         netAccept <- transform context accept
         netTranslate <- transform context translate
         netReserved <- transform context reserved
@@ -322,6 +322,7 @@ instance NetTransformable AST.NodeSpec NetAST.NodeSpec where
 instance NetTransformable AST.NodeType NetAST.NodeType where
     transform _ AST.Memory = return NetAST.Memory
     transform _ AST.Device = return NetAST.Device
+    transform _ AST.Other  = return NetAST.Other
 
 instance NetTransformable AST.BlockSpec NetAST.BlockSpec where
     transform context (AST.SingletonBlock address) = do
index d1fd4fe..fd190f6 100644 (file)
@@ -204,7 +204,7 @@ identifier = do
     return ident
 
 nodeSpec = do
-    nodeType <- optionMaybe $ try nodeType
+    nodeType <- option AST.Other $ try nodeType
     accept <- option [] accept 
     translate <- option [] tranlsate
     reserve <- option [] reserve
diff --git a/tools/sockeye/SockeyeSimplifier.hs b/tools/sockeye/SockeyeSimplifier.hs
deleted file mode 100644 (file)
index a66eef1..0000000
+++ /dev/null
@@ -1,406 +0,0 @@
-{-
-    SockeyeNetBuilder.hs: Decoding net builder for Sockeye
-
-    Part of Sockeye
-
-    Copyright (c) 2017, ETH Zurich.
-
-    All rights reserved.
-
-    This file is distributed under the terms in the attached LICENSE file.
-    If you do not find this file, copies can be found by writing to:
-    ETH Zurich D-INFK, CAB F.78, Universitaetstr. 6, CH-8092 Zurich,
-    Attn: Systems Group.
--}
-
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-module SockeyeSimplifier
-( sockeyeSimplify ) where
-
-import Control.Monad.State
-
-import Data.List (nub, intercalate)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe, maybe)
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-import Numeric (showHex)
-
-import SockeyeChecks
-
-import qualified SockeyeAST as AST
-import qualified SockeyeASTDecodingNet as NetAST
-
-import Text.Groom (groom)
-import Debug.Trace
-
-data FailedCheck
-    = ModuleInstLoop [String]
-    | DuplicateInPort !String !String
-    | DuplicateInMap !String !String
-    | UndefinedInPort !String !String
-    | DuplicateOutPort !String !String
-    | DuplicateOutMap !String !String
-    | UndefinedOutPort !String !String
-    | DuplicateIdentifer !String
-    | UndefinedReference !String
-
-instance Show FailedCheck where
-    show (ModuleInstLoop loop) = concat ["Module instantiation loop:'", intercalate "' -> '" loop, "'"]
-    show (DuplicateInPort  modName port) = concat ["Multiple declarations of input port '", port, "' in '", modName, "'"]
-    show (DuplicateInMap   ns      port) = concat ["Multiple mappings for input port '", port, "' in '", ns, "'"]
-    show (UndefinedInPort  modName port) = concat ["'", port, "' is not an input port in '", modName, "'"]
-    show (DuplicateOutPort modName port) = concat ["Multiple declarations of output port '", port, "' in '", modName, "'"]
-    show (DuplicateOutMap   ns     port) = concat ["Multiple mappings for output port '", port, "' in '", ns, "'"]
-    show (UndefinedOutPort modName port) = concat ["'", port, "' is not an output port in '", modName, "'"]
-    show (DuplicateIdentifer ident) = concat ["Multiple declarations of node '", show ident, "'"]
-    show (UndefinedReference ident) = concat ["Reference to undefined node '", show ident, "'"]
-
-data Context = Context
-    { spec         :: AST.SockeyeSpec
-    , curNamespace :: NetAST.Namespace
-    , curModule    :: !String
-    , paramValues  :: Map String Integer
-    , varValues    :: Map String Integer
-    }
-
-sockeyeSimplify :: AST.SockeyeSpec -> Either (CheckFailure FailedCheck) AST.SockeyeSpec
-sockeyeSimplify ast = do
-    let
-        emptySpec = AST.SockeyeSpec Map.empty
-        context = Context
-            { spec         = emptySpec
-            , curNamespace = NetAST.Namespace []
-            , curModule    = ""
-            , paramValues  = Map.empty
-            , varValues    = Map.empty
-            }
-    runChecks $ evalStateT (simplify context ast) Map.empty
-    -- let
-    --     nodeIds = map fst net
-    -- checkDuplicates nodeIds DuplicateIdentifer
-    -- let
-    --     nodeMap = Map.fromList net
-    --     symbols = Map.keysSet nodeMap
-    --     netSpec = NetAST.NetSpec $ nodeMap
-    -- check symbols netSpec
-    -- return netSpec
-
---
--- Simplify AST (instantiate module templates, expand for constructs)
---
-class ASTSimplifiable a b where
-    simplify :: Context -> a -> StateT (Map String AST.Module) (Checks FailedCheck) b
-
-instance ASTSimplifiable AST.SockeyeSpec AST.SockeyeSpec where
-    simplify context ast = do
-        let
-            rootInst = AST.ModuleInst
-                { AST.namespace  = AST.SimpleIdent ""
-                , AST.moduleName = "@root"
-                , AST.arguments  = Map.empty
-                , AST.inPortMap  = []
-                , AST.outPortMap = []
-                }
-            specContext = context
-                { spec = ast }
-        inst <- simplify specContext rootInst
-        return (inst :: [AST.ModuleInst])
-        modules <- get
-        return AST.SockeyeSpec
-            { AST.modules = modules }
-
-instance ASTSimplifiable AST.Module AST.Module where
-    simplify context ast = do
-        let
-            inPorts = AST.inputPorts ast
-            outPorts = AST.outputPorts ast
-            nodeDecls = AST.nodeDecls ast
-            moduleInsts = AST.moduleInsts ast
-            modName = curModule context
-        simpleInPorts <- do
-            simplePorts <- simplify context inPorts
-            return $ concat (simplePorts :: [[AST.Port]])
-        simpleOutPorts <- do
-            simplePorts <- simplify context outPorts
-            return $ concat (simplePorts :: [[AST.Port]])
-        checkDuplicates (map (AST.prefix . AST.portId) simpleInPorts) $ DuplicateInPort modName
-        checkDuplicates (map (AST.prefix . AST.portId) simpleOutPorts) $ DuplicateOutPort modName
-        simpleDecls <- simplify context nodeDecls
-        simpleInsts <- simplify context moduleInsts
-        return AST.Module
-            { AST.paramNames   = []
-            , AST.paramTypeMap = Map.empty
-            , AST.inputPorts   = simpleInPorts
-            , AST.outputPorts  = simpleOutPorts
-            , AST.nodeDecls    = concat (simpleDecls :: [[AST.NodeDecl]])
-            , AST.moduleInsts  = concat (simpleInsts :: [[AST.ModuleInst]])
-            }
-
-instance ASTSimplifiable AST.Port [AST.Port] where
-    simplify context (AST.MultiPort for) = do
-        simpleFor <- simplify context for
-        return $ concat (simpleFor :: [[AST.Port]])
-    simplify context ast@(AST.InputPort {}) = do
-        let
-            ident = AST.portId ast
-            width = AST.portWidth ast
-        simpleIdent <- simplify context ident
-        return [AST.InputPort
-            { AST.portId    = simpleIdent
-            , AST.portWidth = width
-            }]
-    simplify context ast@(AST.OutputPort {}) = do
-        let
-            ident = AST.portId ast
-            width = AST.portWidth ast
-        simpleIdent <- simplify context ident
-        return [AST.OutputPort
-            { AST.portId    = simpleIdent
-            , AST.portWidth = width
-            }]
-
-instance ASTSimplifiable AST.ModuleInst [AST.ModuleInst] where
-    simplify context (AST.MultiModuleInst for) = do 
-        simpleFor <- simplify context for
-        return $ concat (simpleFor :: [[AST.ModuleInst]])
-    simplify context ast = do
-        let
-            namespace = AST.namespace ast
-            name = AST.moduleName ast
-            args = AST.arguments ast
-            inPortMap = AST.inPortMap ast
-            outPortMap = AST.outPortMap ast
-            mod = getModule context name
-        simpleNS <- simplify context namespace
-        simpleInMap <- simplify context inPortMap
-        simpleOutMap <- simplify context outPortMap
-        simpleArgs <- simplify context args
-        let
-            simpleName = concat [name, "(", intercalate ", " $ argValues (simpleArgs :: Map String Integer) mod, ")"]
-        simpleModule <- simplify (moduleContext simpleName simpleArgs) mod
-        let
-            simplified = AST.ModuleInst
-                { AST.namespace  = simpleNS
-                , AST.moduleName = simpleName
-                , AST.arguments  = Map.empty
-                , AST.inPortMap  = concat (simpleInMap :: [[AST.PortMap]])
-                , AST.outPortMap = concat (simpleOutMap :: [[AST.PortMap]])
-                }
-        modify $ Map.insert simpleName simpleModule
-        return [simplified]
-        where
-            moduleContext name paramValues = context
-                    { curModule   = name
-                    , paramValues = paramValues
-                    , varValues   = Map.empty
-                    }
-            argValues args mod =
-                let
-                    paramNames = AST.paramNames mod
-                    paramTypes = AST.paramTypeMap mod
-                    params = map (\p -> (p, paramTypes Map.! p)) paramNames
-                in map showValue params
-                    where
-                        showValue (name, AST.AddressParam)  = "0x" ++ showHex (args Map.! name) ""
-                        showValue (name, AST.NaturalParam) = show (args Map.! name)
-            addModule k m spec =
-                let
-                    prevMods = AST.modules spec
-                    newMods = Map.insert k m prevMods
-                in spec
-                    { AST.modules = newMods }
-
-instance ASTSimplifiable AST.ModuleArg Integer where
-    simplify _ (AST.AddressArg v) = return v
-    simplify _ (AST.NaturalArg v) = return v
-    simplify context (AST.ParamArg name) = return $ getParamValue context name
-
-instance ASTSimplifiable AST.PortMap [AST.PortMap] where
-    simplify context (AST.MultiPortMap for) = do
-        simpleFor <- simplify context for
-        return $ concat (simpleFor :: [[AST.PortMap]])
-    simplify context ast = do
-        let
-            mappedId = AST.mappedId ast
-            mappedPort = AST.mappedPort ast
-        simpleId <- simplify context mappedId
-        simplePort <- simplify context mappedPort
-        let
-            simplePortMap = AST.PortMap
-                { AST.mappedId   = simpleId
-                , AST.mappedPort = simplePort
-                }
-        return [simplePortMap]
-
-instance ASTSimplifiable AST.NodeDecl [AST.NodeDecl] where
-    simplify context (AST.MultiNodeDecl for) = do
-        simpleFor <- simplify context for
-        return $ concat (simpleFor :: [[AST.NodeDecl]])
-    simplify context ast = do
-        let
-            nodeId = AST.nodeId ast
-            nodeSpec = AST.nodeSpec ast
-        simpleNodeId <- simplify context nodeId
-        simpleNodeSpec <- simplify context nodeSpec
-        let
-            simpleNodeDecl = AST.NodeDecl
-                { AST.nodeId   = simpleNodeId
-                , AST.nodeSpec = simpleNodeSpec
-                }
-        return [simpleNodeDecl]
-
-instance ASTSimplifiable AST.Identifier AST.Identifier where
-    simplify context ast = do
-        let
-            name = simpleName ast
-        return $ AST.SimpleIdent name
-        where
-            simpleName (AST.SimpleIdent name) = name
-            simpleName ident =
-                let
-                    prefix = AST.prefix ident
-                    varName = AST.varName ident
-                    suffix = AST.suffix ident
-                    varValue = show $ getVarValue context varName
-                    suffixName = case suffix of
-                        Nothing -> ""
-                        Just s  -> simpleName s
-                in prefix ++ varValue ++ suffixName
-
-instance ASTSimplifiable AST.NodeSpec AST.NodeSpec where
-    simplify context ast = do
-        let
-            nodeType = AST.nodeType ast
-            accept = AST.accept ast
-            translate = AST.translate ast
-            reserved = AST.reserved ast
-            overlay = AST.overlay ast
-        simpleAccept <- simplify context accept
-        simpleTranslate <- simplify context translate
-        simpleReserved <- simplify context reserved
-        -- simpleOverlay <- maybe (return Nothing) simplifyOverlay overlay
-        return AST.NodeSpec
-            { AST.nodeType  = nodeType
-            , AST.accept    = simpleAccept
-            , AST.translate = simpleTranslate
-            , AST.reserved  = simpleReserved
-            , AST.overlay   = Nothing --simpleOverlay
-            }
-        -- where
-        --     simplifyOverlay ident = do
-        --         simpleIdent <- simplify context ident
-        --         return $ Just simpleIdent
-
-instance ASTSimplifiable AST.BlockSpec AST.BlockSpec where
-    simplify context (AST.SingletonBlock base) = do
-        simpleBase <- simplify context base
-        return $ AST.SingletonBlock simpleBase
-    simplify context (AST.RangeBlock base limit) = do
-        simpleBase <- simplify context base
-        simpleLimit <- simplify context limit
-        return AST.RangeBlock
-            { AST.base  = simpleBase
-            , AST.limit = simpleLimit
-            }
-    simplify context (AST.LengthBlock base bits) = do
-        simpleBase <- simplify context base
-        return AST.LengthBlock
-            { AST.base = simpleBase
-            , AST.bits = bits
-            }
-
-instance ASTSimplifiable AST.MapSpec AST.MapSpec where
-    simplify context ast = do
-        let
-            block = AST.block ast
-            destNode = AST.destNode ast
-            destBase = fromMaybe (AST.base block) (AST.destBase ast)
-        simpleBlock <- simplify context block
-        simpleDestNode <- simplify context destNode
-        simpleDestBase <- simplify context destBase
-        return AST.MapSpec
-            { AST.block    = simpleBlock
-            , AST.destNode = simpleDestNode
-            , AST.destBase = Just simpleDestBase
-            }
-
-instance ASTSimplifiable AST.Address AST.Address where
-    simplify context (AST.ParamAddress name) = do
-        let value = getParamValue context name
-        return $ AST.LiteralAddress value
-    simplify _ ast = return ast
-
-instance ASTSimplifiable a b => ASTSimplifiable (AST.For a) [b] where
-    simplify context ast = do
-        let
-            body = AST.body ast
-            varRanges = AST.varRanges ast
-        concreteRanges <- simplify context varRanges
-        let
-            valueList = Map.foldWithKey iterations [] concreteRanges
-            iterContexts = map iterationContext valueList
-        mapM (\c -> simplify c body) iterContexts
-        where
-            iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
-            iterations k vs ms = concat $ map (f ms k) vs
-                where
-                    f ms k v = map (Map.insert k v) ms
-            iterationContext varMap =
-                let
-                    values = varValues context
-                in context
-                    { varValues = values `Map.union` varMap }
-
-instance ASTSimplifiable AST.ForRange [Integer] where
-    simplify context ast = do
-        let
-            start = AST.start ast
-            end = AST.end ast
-        simpleStart <- simplify context start
-        simpleEnd <- simplify context end
-        return [simpleStart..simpleEnd]
-
-instance ASTSimplifiable AST.ForLimit Integer where
-    simplify _ (AST.LiteralLimit value) = return value
-    simplify context (AST.ParamLimit name) = return $ getParamValue context name
-
-instance (Traversable t, ASTSimplifiable a b) => ASTSimplifiable (t a) (t b) where
-    simplify context ast = mapM (simplify context) ast
-
-
-getModule :: Context -> String -> AST.Module
-getModule context name =
-    let
-        modules = AST.modules $ spec context
-    in modules Map.! name
-
-getParamValue :: Context -> String -> Integer
-getParamValue context name =
-    let
-        params = paramValues context
-    in params Map.! name
-
-getVarValue :: Context -> String -> Integer
-getVarValue context name =
-    let
-        vars = varValues context
-    in vars Map.! name
-
-checkDuplicates :: (Eq a, Show a) => [a] -> (String -> FailedCheck) -> StateT (Map String AST.Module) (Checks FailedCheck) ()
-checkDuplicates nodeIds fail = do
-    let
-        duplicates = duplicateNames nodeIds
-    case duplicates of
-        [] -> return ()
-        _  -> lift $ mapM_ (failure . fail . show) duplicates
-    where
-        duplicateNames [] = []
-        duplicateNames (x:xs)
-            | x `elem` xs = nub $ [x] ++ duplicateNames xs
-            | otherwise = duplicateNames xs