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