Sockeye: Start implementation of net builder
[barrelfish] / tools / sockeye / SockeyeNetBuilder.hs
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
20 module SockeyeNetBuilder
21 ( sockeyeBuildNet ) where
22
23 import Data.Either
24
25 import Data.Map (Map)
26 import qualified Data.Map as Map
27
28 import qualified SockeyeAST as AST
29 import qualified SockeyeASTDecodingNet as NetAST
30
31 import Debug.Trace
32
33 type NetList = [(NetAST.NodeId, NetAST.NodeSpec)]
34
35 newtype CheckFailure = CheckFailure
36     { message :: String }
37
38 instance Show CheckFailure where
39     show f = unlines $ ["", message f]
40
41 data Context = Context
42     { spec        :: AST.SockeyeSpec
43     , paramValues :: Map String Word
44     , varValues   :: Map String Word
45     }
46
47 sockeyeBuildNet :: AST.SockeyeSpec -> Either CheckFailure NetAST.NetSpec
48 sockeyeBuildNet ast = do
49     let
50         emptySpec = AST.SockeyeSpec Map.empty
51         context = Context
52             { spec        = emptySpec
53             , paramValues = Map.empty
54             , varValues   = Map.empty
55             }
56     net <- buildNet context ast
57     -- TODO: check duplicates
58     let
59         nodeMap = Map.fromList net
60     -- TODO: check references
61     return $ NetAST.NetSpec nodeMap
62
63 class NetSource a b where
64     buildNet :: Context -> a -> Either CheckFailure b
65
66 instance NetSource AST.SockeyeSpec NetList where
67     buildNet context ast = do
68         let
69             rootInst = AST.ModuleInst
70                 { AST.nameSpace  = AST.SimpleIdent ""
71                 , AST.moduleName = "@root"
72                 , AST.arguments  = Map.empty
73                 , AST.inPortMap  = []
74                 , AST.outPortMap = []
75                 }
76             specContext = context
77                 { spec = ast }
78         buildNet specContext rootInst
79
80 instance NetSource AST.ModuleInst NetList where
81     buildNet context (AST.MultiModuleInst for) = buildNet context for
82     buildNet context ast = do
83         let
84             nameSpace = AST.nameSpace ast
85             name = AST.moduleName ast
86             args = AST.arguments ast
87             mod = getModule context name
88             nodeDecls = AST.nodeDecls mod
89             modInsts = AST.moduleInsts mod
90             concreteArgs = Map.map argumentValue args
91             modContext = moduleContext concreteArgs
92             nameSpaceId = identToName context nameSpace
93         declNet <- buildNet modContext nodeDecls
94         instNet <- buildNet modContext modInsts
95         let
96             prefixDeclNet = map (prefix nameSpaceId) declNet
97             prefixInstNet = map (prefix nameSpaceId) instNet
98         return $ prefixDeclNet ++ prefixInstNet
99         where
100             argumentValue (AST.AddressArg value) = value
101             argumentValue (AST.NumberArg value) = value
102             argumentValue (AST.ParamArg name) = getParamValue context name
103             moduleContext paramValues =
104                 context
105                     { paramValues = paramValues
106                     , varValues = Map.empty
107                     }
108
109
110 instance NetSource AST.Identifier NetAST.NodeId where
111     buildNet context ast = do
112         let
113             name = identToName context ast
114         return NetAST.NodeId
115             { NetAST.namespace = []
116             , NetAST.name      = name
117             }
118
119 instance NetSource AST.NodeDecl NetList where
120     buildNet context (AST.MultiNodeDecl for) = buildNet context for
121     buildNet context ast = do
122         let
123             ident = AST.nodeId ast
124             nodeSpec = AST.nodeSpec ast
125         nodeId <- buildNet context ident
126         netNodeSpec <- buildNet context nodeSpec
127         return [(nodeId, netNodeSpec)]
128
129 instance NetSource a NetList => NetSource [a] NetList where
130     buildNet context ast = do
131         let
132             decls = map (buildNet context) ast
133             fs = lefts decls
134             ds = rights decls
135         case fs of
136             [] -> return $ concat ds
137             _  -> Left $ CheckFailure (unlines $ map message fs)
138
139 instance NetSource AST.NodeSpec NetAST.NodeSpec where
140     buildNet context ast = do
141         return NetAST.NodeSpec
142             { NetAST.nodeType  = NetAST.Other
143             , NetAST.accept    = []
144             , NetAST.translate = []
145             , NetAST.overlay   = Nothing
146             }
147
148 instance NetSource a NetList => NetSource (AST.For a) NetList where
149     buildNet context ast = do
150         let
151             body = AST.body ast
152             varRanges = AST.varRanges ast
153             concreteRanges = Map.map concreteRange varRanges
154             valueList = Map.foldWithKey iterations [] concreteRanges
155             iterContexts = map iterationContext valueList
156             decls = map (\c -> buildNet c body) iterContexts
157             fs = lefts decls
158             ds = rights decls
159         case fs of
160             [] -> return $ concat ds
161             _  -> Left $ CheckFailure (unlines $ map message fs)
162         where
163             concreteRange range =
164                 let
165                     start = limitVal $ AST.start range
166                     end = limitVal $ AST.end range
167                 in [start..end]
168             limitVal (AST.NumberLimit value) = value
169             limitVal (AST.ParamLimit name) = getParamValue context name
170             iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
171             iterations k vs ms = concat $ map (f ms k) vs
172                 where
173                     f ms k v = map (Map.insert k v) ms
174             iterationContext varMap =
175                 let values = varValues context
176                 in context
177                     { varValues = values `Map.union` varMap }
178
179 getModule :: Context -> String -> AST.Module
180 getModule context name =
181     let
182         modules = AST.modules $ spec context
183     in modules Map.! name
184
185 getParamValue :: Context -> String -> Word
186 getParamValue context name =
187     let
188         params = paramValues context
189     in params Map.! name
190
191 getVarValue :: Context -> String -> Word
192 getVarValue context name =
193     let
194         vars = varValues context
195     in vars Map.! name
196
197 identToName :: Context -> AST.Identifier -> String
198 identToName _ (AST.SimpleIdent name) = name
199 identToName context ident =
200     let
201         prefix = AST.prefix ident
202         varName = AST.varName ident
203         suffix = AST.suffix ident
204         varValue = show $ getVarValue context varName
205         suffixName = case suffix of
206             Nothing -> ""
207             Just s  -> identToName context s
208     in prefix ++ varValue ++ suffixName
209
210 prefix :: String -> (NetAST.NodeId, NetAST.NodeSpec) -> (NetAST.NodeId, NetAST.NodeSpec)
211 prefix nameSpace (nodeId, nodeSpec) =
212     let
213         prevNS = NetAST.namespace nodeId
214         prefixed = if nameSpace == ""
215             then nodeId
216             else nodeId
217                 { NetAST.namespace = nameSpace:prevNS }
218     in (prefixed, nodeSpec)