diff --git a/stack-8.4.yaml b/stack-8.4.yaml index 8b18ac4e..337b3201 100644 --- a/stack-8.4.yaml +++ b/stack-8.4.yaml @@ -6,9 +6,7 @@ resolver: lts-12.26 packages: - base -- x86 - symbolic -- x86_symbolic - deps/crucible/what4 - deps/crucible/crucible - deps/crucible/crucible-llvm @@ -20,6 +18,10 @@ packages: - deps/llvm-pretty-bc-parser - deps/parameterized-utils - submodules/macaw-loader/macaw-loader +# X86 specific repos +- x86 +- x86/support +- x86_symbolic # - submodules/dismantle/dismantle-tablegen # - macaw-semmc # - submodules/semmc/semmc diff --git a/stack-8.6.yaml b/stack-8.6.yaml index b5410291..12d22e5a 100644 --- a/stack-8.6.yaml +++ b/stack-8.6.yaml @@ -6,9 +6,7 @@ resolver: lts-13.13 packages: - base -- x86 - symbolic -- x86_symbolic - deps/crucible/what4 - deps/crucible/crucible - deps/crucible/crucible-llvm @@ -20,6 +18,10 @@ packages: - deps/llvm-pretty-bc-parser - deps/parameterized-utils - submodules/macaw-loader/macaw-loader +# X86 specific repos +- x86 +- x86/support +- x86_symbolic # - submodules/dismantle/dismantle-tablegen # - macaw-semmc # - submodules/semmc/semmc diff --git a/x86/support/make_bsd_syscalls/Main.hs b/x86/support/make_bsd_syscalls/Main.hs index 86efaf15..bb40a149 100644 --- a/x86/support/make_bsd_syscalls/Main.hs +++ b/x86/support/make_bsd_syscalls/Main.hs @@ -10,15 +10,12 @@ 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 Data.Either (either) -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (catMaybes, maybe) +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.Ident import Language.C.Data.Name (newNameSupply) import Language.C.Data.Position (position) import System.Environment (getArgs) @@ -27,8 +24,6 @@ import System.IO import Text.PrettyPrint import Text.Show.Pretty -import Debug.Trace - -- FIXME: clag from Data.Macaw.Architecture.Syscall data SyscallArgType = VoidArgType | WordArgType deriving (Eq, Show, Read) @@ -115,10 +110,15 @@ generateHSFile tunit sis = -- summariseDeclEvent idecl = pretty idecl - summariseDeclEvent (getVarDecl -> VarDecl vname _ (FunctionType (FunType rettyp params _) _)) = - ( identToString (identOfVarName vname) - , typeToArgType rettyp - , map (typeToArgType . declType) params ) + 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 @@ -129,8 +129,8 @@ generateHSFile tunit sis = -- declToArgType d = error ("unhandled decl (in type) " ++ show d) typeToArgType :: Type -> SyscallArgType -typeToArgType typ = - case typ of +typeToArgType tp = + case tp of DirectType typ' _ _ -> case typ' of TyVoid -> VoidArgType @@ -138,7 +138,7 @@ typeToArgType typ = TyFloating TyLDouble -> unhandled TyFloating _ -> unhandled -- XMMFloatType TyComplex _ -> unhandled - TyComp comp -> unhandled -- compTypeToArgType comp + TyComp _comp -> unhandled -- compTypeToArgType comp TyEnum _ -> WordArgType -- FIXME: ??? TyBuiltin _ -> unhandled PtrType _ _ _ -> WordArgType @@ -146,7 +146,7 @@ typeToArgType typ = FunctionType _ _ -> unhandled TypeDefType (TypeDefRef _ typ _) _ _ -> typeToArgType typ where - unhandled = error ("Unhandled type: " ++ show (pretty typ)) + unhandled = error ("Unhandled type: " ++ show (pretty tp)) ------------------------------------------------------------------------ -- File preprocessing diff --git a/x86/support/make_linux_syscalls/Main.hs b/x86/support/make_linux_syscalls/Main.hs index 19f6f79d..bcf23273 100644 --- a/x86/support/make_linux_syscalls/Main.hs +++ b/x86/support/make_linux_syscalls/Main.hs @@ -6,7 +6,6 @@ The driver for creating SyscallInfo.Linux {-# 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) @@ -14,14 +13,12 @@ import qualified Data.ByteString.Char8 as BS import Data.Either (either) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (catMaybes, maybe, isNothing, listToMaybe) +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.Ident -import Language.C.Data.Name (newNameSupply) -import Language.C.Data.Position (position) import Language.C.System.GCC (newGCC) import System.Environment (getArgs) import System.Exit @@ -29,8 +26,6 @@ import System.IO import Text.PrettyPrint import Text.Show.Pretty -import Debug.Trace - -- FIXME: clag from Data.Macaw.Architecture.Syscall data SyscallArgType = VoidArgType | WordArgType | XMMFloatType deriving (Eq, Show, Read) @@ -51,15 +46,16 @@ data SyscallArgType = VoidArgType | WordArgType | XMMFloatType data SyscallInfo = SyscallInfo { syscallNo :: Integer - , syscallABI :: ByteString + , _syscallABI :: ByteString , syscallName :: ByteString , syscallProto :: Either ByteString IdentDecl } -- deriving Show -pp si = print $ integer (syscallNo si) <+> text (show $ syscallName si) - <+> text "->" - <+> either (const "???") pretty (syscallProto si) +instance Show SyscallInfo where + show si = show $ integer (syscallNo si) <+> text (show $ syscallName si) + <+> text "->" + <+> either (const "???") pretty (syscallProto si) -- A bit hacky, but no less than using TH to read in a text file generateHSFile :: [SyscallInfo] -> Doc @@ -84,10 +80,13 @@ generateHSFile sis = , Left str <- [ syscallProto si ] ] -- syscallInfo :: CExtDecl -> Maybe (String, SyscallArgType, [SyscallArgType]) - syscallInfo (getVarDecl -> VarDecl vname _ (FunctionType (FunType rettyp params _) _)) = - ( identToString (identOfVarName vname) - , typeToArgType rettyp - , map (typeToArgType . declType) params ) + syscallInfo d = + case getVarDecl d of + VarDecl vname _ (FunctionType (FunType rettyp params _) _) -> + ( identToString (identOfVarName vname) + , typeToArgType rettyp + , map (typeToArgType . declType) params ) + _ -> error "syscallInfo given unexpected declaration." -- syscallInfo (CDeclExt (CDecl [CTypeSpec spec] [(Just declr, _, _)] _)) -- | CDeclr (Just ident) [CFunDeclr (Right (decls, _)) _ _] _ _ _ <- declr @@ -98,8 +97,8 @@ generateHSFile sis = -- declToArgType d = error ("unhandled decl (in type) " ++ show d) typeToArgType :: Type -> SyscallArgType -typeToArgType typ = - case typ of +typeToArgType tp = + case tp of DirectType typ' _ _ -> case typ' of TyVoid -> VoidArgType @@ -107,7 +106,7 @@ typeToArgType typ = TyFloating TyLDouble -> unhandled TyFloating _ -> XMMFloatType TyComplex _ -> unhandled - TyComp comp -> unhandled -- compTypeToArgType comp + TyComp _comp -> unhandled -- compTypeToArgType comp TyEnum _ -> WordArgType -- FIXME: ??? TyBuiltin _ -> unhandled PtrType _ _ _ -> WordArgType @@ -115,10 +114,7 @@ typeToArgType typ = FunctionType _ _ -> unhandled TypeDefType (TypeDefRef _ typ _) _ _ -> typeToArgType typ where - unhandled = error ("Unhandled type: " ++ show (pretty typ)) - -compTypeToArgType :: CompTypeRef -> SyscallArgType -compTypeToArgType ctyp = trace ("Comp type: " ++ show (pretty ctyp)) WordArgType + unhandled = error ("Unhandled type: " ++ show (pretty tp)) -- We support as little as possible here ... -- typeSpecToArgType :: Show a => CTypeSpecifier a -> SyscallArgType @@ -152,7 +148,7 @@ readOneCFile f = do let gdecls = case runTrav_ (analyseAST tunit) of Left err -> error $ "Error: " ++ (show err) - Right (gdecls, _) -> gdecls + Right (d, _) -> d return (Map.mapKeys (\(Ident name _ _) -> BS.pack name) $ gObjs gdecls)