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