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