712112dcd9dd4a7036365c777a27241b47c4b4c4
[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 Data.Maybe (fromMaybe, maybe)
29
30 import qualified SockeyeAST as AST
31 import qualified SockeyeASTDecodingNet as NetAST
32
33 import Debug.Trace
34
35 type NetNodeDecl = (NetAST.NodeId, NetAST.NodeSpec)
36 type NetList = [NetNodeDecl]
37
38 newtype CheckFailure = CheckFailure
39     { message :: String }
40
41 instance Show CheckFailure where
42     show f = unlines $ ["", message f]
43
44 data Context = Context
45     { spec           :: AST.SockeyeSpec
46     , curNamespace   :: [String]
47     , paramValues    :: Map String Word
48     , varValues      :: Map String Word
49     }
50
51 sockeyeBuildNet :: AST.SockeyeSpec -> Either CheckFailure NetAST.NetSpec
52 sockeyeBuildNet ast = do
53     let
54         emptySpec = AST.SockeyeSpec Map.empty
55         context = Context
56             { spec         = emptySpec
57             , curNamespace = []
58             , paramValues  = Map.empty
59             , varValues    = Map.empty
60             }
61         net = transform context ast
62     -- TODO: check duplicates
63         netSpec = Map.fromList net
64     -- TODO: check references
65     return netSpec
66
67 class NetTransformable a b where
68     transform :: Context -> a -> b
69
70 instance NetTransformable AST.SockeyeSpec NetList where
71     transform context ast =
72         let
73             rootInst = AST.ModuleInst
74                 { AST.namespace  = AST.SimpleIdent ""
75                 , AST.moduleName = "@root"
76                 , AST.arguments  = Map.empty
77                 , AST.inPortMap  = []
78                 , AST.outPortMap = []
79                 }
80             specContext = context
81                 { spec = ast }
82         in transform specContext rootInst
83
84 instance NetTransformable AST.ModuleInst NetList where
85     transform context (AST.MultiModuleInst for) = transform context for
86     transform context ast =
87         let
88             namespace = AST.namespace ast
89             name = AST.moduleName ast
90             args = AST.arguments ast
91             mod = getModule context name
92             nodeDecls = AST.nodeDecls mod
93             modInsts = AST.moduleInsts mod
94             argValues = transform context args
95             netNamespace = identToName context namespace
96             modContext = moduleContext netNamespace argValues
97             declNet = transform modContext nodeDecls
98             instNet = transform modContext modInsts
99         in declNet ++ instNet
100         where
101             moduleContext namespace paramValues =
102                 let
103                     curNS = curNamespace context
104                     newNS = case namespace of
105                         "" -> curNS
106                         _  -> namespace:curNS
107                 in context
108                     { curNamespace = newNS
109                     , paramValues  = paramValues
110                     , varValues    = Map.empty
111                     }
112
113 instance NetTransformable AST.ModuleArg Word where
114     transform context (AST.AddressArg value) = value
115     transform context (AST.NaturalArg value) = value
116     transform context (AST.ParamArg name) = getParamValue context name
117
118
119 instance NetTransformable AST.Identifier NetAST.NodeId where
120     transform context ast =
121         let
122             namespace = curNamespace context
123             name = identToName context ast
124         in NetAST.NodeId
125             { NetAST.namespace = namespace
126             , NetAST.name      = name
127             }
128
129 instance NetTransformable AST.NodeDecl NetList where
130     transform context (AST.MultiNodeDecl for) = transform context for
131     transform context ast =
132         let
133             ident = AST.nodeId ast
134             nodeSpec = AST.nodeSpec ast
135             nodeId = transform context ident
136             netNodeSpec = transform context nodeSpec
137         in [(nodeId, netNodeSpec)]
138
139 instance NetTransformable AST.NodeSpec NetAST.NodeSpec where
140     transform context ast = 
141         let
142             nodeType = AST.nodeType ast
143             accept = AST.accept ast
144             translate = AST.translate ast
145             overlay = AST.overlay ast
146             netNodeType = maybe NetAST.Other (transform context) nodeType
147             netAccept = map (transform context) accept
148             netTranslate = map (transform context) translate
149             netOverlay = fmap (transform context) overlay
150         in NetAST.NodeSpec
151             { NetAST.nodeType  = netNodeType
152             , NetAST.accept    = netAccept
153             , NetAST.translate = netTranslate
154             , NetAST.overlay   = netOverlay
155             }
156
157 instance NetTransformable AST.NodeType NetAST.NodeType where
158     transform _ AST.Memory = NetAST.Memory
159     transform _ AST.Device = NetAST.Device
160
161 instance NetTransformable AST.BlockSpec NetAST.BlockSpec where
162     transform context (AST.SingletonBlock address) =
163         let
164             netAddress = transform context address
165         in NetAST.BlockSpec
166             { NetAST.base  = netAddress
167             , NetAST.limit = netAddress
168             }
169     transform context (AST.RangeBlock base limit) =
170         let
171             netBase = transform context base
172             netLimit = transform context limit
173         in NetAST.BlockSpec
174             { NetAST.base  = netBase
175             , NetAST.limit = netLimit
176             }
177     transform context (AST.LengthBlock base bits) =
178         let
179             netBase = transform context base
180             netLimit = netBase + 2^bits - 1
181         in NetAST.BlockSpec
182             { NetAST.base  = netBase
183             , NetAST.limit = netLimit
184             }
185
186 instance NetTransformable AST.MapSpec NetAST.MapSpec where
187     transform context ast =
188         let
189             block = AST.block ast
190             destNode = AST.destNode ast
191             destBase = fromMaybe (AST.base block) (AST.destBase ast)
192             netBlock = transform context block
193             netDestNode = transform context destNode
194             netDestBase = transform context destBase
195         in NetAST.MapSpec
196             { NetAST.srcBlock = netBlock
197             , NetAST.destNode = netDestNode
198             , NetAST.destBase = netDestBase
199             }
200
201 instance NetTransformable AST.Address NetAST.Address where
202     transform _ (AST.LiteralAddress value) = value
203     transform context (AST.ParamAddress name) = getParamValue context name
204
205 instance NetTransformable a NetList => NetTransformable (AST.For a) NetList where
206     transform context ast =
207         let
208             body = AST.body ast
209             varRanges = AST.varRanges ast
210             concreteRanges = Map.map (transform context) varRanges
211             valueList = Map.foldWithKey iterations [] concreteRanges
212             iterContexts = map iterationContext valueList
213         in concat $ map (\c -> transform c body) iterContexts
214         where
215             iterations k vs [] = [Map.fromList [(k,v)] | v <- vs]
216             iterations k vs ms = concat $ map (f ms k) vs
217                 where
218                     f ms k v = map (Map.insert k v) ms
219             iterationContext varMap =
220                 let
221                     values = varValues context
222                 in context
223                     { varValues = values `Map.union` varMap }
224
225 instance NetTransformable AST.ForRange [Word] where
226     transform context ast =
227         let
228             start = AST.start ast
229             end = AST.end ast
230             startVal = transform context start
231             endVal = transform context end
232         in [startVal..endVal]
233
234 instance NetTransformable AST.ForLimit Word where
235     transform _ (AST.LiteralLimit value) = value
236     transform context (AST.ParamLimit name) = getParamValue context name
237
238 instance NetTransformable a b => NetTransformable (Map k a) (Map k b) where
239     transform context ast = Map.map (transform context) ast
240
241 instance NetTransformable a NetList => NetTransformable [a] NetList where
242     transform context ast = concat $ map (transform context) ast
243
244 getModule :: Context -> String -> AST.Module
245 getModule context name =
246     let
247         modules = AST.modules $ spec context
248     in modules Map.! name
249
250 getParamValue :: Context -> String -> Word
251 getParamValue context name =
252     let
253         params = paramValues context
254     in params Map.! name
255
256 getVarValue :: Context -> String -> Word
257 getVarValue context name =
258     let
259         vars = varValues context
260     in vars Map.! name
261
262 identToName :: Context -> AST.Identifier -> String
263 identToName _ (AST.SimpleIdent name) = name
264 identToName context ident =
265     let
266         prefix = AST.prefix ident
267         varName = AST.varName ident
268         suffix = AST.suffix ident
269         varValue = show $ getVarValue context varName
270         suffixName = case suffix of
271             Nothing -> ""
272             Just s  -> identToName context s
273     in prefix ++ varValue ++ suffixName