1{-
2  SockeyeBackendProlog.hs: Backend for generating ECLiPSe-Prolog facts 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, Universitaetstrasse 6, CH-8092 Zurich,
13  Attn: Systems Group.
14-}
15
16{-# LANGUAGE TypeSynonymInstances #-}
17{-# LANGUAGE FlexibleInstances #-}
18{-# LANGUAGE FlexibleContexts #-}
19
20module SockeyeBackendProlog
21( compile ) where
22
23import Control.Monad.State
24
25import Data.Char
26import Data.List
27import qualified Data.Map as Map
28import Numeric (showHex)
29
30import qualified SockeyeASTDecodingNet as AST
31
32compile :: AST.NetSpec -> String
33compile = generate
34
35{- Code Generator -}
36class PrologGenerator a where
37    generate :: a -> String
38
39instance PrologGenerator AST.NetSpec where
40    generate net = let
41        mapped = Map.mapWithKey toFact net
42        facts = Map.elems mapped
43        in unlines facts
44        where
45            toFact nodeId nodeSpec = let
46                idString = generate nodeId
47                specString = generate nodeSpec
48                in struct "node" [("id", idString), ("spec", specString)] ++ "."
49
50instance PrologGenerator AST.NodeId where
51    generate ast = let
52        name = AST.name ast
53        namespace = AST.namespace ast
54        in struct "node_id" [("name", atom name), ("namespace", list $ map atom namespace)]
55
56instance PrologGenerator AST.NodeSpec where
57    generate ast = let
58        nodeType = AST.nodeType ast
59        accept = AST.accept ast
60        translate = AST.translate ast
61        reserved = AST.reserved ast
62        overlay = AST.overlay ast
63        mapBlocks = map AST.srcBlock translate
64        overMaps = case overlay of
65            Nothing -> []
66            Just o -> overlayMaps (AST.over o) (AST.width o) (accept ++ mapBlocks ++ reserved)
67        nodeTypeString = generate nodeType
68        acceptString = generate accept
69        translateString = generate (translate ++ overMaps)
70        in struct "node_spec" [("type", nodeTypeString), ("accept", acceptString), ("translate", translateString)]
71
72overlayMaps :: AST.NodeId -> Integer -> [AST.BlockSpec] -> [AST.MapSpec]
73overlayMaps destId width blocks =
74    let
75        blockPoints = concat $ map toScanPoints blocks
76        maxAddress = 2^width
77        overStop  = BlockStart $ maxAddress
78        scanPoints = filter ((maxAddress >=) . address) $ sort (overStop:blockPoints)
79        startState = ScanLineState
80            { insideBlocks    = 0
81            , startAddress    = 0
82            }
83    in evalState (scanLine scanPoints []) startState
84    where
85        toScanPoints (AST.BlockSpec base limit _) =
86                [ BlockStart base
87                , BlockEnd   limit
88                ]
89        scanLine [] ms = return ms
90        scanLine (p:ps) ms = do
91            maps <- pointAction p ms
92            scanLine ps maps
93        pointAction (BlockStart a) ms = do
94            s <- get
95            let
96                i = insideBlocks s
97                base = startAddress s
98                limit = a - 1
99            maps <- if (i == 0) && (base <= limit)
100                then
101                    let
102                        baseAddress = startAddress s
103                        limitAddress = a - 1
104                        srcBlock = AST.BlockSpec baseAddress limitAddress (AST.PropSpec [])
105                        m = AST.MapSpec srcBlock destId baseAddress (AST.PropSpec [])
106                    in return $ m:ms
107                else return ms
108            modify (\s -> s { insideBlocks = i + 1})
109            return maps
110        pointAction (BlockEnd a) ms = do
111            s <- get
112            let
113                i = insideBlocks s
114            put $ ScanLineState (i - 1) (a + 1)
115            return ms
116
117data StoppingPoint
118    = BlockStart { address :: !AST.Address }
119    | BlockEnd   { address :: !AST.Address }
120    deriving (Eq, Show)
121
122instance Ord StoppingPoint where
123    (<=) (BlockStart a1) (BlockEnd   a2)
124        | a1 == a2 = True
125        | otherwise = a1 <= a2
126    (<=) (BlockEnd   a1) (BlockStart a2)
127        | a1 == a2 = False
128        | otherwise = a1 <= a2
129    (<=) sp1 sp2 = (address sp1) <= (address sp2)
130
131data ScanLineState
132    = ScanLineState
133        { insideBlocks :: !Integer
134        , startAddress :: !AST.Address
135        } deriving (Show)
136
137instance PrologGenerator AST.NodeType where
138    generate AST.Core   = atom "core"
139    generate AST.Device = atom "device"
140    generate AST.Memory = atom "memory"
141    generate AST.Other  = atom "other"
142
143instance PrologGenerator AST.PropSpec where
144    generate propSpec =
145      list $ map atom (AST.identifiers propSpec)
146
147instance PrologGenerator AST.BlockSpec where
148    generate blockSpec = let
149        base = generate $ AST.base blockSpec
150        limit = generate $ AST.limit blockSpec
151        props = generate $ AST.props blockSpec
152        in struct "block" [("base", base), ("limit", limit), ("props", props)]
153
154instance PrologGenerator AST.MapSpec where
155    generate mapSpec = let
156        src  = generate $ AST.srcBlock mapSpec
157        dest = generate $ AST.destNode mapSpec
158        base = generate $ AST.destBase mapSpec
159        destProps = generate $ AST.destProps mapSpec
160        in struct "map" [("src_block", src), ("dest_node", dest),
161          ("dest_base", base), ("dest_props", destProps)]
162
163instance PrologGenerator AST.Address where
164    generate addr = "0x" ++ showHex addr ""
165
166instance PrologGenerator a => PrologGenerator [a] where
167    generate ast = let
168        mapped = map generate ast
169        in list mapped
170
171{- Helper functions -}
172atom :: String -> String
173atom "" = ""
174atom name@(c:cs)
175    | isLower c && allAlphaNum cs = name
176    | otherwise = quotes name
177    where
178        allAlphaNum cs = foldl (\acc c -> isAlphaNum c && acc) True cs
179
180predicate :: String -> [String] -> String
181predicate name args = name ++ (parens $ intercalate "," args)
182
183struct :: String -> [(String, String)] -> String
184struct name fields = name ++ (braces $ intercalate "," (map toFieldString fields))
185    where
186        toFieldString (key, value) = key ++ ":" ++ value
187
188list :: [String] -> String
189list elems = brackets $ intercalate "," elems
190
191enclose :: String -> String -> String -> String
192enclose start end string = start ++ string ++ end
193
194parens :: String -> String
195parens = enclose "(" ")"
196
197brackets :: String -> String
198brackets = enclose "[" "]"
199
200braces :: String -> String
201braces = enclose "{" "}"
202
203quotes :: String -> String
204quotes = enclose "'" "'"
205