mirror of
https://github.com/GaloisInc/macaw.git
synced 2024-11-29 21:44:11 +03:00
258 lines
8.9 KiB
Haskell
258 lines
8.9 KiB
Haskell
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternGuards #-}
|
|
module Main
|
|
( main
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Data.Attoparsec.ByteString.Char8 (Parser)
|
|
import qualified Data.Attoparsec.ByteString.Char8 as P
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString.Char8 as BS
|
|
import qualified Data.Map as Map
|
|
import Data.Maybe (catMaybes)
|
|
import Language.C
|
|
import Language.C.Analysis.AstAnalysis
|
|
import Language.C.Analysis.SemRep
|
|
import Language.C.Analysis.TravMonad
|
|
import Language.C.Data.Name (newNameSupply)
|
|
import Language.C.Data.Position (position)
|
|
import System.Environment (getArgs)
|
|
import System.Exit
|
|
import System.IO
|
|
import Text.PrettyPrint
|
|
import Text.Show.Pretty
|
|
|
|
-- FIXME: clag from Data.Macaw.Architecture.Syscall
|
|
data SyscallArgType = VoidArgType | WordArgType
|
|
deriving (Eq, Show, Read)
|
|
|
|
|
|
-- | The syscall.master file looks like (after pre-processing)
|
|
--
|
|
-- # <line no> filename
|
|
-- ... c header stuff
|
|
-- # <line no> "syscalls.master"
|
|
-- ; comment line
|
|
-- ...
|
|
-- <syscall no.>\t<audit>\t<syscall type>\t<prototype> ... ignored stuff ...
|
|
--
|
|
-- for example
|
|
--
|
|
-- 538 43207 STD { int bindat(int fd, int s, caddr_t name, int namelen); }
|
|
--
|
|
-- This file then does the following:
|
|
-- 1. Divide the file into two parts: the C headers and the syscall defs
|
|
-- 2. Parse each line in the syscall defs to extract the propotype
|
|
-- 3. Extract the argument types from the C prototype.
|
|
|
|
data SyscallInfo =
|
|
SyscallInfo { syscallNo :: Integer
|
|
, syscallAudit :: Integer
|
|
, syscallType :: ByteString
|
|
, syscallProto :: Maybe CExtDecl
|
|
}
|
|
deriving Show
|
|
|
|
|
|
syscallLine :: [Ident] -> Parser (Maybe SyscallInfo)
|
|
syscallLine idents =
|
|
P.choice [ P.char ';' >> return Nothing
|
|
, parseLine
|
|
]
|
|
where
|
|
parseLine = do
|
|
num <- P.decimal
|
|
P.skipSpace
|
|
audit <- P.decimal
|
|
P.skipSpace
|
|
cl <- P.takeWhile (not . P.isSpace)
|
|
P.skipSpace
|
|
cdecl <- P.choice [ P.char '{' >> P.takeTill ((==) '}') >>= return . parseDecl
|
|
, P.takeWhile1 (not . P.isSpace) >> return Nothing
|
|
]
|
|
return (Just (SyscallInfo num audit cl cdecl))
|
|
|
|
parseDecl bytes =
|
|
-- FIXME: we should maybe chain through newNameSupply? I don't think it is ever used ...
|
|
case execParser extDeclP bytes (position 0 "" 0 0 Nothing) idents newNameSupply of
|
|
Left _err -> Nothing
|
|
Right (cdecl, _unusedNames) -> Just cdecl
|
|
|
|
------------------------------------------------------------------------
|
|
-- Haskell generation
|
|
|
|
-- A bit hacky, but no less than using TH to read in a text file
|
|
generateHSFile :: CTranslUnit -> [SyscallInfo] -> Doc
|
|
generateHSFile tunit sis =
|
|
vcat [ text "-- DO NOT EDIT. Generated from make_bsd_syscalls/Main.hs"
|
|
, text "module Data.Macaw.X86.SyscallInfo.FreeBSD (syscallInfo) where"
|
|
, text "import Data.Map (Map, fromList)"
|
|
, text "import Data.Word"
|
|
, text "import Data.Macaw.X86.SyscallInfo"
|
|
, text ""
|
|
, text "syscallInfo :: Map Word64 SyscallTypeInfo"
|
|
, text "syscallInfo =" <+> ppDoc syscallMap ]
|
|
where
|
|
syscallMap = Map.fromList [ (syscallNo si, info)
|
|
| si <- sis
|
|
, Just d <- [ syscallProto si ]
|
|
, Right (info, _) <- [ syscallInfo d ] ]
|
|
-- syscallInfo :: CExtDecl -> Maybe (String, SyscallArgType, [SyscallArgType])
|
|
syscallInfo cdecl =
|
|
runTrav (error "no decl") $ do
|
|
_ <- analyseAST tunit
|
|
let handler (DeclEvent idecl) = modifyUserState (const $ summariseDeclEvent idecl)
|
|
handler _ = return ()
|
|
withExtDeclHandler (analyseExt cdecl) handler
|
|
getUserState
|
|
|
|
-- summariseDeclEvent idecl = pretty idecl
|
|
|
|
summariseDeclEvent d =
|
|
case getVarDecl d of
|
|
VarDecl vname _ (FunctionType (FunType rettyp params _) _) ->
|
|
( identToString (identOfVarName vname)
|
|
, typeToArgType rettyp
|
|
, map (typeToArgType . declType) params
|
|
)
|
|
_ -> error "summariseDeclEvent given unexpected declaration."
|
|
|
|
|
|
-- syscallInfo (CDeclExt (CDecl [CTypeSpec spec] [(Just declr, _, _)] _))
|
|
-- | CDeclr (Just ident) [CFunDeclr (Right (decls, _)) _ _] _ _ _ <- declr
|
|
-- = Just (identToString ident, typeSpecToArgType spec, map declToArgType decls)
|
|
-- syscallInfo d = error ("unhandled decl" ++ show d)
|
|
|
|
-- declToArgType (CDecl [CTypeSpec spec] _) = typeSpecToArgType spec
|
|
-- declToArgType d = error ("unhandled decl (in type) " ++ show d)
|
|
|
|
typeToArgType :: Type -> SyscallArgType
|
|
typeToArgType tp =
|
|
case tp of
|
|
DirectType typ' _ _ ->
|
|
case typ' of
|
|
TyVoid -> VoidArgType
|
|
TyIntegral _ -> WordArgType
|
|
TyFloating TyLDouble -> unhandled
|
|
TyFloating _ -> unhandled -- XMMFloatType
|
|
TyComplex _ -> unhandled
|
|
TyComp _comp -> unhandled -- compTypeToArgType comp
|
|
TyEnum _ -> WordArgType -- FIXME: ???
|
|
TyBuiltin _ -> unhandled
|
|
PtrType _ _ _ -> WordArgType
|
|
ArrayType _ _ _ _ -> WordArgType
|
|
FunctionType _ _ -> unhandled
|
|
TypeDefType (TypeDefRef _ typ _) _ _ -> typeToArgType typ
|
|
where
|
|
unhandled = error ("Unhandled type: " ++ show (pretty tp))
|
|
|
|
------------------------------------------------------------------------
|
|
-- File preprocessing
|
|
|
|
cppLinePragma :: Parser (Integer, String)
|
|
cppLinePragma = do
|
|
_ <- P.string "# "
|
|
n <- P.decimal
|
|
_ <- P.space
|
|
_ <- P.char '"'
|
|
filename <- P.many1 (P.satisfy ((/=) '"'))
|
|
_ <- P.char '"'
|
|
-- .. other stuff until end of line, we don't really care though
|
|
return (n, filename)
|
|
|
|
-- | This attempts to parses a bytestring line of the form:
|
|
--
|
|
-- "# ?decimal "?filename".*
|
|
--
|
|
-- If it matches this, then it returns the decimal value and
|
|
-- filenumber. If it does not, then it returns nothing.
|
|
isCPPLinePragma :: BS.ByteString
|
|
-> Maybe (Integer, String)
|
|
isCPPLinePragma str =
|
|
case P.parseOnly cppLinePragma str of
|
|
Left _ -> Nothing
|
|
Right r -> Just r
|
|
|
|
-- | This takes the lines in a file, and returns a pair of lines.
|
|
-- The first contains those lines between a pragma of the form
|
|
--
|
|
-- # XX "syscalls.master"
|
|
--
|
|
-- and a pragma with any other filename.
|
|
--
|
|
-- The second contains the other lines.
|
|
splitFile :: [BS.ByteString] -> ([BS.ByteString], [BS.ByteString])
|
|
splitFile = go False mempty
|
|
where
|
|
go :: Bool
|
|
-- ^ This flag is true if the last CPP line pragma had the filemname
|
|
-- syscalls.master"
|
|
-> ([BS.ByteString], [BS.ByteString])
|
|
-- ^ This contains the lines outside the system call
|
|
-- contents and the lines inside of respectively.
|
|
-> [BS.ByteString]
|
|
-> ([BS.ByteString], [BS.ByteString])
|
|
go _ acc [] = acc
|
|
go inSyscalls acc (l : ls)
|
|
| Just (_, filename) <- isCPPLinePragma l
|
|
= go (filename == "syscalls.master") acc ls
|
|
-- Add lines in the system
|
|
| otherwise =
|
|
go inSyscalls (acc & (if inSyscalls then _1 else _2) %~ (++ [l])) ls
|
|
|
|
------------------------------------------------------------------------
|
|
-- Parsing
|
|
|
|
translUnitToIdents :: CTranslUnit -> [Ident]
|
|
translUnitToIdents (CTranslUnit decls _) =
|
|
[ ident | CDeclExt (CDecl _ tdecls _) <- decls
|
|
, (Just (CDeclr (Just ident) _ _ _ _), _, _) <- tdecls ]
|
|
|
|
------------------------------------------------------------------------
|
|
-- Main
|
|
|
|
parseSyscallLine :: [Ident] -> BS.ByteString -> IO (Maybe SyscallInfo)
|
|
parseSyscallLine idents l =
|
|
case P.parseOnly (syscallLine idents) l of
|
|
Left err -> do
|
|
hPutStrLn stderr $ "Could not parse system call:"
|
|
hPutStrLn stderr $ " " ++ show err
|
|
hPutStrLn stderr $ " Input: " ++ BS.unpack l
|
|
exitFailure
|
|
Right i ->
|
|
return i
|
|
|
|
showUsageAndExit :: IO a
|
|
showUsageAndExit = do
|
|
hPutStrLn stderr $ unlines
|
|
[ "This program generates the Haskell module that maps system call ids"
|
|
, "in FreeBSD to the name, argument types, and result type."
|
|
, ""
|
|
, "Please specify the system.master.h file as the first argument."
|
|
, "The resulting Haskell module will be written to standard out."
|
|
]
|
|
exitFailure
|
|
|
|
main :: IO ()
|
|
main = do
|
|
args <- getArgs
|
|
input <-
|
|
case args of
|
|
[input] -> pure input
|
|
_ -> showUsageAndExit
|
|
|
|
-- Get contents and split into lines.
|
|
ls <- BS.split '\n' <$> BS.readFile input
|
|
|
|
let (syscalls, split_headers) = splitFile (filter (not . BS.null) ls)
|
|
headers = BS.intercalate "\n" split_headers
|
|
Right tunit = parseC headers (position 0 "" 0 0 Nothing)
|
|
idents = translUnitToIdents tunit
|
|
|
|
ms <- mapM (parseSyscallLine idents) (tail syscalls)
|
|
putStrLn "Got ms"
|
|
-- mapM_ pp (catMaybes ms)
|
|
print $ generateHSFile tunit $ catMaybes ms
|