1%include polycode.fmt 2 3%if false 4 Flounder2: an even more simpler IDL for Barrelfish 5 6 Copyright (c) 2009, 2010 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 15 16> module Main where 17 18> import System.Environment 19> import System.Exit 20> import System.Console.GetOpt 21> import System.IO 22> import System.FilePath.Posix 23> import Data.Maybe 24> import Control.Monad 25> import Data.Eq 26 27> import Text.ParserCombinators.Parsec as Parsec 28> import qualified Parser 29> import qualified Syntax 30> import qualified Arch 31> import qualified Backend 32> import qualified GHBackend 33> import qualified GCBackend 34> import qualified LMP 35> import qualified UMP 36> import qualified UMP_IPI 37> import qualified Multihop 38> import qualified Loopback 39> import qualified Local 40> import qualified RPCClient 41> import qualified MsgBuf 42> import qualified THCBackend 43> import qualified THCStubsBackend 44> import qualified AHCI 45 46> data Target = GenericHeader 47> | GenericCode 48> | MessageHandlers 49> | LMP_Header 50> | LMP_Stub 51> | UMP_Header 52> | UMP_Stub 53> | UMP_IPI_Header 54> | UMP_IPI_Stub 55> | Multihop_Stub 56> | Multihop_Header 57> | Loopback_Header 58> | Loopback_Stub 59> | Local_Header 60> | Local_Stub 61> | RPCClient_Header 62> | RPCClient_Stub 63> | MsgBuf_Header 64> | MsgBuf_Stub 65> | THCHeader 66> | THCStubs 67> | AHCI_Header 68> | AHCI_Stub 69> deriving (Show, Eq) 70 71> data Options = Options { 72> optTargets :: [Target], 73> optArch :: Maybe Arch.Arch, 74> optIncludes :: [String] 75> } 76 77> defaultOptions = Options { optTargets = [], optArch = Nothing, optIncludes = [] } 78 79> generator :: Options -> Target -> String -> String -> Syntax.Interface -> String 80> generator _ GenericHeader = GHBackend.compile 81> generator _ GenericCode = GCBackend.compile 82> generator _ MessageHandlers = GCBackend.compile_message_handlers 83> generator _ LMP_Header = LMP.header 84> generator opts LMP_Stub 85> | isNothing arch = error "no architecture specified for LMP stubs" 86> | otherwise = LMP.stub (fromJust arch) 87> where arch = optArch opts 88> generator _ UMP_Header = UMP.header 89> generator opts UMP_Stub 90> | isNothing arch = error "no architecture specified for UMP stubs" 91> | otherwise = UMP.stub (fromJust arch) 92> where arch = optArch opts 93> generator _ UMP_IPI_Header = UMP_IPI.header 94> generator opts UMP_IPI_Stub 95> | isNothing arch = error "no architecture specified for UMP_IPI stubs" 96> | otherwise = UMP_IPI.stub (fromJust arch) 97> where arch = optArch opts 98> generator _ Multihop_Header = Multihop.header 99> generator opts Multihop_Stub 100> | isNothing arch = error "no architecture specified for Multihop stubs" 101> | otherwise = Multihop.stub (fromJust arch) 102> where arch = optArch opts 103> generator _ Loopback_Header = Loopback.header 104> generator _ Loopback_Stub = Loopback.stub 105> generator _ Local_Header = Local.header 106> generator _ Local_Stub = Local.stub 107> generator _ RPCClient_Header = RPCClient.header 108> generator _ RPCClient_Stub = RPCClient.stub 109> generator _ MsgBuf_Header = MsgBuf.header 110> generator _ MsgBuf_Stub = MsgBuf.stub 111> generator _ THCHeader = THCBackend.compile 112> generator _ THCStubs = THCStubsBackend.compile 113> generator _ AHCI_Header = AHCI.header 114> generator _ AHCI_Stub = AHCI.stub 115 116> addTarget :: Target -> Options -> IO Options 117> addTarget t o = return o { optTargets = (optTargets o) ++ [t] } 118 119> addTargets :: Target -> Target -> Options -> IO Options 120> addTargets t1 t2 o = return o { optTargets = (optTargets o) ++ (if (elem t1 (optTargets o)) then [t2] else [t1, t2]) } 121 122> setArch :: String -> Options -> IO Options 123> setArch s o = case optArch o of 124> Nothing -> if isJust arch then return o { optArch = arch } 125> else ioError $ userError $ "unknown architecture '" ++ s ++ "'" 126> Just _ -> ioError $ userError "multiple architectures are not supported" 127> where 128> arch = Arch.parse_arch s 129 130> addInclude :: String -> Options -> IO Options 131> addInclude s o = return o { optIncludes = (optIncludes o) ++ [s] } 132 133> options :: [OptDescr (Options -> IO Options)] 134> options = [ 135> Option ['G'] ["generic-header"] (NoArg $ addTarget GenericHeader) "Create a generic header file", 136> Option [] ["generic-stub"] (NoArg $ addTargets MessageHandlers GenericCode) "Create generic part of stub implemention", 137> Option ['a'] ["arch"] (ReqArg setArch "ARCH") "Architecture for stubs", 138> Option ['i'] ["import"] (ReqArg addInclude "FILE") "Include a given file before processing", 139> Option [] ["lmp-header"] (NoArg $ addTarget LMP_Header) "Create a header file for LMP", 140> Option [] ["lmp-stub"] (NoArg $ addTargets MessageHandlers LMP_Stub) "Create a stub file for LMP", 141> Option [] ["ump-header"] (NoArg $ addTarget UMP_Header) "Create a header file for UMP", 142> Option [] ["ump-stub"] (NoArg $ addTargets MessageHandlers UMP_Stub) "Create a stub file for UMP", 143> Option [] ["ump_ipi-header"] (NoArg $ addTarget UMP_IPI_Header) "Create a header file for UMP_IPI", 144> Option [] ["ump_ipi-stub"] (NoArg $ addTarget UMP_IPI_Stub) "Create a stub file for UMP_IPI", 145> Option [] ["multihop-header"] (NoArg $ addTarget Multihop_Header) "Create a header file for Multihop", 146> Option [] ["multihop-stub"] (NoArg $ addTarget Multihop_Stub) "Create a stub file for Multihop", 147> Option [] ["loopback-header"] (NoArg $ addTarget Loopback_Header) "Create a header file for loopback", 148> Option [] ["loopback-stub"] (NoArg $ addTarget Loopback_Stub) "Create a stub file for loopback", 149> Option [] ["local-header"] (NoArg $ addTarget Local_Header) "Create a header file for local", 150> Option [] ["local-stub"] (NoArg $ addTarget Local_Stub) "Create a stub file for local", 151> Option [] ["rpcclient-header"] (NoArg $ addTarget RPCClient_Header) "Create a header file for RPC", 152> Option [] ["rpcclient-stub"] (NoArg $ addTarget RPCClient_Stub) "Create a stub file for RPC", 153> Option [] ["msgbuf-header"] (NoArg $ addTarget MsgBuf_Header) "Create a header file for message buffers", 154> Option [] ["msgbuf-stub"] (NoArg $ addTarget MsgBuf_Stub) "Create a stub file for message buffers", 155 156> Option ['T'] ["thc-header"] (NoArg $ addTarget THCHeader) "Create a THC header file", 157> Option ['B'] ["thc-stubs"] (NoArg $ addTarget THCStubs) "Create a THC stubs C file", 158> Option [] ["ahci-header"] (NoArg $ addTarget AHCI_Header) "Create a header file for AHCI", 159> Option [] ["ahci-stub"] (NoArg $ addTarget AHCI_Stub) "Create a stub file for AHCI" ] 160 161> compile :: Options -> Target -> Syntax.Interface -> String -> String -> Handle -> IO () 162> compile opts fl ast infile outfile outfiled = 163> hPutStr outfiled $ (generator opts fl) infile outfile ast 164 165> parseFile :: (String -> IO (Either Parsec.ParseError a)) -> String -> IO a 166> parseFile parsefn fname = do 167> input <- parsefn fname 168> case input of 169> Left err -> do 170> hPutStrLn stderr $ "Parse error at: " ++ (show err) 171> exitWith $ ExitFailure 1 172> Right x -> return x 173 174> parseIncludes :: Options -> IO [(String, Syntax.Declaration)] 175> parseIncludes opts 176> = foldM (\d -> parseFile $ Parser.parse_include d) [] (optIncludes opts) 177 178> checkFilename :: Syntax.Interface -> String -> IO () 179> checkFilename interface fname = do 180> let Syntax.Interface ifacename _ _ = interface 181> if ifacename == takeBaseName fname then return () else ioError $ userError ("Interface name '" ++ ifacename ++ "' has to equal filename in " ++ fname) 182 183> main :: IO () 184> main = do 185> argv <- System.Environment.getArgs 186> case getOpt RequireOrder options argv of 187> (optf, [ inFile, outFile ], []) -> do 188> opts <- foldM (flip id) defaultOptions optf 189> includeDecls <- parseIncludes opts 190> ast <- parseFile (Parser.parse_intf includeDecls) inFile 191> outFileD <- openFile outFile WriteMode 192> checkFilename ast inFile 193> sequence_ $ map (\target 194> -> compile opts target ast inFile outFile outFileD) 195> (optTargets opts) 196> hClose outFileD 197> (_, _, errors) -> do 198> hPutStr stderr (concat errors ++ usageInfo usage options) 199> exitWith (ExitFailure 1) 200> where 201> usage = "Usage: flounder [OPTION...] input.if output" 202