Sockeye: Rename Checker to TypeChecker
[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 ( buildSockeyeNet ) where
22
23 import Control.Monad.State
24
25 import Data.Either
26 import Data.List (nub, intercalate, sort)
27 import Data.Map (Map)
28 import qualified Data.Map as Map
29 import Data.Maybe (fromMaybe)
30 import Data.Set (Set)
31 import qualified Data.Set as Set
32
33 import SockeyeChecks
34
35 import qualified SockeyeASTInstantiator as InstAST
36 import qualified SockeyeASTDecodingNet as NetAST
37
38 import Debug.Trace
39
40 data NetBuildFails
41     = UndefinedOutPort   !String !String
42     | UndefinedInPort    !String !String
43     | UndefinedReference !String !String
44
45 instance Show NetBuildFails where
46     show (UndefinedInPort  inst port)    = concat ["Mapping to undefined input port '",   port, "' in module instantiation '", inst, "'"]
47     show (UndefinedOutPort inst port)    = concat ["Mapping to undefined output port '",  port, "' in module instantiation '", inst, "'"]
48     show (UndefinedReference decl ident) = concat ["Reference to undefined node '", ident, "' in declaration of node '", decl, "'"]
49
50 type PortMap = Map InstAST.Identifier NetAST.NodeId
51
52 data Context = Context
53     { modules      :: Map String InstAST.Module
54     , curNamespace :: [String]
55     , inPortMap    :: PortMap
56     , outPortMap   :: PortMap
57     , mappedBlocks :: [InstAST.BlockSpec]
58     }
59
60 buildSockeyeNet :: InstAST.SockeyeSpec -> Either (FailedChecks NetBuildFails) NetAST.NetSpec
61 buildSockeyeNet ast = do
62     let
63         context = Context
64             { modules      = Map.empty
65             , curNamespace = []
66             , inPortMap    = Map.empty
67             , outPortMap   = Map.empty
68             , mappedBlocks = []
69             }        
70     net <- runChecks $ transform context ast
71     -- check Set.empty net
72     return net
73
74 --            
75 -- Build net
76 --
77 class NetTransformable a b where
78     transform :: Context -> a -> Checks NetBuildFails b
79
80 instance NetTransformable InstAST.SockeyeSpec NetAST.NetSpec where
81     transform context ast = do
82         let
83             rootInst = InstAST.root ast
84             mods = InstAST.modules ast
85             specContext = context
86                 { modules = mods }
87         transform specContext rootInst
88
89 instance NetTransformable InstAST.Module NetAST.NetSpec where
90     transform context ast = do
91         let ports = InstAST.ports ast
92             nodeDecls = InstAST.nodeDecls ast
93             moduleInsts = InstAST.moduleInsts ast
94         -- TODO check mappings to non existing port
95         portDecls <- transform context ports
96         netDecls <- transform context nodeDecls
97         netInsts <- transform context moduleInsts     
98         return $ Map.unions (portDecls ++ netDecls ++ netInsts)
99
100 instance NetTransformable InstAST.Port NetAST.NetSpec where
101     transform context ast@(InstAST.InputPort {}) = do
102         let portId = InstAST.portId ast
103             portWidth = InstAST.portWidth ast
104             portMap = inPortMap context
105             mappedId = Map.lookup portId portMap
106         netPortId <- transform context portId
107         case mappedId of
108             Nothing    -> return Map.empty
109             Just ident -> do
110                 let node = portNode netPortId portWidth
111                 return $ Map.fromList [(ident, node)]
112     transform context ast@(InstAST.OutputPort {}) = do
113         let portId = InstAST.portId ast
114             portWidth = InstAST.portWidth ast
115             portMap = outPortMap context
116             mappedId = Map.lookup portId portMap
117         netPortId <- transform context portId
118         case mappedId of
119             Nothing    -> return $ Map.fromList [(netPortId, portNodeTemplate)]
120             Just ident -> do
121                 let node = portNode ident portWidth
122                 return $ Map.fromList $ [(netPortId, node)]
123
124 portNode :: NetAST.NodeId -> Integer -> NetAST.NodeSpec
125 portNode destNode width =
126     let base = 0
127         limit = 2^width - 1
128         srcBlock = NetAST.BlockSpec
129             { NetAST.base  = base
130             , NetAST.limit = limit
131             }
132         map = NetAST.MapSpec
133                 { NetAST.srcBlock = srcBlock
134                 , NetAST.destNode = destNode
135                 , NetAST.destBase = base
136                 }
137     in portNodeTemplate { NetAST.translate = [map] }
138
139 portNodeTemplate :: NetAST.NodeSpec
140 portNodeTemplate = NetAST.NodeSpec
141     { NetAST.nodeType  = NetAST.Other
142     , NetAST.accept    = []
143     , NetAST.translate = []
144     }
145
146 instance NetTransformable InstAST.ModuleInst NetAST.NetSpec where
147     transform context ast = do
148         let name = InstAST.moduleName ast
149             namespace = InstAST.namespace ast
150             inPortMap = InstAST.inPortMap ast
151             outPortMap = InstAST.outPortMap ast
152             mod = getModule context name
153         netInMap <- transform context inPortMap
154         netOutMap <- transform context outPortMap
155         let instContext = context
156                 { curNamespace = namespace:(curNamespace context)
157                 , inPortMap    = netInMap
158                 , outPortMap   = netOutMap
159                 }
160         transform instContext mod
161
162 instance NetTransformable InstAST.PortMap PortMap where
163     transform context ast = do
164         mapM (transform context) ast
165
166 instance NetTransformable InstAST.NodeDecl NetAST.NetSpec where
167     transform context ast = do
168         let nodeId = InstAST.nodeId ast
169             nodeSpec = InstAST.nodeSpec ast
170         netNodeId <- transform context nodeId
171         netNodeSpec <- transform context nodeSpec
172         return $ Map.fromList [(netNodeId, netNodeSpec)]
173
174 instance NetTransformable InstAST.Identifier NetAST.NodeId where
175     transform context ast = do
176         let namespace = curNamespace context
177         return NetAST.NodeId
178             { NetAST.namespace = namespace
179             , NetAST.name      = ast
180             }
181
182 instance NetTransformable InstAST.NodeSpec NetAST.NodeSpec where
183     transform context ast = do
184         let
185             nodeType = InstAST.nodeType ast
186             accept = InstAST.accept ast
187             translate = InstAST.translate ast
188             reserved = InstAST.reserved ast
189             overlay = InstAST.overlay ast
190         netTranslate <- transform context translate
191         let
192             mapBlocks = map NetAST.srcBlock netTranslate
193             nodeContext = context
194                 { mappedBlocks = accept ++ mapBlocks ++ reserved }
195         netOverlay <- case overlay of
196                 Nothing -> return []
197                 Just o  -> transform nodeContext o
198         return NetAST.NodeSpec
199             { NetAST.nodeType  = nodeType
200             , NetAST.accept    = accept
201             , NetAST.translate = netTranslate ++ netOverlay
202             }
203
204 instance NetTransformable InstAST.MapSpec NetAST.MapSpec where
205     transform context ast = do
206         let
207             srcBlock = InstAST.srcBlock ast
208             destNode = InstAST.destNode ast
209             destBase = InstAST.destBase ast
210         netDestNode <- transform context destNode
211         return NetAST.MapSpec
212             { NetAST.srcBlock = srcBlock
213             , NetAST.destNode = netDestNode
214             , NetAST.destBase = destBase
215             }
216
217 instance NetTransformable InstAST.OverlaySpec [NetAST.MapSpec] where
218     transform context ast = do
219         let
220             over = InstAST.over ast
221             width = InstAST.width ast
222             blocks = mappedBlocks context
223         netOver <- transform context over
224         let maps = overlayMaps netOver width blocks
225         return maps
226
227 overlayMaps :: NetAST.NodeId -> Integer -> [NetAST.BlockSpec] -> [NetAST.MapSpec]
228 overlayMaps destId width blocks =
229     let
230         blockPoints = concat $ map toScanPoints blocks
231         maxAddress = 2^width
232         overStop  = BlockStart $ maxAddress
233         scanPoints = filter ((maxAddress >=) . address) $ sort (overStop:blockPoints)
234         startState = ScanLineState
235             { insideBlocks    = 0
236             , startAddress    = 0
237             }
238     in evalState (scanLine scanPoints []) startState
239     where
240         toScanPoints (NetAST.BlockSpec base limit) =
241                 [ BlockStart base
242                 , BlockEnd   limit
243                 ]
244         scanLine [] ms = return ms
245         scanLine (p:ps) ms = do
246             maps <- pointAction p ms
247             scanLine ps maps
248         pointAction (BlockStart a) ms = do
249             s <- get       
250             let
251                 i = insideBlocks s
252                 base = startAddress s
253                 limit = a - 1
254             maps <- if (i == 0) && (base <= limit)
255                 then
256                     let
257                         baseAddress = startAddress s
258                         limitAddress = a - 1
259                         srcBlock = NetAST.BlockSpec baseAddress limitAddress
260                         m = NetAST.MapSpec srcBlock destId baseAddress
261                     in return $ m:ms
262                 else return ms
263             modify (\s -> s { insideBlocks = i + 1})
264             return maps
265         pointAction (BlockEnd a) ms = do
266             s <- get
267             let
268                 i = insideBlocks s
269             put $ ScanLineState (i - 1) (a + 1)
270             return ms
271
272 data StoppingPoint
273     = BlockStart { address :: !NetAST.Address }
274     | BlockEnd   { address :: !NetAST.Address }
275     deriving (Eq, Show)
276
277 instance Ord StoppingPoint where
278     (<=) (BlockStart a1) (BlockEnd   a2)
279         | a1 == a2 = True
280         | otherwise = a1 <= a2
281     (<=) (BlockEnd   a1) (BlockStart a2)
282         | a1 == a2 = False
283         | otherwise = a1 <= a2
284     (<=) sp1 sp2 = (address sp1) <= (address sp2)
285
286 data ScanLineState
287     = ScanLineState
288         { insideBlocks :: !Integer
289         , startAddress :: !NetAST.Address
290         } deriving (Show)
291
292 instance NetTransformable a b => NetTransformable [a] [b] where
293     transform context as = mapM (transform context) as
294
295 -- instance (Ord k, NetTransformable a b) => NetTransformable (Map k a) (Map k b) where
296 --     transform context ast = do
297 --         let
298 --             ks = Map.keys ast
299 --             es = Map.elems ast
300 --         ts <- transform context es
301 --         return $ Map.fromList (zip ks ts)
302
303 -- --
304 -- -- Checks
305 -- --
306 -- class NetCheckable a where
307 --     check :: Set NetAST.NodeId -> a -> Either CheckFailure ()
308
309 -- instance NetCheckable NetAST.NetSpec where
310 --     check _ (NetAST.NetSpec net) = do
311 --         let
312 --             specContext = Map.keysSet net
313 --         check specContext $ Map.elems net
314
315 -- instance NetCheckable NetAST.NodeSpec where
316 --     check context net = do
317 --         let
318 --             translate = NetAST.translate net
319 --         check context translate
320
321 -- instance NetCheckable NetAST.MapSpec where
322 --     check context net = do
323 --         let
324 --            destNode = NetAST.destNode net
325 --         check context destNode
326
327 -- instance NetCheckable NetAST.NodeId where
328 --     check context net = do
329 --         if net `Set.member` context
330 --             then return ()
331 --             else Left $ CheckFailure [UndefinedReference $ show net]
332
333 -- instance NetCheckable a => NetCheckable [a] where
334 --     check context net = do
335 --         let
336 --             checked = map (check context) net
337 --             fs = lefts $ checked
338 --         case fs of
339 --             [] -> return ()
340 --             _  -> Left $ CheckFailure (concat $ map failures fs)
341
342 getModule :: Context -> String -> InstAST.Module
343 getModule context name = (modules context) Map.! name