Add arch-specific decls + type instances + rewriters

This also lets us add 'withArchConstraints' easily.

macaw-ppc/macaw-ppc.cabal

@@ -17,6 +17,7 @@ cabal-version:       >=1.10
 
 library
   exposed-modules:     Data.Macaw.PPC
+                       Data.Macaw.PPC.Arch
                        Data.Macaw.PPC.Disassemble
                        Data.Macaw.PPC.Eval
                        Data.Macaw.PPC.Generator
@@ -35,6 +36,7 @@ library
                        semmc-ppc,
                        lens,
                        macaw-base,
+                       ansi-wl-pprint,
                        mtl,
                        parameterized-utils
   hs-source-dirs:      src

macaw-ppc/src/Data/Macaw/PPC.hs

@@ -16,9 +16,7 @@ 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.Macaw.Types as MT
 
-import qualified Dismantle.PPC as D
 import qualified SemMC.Architecture.PPC32 as PPC32
 import qualified SemMC.Architecture.PPC64 as PPC64
 
@@ -32,10 +30,7 @@ import Data.Macaw.PPC.Eval ( mkInitialAbsState,
 import Data.Macaw.PPC.Identify ( identifyCall,
                                  identifyReturn
                                )
-import Data.Macaw.PPC.Rewrite ( rewriteArchFn,
+import Data.Macaw.PPC.Arch ( rewriteTermStmt, rewriteStmt, rewritePrimFn )
-                                rewriteArchStmt,
-                                rewriteArchTermStmt
-                              )
 
 archDemandContext :: proxy ppc -> MDS.DemandContext ppc ids
 archDemandContext = undefined
@@ -47,7 +42,7 @@ jumpTableEntrySize = undefined
 
 ppc64_linux_info :: MI.ArchitectureInfo PPC64.PPC
 ppc64_linux_info =
-  MI.ArchitectureInfo { MI.withArchConstraints = undefined
+  MI.ArchitectureInfo { MI.withArchConstraints = \x -> x
                       , MI.archAddrWidth = MM.Addr64
                       , MI.archEndianness = MM.BigEndian
                       , MI.jumpTableEntrySize = jumpTableEntrySize proxy
@@ -59,9 +54,9 @@ ppc64_linux_info =
                       , MI.postCallAbsState = postCallAbsState proxy
                       , MI.identifyCall = identifyCall proxy
                       , MI.identifyReturn = identifyReturn proxy
-                      , MI.rewriteArchFn = rewriteArchFn proxy
+                      , MI.rewriteArchFn = rewritePrimFn
-                      , MI.rewriteArchStmt = rewriteArchStmt proxy
+                      , MI.rewriteArchStmt = rewriteStmt
-                      , MI.rewriteArchTermStmt = rewriteArchTermStmt proxy
+                      , MI.rewriteArchTermStmt = rewriteTermStmt
                       , MI.archDemandContext = archDemandContext proxy
                       }
   where
@@ -70,7 +65,7 @@ ppc64_linux_info =
 
 ppc32_linux_info :: MI.ArchitectureInfo PPC32.PPC
 ppc32_linux_info =
-  MI.ArchitectureInfo { MI.withArchConstraints = undefined
+  MI.ArchitectureInfo { MI.withArchConstraints = \x -> x
                       , MI.archAddrWidth = MM.Addr32
                       , MI.archEndianness = MM.BigEndian
                       , MI.jumpTableEntrySize = jumpTableEntrySize proxy
@@ -82,9 +77,9 @@ ppc32_linux_info =
                       , MI.postCallAbsState = postCallAbsState proxy
                       , MI.identifyCall = identifyCall proxy
                       , MI.identifyReturn = identifyReturn proxy
-                      , MI.rewriteArchFn = rewriteArchFn proxy
+                      , MI.rewriteArchFn = rewritePrimFn
-                      , MI.rewriteArchStmt = rewriteArchStmt proxy
+                      , MI.rewriteArchStmt = rewriteStmt
-                      , MI.rewriteArchTermStmt = rewriteArchTermStmt proxy
+                      , MI.rewriteArchTermStmt = rewriteTermStmt
                       , MI.archDemandContext = archDemandContext proxy
                       }
   where

macaw-ppc/src/Data/Macaw/PPC/Arch.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Macaw.PPC.Arch (
+  PPCTermStmt(..),
+  rewriteTermStmt,
+  PPCStmt(..),
+  rewriteStmt,
+  PPCPrimFn(..),
+  rewritePrimFn
+  ) where
+
+import qualified Text.PrettyPrint.ANSI.Leijen as PP
+import qualified Data.Parameterized.TraversableFC as FC
+import qualified Data.Macaw.CFG as MC
+import           Data.Macaw.CFG.Rewriter ( Rewriter, rewriteValue, evalRewrittenArchFn )
+import qualified Data.Macaw.Types as MT
+
+import qualified SemMC.Architecture.PPC32 as PPC32
+import qualified SemMC.Architecture.PPC64 as PPC64
+
+import Data.Macaw.PPC.PPCReg
+
+data PPCTermStmt ids where
+  PPCSyscall :: PPCTermStmt ids
+
+type instance MC.ArchTermStmt PPC64.PPC = PPCTermStmt
+type instance MC.ArchTermStmt PPC32.PPC = PPCTermStmt
+
+instance MC.PrettyF PPCTermStmt where
+  prettyF ts =
+    case ts of
+      PPCSyscall -> PP.text "ppc_syscall"
+
+rewriteTermStmt :: PPCTermStmt src -> Rewriter ppc src tgt (PPCTermStmt tgt)
+rewriteTermStmt s =
+  case s of
+    PPCSyscall -> pure PPCSyscall
+
+-- | We currently have no PPC-specific statements.  Remove 'None' if we add some.
+data PPCStmt ids where
+  None :: PPCStmt ids
+
+instance MC.PrettyF PPCStmt where
+  prettyF None = PP.text "None"
+
+type instance MC.ArchStmt PPC64.PPC = PPCStmt
+type instance MC.ArchStmt PPC32.PPC = PPCStmt
+
+rewriteStmt :: PPCStmt src -> Rewriter ppc src tgt ()
+rewriteStmt _ = return ()
+
+data PPCPrimFn ppc f tp where
+  IDiv :: proxy ppc
+       -> f (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc)))
+       -> f (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc)))
+       -> PPCPrimFn ppc f (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc)))
+
+instance MT.HasRepr (PPCPrimFn ppc (MC.Value ppc ids)) MT.TypeRepr where
+  typeRepr f =
+    case f of
+      IDiv {} -> undefined
+
+rewritePrimFn :: (PPCWidth ppc, MC.ArchFn ppc ~ PPCPrimFn ppc)
+              => PPCPrimFn ppc (MC.Value ppc src) tp
+              -> Rewriter ppc src tgt (MC.Value ppc tgt tp)
+rewritePrimFn f =
+  case f of
+    IDiv p lhs rhs -> do
+      tgtFn <- IDiv p <$> rewriteValue lhs <*> rewriteValue rhs
+      evalRewrittenArchFn tgtFn
+
+ppPrimFn :: (Applicative m) => (forall u . f u -> m PP.Doc) -> PPCPrimFn ppc f tp -> m PP.Doc
+ppPrimFn _pp f =
+  case f of
+    IDiv {} -> pure (PP.text "idiv")
+
+instance MC.IsArchFn (PPCPrimFn ppc) where
+  ppArchFn = ppPrimFn
+
+instance FC.FunctorFC (PPCPrimFn ppc) where
+  fmapFC = FC.fmapFCDefault
+
+instance FC.FoldableFC (PPCPrimFn ppc) where
+  foldMapFC = FC.foldMapFCDefault
+
+instance FC.TraversableFC (PPCPrimFn ppc) where
+  traverseFC go f =
+    case f of
+      IDiv p lhs rhs -> IDiv p <$> go lhs <*> go rhs
+
+type instance MC.ArchFn PPC64.PPC = PPCPrimFn PPC64.PPC
+type instance MC.ArchFn PPC32.PPC = PPCPrimFn PPC32.PPC