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