aos/tools/mackerel/Main.hs

{- 
   Mackerel: a strawman device definition DSL for Barrelfish
   
  Copyright (c) 2007-2011, ETH Zurich.
  All rights reserved.
  
  This file is distributed under the terms in the attached LICENSE file.
  If you do not find this file, copies can be found by writing to:
  ETH Zurich D-INFK, Universitaetstrasse 6, CH-8092 Zurich. Attn: Systems Group.
-}

module Main where
 
import System.IO
import System.IO.Error
import System.Console.GetOpt
import System.FilePath
import System.Exit
import System.Environment
import Data.Maybe
import Data.List
import Text.ParserCombinators.Parsec as Parsec
import Text.Printf
import qualified MackerelParser
import qualified BitFieldDriver
import qualified ShiftDriver
import Checks
import Dev
import Control.Exception

--
-- Command line options and parsing code
--

-- Datatypes for carrying command options around
data Target = BitFieldDriver | ShiftDriver | NullDriver deriving (Eq, Show)

data Options = Options {
  opt_infilename :: Maybe String,
  opt_outfilename :: Maybe String,
  opt_includedirs :: [String],
  opt_target :: Target,
  opt_usage_error :: Bool,
  opt_verbosity :: Integer
  } deriving (Show,Eq)

defaultOptions :: Options
defaultOptions = Options { 
  opt_infilename = Nothing,
  opt_outfilename = Nothing,
  opt_includedirs = [],
  opt_target = ShiftDriver,
  opt_usage_error = False,
  opt_verbosity = 1 }

-- For driving System.GetOpt
options :: [OptDescr (Options -> Options)]
options =
  [ Option ['c'] ["input-file"] 
    (ReqArg (\f opts -> opts { opt_infilename = Just f } ) "file")
    "input file"
  , Option ['I'] ["include-dir"]
    (ReqArg (\ d opts -> opts { opt_includedirs = opt_includedirs opts ++ [d] }) "dir")
    "include directory (can be given multiple times)"
  , Option ['v'] ["verbose"]
    (NoArg (\ opts -> opts { opt_verbosity = opt_verbosity opts + 1 } ))
    "increase verbosity level"
  , Option ['o'] ["output"]
    (ReqArg (\ f opts -> opts { opt_outfilename = Just f }) "file")
     "output file name"
  , Option ['S'] ["shift-driver"]
    (NoArg (\ opts -> opts { opt_target = ShiftDriver } ))
     "use shift driver (default; preferred)"
  , Option ['n'] ["null-driver"]
    (NoArg (\ opts -> opts { opt_target = NullDriver } ))
     "use null output driver (don't generate any C)"
  , Option ['B'] ["bitfield-driver"]
    (NoArg (\ opts -> opts { opt_target = BitFieldDriver } ))
     "use bitfield driver (deprecrated: do not use)"
  ]

--
-- Set the correct default input and output files
--

defaultOutput :: Options -> Options
defaultOutput opts = 
  case opt_outfilename opts of
    (Just _) -> 
      opts
    Nothing  -> 
      opts { opt_outfilename = 
                Just (case opt_infilename opts of
                         (Just i) -> 
                           ((dropExtension $ takeFileName i) ++ "_dev.h")
                         Nothing -> "mackerel_output.h" 
                     )
           }

defaultInput :: Options -> [String] -> IO (Options)
defaultInput opts [f] = 
  if isNothing $ opt_infilename opts
  then return (defaultOutput (opts { opt_infilename = Just f }))
  else usageError []
defaultInput opts [] = 
  if (isJust $ opt_infilename opts)
  then return (defaultOutput opts)
  else usageError []
defaultInput _ _ = usageError []

compilerOpts :: [String] -> IO (Options)
compilerOpts argv =
  case getOpt Permute options argv of
    (o,n,[])   -> defaultInput (foldl (flip id) defaultOptions o) n
    (_,_,errs) -> usageError errs

usageError :: [String] -> IO (Options)
usageError errs = 
  ioError (userError (concat errs ++ usageInfo usage options))
  where usage = "Usage: mackerel <options> <input file>" 

--
-- Processing source files
---

-- Null compilation 
nullCompiler :: String -> String -> Dev.Rec -> String
nullCompiler _ _ _ = ""

-- Perform run-time checks
run_checks :: String -> Dev.Rec -> IO String
run_checks input_fn dev =
    case (Checks.check_all input_fn dev) of
      Just errors ->
          do { (hPutStrLn stderr (unlines [ e ++ "\n"  | e <-errors]))
             ; System.Exit.exitWith (ExitFailure 1)
             }
      Nothing -> do { return "" }

-- Parsing the input file into an AST
parseFile :: String -> IO MackerelParser.DeviceFile
parseFile fname = do
    src <- readFile fname
    case (runParser MackerelParser.devfile () fname src) of
        Left err -> ioError $ userError ("Parse error at: " ++ (show err))
        Right x -> return x

-- Traverse the include path to find an import file
findImport :: [String] -> String -> IO MackerelParser.DeviceFile
findImport [] f = 
  ioError (userError $ printf "Can't find import '%s'" f)
findImport (d:t) f = 
  do 
    catch (parseFile (d </> f))
      (\e -> (if isDoesNotExistError e then findImport t f else ioError e))

-- Perform the transitive closure of all the imports

resolveImports :: [MackerelParser.DeviceFile] -> [String] 
                  -> IO [MackerelParser.DeviceFile]
resolveImports dfl path = 
  let allimports = nub $ concat [ il | (MackerelParser.DeviceFile _ il) <- dfl ]
      gotimports = [ n | (MackerelParser.DeviceFile (MackerelParser.Device n _ _ _ _) _) <- dfl ]
      required = allimports \\ gotimports
  in
   case required of
     [] -> return dfl
     (t:_) -> do { i <- (findImport path (t ++ ".dev"))
                 ; resolveImports (dfl ++ [i]) path
                 }

testentry :: IO ()
testentry = 
  let input_fn = "../../devices/xapic.dev"
      output_fn = "x2apic.dev.h"
      includedirs = ["../../devices"]
  in
   do { hPutStrLn stdout ("IN: " ++ input_fn)
      ; hPutStrLn stdout ("OUT: " ++ output_fn)
      ; df  <- parseFile input_fn
      ; dfl <- resolveImports [df] includedirs
      ; let dev = make_dev df (tail dfl) in
      do { _ <- run_checks input_fn dev
         ; outFileD <- openFile output_fn WriteMode
         ; hPutStr outFileD (ShiftDriver.compile input_fn output_fn dev)
         ; hClose outFileD 
         }
      }
  

-- Main entry point of Mackernel 
main :: IO ()
main = do { cli <- System.Environment.getArgs
          ; opts <- compilerOpts cli
          ; let input_fn = fromJust $ opt_infilename opts
                output_fn = fromJust $ opt_outfilename opts
            in 
             do { df  <- parseFile input_fn
                ; dfl <- resolveImports [df] (opt_includedirs opts)
                ; let dev = make_dev df (tail dfl) in
                do { _ <- run_checks input_fn dev
                   ; outFileD <- openFile output_fn WriteMode
                   ; hPutStr outFileD ((case (opt_target opts) of
                                           NullDriver -> nullCompiler 
                                           ShiftDriver -> ShiftDriver.compile 
                                           BitFieldDriver -> BitFieldDriver.compile)
                                       input_fn output_fn dev)
                   ; hClose outFileD          
                   }
                }
          }