1 {- 2 SockeyeBackendProlog.hs: Backend for generating ECLiPSe-Prolog for Sockeye 3 4 Part of Sockeye 5 6 Copyright (c) 2018, 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, Universitaetstrasse 6, CH-8092 Zurich, 13 Attn: Systems Group. 14-} 15 16 17{- 18 TODO: This currently works on a subset of the parser AST. Ideally, there would be 19 a transformation first that: 20 * Removes wildcards and replaces it with forall loops (introducing a new variable) 21 * Expands natural expression into a seperate definition blocks (introducing new local 22 variable for each block) 23 * Everytime a range is encountered, it's passed to a natural limit/base range (no more bit ops) 24 * Pushes the type of accepted/translated blocks own to the specific blocks, this should 25 also merge the translte/convert types into one. 26-} 27 28module SockeyeBackendPrologMultiDim 29( compile, compileDirect ) where 30 31import qualified Data.Map as Map 32import Data.Char 33import Data.List 34import Text.Printf 35import Control.Exception (throw, Exception) 36 37import qualified SockeyeSymbolTable as ST 38import qualified SockeyeAST as SAST 39import qualified SockeyeParserAST as AST 40 41data PrologBackendException 42 = MultiDimensionalQuantifierException 43 | NYIException String 44 deriving(Show) 45 46instance Exception PrologBackendException 47 48{- The structure of the code generator should be very similar to the old Prolog Backend -} 49compile :: ST.Sockeye -> SAST.Sockeye -> String 50compile symTable ast = "Prolog backend not yet implemented" 51 52compileDirect :: AST.Sockeye -> String 53compileDirect = generate 54 55{- Code Generator -} 56class PrologGenerator a where 57 generate :: a -> String 58 59instance PrologGenerator AST.Sockeye where 60 generate s = let 61 files = map snd (Map.toList (AST.files s)) 62 in concat (map generate files) 63 64instance PrologGenerator AST.SockeyeFile where 65 generate f = concat (map generate (AST.modules f)) 66 67gen_node_param_list :: [AST.NodeDeclaration] -> [String] 68gen_node_param_list ndl = map AST.nodeName ndl 69 70gen_nat_param_list :: [AST.ModuleParameter] -> [String] 71gen_nat_param_list pp = map AST.paramName pp 72 73instance PrologGenerator AST.Module where 74 generate m = let 75 name = "add_" ++ AST.moduleName m 76 mi = gen_module_info m 77 p1 = gen_nat_param_list (AST.parameters m) 78 bodyChecks = ["is_list(Id)"] 79 nodeDecls = map gen_node_decls (AST.nodeDecls m) 80 instDecls = map gen_inst_decls (AST.instDecls m) 81 bodyDefs = concat $ map (gen_body_defs mi) (AST.definitions m) 82 83 body = intercalate ",\n " $ bodyChecks ++ nodeDecls ++ instDecls ++ bodyDefs 84 in name ++ stringify (["Id"] ++ p1) ++ " :- \n " ++ body ++ ".\n\n" 85 where 86 stringify [] = "" 87 stringify pp = parens $ intercalate "," pp 88 89-- Inside each function we add variable that contains 90-- * nodeId 91-- * params 92-- * constants 93-- This will return the name of these variables 94local_nodeid_name :: String -> String 95local_nodeid_name x = "ID_" ++ x 96 97local_inst_name :: String -> String 98local_inst_name x = "ID_" ++ x 99 100-- Prefix tat as well? 101local_param_name :: String -> String 102local_param_name x = x 103 104local_const_name :: String -> String 105local_const_name x = "CONST_" ++ x 106 107-- Generates something a la: 108-- (ID_RAM) = (['ram', Id]) 109gen_inst_decls :: AST.InstanceDeclaration -> String 110gen_inst_decls x = 111 let 112 var = local_nodeid_name $ AST.instName x 113 decl = list_prepend (doublequotes $ AST.instName x) (local_param_name "Id") 114 in var ++ " = " ++ decl 115 116-- Generates something a la: 117-- (ID_RAM, INKIND_RAM, OUTKIND_RAM) = (['ram' | Id], memory, memory) 118gen_node_decls :: AST.NodeDeclaration -> String 119gen_node_decls x = 120 let 121 var = local_nodeid_name $ AST.nodeName x 122 decl_kind_in = generate (AST.originDomain (AST.nodeType x)) 123 decl_kind_out = generate (AST.targetDomain (AST.nodeType x)) 124 decl_id = list_prepend (doublequotes $ AST.nodeName x) (local_param_name "Id") 125 decl_tup = tuple [decl_id, decl_kind_in, decl_kind_out] 126 127 -- Build the variable list 128 pf = AST.nodeName x 129 var_tup = tuple [local_nodeid_name pf, "INKIND_" ++ pf, "OUTKIND_" ++ pf] 130 in var_tup ++ " = " ++ decl_tup 131 132 133-- This transformation is probably better to be in an AST transform 134data MyAddressBlock = MyAddressBlock { 135 domain :: !AST.Domain, 136 addresses :: AST.Address, 137 properties :: AST.PropertyExpr 138 } 139 140pack_address_block :: ModuleInfo -> AST.AddressBlock -> MyAddressBlock 141pack_address_block mi ab = MyAddressBlock { 142 domain = AST.Memory, 143 addresses = SAST.addresses ab, 144 properties = SAST.properties ab 145} 146 147data OneMapSpec = OneMapSpec 148 { 149 srcNode :: AST.UnqualifiedRef, 150 srcAddr :: MyAddressBlock, 151 targetNode :: AST.NodeReference, 152 targetAddr :: MyAddressBlock 153 } 154 155 156map_spec_flatten :: ModuleInfo -> AST.Definition -> [OneMapSpec] 157map_spec_flatten mi def = case def of 158 (AST.Maps _ n maps) -> 159 [OneMapSpec n (src_ab n $ AST.mapAddr map_spec) (AST.targetNode map_target) (dest_ab n $ AST.targetAddr map_target) 160 | map_spec <- maps, map_target <- (AST.mapTargets map_spec)] 161 _ -> [] 162 where 163 nt uqr = (node_type mi) Map.! (AST.refName uqr) 164 src_ab uqr ab = MyAddressBlock { 165 domain = ST.originDomain $ nt uqr, 166 properties = SAST.properties ab, 167 addresses = SAST.addresses ab 168 } 169 dest_ab uqr ab = MyAddressBlock { 170 domain = ST.targetDomain $ nt uqr, 171 addresses = SAST.addresses ab, 172 properties = SAST.properties ab 173 } 174 175data ModuleInfo = ModuleInfo 176 { 177 params :: [String], 178 node_type :: Map.Map String ST.NodeType 179 } 180 181gen_module_info :: AST.Module -> ModuleInfo 182gen_module_info x = 183 ModuleInfo { 184 params = ["Id"] ++ mparams ++ nodes ++ insts, 185 node_type = Map.fromList [(AST.nodeName z, AST.nodeType $ z) | z <- AST.nodeDecls x] 186 } 187 where 188 insts = [local_inst_name $ AST.instName d | d <- AST.instDecls x] 189 mparams = (gen_nat_param_list $ AST.parameters x) 190 nodes = [local_nodeid_name $ AST.nodeName d | d <- AST.nodeDecls x] 191 192add_param :: ModuleInfo -> String -> ModuleInfo 193add_param mi s = ModuleInfo { params = (params mi) ++ [s], node_type = node_type mi} 194 195param_str :: ModuleInfo -> String 196param_str mi = case params mi of 197 [] -> "" 198 li -> "," ++ intercalate "," [predicate "param" [p] | p <- li] 199 200 201generate_conj :: ModuleInfo -> [AST.Definition] -> String 202generate_conj mi li = 203 intercalate ",\n" $ concat [gen_body_defs mi inn | inn <- li] 204 205-- generate forall with a explicit variable name 206forall_qual :: ModuleInfo -> String -> AST.NaturalSet -> [AST.Definition] -> String 207forall_qual mi varName ns body = 208 "(" ++ 209 predicate "iblock_values" [generate ns, it_list] ++ "," ++ 210 "(" ++ 211 predicate "foreach" [it_var, it_list] 212 ++ param_str mi 213 ++ " do \n" ++ 214 body_str ++ "\n))" 215 where 216 id_var = "ID_" ++ varName 217 it_var = "IDT_" ++ varName 218 it_list = "IDL_" ++ varName 219 body_str = generate_conj (add_param mi it_var) body 220 221forall_uqr :: ModuleInfo -> AST.UnqualifiedRef -> String -> String 222forall_uqr mi ref body_str = case (AST.refIndex ref) of 223 Nothing -> printf "(%s = %s, %s)" it_var id_var body_str 224 Just ai -> "(" ++ 225 predicate "iblock_values" [generate ai, it_list] ++ "," ++ 226 "(" ++ 227 predicate "foreach" [it_var, it_list] 228 ++ param_str mi 229 ++ " do " ++ 230 itid_var ++ " = " ++ list_prepend it_var id_var ++ "," ++ 231 body_str ++ "))" 232 where 233 id_var = "ID_" ++ (AST.refName ref) 234 it_var = "IDT_" ++ (AST.refName ref) 235 itid_var = "IDI_" ++ (AST.refName ref) 236 it_list = "IDL_" ++ (AST.refName ref) 237 238gen_bind_defs :: String -> [AST.PortBinding] -> String 239gen_bind_defs uql_var binds = 240 let 241 dest bind = generate $ AST.boundNode bind 242 src bind = list_prepend (doublequotes $ AST.refName $ AST.boundPort $ bind) uql_var 243 pb bind = assert $ predicate "node_overlay" [src bind, dest bind] 244 preds = [pb bind | bind <- binds] 245 in intercalate "," preds 246 247gen_index :: AST.UnqualifiedRef -> String 248gen_index uqr = 249 case (AST.refIndex uqr) of 250 Nothing -> local_nodeid_name $ AST.refName uqr 251 Just ai -> list_prepend (gen_ai ai) (local_nodeid_name $ AST.refName uqr) 252 where 253 gen_ai (AST.ArrayIndex _ ws) = list [gen_wildcard_simple w | w <- ws] 254 gen_wildcard_simple (AST.ExplicitSet _ ns) = gen_natural_set ns 255 gen_natural_set (ST.NaturalSet _ nrs) = gen_natural_ranges nrs 256 gen_natural_ranges [nr] = gen_ns_simple nr 257 gen_ns_simple (ST.SingletonRange _ base) = gen_exp_simple base 258 gen_exp_simple (AST.Variable _ vn) = "IDT_" ++ vn 259 gen_exp_simple (AST.Literal _ int) = show int 260 261 262 263gen_body_defs :: ModuleInfo -> AST.Definition -> [String] 264gen_body_defs mi x = case x of 265 (AST.Accepts _ n accepts) -> [(assert $ predicate "node_accept" [generate n, generate (new_ab acc)]) 266 | acc <- accepts] 267 (AST.Maps _ _ _) -> [(assert $ predicate "node_translate_dyn" 268 [generate $ srcNode om, generate $ srcAddr om, generate $ targetNode om, generate $ targetAddr om]) 269 | om <- map_spec_flatten mi x] 270 (AST.Overlays _ src dest) -> [assert $ predicate "node_overlay" [generate src, generate dest]] 271 -- (AST.Instantiates _ i im args) -> [forall_uqr mi i (predicate ("add_" ++ im) ["IDT_" ++ (AST.refName i)])] 272 (AST.Instantiates _ i im args) -> [ predicate ("add_" ++ im) [gen_index i] ] 273 -- (AST.Binds _ i binds) -> [forall_uqr mi i $ gen_bind_defs ("IDT_" ++ (AST.refName i)) binds] 274 (AST.Binds _ i binds) -> [gen_bind_defs (gen_index i) binds] 275 (AST.Forall _ varName varRange body) -> [forall_qual mi varName varRange body] 276 (AST.Converts _ _ _ ) -> throw $ NYIException "Converts" 277 where 278 new_ab ab = pack_address_block mi ab 279 280instance PrologGenerator AST.UnqualifiedRef where 281 generate uq = case (AST.refIndex uq) of 282 Nothing -> local_nodeid_name $ AST.refName uq 283 Just ai -> list_prepend (generate ai) (local_nodeid_name $ AST.refName uq) 284 285instance PrologGenerator AST.WildcardSet where 286 generate a = case a of 287 AST.ExplicitSet _ ns -> generate ns 288 AST.Wildcard _ -> "NYI!?" 289 290instance PrologGenerator AST.ArrayIndex where 291 generate (AST.ArrayIndex _ wcs) = brackets $ intercalate "," [generate x | x <- wcs] 292 293instance PrologGenerator AST.MapSpec where 294 generate ms = struct "map" [("src_block", generate (AST.mapAddr ms)), 295 ("dests", list $ map generate (AST.mapTargets ms))] 296 297instance PrologGenerator AST.MapTarget where 298 generate mt = struct "dest" [("id", generate (AST.targetNode mt)), 299 ("base", generate (AST.targetAddr mt))] 300 301instance PrologGenerator AST.NodeReference where 302 generate nr = case nr of 303 AST.InternalNodeRef _ nn -> gen_index nn 304 AST.InputPortRef _ inst node -> list_prepend (doublequotes $ AST.refName node) (gen_index inst) 305 306instance PrologGenerator MyAddressBlock where 307 -- TODO: add properties 308 -- We have to generate something like this, probably involves an extra step in the AST. 309 -- pred_99(propspec) :- member(prop1, propspec), member(prop2, propspec 310 -- node_accept( ..., block{propspec: pred_99}). 311 -- to check: B = block{propspec: PS}, call(PS, current_properties) 312 generate ab = list $ [generate $ domain ab] ++ blocks 313 where 314 blocks = gen_a $ addresses ab 315 gen_a (AST.Address _ ws) = map gen_ws ws 316 gen_ws (AST.ExplicitSet _ ns) = generate ns 317 gen_ws (AST.Wildcard _ ) = "NYI" 318 319instance PrologGenerator AST.Domain where 320 generate d = case d of 321 AST.Memory -> atom "memory" 322 AST.Interrupt -> atom "interrupt" 323 AST.Power -> atom "power" 324 AST.Clock -> atom "clock" 325 326instance PrologGenerator AST.AddressBlock where 327 -- TODO: add properties 328 -- We have to generate something like this, probably involves an extra step in the AST. 329 -- pred_99(propspec) :- member(prop1, propspec), member(prop2, propspec 330 -- node_accept( ..., block{propspec: pred_99}). 331 -- to check: B = block{propspec: PS}, call(PS, current_properties) 332 generate ab = generate $ SAST.addresses ab 333 334 335instance PrologGenerator AST.Address where 336 generate a = case a of 337 AST.Address _ ws -> tuple $ map generate ws 338 339instance PrologGenerator AST.NaturalSet where 340 generate a = case a of 341 AST.NaturalSet _ nrs -> list $ map generate nrs 342 343instance PrologGenerator AST.NaturalRange where 344 generate nr = case nr of 345 AST.SingletonRange _ b -> struct "block" 346 [("base", generate b), ("limit", generate b)] 347 AST.LimitRange _ b l -> struct "block" 348 [("base", generate b), ("limit", generate l)] 349 AST.BitsRange _ b bits -> "BITSRANGE NYI" 350 -- struct "block" [("base", generate b), ("limit", show 666)] 351 352instance PrologGenerator AST.NaturalExpr where 353 generate nr = case nr of 354 SAST.Constant _ v -> local_const_name v 355 SAST.Variable _ v -> "IDT_" ++ v 356 SAST.Parameter _ v -> local_param_name v 357 SAST.Literal _ n -> show n 358 SAST.Addition _ a b -> "(" ++ generate a ++ ")+(" ++ generate b ++ ")" 359 SAST.Subtraction _ a b -> "(" ++ generate a ++ ")-(" ++ generate b ++ ")" 360 SAST.Multiplication _ a b -> "(" ++ generate a ++ ")*(" ++ generate b ++ ")" 361 SAST.Slice _ a bitrange -> "SLICE NYI" 362 SAST.Concat _ a b -> "CONCAT NYI" 363 364 365{- Helper functions -} 366atom :: String -> String 367atom "" = "" 368atom name@(c:cs) 369 | isLower c && allAlphaNum cs = name 370 | otherwise = quotes name 371 where 372 allAlphaNum cs = foldl (\acc c -> isAlphaNum c && acc) True cs 373 374predicate :: String -> [String] -> String 375predicate name args = name ++ (parens $ intercalate "," args) 376 377struct :: String -> [(String, String)] -> String 378struct name fields = name ++ (braces $ intercalate "," (map toFieldString fields)) 379 where 380 toFieldString (key, value) = key ++ ":" ++ value 381 382tuple :: [String] -> String 383tuple elems = parens $ intercalate "," elems 384 385list :: [String] -> String 386list elems = brackets $ intercalate "," elems 387 388list_prepend :: String -> String -> String 389list_prepend a li = brackets $ a ++ " | " ++ li 390 391enclose :: String -> String -> String -> String 392enclose start end string = start ++ string ++ end 393 394parens :: String -> String 395parens = enclose "(" ")" 396 397brackets :: String -> String 398brackets = enclose "[" "]" 399 400braces :: String -> String 401braces = enclose "{" "}" 402 403quotes :: String -> String 404quotes = enclose "'" "'" 405 406doublequotes :: String -> String 407doublequotes = enclose "\"" "\"" 408 409 410nat_range_from :: AST.NaturalRange -> String 411nat_range_from nr = case nr of 412 AST.SingletonRange _ b -> generate b 413 AST.LimitRange _ b _ -> generate b 414 AST.BitsRange _ _ _ -> "BitsRange NOT IMPLEMENTED" 415 416nat_range_to :: AST.NaturalRange -> String 417nat_range_to nr = case nr of 418 AST.SingletonRange _ b -> generate b 419 AST.LimitRange _ _ l -> generate l 420 AST.BitsRange _ _ _ -> "BitsRange NOT IMPLEMENTED" 421 422-- Params are variables passed into the for body 423for_body_inner :: [String] -> String -> String -> (Int, AST.NaturalRange) -> String 424for_body_inner params itvar body itrange = 425 let 426 itvar_local = itvar ++ (show $ fst itrange) 427 from = nat_range_from $ (snd itrange) 428 to = nat_range_to $ (snd itrange) 429 for = printf "for(%s,%s,%s)" itvar_local from to :: String 430 paramf x = printf "param(%s)" x :: String 431 header = intercalate "," ([for] ++ map paramf params) 432 in printf "(%s \ndo\n %s \n)" header body 433 434enumerate = zip [0..] 435 436for_body :: [String] -> String -> AST.NaturalSet -> String -> String 437for_body params itvar (AST.NaturalSet _ ranges) body = 438 foldl fbi body (enumerate ranges) 439 where 440 fbi = for_body_inner params itvar 441 442 443assert :: String -> String 444assert x = "assert" ++ parens x 445