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