Sockeye: Start implementing decoding net transformation
[barrelfish] / tools / sockeye / SockeyeNetBuilder.hs
index 7511e43..0224180 100644 (file)
@@ -89,20 +89,18 @@ sockeyeBuildNet ast = do
             , AST.inPortMap  = []
             , AST.outPortMap = []
             }
-        (netRoots, simpleAST) = runState (simplify context rootInst) emptySpec
-    traceShow (groom (netRoots :: [AST.ModuleInst])) $ return ()
-    traceShow (groom simpleAST) $ return ()
-    return NetAST.NetSpec
-        { NetAST.net = 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
+        (netRoot:[], simpleAST) = runState (simplify context rootInst) emptySpec
+    trace (groom simpleAST) $ return ()
+    net <- transform context (netRoot :: AST.ModuleInst)
+    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)
@@ -110,6 +108,34 @@ sockeyeBuildNet ast = do
 class ASTSimplifiable a b where
     simplify :: Context -> a -> State AST.SockeyeSpec b
 
+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
+        simpleInPorts <- simplify context inPorts
+        simpleOutPorts <- simplify context outPorts
+        simpleDecls <- simplify context nodeDecls
+        simpleInsts <- simplify context moduleInsts
+        return AST.Module
+            { AST.paramNames   = []
+            , AST.paramTypeMap = Map.empty
+            , AST.inputPorts   = concat (simpleInPorts :: [[AST.Port]])
+            , AST.outputPorts  = concat (simpleOutPorts :: [[AST.Port]])
+            , 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.Port ident) = do
+        simpleIdent <- simplify context ident
+        return [AST.Port simpleIdent]
+
 instance ASTSimplifiable AST.ModuleInst [AST.ModuleInst] where
     simplify context (AST.MultiModuleInst for) = do 
         simpleFor <- simplify context for
@@ -128,12 +154,12 @@ instance ASTSimplifiable AST.ModuleInst [AST.ModuleInst] where
         simpleArgs <- simplify context args
         simpleModule <- simplify (moduleContext simpleArgs) mod
         let
-            simpleName = concat [name, " (", intercalate ", " $ argValues simpleArgs mod, ")"]
+            simpleName = concat [name, "(", intercalate ", " $ argValues simpleArgs mod, ")"]
             simplified = AST.ModuleInst
-                { AST.namespace = simpleNS
+                { AST.namespace  = simpleNS
                 , AST.moduleName = simpleName
-                , AST.arguments = Map.empty
-                , AST.inPortMap = concat (simpleInMap :: [[AST.PortMap]])
+                , AST.arguments  = Map.empty
+                , AST.inPortMap  = concat (simpleInMap :: [[AST.PortMap]])
                 , AST.outPortMap = concat (simpleOutMap :: [[AST.PortMap]])
                 }
         modify $ addModule simpleName simpleModule
@@ -216,6 +242,66 @@ instance ASTSimplifiable AST.Identifier AST.Identifier where
                         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
+            overlay = AST.overlay ast
+        simpleAccept <- simplify context accept
+        simpleTranslate <- simplify context translate
+        simpleOverlay <- maybe (return Nothing) simplifyOverlay overlay
+        return AST.NodeSpec
+            { AST.nodeType  = nodeType
+            , AST.accept    = simpleAccept
+            , AST.translate = simpleTranslate
+            , AST.overlay   = 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
@@ -250,88 +336,37 @@ instance ASTSimplifiable AST.ForLimit Word where
     simplify _ (AST.LiteralLimit value) = return value
     simplify context (AST.ParamLimit name) = return $ getParamValue context name
 
-instance ASTSimplifiable a b => ASTSimplifiable [a] [b] where
+instance (Traversable t, ASTSimplifiable a b) => ASTSimplifiable (t a) (t b) where
     simplify context ast = mapM (simplify context) ast
 
-instance (Ord k, ASTSimplifiable a b) => ASTSimplifiable (Map k a) (Map k b) where
-    simplify context ast = do
-        let
-            ks = Map.keys ast
-            es = Map.elems ast
-        ts <- simplify context es
-        return $ Map.fromList (zip ks ts)
-
 --            
 -- Build net
 --
--- class NetTransformable a b where
---     transform :: Context -> a -> Either CheckFailure b
+class NetTransformable a b where
+    transform :: Context -> a -> Either CheckFailure b
 
--- instance NetTransformable AST.SockeyeSpec NetList where
---     transform 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 }
---         transform specContext rootInst
-
--- instance NetTransformable AST.Port PortList where
---     transform context (AST.MultiPort for) = do
---         ts <- transform context for
---         return $ concat (ts :: [PortList])
---     transform context (AST.Port ident) = do
---         netPort <- transform context ident
---         return [netPort]
+instance NetTransformable AST.Module NetList where
+    transform context ast = return []
 
--- instance NetTransformable AST.ModuleInst NetList where
---     transform context (AST.MultiModuleInst for) = do
---         ts <- transform context for
---         return $ concat (ts :: [NetList])
---     transform 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
---             inPorts = AST.inputPorts mod
---             outPorts = AST.outputPorts mod
---             nodeDecls = AST.nodeDecls mod
---             modInsts = AST.moduleInsts mod
---         argValues <- transform context args
---         let
---             netNamespace = identToName context namespace
---             modContext = moduleContext netNamespace argValues
---         netInPorts <- do
---             ts <- transform modContext inPorts
---             return $ concat (ts :: [PortList])
---         netOutPorts <- do
---             ts <- transform modContext outPorts
---             return $ concat (ts :: [PortList])
---         checkDuplicates netInPorts (DuplicateInPort ast)
---         checkDuplicates netOutPorts (DuplicateOutPort ast)
---         declNet <- transform modContext nodeDecls
---         instNet <- transform modContext modInsts
---         return . concat $ declNet ++ instNet
---         where
---             moduleContext namespace paramValues =
---                 let
---                     curNS = NetAST.ns $ curNamespace context
---                     newNS = case namespace of
---                         "" -> NetAST.Namespace curNS
---                         _  -> NetAST.Namespace $ namespace:curNS
---                 in context
---                     { curNamespace = newNS
---                     , paramValues  = paramValues
---                     , varValues    = Map.empty
---                     }
+instance NetTransformable AST.ModuleInst NetList where
+    transform context ast = do
+        let
+            namespace = AST.namespace ast
+            name = AST.moduleName ast
+            inPortMap = AST.inPortMap ast
+            outPortMap = AST.outPortMap ast
+            mod = getModule context name
+            modContext = moduleContext namespace
+        transform modContext mod
+            where
+                moduleContext namespace =
+                    let
+                        curNS = NetAST.ns $ curNamespace context
+                        newNS = case namespace of
+                            AST.SimpleIdent "" -> NetAST.Namespace curNS
+                            AST.SimpleIdent ns  -> NetAST.Namespace $ ns:curNS
+                    in context
+                        { curNamespace = newNS }
 
 -- instance NetTransformable AST.PortMap PortMap where
 --     transform context (AST.MultiPortMap for) = do