1{-# LANGUAGE DeriveGeneric, DuplicateRecordFields #-}
2
3module SockeyeBackendLISA
4    ( compileDirect
5    )
6where
7
8import qualified Data.Map as Map
9import Data.List
10import Data.Maybe
11import Data.Ord
12import Data.Aeson
13import Control.Exception (throw, Exception)
14import Debug.Trace
15import GHC.Generics
16import Text.Read
17
18import qualified SockeyeSymbolTable as SST
19import qualified SockeyeAST as SAST
20import qualified SockeyeParserAST as SPAST
21
22{- Auxiliary File -}
23
24data AuxData = AuxData
25    { connections :: [AuxConnection]
26    , parameters :: [AuxParameter]
27    }
28    deriving (Generic, Show)
29
30instance FromJSON AuxData
31
32data AuxConnection = AuxConnection
33    { moduleName :: String
34    , source :: AuxConnectionDef
35    , target :: AuxConnectionDef
36    }
37    deriving (Generic, Show)
38
39instance FromJSON AuxConnection
40
41instance LISAGenerator AuxConnection where
42    generate (AuxConnection _ source target) = (generate source) ++ " => " ++ (generate target) ++ ";"
43
44data AuxConnectionDef = AuxConnectionDef
45    { name :: String
46    , port :: String
47    , address :: Maybe String
48    }
49    deriving (Generic, Show)
50
51instance FromJSON AuxConnectionDef
52
53instance LISAGenerator AuxConnectionDef where
54    generate (AuxConnectionDef name port (Just address)) = name ++ "." ++ port ++ "[" ++ address ++ "]"
55    generate (AuxConnectionDef name port Nothing) = name ++ "." ++ port
56
57data AuxParameter = AuxParameter
58    { moduleName :: String
59    , component :: String
60    , name :: String
61    , translation :: Maybe String
62    , value :: Maybe String
63    }
64    deriving (Generic, Show)
65
66instance FromJSON AuxParameter
67
68{- LISA Backend -}
69
70class LISAGenerator a where
71    generate :: a -> String
72
73compileDirect :: SPAST.Sockeye -> Maybe AuxData -> String
74compileDirect s aux = let
75    -- sockeye = preprocess s
76    sockeye = s
77    files = map snd (Map.toList (SPAST.files sockeye))
78    modules = map (\file -> generateModules (SPAST.modules file) aux) files
79    in
80        intercalate "\n" modules
81
82{- Ports -}
83
84data Ports = Ports
85    { ports_auxData :: Maybe AuxData
86    , ports_nodeDecls :: [SPAST.NodeDeclaration]
87    }
88    deriving (Show)
89
90instance LISAGenerator Ports where
91    generate (Ports _ nodeDecls) = let
92        ports = map generate nodeDecls
93        in
94            intercalate "\n" ports
95
96{- Resources -}
97
98data Resources = Resources
99    { res_auxData :: Maybe AuxData
100    , res_parameters    :: [SPAST.ModuleParameter]
101    , res_constants     :: [SPAST.NamedConstant]
102    }
103    deriving (Show)
104
105instance LISAGenerator Resources where
106    generate r = let
107        parameters = map generate (res_parameters r)
108        constants = map (\(SPAST.NamedConstant _ name value) -> "PARAMETER { type(int), default(" ++ (show value) ++ ") } " ++ name ++ ";") (res_constants r)
109        in
110            "resources {\n"
111            ++ (intercalate "\n" $ parameters ++ constants)
112            ++ "\n}"
113
114{- Composition -}
115
116data Composition = Composition
117    { comp_moduleName :: String
118    , comp_auxData :: Maybe AuxData
119    , comp_modules :: [SPAST.Module]
120    , comp_declarations :: [SPAST.NodeDeclaration]
121    , comp_definitions :: [SPAST.Definition]
122    }
123    deriving (Show)
124
125instance LISAGenerator Composition where
126    generate (Composition moduleName auxData modules declarations definitions) = let
127        composition = (filter (not . null) (map (\def -> generateInstantiation moduleName auxData def modules) definitions))
128
129        filteredDefs = filter (\x -> (||) (isOverlays x) $ (||) (isAccepts x) (isMaps x)) definitions
130        zipped = matchDefinitionsAndDeclarations declarations filteredDefs
131        associatedComponents = nub $ concatMap (generateAssociatedComponents) zipped
132        derivedComponents = associatedComponents
133        in
134            "composition {\n"
135            ++ (intercalate "\n" $ composition ++ derivedComponents)
136            ++ "\n}"
137
138generateInstantiation :: String -> Maybe AuxData -> SPAST.Definition -> [SPAST.Module] -> String
139generateInstantiation moduleName auxData (SPAST.Instantiates meta inst mod args) modules = let
140    params = case find (((==) mod) . SPAST.moduleName) modules of
141        Nothing -> error $ "Module parameters not found for " ++ mod ++ " : " ++ (show meta)
142        Just x -> map SPAST.paramName (SPAST.parameters x)
143    mapParamName _name = case auxData of
144        Nothing -> _name
145        Just AuxData{parameters=params} -> case find (\AuxParameter{moduleName=modName, name=__name, component=cName} -> (modName == moduleName) && (_name == __name) && (SAST.refName inst) == cName) params of
146            Just AuxParameter{translation=(Just translation)} -> translation
147            _ -> _name
148    mapParamValue _name value = case auxData of
149        Nothing -> value
150        Just AuxData{parameters=params} -> case find (\AuxParameter{moduleName=modName, name=__name, component=cName} -> (modName == moduleName) && (_name == __name) && (SAST.refName inst) == cName) params of
151            Just AuxParameter{value=(Just _value)} -> _value
152            _ -> value
153    in
154        (generate inst) ++ ": " ++ mod ++ "(" ++ (intercalate ", " (map (\(name, arg) -> "\"" ++ (mapParamName name) ++ "\"=" ++ (mapParamValue name $ generate arg)) (zip params args))) ++ ");"
155generateInstantiation _ _ _ _ = ""
156
157generateAssociatedComponents :: (SPAST.NodeDeclaration, SPAST.Definition) -> [String]
158generateAssociatedComponents ((SPAST.NodeDeclaration _ _ (SPAST.NodeType _ SPAST.Memory _ _ _) _ _), (SPAST.Maps _ node _)) = [(generate node) ++ "_DECODER: PVBusDecoder();"]
159generateAssociatedComponents ((SPAST.NodeDeclaration _ _ (SPAST.NodeType _ SPAST.Memory (SST.TypeLiteral _ (SST.AddressType _ sets)) _ _) _ _), (SPAST.Accepts _ node _)) = [(generate node) ++ "_DECODER: PVBusDecoder();", (generate node) ++ "_MEMORY: RAMDevice(\"size\"=" ++ (snd $ getNaturalSetBounds $ head sets) ++ ");"]
160generateAssociatedComponents ((SPAST.NodeDeclaration _ _ (SPAST.NodeType _ SPAST.Memory (SST.TypeName _ name) _ _) _ _), (SPAST.Accepts _ node _)) = [(generate node) ++ "_DECODER: PVBusDecoder();", (generate node) ++ "_MEMORY: RAMDevice(\"size\"=" ++ (name) ++ ");"]
161generateAssociatedComponents ((SPAST.NodeDeclaration _ _ (SPAST.NodeType _ SPAST.Memory _ _ _) _ _), (SPAST.Overlays _ node _)) = [(generate node) ++ "_DECODER: PVBusDecoder();"]
162generateAssociatedComponents _ = []
163
164data Connection = Connection
165    { conn_moduleName :: String
166    , conn_auxData :: Maybe AuxData
167    , conn_declarations :: [SPAST.NodeDeclaration]
168    , conn_definitions :: [SPAST.Definition]
169    }
170    deriving (Show)
171
172instance LISAGenerator Connection where
173    generate (Connection moduleName auxData declarations definitions) = let
174        decls = declarations
175        sortedConnections = sortBy overlaysFirst (filter (not . isInstantiation) definitions)
176        part = partition (\x -> (||) (isOverlays x) $ (||) (isAccepts x) (isMaps x)) sortedConnections
177        derivedConnections = matchDefinitionsAndDeclarations decls (fst part)
178        basicConnections = snd part
179        connection = nub $ filter (not . null) $ (map generateDecoderConnection derivedConnections) ++ (map generateAssociatedConnection derivedConnections) ++ (map generate basicConnections)
180        auxConnections = case auxData of
181            Nothing -> []
182            Just AuxData{connections=conns} -> map generate (filter (\AuxConnection{moduleName=_name} -> _name == moduleName) conns)
183        in
184            "connection {\n"
185            ++ (intercalate "\n" $ connection ++ auxConnections)
186            ++ "\n}"
187
188{- Sockeye AST -}
189instance LISAGenerator SAST.UnqualifiedRef where
190    generate (SAST.UnqualifiedRef _ name index) = name ++ (generate index)
191
192instance LISAGenerator SAST.NodeReference where
193    generate (SAST.InternalNodeRef _ ref) = generate ref
194    generate (SAST.InputPortRef _ inst node) = (generate inst) ++ "." ++ (generate node)
195
196instance LISAGenerator SAST.ArrayIndex where
197    generate (SAST.ArrayIndex _ set) = head (map generate set)
198
199instance LISAGenerator SAST.Address where
200    generate (SAST.Address _ set) = head (map generate set)
201
202instance LISAGenerator SAST.AddressBlock where
203    generate (SAST.AddressBlock _ addr _) = generate addr
204
205instance LISAGenerator SAST.WildcardSet where
206    generate (SAST.ExplicitSet _ set) = generate set
207    generate (SAST.Wildcard _) = ""
208
209instance LISAGenerator SAST.NaturalSet where
210    generate set = let
211        bounds = getNaturalSetBounds set
212        in
213            if ((fst bounds) == (snd bounds)) then "[" ++ (fst bounds) ++ "]" else "[" ++ (fst bounds) ++ ".." ++ (snd bounds) ++ "]"
214
215instance LISAGenerator SAST.NaturalRange where
216    generate range = let
217        bounds = getNaturalRangeBounds range
218        in
219            "[" ++ (fst bounds) ++ ".." ++ (snd bounds) ++ "]"
220
221instance LISAGenerator SAST.NaturalExpr where
222    generate (SAST.Addition _ exprL exprR) = "(" ++ (generate exprL) ++ ") + (" ++ (generate exprR) ++ ")"
223    generate (SAST.Subtraction _ exprL exprR) = "(" ++ (generate exprL) ++ ") - (" ++ (generate exprR) ++ ")"
224    generate (SAST.Multiplication _ exprL exprR) = "(" ++ (generate exprL) ++ ") * (" ++ (generate exprR) ++ ")"
225    generate (SAST.Slice meta expr range) = let
226        value = generate expr
227        lower = rangeLowerBound range
228        upper = rangeUpperBound range
229        shift = value ++ " >> " ++ lower
230        mask = "(1ul << ((" ++ upper ++ ") - (" ++ lower ++ ") + 1)) - 1"
231        in
232            "(" ++ shift ++ ") & (" ++ mask ++ ")"
233    generate (SAST.Concat _ exprL (SAST.Slice meta exprR range)) = let
234        value = generate exprL
235        concat = generate (SAST.Slice meta exprR range)
236        lower = rangeLowerBound range
237        upper = rangeUpperBound range
238        shift = "((" ++ value ++ ") << (" ++ upper ++ ") - (" ++ lower ++ ") + 1))"
239        in
240            shift ++ " | " ++ concat
241    generate (SAST.Concat meta _ _) = error ("Invalid concat expression: " ++ (show meta))
242    generate (SAST.Parameter _ name) = name
243    generate (SAST.Constant _ name) = name
244    generate (SAST.Variable _ name) = name
245    generate (SAST.Literal _ value) = show value
246
247instance LISAGenerator SAST.PropertyExpr where
248    generate (SAST.And meta _ _) = error ("Property expression not supported: " ++ (show meta))
249    generate (SAST.Or meta _ _) = error ("Property expression not supported: " ++ (show meta))
250    generate (SAST.Not meta _) = error ("Property expression not supported: " ++ (show meta))
251    generate (SAST.Property meta _) = error ("Property expression not supported: " ++ (show meta))
252    generate (SAST.True) = error ("True Property expression not supported")
253    generate (SAST.False) = error ("False Property expression not supported")
254
255{- Sockeye Symbol Table -}
256instance LISAGenerator SST.Instance where
257    generate _ = "NYI"
258
259instance LISAGenerator SST.Node where
260    generate _ = "NYI"
261
262instance LISAGenerator SST.Domain where
263    generate SST.Memory = "PVBus"
264    generate SST.Interrupt = "Signal"
265    generate SST.Power = error "Power domain is not supported"
266    generate SST.Clock = "ClockSignal"
267
268instance LISAGenerator SST.EdgeType where
269    generate (SST.TypeLiteral _ address) = generate address
270    generate (SST.TypeName _ name) = name
271
272instance LISAGenerator SST.NamedConstant where
273    generate _ = "NYI"
274
275instance LISAGenerator SST.ArraySize where
276    generate (SST.ArraySize meta sets) = let 
277        bounds = getNaturalSetBounds $ head sets
278        lower = fst bounds
279        err = case readMaybe lower :: Maybe Integer of
280            Nothing -> error ("Failed to parse lower bound as integer: " ++ (show meta))
281            Just 0 -> ""
282            Just _ -> error ("Lower bound of array size is not 0: " ++ (show meta))
283        upper = snd bounds
284        in
285            if err == "" then (case readMaybe upper :: Maybe Integer of
286                Nothing -> error ("Failed to parse upper bound as integer: " ++ (show meta))
287                Just int -> "[" ++ (show $ int + 1) ++ "]") else ""
288
289
290instance LISAGenerator SST.AddressType where
291    generate (SST.AddressType _ sets) = generate $ head sets
292
293{- Sockeye Parser AST -}
294instance LISAGenerator SPAST.NamedConstant where
295    generate _ = "NYI"
296
297instance LISAGenerator SPAST.NamedType where
298    generate _ = "NYI"
299
300instance LISAGenerator SPAST.PortBinding where
301    generate (SPAST.PortBinding _ port node) = "." ++ (generate port) ++ " => " ++ "self." ++ (generate node)
302
303instance LISAGenerator SPAST.MapTarget where
304    generate (SPAST.MapTarget _ node addr) = (generate node) ++ (generate addr)
305
306instance LISAGenerator SPAST.MapSpec where
307    generate (SPAST.MapSpec _ addrBlock targets) = intercalate "ERROR" (map (\target -> (generate addrBlock) ++ " => " ++ (generate target)) targets)
308
309instance LISAGenerator SPAST.Definition where
310    generate (SPAST.Accepts _ node addrBlocks) = intercalate "\n" (map (\addrBlock -> "self." ++ (generate node) ++ (generate addrBlock) ++ " => " ++ "self." ++ (generate node) ++ (generate addrBlock) ++ ";") addrBlocks)
311    generate (SPAST.Maps _ node specs) = intercalate "\n" (map (\spec -> "self." ++ (generate node) ++ (generate spec) ++ ";") specs)
312    generate (SPAST.Converts meta _ _) = error ("Converts not supported: " ++ (show meta))
313    generate (SPAST.Overlays meta node (SAST.InternalNodeRef _ target)) = "self." ++ (generate node) ++ " => self." ++ (generate target) ++ ";"
314    generate (SPAST.BlockOverlays meta _ _ _) = error ("BlockOverlays not supported: " ++ (show meta))
315    generate (SPAST.Instantiates meta ref mod args) = error ("Invalid definition statement: " ++ (show meta))
316    generate (SPAST.Binds _ node bindings) = intercalate "\n" (map (\binding -> (generate node) ++ (generate binding) ++ ";") bindings)
317    generate (SPAST.Forall meta _ _ _) = error ("Forall not supported: " ++ (show meta))
318
319generateAssociatedConnection :: (SPAST.NodeDeclaration, SPAST.Definition) -> String
320generateAssociatedConnection ((SPAST.NodeDeclaration _ _ (SST.NodeType _ SST.Memory _ _ _) _ _), (SPAST.Maps _ node specs)) = intercalate "\n" (map (\spec -> (generate node) ++ "_DECODER.pvbus_m_range" ++ (generate spec) ++ ";") specs)
321generateAssociatedConnection ((SPAST.NodeDeclaration _ _ (SST.NodeType _ SST.Memory _ _ _) _ _), (SPAST.Accepts _ node addrBlocks)) = intercalate "\n" (map (\addrBlock -> (generate node) ++ "_DECODER.pvbus_m_range" ++ (generate addrBlock) ++ " => " ++ (generate node) ++ "_MEMORY.pvbus" ++ (generate addrBlock) ++ ";") addrBlocks)
322generateAssociatedConnection ((SPAST.NodeDeclaration _ _ (SST.NodeType _ SST.Memory edge _ _) _ _), (SPAST.Overlays _ node target)) = (generate node) ++ "_DECODER.pvbus_m_range" ++ (generate edge) ++ " => self." ++ (generate target) ++ ";"
323generateAssociatedConnection (_, def) = generate def
324
325generateDecoderConnection :: (SPAST.NodeDeclaration, SPAST.Definition) -> String
326generateDecoderConnection ((SPAST.NodeDeclaration _ _ (SST.NodeType _ SST.Memory _ _ _) name _), _) = "self." ++ name ++ " => " ++ name ++ "_DECODER.pvbus_s;"
327generateDecoderConnection _ = ""
328
329instance LISAGenerator SPAST.NodeKind where
330    generate SPAST.InputPort = "master"
331    generate SPAST.InternalNode = "internal"
332    generate SPAST.OutputPort = "slave"
333
334instance LISAGenerator SPAST.NodeDeclaration where
335    generate (SPAST.NodeDeclaration _ nodeKind (SPAST.NodeType _ domain _ _ _) name size) = let
336        _kind = generate nodeKind
337        protocol = generate domain
338        in
339            _kind ++ " port<" ++ protocol ++ "> " ++ name ++ (generate size) ++ " {}"
340
341instance LISAGenerator SPAST.InstanceDeclaration where
342    generate (SPAST.InstanceDeclaration meta _ _ _) = error ("Instances declarations are not supported: " ++ (show meta))
343
344instance LISAGenerator SPAST.ModuleParameter where
345    generate (SPAST.ModuleParameter _ name set) = "PARAMETER { type(int), min(" ++ (fst (getNaturalSetBounds set)) ++ "), max(" ++ (snd (getNaturalSetBounds set)) ++ ") } " ++ name ++ ";"
346
347generateModules :: [SPAST.Module] -> Maybe AuxData -> String
348generateModules ms aux = intercalate "\n" (map generateModule (filter (not . SPAST.moduleExtern) ms))
349        where 
350            generateModule m = let
351                moduleName = SPAST.moduleName m
352                ports = generate (Ports aux (SPAST.nodeDecls m))
353                resources = generate (Resources aux (SPAST.parameters m) (SPAST.constants m))
354                composition = generate (Composition moduleName aux ms (SPAST.nodeDecls m) (SPAST.definitions m))
355                connection = generate (Connection moduleName aux (SPAST.nodeDecls m) (SPAST.definitions m))
356                in
357                    "component " ++ moduleName ++ " {\n\n"
358                        ++ ports ++ "\n\n"
359                        ++ resources ++ "\n\n"
360                        ++ composition ++ "\n\n"
361                        ++ connection ++ "\n\n"
362                        ++ "}"
363
364instance (LISAGenerator a) => LISAGenerator (Maybe a) where
365    generate (Just some) = generate some
366    generate Nothing = ""
367
368{- Helper Functions-}
369
370getNaturalSetBounds :: SAST.NaturalSet -> (String, String)
371getNaturalSetBounds (SAST.NaturalSet _ (range:[])) = getNaturalRangeBounds range
372getNaturalSetBounds (SAST.NaturalSet meta (range:ranges)) = let
373    bounds = getNaturalRangeBounds range
374    end = getNaturalSetBounds (SAST.NaturalSet meta ranges)
375    in
376        ("(" ++ (fst bounds) ++ " * " ++ (fst end) ++ ")", "(" ++ (snd bounds) ++ " * " ++ (snd end) ++ ")")
377
378getNaturalRangeBounds :: SAST.NaturalRange -> (String, String)
379getNaturalRangeBounds range = (rangeLowerBound range, rangeUpperBound range)
380
381matchDefinitionsAndDeclarations :: [SPAST.NodeDeclaration] -> [SPAST.Definition] -> [(SPAST.NodeDeclaration, SPAST.Definition)]
382matchDefinitionsAndDeclarations decls defs = zipped
383    where
384        findDecl d = find (\(SPAST.NodeDeclaration _ _ _ name _) -> name == (SAST.refName $ SPAST.node d)) decls 
385        zipped = zip (map (\def -> if (isJust $ findDecl def) then (fromJust $ findDecl def) else (error ("No declaration found for definition: " ++ (show $ SPAST.defMeta def)))) defs) defs
386
387isAccepts :: SPAST.Definition -> Bool
388isAccepts (SPAST.Accepts _ _ _) = True
389isAccepts _ = False
390
391isMaps :: SPAST.Definition -> Bool
392isMaps (SPAST.Maps _ _ _) = True
393isMaps _ = False
394
395isOverlays :: SPAST.Definition -> Bool
396isOverlays (SPAST.Overlays _ _ _) = True
397isOverlays _ = False
398
399isInstantiation :: SPAST.Definition -> Bool
400isInstantiation (SPAST.Instantiates _ _ _ _) = True
401isInstantiation _ = False
402
403rangeUpperBound :: SAST.NaturalRange -> String
404rangeUpperBound (SAST.SingletonRange _ base) = (generate base)
405rangeUpperBound (SAST.LimitRange _ _ limit) = (generate limit)
406rangeUpperBound (SAST.BitsRange _ base bits) = (generate base) ++ " + ((1ul << " ++ (generate bits) ++ ") - 1)"
407
408rangeLowerBound :: SAST.NaturalRange -> String
409rangeLowerBound (SAST.SingletonRange _ base) = (generate base)
410rangeLowerBound (SAST.LimitRange _ base _) = (generate base)
411rangeLowerBound (SAST.BitsRange _ base _) = (generate base)
412
413overlaysFirst :: SPAST.Definition -> SPAST.Definition -> Ordering
414overlaysFirst SPAST.Overlays{} SPAST.Overlays{} = EQ
415overlaysFirst SPAST.Overlays{} _ = LT
416overlaysFirst _ SPAST.Overlays{} = GT
417overlaysFirst _ _ = EQ
418