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)