mirror of
https://github.com/GaloisInc/macaw.git
synced 2024-12-25 23:23:18 +03:00
Remove a type parameter
We don't need the separate w - it is just a function (ArchAddrWidth) of the architecture.
This commit is contained in:
Tristan Ravitch
parent
d5c5d40ddb
commit
083f9b4fa1
@ -27,16 +27,22 @@ import qualified Data.Parameterized.Nonce as NC
|
||||
|
||||
import Data.Macaw.PPC.Generator
|
||||
|
||||
newtype DisM ppc s a = DisM { unDisM :: ET.ExceptT (DisassembleException ppc) (ST s) a }
|
||||
type LocatedFailure ppc s = ([Block ppc s], MM.MemWord (RegAddrWidth (ArchReg ppc)), TranslationError (RegAddrWidth (ArchReg ppc)))
|
||||
newtype DisM ppc s a = DisM { unDisM :: ET.ExceptT (LocatedFailure ppc s) (ST s) a }
|
||||
deriving (Functor,
|
||||
Applicative,
|
||||
Monad,
|
||||
ET.MonadError (DisassembleException ppc))
|
||||
ET.MonadError (LocatedFailure ppc s))
|
||||
|
||||
data DisassembleException w = InvalidNextIP Word64 Word64
|
||||
| DecodeError (MM.MemoryError w)
|
||||
data TranslationError w = TranslationError { transErrorAddr :: MM.MemSegmentOff w
|
||||
, transErrorReason :: TranslationErrorReason w
|
||||
}
|
||||
|
||||
deriving instance (MM.MemWidth w) => Show (DisassembleException w)
|
||||
data TranslationErrorReason w = InvalidNextIP Word64 Word64
|
||||
| DecodeError (MM.MemoryError w)
|
||||
deriving (Show)
|
||||
|
||||
deriving instance (MM.MemWidth w) => Show (TranslationError w)
|
||||
|
||||
liftST :: ST s a -> DisM ppc s a
|
||||
liftST = DisM . lift
|
||||
@ -65,35 +71,45 @@ readInstruction mem addr = MM.addrWidthClass (MM.memAddrWidth mem) $ do
|
||||
Just insn -> return (insn, fromIntegral bytesRead)
|
||||
Nothing -> ET.throwError (MM.InvalidInstruction (MM.relativeSegmentAddr addr) contents)
|
||||
|
||||
disassembleBlock :: (w ~ RegAddrWidth (ArchReg ppc))
|
||||
=> MM.Memory (ArchAddrWidth ppc)
|
||||
-> GenState ppc w s ids
|
||||
-> MM.MemSegmentOff w
|
||||
-> MM.MemWord w
|
||||
-> DisM w s (MM.MemWord w, GenState ppc w s ids)
|
||||
failAt :: GenState ppc s ids
|
||||
-> MM.MemWord (ArchAddrWidth ppc)
|
||||
-> MM.MemSegmentOff (ArchAddrWidth ppc)
|
||||
-> TranslationErrorReason (ArchAddrWidth ppc)
|
||||
-> DisM ppc s a
|
||||
failAt gs offset curIPAddr reason = do
|
||||
let exn = TranslationError { transErrorAddr = curIPAddr
|
||||
, transErrorReason = reason
|
||||
}
|
||||
undefined ([], offset, exn)
|
||||
|
||||
disassembleBlock :: MM.Memory (ArchAddrWidth ppc)
|
||||
-> GenState ppc s ids
|
||||
-> MM.MemSegmentOff (ArchAddrWidth ppc)
|
||||
-> MM.MemWord (ArchAddrWidth ppc)
|
||||
-> DisM ppc s (MM.MemWord (ArchAddrWidth ppc), GenState ppc s ids)
|
||||
disassembleBlock mem gs curIPAddr maxOffset = do
|
||||
let seg = MM.msegSegment curIPAddr
|
||||
let off = MM.msegOffset curIPAddr
|
||||
case readInstruction mem curIPAddr of
|
||||
Left err -> undefined
|
||||
Left err -> failAt gs off curIPAddr (DecodeError err)
|
||||
Right (i, bytesRead) -> do
|
||||
-- let nextIP = MM.relativeAddr seg (off + bytesRead)
|
||||
-- let nextIPVal = MC.RelocatableValue undefined nextIP
|
||||
undefined
|
||||
|
||||
tryDisassembleBlock :: (MM.MemWidth w,
|
||||
w ~ RegAddrWidth (ArchReg ppc))
|
||||
tryDisassembleBlock :: (MM.MemWidth (ArchAddrWidth ppc))
|
||||
=> MM.Memory (ArchAddrWidth ppc)
|
||||
-> NC.NonceGenerator (ST s) s
|
||||
-> ArchSegmentOff ppc
|
||||
-> ArchAddrWord ppc
|
||||
-> DisM w s ([Block ppc s], MM.MemWord (ArchAddrWidth ppc))
|
||||
-> DisM ppc s ([Block ppc s], MM.MemWord (ArchAddrWidth ppc))
|
||||
tryDisassembleBlock mem nonceGen startAddr maxSize = do
|
||||
let gs0 = initGenState nonceGen startAddr
|
||||
let startOffset = MM.msegOffset startAddr
|
||||
(nextIPOffset, gs1) <- disassembleBlock mem gs0 startAddr (startOffset + maxSize)
|
||||
unless (nextIPOffset > startOffset) $ do
|
||||
ET.throwError (InvalidNextIP (fromIntegral nextIPOffset) (fromIntegral startOffset))
|
||||
let reason = InvalidNextIP (fromIntegral nextIPOffset) (fromIntegral startOffset)
|
||||
failAt gs1 nextIPOffset startAddr reason
|
||||
let blocks = F.toList (blockSeq gs1 ^. frontierBlocks)
|
||||
return (blocks, nextIPOffset - startOffset)
|
||||
|
||||
@ -116,5 +132,5 @@ disassembleFn :: (MM.MemWidth (RegAddrWidth (ArchReg ppc)))
|
||||
disassembleFn _ mem nonceGen startAddr maxSize _ = do
|
||||
mr <- ET.runExceptT (unDisM (tryDisassembleBlock mem nonceGen startAddr maxSize))
|
||||
case mr of
|
||||
Left exn -> return ([], 0, Just (show exn))
|
||||
Left (blocks, off, exn) -> return (blocks, off, Just (show exn))
|
||||
Right (blocks, bytes) -> return (blocks, bytes, Nothing)
|
||||
|
||||
@ -82,15 +82,16 @@ pBlockState = lens _pBlockState (\s v -> s { _pBlockState = v })
|
||||
------------------------------------------------------------------------
|
||||
-- GenState
|
||||
|
||||
data GenState ppc w s ids = GenState { assignIdGen :: !(NC.NonceGenerator (ST s) ids)
|
||||
, blockSeq :: !(BlockSeq ppc ids)
|
||||
, _blockState :: !(PreBlock ppc ids)
|
||||
, genAddr :: !(MM.MemSegmentOff w)
|
||||
}
|
||||
data GenState ppc s ids =
|
||||
GenState { assignIdGen :: !(NC.NonceGenerator (ST s) ids)
|
||||
, blockSeq :: !(BlockSeq ppc ids)
|
||||
, _blockState :: !(PreBlock ppc ids)
|
||||
, genAddr :: !(MM.MemSegmentOff (ArchAddrWidth ppc))
|
||||
}
|
||||
|
||||
initGenState :: NC.NonceGenerator (ST s) ids
|
||||
-> MM.MemSegmentOff w
|
||||
-> GenState ppc w s ids
|
||||
-> MM.MemSegmentOff (ArchAddrWidth ppc)
|
||||
-> GenState ppc s ids
|
||||
initGenState nonceGen addr =
|
||||
GenState { assignIdGen = nonceGen
|
||||
, blockSeq = BlockSeq { _nextBlockID = 0, _frontierBlocks = Seq.empty }
|
||||
@ -98,54 +99,54 @@ initGenState nonceGen addr =
|
||||
, genAddr = addr
|
||||
}
|
||||
|
||||
blockState :: Simple Lens (GenState ppc w s ids) (PreBlock ppc ids)
|
||||
blockState :: Simple Lens (GenState ppc s ids) (PreBlock ppc ids)
|
||||
blockState = lens _blockState (\s v -> s { _blockState = v })
|
||||
|
||||
curPPCState :: Simple Lens (GenState ppc w s ids) (RegState (PPCReg ppc) (Value ppc ids))
|
||||
curPPCState :: Simple Lens (GenState ppc s ids) (RegState (PPCReg ppc) (Value ppc ids))
|
||||
curPPCState = blockState . pBlockState
|
||||
|
||||
------------------------------------------------------------------------
|
||||
-- PPCGenerator
|
||||
|
||||
newtype PPCGenerator ppc w s ids a = PPCGenerator { runGen :: St.StateT (GenState ppc w s ids) (ST s) a }
|
||||
newtype PPCGenerator ppc s ids a = PPCGenerator { runGen :: St.StateT (GenState ppc s ids) (ST s) a }
|
||||
deriving (Monad,
|
||||
Functor,
|
||||
Applicative,
|
||||
St.MonadState (GenState ppc w s ids))
|
||||
St.MonadState (GenState ppc s ids))
|
||||
|
||||
runGenerator :: GenState ppc w s ids -> PPCGenerator ppc w s ids a -> ST s (a, GenState ppc w s ids)
|
||||
runGenerator :: GenState ppc s ids -> PPCGenerator ppc s ids a -> ST s (a, GenState ppc s ids)
|
||||
runGenerator s0 act = St.runStateT (runGen act) s0
|
||||
|
||||
execGenerator :: GenState ppc w s ids -> PPCGenerator ppc w s ids () -> ST s (GenState ppc w s ids)
|
||||
execGenerator :: GenState ppc s ids -> PPCGenerator ppc s ids () -> ST s (GenState ppc s ids)
|
||||
execGenerator s0 act = St.execStateT (runGen act) s0
|
||||
|
||||
-- Given a stateful computation on the underlying GenState, create a PPCGenerator
|
||||
-- that runs that same computation.
|
||||
modGenState :: St.State (GenState ppc w s ids) a -> PPCGenerator ppc w s ids a
|
||||
modGenState :: St.State (GenState ppc s ids) a -> PPCGenerator ppc s ids a
|
||||
modGenState m = PPCGenerator $ St.StateT $ \genState -> do
|
||||
return $ St.runState m genState
|
||||
|
||||
addStmt :: Stmt ppc ids -> PPCGenerator ppc w s ids ()
|
||||
addStmt :: Stmt ppc ids -> PPCGenerator ppc s ids ()
|
||||
addStmt stmt = (blockState . pBlockStmts) %= (Seq.|> stmt)
|
||||
|
||||
newAssignId :: PPCGenerator ppc w s ids (AssignId ids tp)
|
||||
newAssignId :: PPCGenerator ppc s ids (AssignId ids tp)
|
||||
newAssignId = do
|
||||
nonceGen <- St.gets assignIdGen
|
||||
n <- liftST $ NC.freshNonce nonceGen
|
||||
return (AssignId n)
|
||||
|
||||
liftST :: ST s a -> PPCGenerator ppc w s ids a
|
||||
liftST :: ST s a -> PPCGenerator ppc s ids a
|
||||
liftST = PPCGenerator . lift
|
||||
|
||||
addAssignment :: AssignRhs ppc ids tp
|
||||
-> PPCGenerator ppc w s ids (Assignment ppc ids tp)
|
||||
-> PPCGenerator ppc s ids (Assignment ppc ids tp)
|
||||
addAssignment rhs = do
|
||||
l <- newAssignId
|
||||
let a = Assignment l rhs
|
||||
addStmt $ AssignStmt a
|
||||
return a
|
||||
|
||||
getReg :: PPCReg ppc tp -> PPCGenerator ppc w s ids (Expr ppc ids tp)
|
||||
getReg :: PPCReg ppc tp -> PPCGenerator ppc s ids (Expr ppc ids tp)
|
||||
getReg r = PPCGenerator $ St.StateT $ \genState -> do
|
||||
let expr = ValueExpr (genState ^. blockState ^. pBlockState ^. boundValue r)
|
||||
return (expr, genState)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user