diff --git a/macaw-ppc/src/Data/Macaw/PPC.hs b/macaw-ppc/src/Data/Macaw/PPC.hs index 5b415869..e3097753 100644 --- a/macaw-ppc/src/Data/Macaw/PPC.hs +++ b/macaw-ppc/src/Data/Macaw/PPC.hs @@ -17,6 +17,8 @@ import qualified Data.Macaw.Architecture.Info as MI import Data.Macaw.CFG import qualified Data.Macaw.CFG.DemandSet as MDS import qualified Data.Macaw.Memory as MM +import qualified Data.Parameterized.TraversableFC as FC +import Data.Parameterized.Some ( Some(..), viewSome ) import qualified SemMC.Architecture.PPC32 as PPC32 import qualified SemMC.Architecture.PPC64 as PPC64 @@ -31,13 +33,26 @@ import Data.Macaw.PPC.Eval ( mkInitialAbsState, import Data.Macaw.PPC.Identify ( identifyCall, identifyReturn ) -import Data.Macaw.PPC.Arch ( rewriteTermStmt, rewriteStmt, rewritePrimFn ) +import Data.Macaw.PPC.Arch ( rewriteTermStmt, + rewriteStmt, + rewritePrimFn, + valuesInPPCStmt, + ppcPrimFnHasSideEffects, + PPCArch + ) import Data.Macaw.PPC.PPCReg ( PPCWidth ) import qualified Data.Macaw.PPC.Semantics.PPC32 as PPC32 import qualified Data.Macaw.PPC.Semantics.PPC64 as PPC64 -archDemandContext :: proxy ppc -> MDS.DemandContext ppc ids -archDemandContext = undefined +addValueListDemands :: [Some (Value ppc ids)] -> MDS.DemandComp ppc ids () +addValueListDemands = mapM_ (viewSome MDS.addValueDemands) + +archDemandContext :: (PPCArch ppc) => proxy ppc -> MDS.DemandContext ppc ids +archDemandContext _ = + MDS.DemandContext { MDS.addArchStmtDemands = addValueListDemands . valuesInPPCStmt + , MDS.addArchFnDemands = addValueListDemands . FC.foldMapFC (\v -> [ Some v ]) + , MDS.archFnHasSideEffects = ppcPrimFnHasSideEffects + } -- | NOTE: There isn't necessarily one answer for this. This will need to turn -- into a function. With PIC jump tables, it can be smaller than the native size. diff --git a/macaw-ppc/src/Data/Macaw/PPC/Arch.hs b/macaw-ppc/src/Data/Macaw/PPC/Arch.hs index 1ebc63fa..bd5e44df 100644 --- a/macaw-ppc/src/Data/Macaw/PPC/Arch.hs +++ b/macaw-ppc/src/Data/Macaw/PPC/Arch.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -8,13 +11,18 @@ module Data.Macaw.PPC.Arch ( PPCTermStmt(..), rewriteTermStmt, PPCStmt(..), + valuesInPPCStmt, rewriteStmt, PPCPrimFn(..), - rewritePrimFn + rewritePrimFn, + ppcPrimFnHasSideEffects, + PPCArch ) where import qualified Text.PrettyPrint.ANSI.Leijen as PP import qualified Data.Parameterized.TraversableFC as FC +import qualified Data.Parameterized.TraversableF as TF +import Data.Parameterized.Some ( Some(..) ) import qualified Data.Macaw.CFG as MC import Data.Macaw.CFG.Rewriter ( Rewriter, rewriteValue, evalRewrittenArchFn ) import qualified Data.Macaw.Types as MT @@ -49,16 +57,31 @@ rewriteTermStmt s = PPCTrap -> pure PPCTrap -- | We currently have no PPC-specific statements. Remove 'None' if we add some. -data PPCStmt ids where - None :: PPCStmt ids +data PPCStmt (v :: MT.Type -> *) where + None :: PPCStmt v -instance MC.PrettyF PPCStmt where - prettyF None = PP.text "None" +instance MC.PrettyF (PPCArchStmt ppc) where + prettyF (PPCArchStmt s) = + case s of + None -> PP.text "None" -type instance MC.ArchStmt PPC64.PPC = PPCStmt -type instance MC.ArchStmt PPC32.PPC = PPCStmt +instance TF.FunctorF PPCStmt where + fmapF = TF.fmapFDefault -rewriteStmt :: PPCStmt src -> Rewriter ppc src tgt () +instance TF.FoldableF PPCStmt where + foldMapF = TF.foldMapFDefault + +instance TF.TraversableF PPCStmt where + traverseF _go stmt = + case stmt of + None -> pure None + +newtype PPCArchStmt ppc ids = PPCArchStmt (PPCStmt (MC.Value ppc ids)) + +type instance MC.ArchStmt PPC64.PPC = PPCArchStmt PPC64.PPC +type instance MC.ArchStmt PPC32.PPC = PPCArchStmt PPC32.PPC + +rewriteStmt :: PPCArchStmt ppc src -> Rewriter ppc src tgt () rewriteStmt _ = return () data PPCPrimFn ppc f tp where @@ -72,6 +95,13 @@ instance MT.HasRepr (PPCPrimFn ppc (MC.Value ppc ids)) MT.TypeRepr where case f of IDiv {} -> undefined +-- | Right now, none of the primitive functions has a side effect. That will +-- probably change. +ppcPrimFnHasSideEffects :: PPCPrimFn ppc f tp -> Bool +ppcPrimFnHasSideEffects pf = + case pf of + IDiv {} -> False + rewritePrimFn :: (PPCWidth ppc, MC.ArchFn ppc ~ PPCPrimFn ppc) => PPCPrimFn ppc (MC.Value ppc src) tp -> Rewriter ppc src tgt (MC.Value ppc tgt tp) @@ -102,3 +132,8 @@ instance FC.TraversableFC (PPCPrimFn ppc) where type instance MC.ArchFn PPC64.PPC = PPCPrimFn PPC64.PPC type instance MC.ArchFn PPC32.PPC = PPCPrimFn PPC32.PPC + +valuesInPPCStmt :: PPCArchStmt ppc ids -> [Some (MC.Value ppc ids)] +valuesInPPCStmt (PPCArchStmt s) = TF.foldMapF (\x -> [Some x]) s + +type PPCArch ppc = (PPCWidth ppc, MC.ArchStmt ppc ~ PPCArchStmt ppc, MC.ArchFn ppc ~ PPCPrimFn ppc) diff --git a/macaw-ppc/src/Data/Macaw/PPC/Eval.hs b/macaw-ppc/src/Data/Macaw/PPC/Eval.hs index 575019b4..b0c9a24a 100644 --- a/macaw-ppc/src/Data/Macaw/PPC/Eval.hs +++ b/macaw-ppc/src/Data/Macaw/PPC/Eval.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} module Data.Macaw.PPC.Eval ( @@ -11,6 +12,7 @@ module Data.Macaw.PPC.Eval ( import GHC.TypeLits +import Control.Lens ( (&) ) import qualified Data.Set as S import Data.Macaw.AbsDomain.AbsState as MA @@ -18,6 +20,7 @@ import Data.Macaw.CFG import qualified Data.Macaw.Memory as MM import Data.Parameterized.Some ( Some(..) ) +import Data.Macaw.PPC.Arch import Data.Macaw.PPC.PPCReg preserveRegAcrossSyscall :: (ArchReg ppc ~ PPCReg ppc, 1 <= RegAddrWidth (PPCReg ppc)) @@ -26,26 +29,50 @@ preserveRegAcrossSyscall :: (ArchReg ppc ~ PPCReg ppc, 1 <= RegAddrWidth (PPCReg -> Bool preserveRegAcrossSyscall proxy r = S.member (Some r) (linuxSystemCallPreservedRegisters proxy) -mkInitialAbsState :: proxy ppc +-- | Set up an initial abstract state that holds at the beginning of a basic +-- block. +-- +-- The 'MM.Memory' is the mapped memory region +-- +-- The 'ArchSegmentOff' is the start address of the basic block. +-- +-- Note that we don't initialize the abstract stack. On PowerPC, there are no +-- initial stack entries (since the return address is in the link register). +mkInitialAbsState :: (PPCWidth ppc) + => proxy ppc -> MM.Memory (RegAddrWidth (ArchReg ppc)) -> ArchSegmentOff ppc -> MA.AbsBlockState (ArchReg ppc) -mkInitialAbsState = undefined +mkInitialAbsState _ _mem startAddr = + MA.top & MA.setAbsIP startAddr -absEvalArchFn :: proxy ppc +absEvalArchFn :: (PPCArch ppc) + => proxy ppc -> AbsProcessorState (ArchReg ppc) ids -> ArchFn ppc (Value ppc ids) tp -> AbsValue (RegAddrWidth (ArchReg ppc)) tp -absEvalArchFn = undefined +absEvalArchFn _ _r f = + case f of + IDiv {} -> MA.TopV +-- | For now, none of the architecture-specific statements have an effect on the +-- abstract value. absEvalArchStmt :: proxy ppc -> AbsProcessorState (ArchReg ppc) ids -> ArchStmt ppc ids -> AbsProcessorState (ArchReg ppc) ids -absEvalArchStmt = undefined +absEvalArchStmt _ s _ = s -postCallAbsState :: proxy ppc +-- | There should be no difference in stack height before and after a call, as +-- the callee pushes the return address if required. Return values are also +-- passed in registers. +postCallAbsState :: (PPCWidth ppc) + => proxy ppc -> AbsBlockState (ArchReg ppc) -> ArchSegmentOff ppc -> AbsBlockState (ArchReg ppc) -postCallAbsState = undefined +postCallAbsState proxy = MA.absEvalCall params + where + params = MA.CallParams { MA.postCallStackDelta = 0 + , MA.preserveReg = \r -> S.member (Some r) (linuxCalleeSaveRegisters proxy) + } diff --git a/macaw-ppc/src/Data/Macaw/PPC/Generator.hs b/macaw-ppc/src/Data/Macaw/PPC/Generator.hs index f038a3c6..6e1fd58b 100644 --- a/macaw-ppc/src/Data/Macaw/PPC/Generator.hs +++ b/macaw-ppc/src/Data/Macaw/PPC/Generator.hs @@ -19,7 +19,6 @@ module Data.Macaw.PPC.Generator ( addStmt, addAssignment, getReg, - blockSeq, -- * Lenses blockState, curPPCState, diff --git a/macaw-ppc/src/Data/Macaw/PPC/PPCReg.hs b/macaw-ppc/src/Data/Macaw/PPC/PPCReg.hs index ba28be47..a5d750c3 100644 --- a/macaw-ppc/src/Data/Macaw/PPC/PPCReg.hs +++ b/macaw-ppc/src/Data/Macaw/PPC/PPCReg.hs @@ -13,6 +13,7 @@ module Data.Macaw.PPC.PPCReg ( PPCReg(..), linuxSystemCallPreservedRegisters, + linuxCalleeSaveRegisters, PPCWidth, ArchWidth(..) ) where @@ -77,6 +78,12 @@ linuxSystemCallPreservedRegisters :: (w ~ MC.RegAddrWidth (PPCReg ppc), 1 <= w) linuxSystemCallPreservedRegisters _ = S.fromList [ Some (PPC_GP (D.GPR rnum)) | rnum <- [14..31] ] +linuxCalleeSaveRegisters :: (w ~ MC.RegAddrWidth (PPCReg ppc), 1 <= w) + => proxy ppc + -> S.Set (Some (PPCReg ppc)) +linuxCalleeSaveRegisters _ = + S.fromList [ Some (PPC_GP (D.GPR rnum)) | rnum <- [14..31] ] + type instance MC.RegAddrWidth (PPCReg PPC32.PPC) = 32 type instance MC.RegAddrWidth (PPCReg PPC64.PPC) = 64 diff --git a/macaw-ppc/src/Data/Macaw/PPC/Semantics/PPC32.hs b/macaw-ppc/src/Data/Macaw/PPC/Semantics/PPC32.hs index 0b2e98cd..6319f29b 100644 --- a/macaw-ppc/src/Data/Macaw/PPC/Semantics/PPC32.hs +++ b/macaw-ppc/src/Data/Macaw/PPC/Semantics/PPC32.hs @@ -1,14 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} module Data.Macaw.PPC.Semantics.PPC32 ( execInstruction ) where import qualified Dismantle.PPC as D +import qualified Data.Parameterized.Map as MapF import qualified Data.Macaw.CFG as MC import qualified Data.Macaw.Types as MT import SemMC.Architecture.PPC32 ( PPC ) import Data.Macaw.PPC.Generator +import Data.Macaw.PPC.Semantics.TH ( genExecInstruction ) execInstruction :: MC.Value ppc s (MT.BVType 32) -> D.Instruction -> Maybe (PPCGenerator PPC s ()) -execInstruction = undefined +execInstruction = $(genExecInstruction MapF.empty)