1%include polycode.fmt
2
3%if false
4  Trace Definitions: DSL for trace definitions (subsystems and events)
5
6  Copyright (c) 2013 ETH Zurich.
7  All rights reserved.
8
9  This file is distributed under the terms in the attached LICENSE file.
10  If you do not find this file, copies can be found by writing to:
11  ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
12%endif
13
14> module Main where
15
16> import Text.PrettyPrint.HughesPJ as Pprinter
17
18> import System.Environment
19> import System.Exit
20> import System.Console.GetOpt
21> import System.IO
22> import System.Random
23> import System.FilePath.Posix
24
25> import Data.Char
26> import qualified Data.Map as Map
27
28> import Parser
29
30> addInBetween :: String -> [String] -> [String]
31> addInBetween _ [] = []
32> addInBetween _ (x:[]) = [x]
33> addInBetween inBetween (x:y:xs) = [x] ++ [inBetween] ++ addInBetween inBetween (y:xs)
34
35> printEventJSON :: (String, (EventField, Integer)) -> String
36> printEventJSON (subsystemName, (EventField name desc, number)) =
37>	"\t\t\"" ++ show number ++ "\" : [\"" ++ name ++ "\", \"" ++ theDesc ++ "\" ]"
38>	where
39>		theDesc =
40>			if length desc == 0
41>				then name
42>				else desc
43
44> printSubsysJSON :: (SubsystemClass, Integer) -> String
45> printSubsysJSON (SubsystemClass name events, number) =
46>	"\"" ++ show number ++ "\" : {\n\t" ++ subsysString ++ ",\n\t\"events\" : {\n" ++ eventStrings ++ "\n\t}\n}"
47>	where
48> 		subsysString = "\"name\" : \"" ++ name ++ "\""
49>		eventStrings = concat (addInBetween ",\n" (map printEventJSON (zip (repeat name) (zip events [0..]))))
50
51As the flounder message send / receive trace events are a bit a hack (they use the event to store
52their own payload), they are not part of the pleco file. To still be able to decode them correctly
53in Aquarium, we need to add the corresponding information here with the function "addFlounder".
54
55> addFlounder :: [String]
56> addFlounder  =
57>	[",\n\"-5632\" : {\n\t\"name\" : \"ump send\"\n\t},\n\"-5376\" : {\n\t\"name\" : \"ump receive\"\n\t}"]
58
59> printTraceFileJSON :: [SubsystemClass] -> String
60> printTraceFileJSON subsystems =
61>	concat ( ["{\n"] ++ (addInBetween ",\n" (map printSubsysJSON (zip subsystems [0..]))) ++ addFlounder ++ ["\n}"] )
62
63> printEvent :: (String, (EventField, Integer)) -> String
64> printEvent (subsystemName, (EventField name _, number)) =
65>	"#define TRACE_EVENT_" ++ map toUpper subsystemName ++ "_" ++ map toUpper name ++ "\t" ++ show number ++ "\n"
66
67> printSubsys :: (SubsystemClass, Integer) -> String
68> printSubsys (SubsystemClass name events, number) =
69>	subsysString ++ eventStrings ++ "\n"
70>	where
71> 		subsysString = "#define TRACE_SUBSYS_" ++ map toUpper name ++ "\t" ++ show number ++  "\n"
72>		eventStrings = concat (map printEvent (zip (repeat name) (zip events [0..])))
73
74> printTraceFileC :: [SubsystemClass] -> String
75> printTraceFileC subsystems =
76>	(concat (map printSubsys (zip subsystems [0..]))) ++ "\n\n#define TRACE_NUM_SUBSYSTEMS\t" ++ (show (length subsystems)) ++ "\n"
77
78
79> main :: IO ()
80> main = do
81>        argv <- System.Environment.getArgs
82>        case argv of
83>          [ inF, hdrF, jsonF, codeF ] -> do
84>                         input <- Parser.parse inF
85>                         case input of
86>                           Left err -> do
87>                                       hPutStrLn stderr "parse error at: "
88>                                       hPutStrLn stderr (show err)
89>                                       exitWith (ExitFailure 1)
90>                           Right ast -> do
91>                                        let macro = map toUpper (takeBaseName hdrF) ++ "_BARRELFISH__"
92>                                        let header = printTraceFileC ast
93>                                        fileH <- openFile hdrF WriteMode
94>                                        fileC <- openFile codeF WriteMode
95>                                        fileJ <- openFile jsonF WriteMode
96>                                        let pre = "#ifndef " ++ macro ++ "\n" ++
97>                                                  "#define " ++ macro ++ "\n\n"
98>                                        let post = "\n#endif // " ++ macro
99>                                        hPutStr fileH pre
100>                                        hPutStr fileH header
101>                                        hPutStrLn fileH post
102>                                        hClose fileH
103>                                        hPutStr fileJ (printTraceFileJSON ast)
104>                                        hClose fileJ
105>                                        hClose fileC
106
107>          otherwise -> do
108>                  hPutStrLn stderr "Usage: pleco input.pleco output.h output.json output.c"
109>                  exitWith (ExitFailure 1)
110