2017-11-15 06:00:01 +03:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
2017-10-27 04:38:47 +03:00
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2017-11-08 07:22:49 +03:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
2017-10-27 04:38:47 +03:00
|
|
|
{-# LANGUAGE RankNTypes #-}
|
2017-11-15 06:00:01 +03:00
|
|
|
{-# LANGUAGE TypeApplications #-}
|
2017-10-27 04:38:47 +03:00
|
|
|
module PPC64Tests (
|
|
|
|
ppcAsmTests
|
|
|
|
) where
|
|
|
|
|
2017-11-08 07:29:41 +03:00
|
|
|
import Control.Lens ( (^.) )
|
2017-10-27 04:38:47 +03:00
|
|
|
import qualified Data.Foldable as F
|
|
|
|
import qualified Data.Map as M
|
2017-11-22 01:10:47 +03:00
|
|
|
import Data.Maybe ( fromJust, mapMaybe )
|
2017-11-15 06:00:01 +03:00
|
|
|
import Data.Proxy ( Proxy(..) )
|
2017-10-27 04:38:47 +03:00
|
|
|
import qualified Data.Set as S
|
2017-11-08 07:29:41 +03:00
|
|
|
import Data.Word ( Word64 )
|
|
|
|
import System.FilePath ( dropExtension, replaceExtension )
|
2017-10-27 04:38:47 +03:00
|
|
|
import qualified Test.Tasty as T
|
|
|
|
import qualified Test.Tasty.HUnit as T
|
2017-11-08 07:29:41 +03:00
|
|
|
import Text.Printf ( PrintfArg, printf )
|
|
|
|
import Text.Read ( readMaybe )
|
2017-10-27 04:38:47 +03:00
|
|
|
|
|
|
|
import qualified Data.ElfEdit as E
|
|
|
|
|
|
|
|
import qualified Data.Parameterized.Some as PU
|
|
|
|
import qualified Data.Macaw.Memory as MM
|
|
|
|
import qualified Data.Macaw.Discovery as MD
|
|
|
|
import qualified Data.Macaw.Discovery.State as MD
|
|
|
|
import qualified Data.Macaw.PPC as RO
|
2017-11-16 18:16:22 +03:00
|
|
|
import qualified Data.Macaw.PPC.BinaryFormat.ELF as E
|
2017-11-15 06:00:01 +03:00
|
|
|
import qualified SemMC.Architecture.PPC64 as PPC64
|
2017-10-27 04:38:47 +03:00
|
|
|
|
2017-11-08 07:29:41 +03:00
|
|
|
import Data.List (intercalate)
|
|
|
|
import Debug.Trace (trace)
|
2017-10-28 00:29:04 +03:00
|
|
|
|
2017-11-09 21:43:41 +03:00
|
|
|
import Shared
|
|
|
|
|
2017-10-27 04:38:47 +03:00
|
|
|
ppcAsmTests :: [FilePath] -> T.TestTree
|
|
|
|
ppcAsmTests = T.testGroup "PPC" . map mkTest
|
|
|
|
|
2017-11-08 07:22:49 +03:00
|
|
|
newtype Hex a = Hex a
|
|
|
|
deriving (Eq, Ord, Num, PrintfArg)
|
|
|
|
|
|
|
|
instance (Num a, Show a, PrintfArg a) => Show (Hex a) where
|
|
|
|
show (Hex a) = printf "0x%x" a
|
|
|
|
|
|
|
|
instance (Read a) => Read (Hex a) where
|
|
|
|
readsPrec i s = [ (Hex a, s') | (a, s') <- readsPrec i s ]
|
|
|
|
|
2017-10-27 04:38:47 +03:00
|
|
|
-- | The type of expected results for test cases
|
|
|
|
data ExpectedResult =
|
2017-11-08 07:22:49 +03:00
|
|
|
R { funcs :: [(Hex Word64, [(Hex Word64, Word64)])]
|
2017-10-27 04:38:47 +03:00
|
|
|
-- ^ The first element of the pair is the address of entry point
|
|
|
|
-- of the function. The list is a list of the addresses of the
|
|
|
|
-- basic blocks in the function (including the first block).
|
2017-11-08 07:22:49 +03:00
|
|
|
, ignoreBlocks :: [Hex Word64]
|
2017-10-27 04:38:47 +03:00
|
|
|
-- ^ This is a list of discovered blocks to ignore. This is
|
|
|
|
-- basically just the address of the instruction after the exit
|
|
|
|
-- syscall, as macaw doesn't know that exit never returns and
|
|
|
|
-- discovers a false block after exit.
|
|
|
|
}
|
|
|
|
deriving (Read, Show, Eq)
|
|
|
|
|
|
|
|
-- | Read in a test case from disk and output a test tree.
|
|
|
|
mkTest :: FilePath -> T.TestTree
|
|
|
|
mkTest fp = T.testCase fp $ withELF exeFilename (testDiscovery fp)
|
|
|
|
where
|
|
|
|
asmFilename = dropExtension fp
|
|
|
|
exeFilename = replaceExtension asmFilename "exe"
|
|
|
|
|
2017-10-28 00:29:04 +03:00
|
|
|
showSegments :: (MM.MemWidth w) => MM.Memory w -> String
|
|
|
|
showSegments mem = intercalate "\n" $ map show (MM.memSegments mem)
|
|
|
|
|
2017-10-27 04:38:47 +03:00
|
|
|
-- | Run a test over a given expected result filename and the ELF file
|
|
|
|
-- associated with it
|
|
|
|
testDiscovery :: FilePath -> E.Elf 64 -> IO ()
|
|
|
|
testDiscovery expectedFilename elf =
|
|
|
|
withMemory MM.Addr64 elf $ \mem -> do
|
2017-10-28 00:29:04 +03:00
|
|
|
let Just entryPoint = trace (showSegments mem) $ MM.asSegmentOff mem (findEntryPoint64 elf mem)
|
2017-11-22 01:10:47 +03:00
|
|
|
tocBase = RO.tocBaseForELF (Proxy @PPC64.PPC) elf
|
|
|
|
otherEntryAddrs :: [MM.MemAddr 64]
|
|
|
|
otherEntryAddrs = E.tocEntryAddrsForElf (Proxy @PPC64.PPC) elf
|
|
|
|
otherEntries = mapMaybe (MM.asSegmentOff mem) otherEntryAddrs
|
2018-01-22 21:26:20 +03:00
|
|
|
di = MD.cfgFromAddrs (RO.ppc64_linux_info tocBase) mem M.empty (entryPoint:otherEntries) []
|
2017-10-27 04:38:47 +03:00
|
|
|
expectedString <- readFile expectedFilename
|
|
|
|
case readMaybe expectedString of
|
|
|
|
-- Above: Read in the ExpectedResult from the contents of the file
|
|
|
|
Nothing -> T.assertFailure ("Invalid expected result: " ++ show expectedString)
|
|
|
|
Just er -> do
|
|
|
|
let expectedEntries = M.fromList [ (entry, S.fromList starts) | (entry, starts) <- funcs er ]
|
|
|
|
-- expectedEntries maps function entry points to the set of block starts
|
|
|
|
-- within the function.
|
|
|
|
ignoredBlocks = S.fromList (ignoreBlocks er)
|
2017-11-08 07:50:33 +03:00
|
|
|
allFoundBlockAddrs :: S.Set Word64
|
|
|
|
allFoundBlockAddrs =
|
|
|
|
S.fromList [ fromIntegral (fromJust (MM.asAbsoluteAddr (MM.relativeSegmentAddr (MD.pblockAddr pbr))))
|
|
|
|
| PU.Some dfi <- M.elems (di ^. MD.funInfo)
|
|
|
|
, pbr <- M.elems (dfi ^. MD.parsedBlocks)
|
|
|
|
]
|
2017-11-09 02:46:40 +03:00
|
|
|
-- Test that all discovered blocks were expected (and verify their sizes)
|
2017-10-27 04:38:47 +03:00
|
|
|
F.forM_ (M.elems (di ^. MD.funInfo)) $ \(PU.Some dfi) -> do
|
|
|
|
let actualEntry = fromIntegral (fromJust (MM.asAbsoluteAddr (MM.relativeSegmentAddr (MD.discoveredFunAddr dfi))))
|
2017-11-06 07:51:57 +03:00
|
|
|
actualBlockStarts = S.fromList [ (baddr, bsize)
|
2017-10-27 04:38:47 +03:00
|
|
|
| pbr <- M.elems (dfi ^. MD.parsedBlocks)
|
2017-11-06 07:51:57 +03:00
|
|
|
, trace ("Parsed Block: " ++ show pbr) True
|
|
|
|
, let baddr = fromIntegral (fromJust (MM.asAbsoluteAddr (MM.relativeSegmentAddr (MD.pblockAddr pbr))))
|
|
|
|
, let bsize = fromIntegral (MD.blockSize pbr)
|
2017-10-27 04:38:47 +03:00
|
|
|
]
|
|
|
|
case (S.member actualEntry ignoredBlocks, M.lookup actualEntry expectedEntries) of
|
|
|
|
(True, _) -> return ()
|
2017-10-28 07:08:47 +03:00
|
|
|
(_, Nothing) -> T.assertFailure (printf "Unexpected block start: 0x%x" actualEntry)
|
2017-10-27 04:38:47 +03:00
|
|
|
(_, Just expectedBlockStarts) ->
|
2017-11-06 07:51:57 +03:00
|
|
|
T.assertEqual (printf "Block starts for 0x%x" actualEntry) expectedBlockStarts (actualBlockStarts `removeIgnored` ignoredBlocks)
|
2017-11-09 02:46:40 +03:00
|
|
|
|
|
|
|
-- Test that all expected blocks were discovered
|
2017-11-08 07:50:33 +03:00
|
|
|
F.forM_ (funcs er) $ \(_funcAddr, blockAddrs) ->
|
|
|
|
F.forM_ blockAddrs $ \(blockAddr@(Hex addr), _) -> do
|
|
|
|
T.assertBool ("Missing block address: " ++ show blockAddr) (S.member addr allFoundBlockAddrs)
|
2017-11-06 07:51:57 +03:00
|
|
|
|
|
|
|
removeIgnored :: (Ord b, Ord a) => S.Set (a, b) -> S.Set a -> S.Set (a, b)
|
|
|
|
removeIgnored actualBlockStarts ignoredBlocks =
|
|
|
|
F.foldr (\v@(addr, _) acc -> if S.member addr ignoredBlocks
|
|
|
|
then S.delete v acc
|
|
|
|
else acc) actualBlockStarts actualBlockStarts
|
2017-10-27 04:38:47 +03:00
|
|
|
|