ppc: Change how we translate instructions represented by arch-specific statements

The old method involved providing the TH code a list of match expressions. This made it very difficult to inspect arguments of instructions. The new approach has the architecture backend provide a function that gets the first opportunity to process instructions, which is much more flexible. This commit also includes support for a number of cache hint instructions that use the new features.
2024-11-23 16:35:02 +03:00 · 2017-11-28 21:36:49 -08:00 · 2017-11-28 21:36:49 -08:00 · b033f3788c
commit b033f3788c
parent cea6bf38c8
5 changed files with 116 additions and 33 deletions
--- a/macaw-ppc/src/Data/Macaw/PPC/Arch.hs
+++ b/macaw-ppc/src/Data/Macaw/PPC/Arch.hs
@ -7,7 +7,8 @@
 {-# LANGUAGE KindSignatures        #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 module Data.Macaw.PPC.Arch (
@ -19,12 +20,11 @@ module Data.Macaw.PPC.Arch (
  rewritePrimFn,
  ppcPrimFnHasSideEffects,
  PPCArchConstraints,
-  specialSemanticsCases
+  ppcInstructionMatcher
  ) where

 import           GHC.TypeLits

-import           Language.Haskell.TH
 import qualified Text.PrettyPrint.ANSI.Leijen as PP
 import qualified Data.Parameterized.NatRepr as NR
 import qualified Data.Parameterized.TraversableFC as FC
@ -38,8 +38,10 @@ 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
+import qualified SemMC.Architecture.PPC.Eval as E

 import qualified Data.Macaw.SemMC.Generator as G
+import qualified Data.Macaw.PPC.Operand as O
 import           Data.Macaw.PPC.PPCReg

 data PPCTermStmt ids where
@ -72,13 +74,15 @@ data PPCStmt ppc (v :: MT.Type -> *) where
  Attn :: PPCStmt ppc v
  Sync :: PPCStmt ppc v
  Isync :: PPCStmt ppc v
-
-instance MC.PrettyF (PPCStmt ppc) where
-  prettyF s =
-    case s of
-      Attn -> PP.text "ppc_attn"
-      Sync -> PP.text "ppc_sync"
-      Isync -> PP.text "ppc_isync"
+  -- These are cache hints
+  Dcba :: v (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc))) -> PPCStmt ppc v
+  Dcbf :: v (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc))) -> PPCStmt ppc v
+  Dcbi :: v (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc))) -> PPCStmt ppc v
+  Dcbst :: v (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc))) -> PPCStmt ppc v
+  Dcbz :: v (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc))) -> PPCStmt ppc v
+  Dcbzl :: v (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc))) -> PPCStmt ppc v
+  Dcbt :: v (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc))) -> v (MT.BVType 5) -> PPCStmt ppc v
+  Dcbtst :: v (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc))) -> v (MT.BVType 5) -> PPCStmt ppc v

 instance TF.FunctorF (PPCStmt ppc) where
  fmapF = TF.fmapFDefault
@ -87,18 +91,34 @@ instance TF.FoldableF (PPCStmt ppc) where
  foldMapF = TF.foldMapFDefault

 instance TF.TraversableF (PPCStmt ppc) where
-  traverseF _go stmt =
+  traverseF go stmt =
    case stmt of
      Attn -> pure Attn
      Sync -> pure Sync
      Isync -> pure Isync
+      Dcba ea -> Dcba <$> go ea
+      Dcbf ea -> Dcbf <$> go ea
+      Dcbi ea -> Dcbi <$> go ea
+      Dcbst ea -> Dcbst <$> go ea
+      Dcbz ea -> Dcbz <$> go ea
+      Dcbzl ea -> Dcbzl <$> go ea
+      Dcbt ea th -> Dcbt <$> go ea <*> go th
+      Dcbtst ea th -> Dcbtst <$> go ea <*> go th

 instance MC.IsArchStmt (PPCStmt ppc) where
-  ppArchStmt _pp stmt =
+  ppArchStmt pp stmt =
    case stmt of
      Attn -> PP.text "ppc_attn"
      Sync -> PP.text "ppc_sync"
      Isync -> PP.text "ppc_isync"
+      Dcba ea -> PP.text "ppc_dcba" PP.<+> pp ea
+      Dcbf ea -> PP.text "ppc_dcbf" PP.<+> pp ea
+      Dcbi ea -> PP.text "ppc_dcbi" PP.<+> pp ea
+      Dcbst ea -> PP.text "ppc_dcbst" PP.<+> pp ea
+      Dcbz ea -> PP.text "ppc_dcbz" PP.<+> pp ea
+      Dcbzl ea -> PP.text "ppc_dcbzl" PP.<+> pp ea
+      Dcbt ea th -> PP.text "ppc_dcbt" PP.<+> pp ea PP.<+> pp th
+      Dcbtst ea th -> PP.text "ppc_dcbtst" PP.<+> pp ea PP.<+> pp th

 type instance MC.ArchStmt PPC64.PPC = PPCStmt PPC64.PPC
 type instance MC.ArchStmt PPC32.PPC = PPCStmt PPC32.PPC
@ -177,19 +197,77 @@ type PPCArchConstraints ppc = ( MC.ArchReg ppc ~ PPCReg ppc
                              , 1 <= MC.RegAddrWidth (PPCReg ppc)
                              , KnownNat (MC.RegAddrWidth (PPCReg ppc))
                              , MC.ArchConstraints ppc
+                              , O.ExtractValue ppc D.GPR (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc)))
+                              , O.ExtractValue ppc (Maybe D.GPR) (MT.BVType (MC.RegAddrWidth (MC.ArchReg ppc)))
                              )

+memrrToEffectiveAddress :: forall ppc ids s n
+                         . (n ~ MC.RegAddrWidth (MC.ArchReg ppc), PPCArchConstraints ppc)
+                        => D.MemRR
+                        -> G.Generator ppc ids s (MC.Value ppc ids (MT.BVType n))
+memrrToEffectiveAddress memrr = do
+  offset <- O.extractValue (E.interpMemrrOffsetExtractor memrr)
+  base <- O.extractValue (E.interpMemrrBaseExtractor memrr)
+  isr0 <- O.extractValue (E.interpIsR0 (E.interpMemrrBaseExtractor memrr))
+  let repr = MT.knownNat @n
+  let zero = MC.BVValue repr 0
+  b <- G.addExpr (G.AppExpr (MC.Mux (MT.BVTypeRepr repr) isr0 zero base))
+  G.addExpr (G.AppExpr (MC.BVAdd repr b offset))
+
 -- | Manually-provided semantics for instructions whose full semantics cannot be
 -- expressed in our semantics format.
 --
 -- This includes instructions with special side effects that we don't have a way
 -- to talk about in the semantics; especially useful for architecture-specific
 -- terminator statements.
-specialSemanticsCases :: [MatchQ]
-specialSemanticsCases =
-  [ match (conP 'D.SC []) (normalB [| Just (G.finishWithTerminator (MC.ArchTermStmt PPCSyscall)) |]) []
-  , match (conP 'D.TRAP []) (normalB [| Just (G.finishWithTerminator (MC.ArchTermStmt PPCTrap)) |]) []
-  , match (conP 'D.ATTN []) (normalB [| Just (G.addStmt (MC.ExecArchStmt Attn)) |]) []
-  , match (conP 'D.SYNC []) (normalB [| Just (G.addStmt (MC.ExecArchStmt Sync)) |]) []
-  , match (conP 'D.ISYNC []) (normalB [| Just (G.addStmt (MC.ExecArchStmt Isync)) |]) []
-  ]
+ppcInstructionMatcher :: (PPCArchConstraints ppc) => D.Instruction -> Maybe (G.Generator ppc ids s ())
+ppcInstructionMatcher (D.Instruction opc operands) =
+  case opc of
+    D.SC -> Just (G.finishWithTerminator (MC.ArchTermStmt PPCSyscall))
+    D.TRAP -> Just (G.finishWithTerminator (MC.ArchTermStmt PPCTrap))
+    D.ATTN -> Just (G.addStmt (MC.ExecArchStmt Attn))
+    D.SYNC -> Just (G.addStmt (MC.ExecArchStmt Sync))
+    D.ISYNC -> Just (G.addStmt (MC.ExecArchStmt Isync))
+    D.DCBA ->
+      case operands of
+        D.Memrr memrr D.:> D.Nil -> Just $ do
+          ea <- memrrToEffectiveAddress memrr
+          G.addStmt (MC.ExecArchStmt (Dcba ea))
+    D.DCBF ->
+      case operands of
+        D.Memrr memrr D.:> D.Nil -> Just $ do
+          ea <- memrrToEffectiveAddress memrr
+          G.addStmt (MC.ExecArchStmt (Dcbf ea))
+    D.DCBI ->
+      case operands of
+        D.Memrr memrr D.:> D.Nil -> Just $ do
+          ea <- memrrToEffectiveAddress memrr
+          G.addStmt (MC.ExecArchStmt (Dcbi ea))
+    D.DCBST ->
+      case operands of
+        D.Memrr memrr D.:> D.Nil -> Just $ do
+          ea <- memrrToEffectiveAddress memrr
+          G.addStmt (MC.ExecArchStmt (Dcbst ea))
+    D.DCBZ ->
+      case operands of
+        D.Memrr memrr D.:> D.Nil -> Just $ do
+          ea <- memrrToEffectiveAddress memrr
+          G.addStmt (MC.ExecArchStmt (Dcbz ea))
+    D.DCBZL ->
+      case operands of
+        D.Memrr memrr D.:> D.Nil -> Just $ do
+          ea <- memrrToEffectiveAddress memrr
+          G.addStmt (MC.ExecArchStmt (Dcbzl ea))
+    D.DCBT ->
+      case operands of
+        D.Memrr memrr D.:> D.U5imm imm D.:> D.Nil -> Just $ do
+          ea <- memrrToEffectiveAddress memrr
+          th <- O.extractValue imm
+          G.addStmt (MC.ExecArchStmt (Dcbt ea th))
+    D.DCBTST ->
+      case operands of
+        D.Memrr memrr D.:> D.U5imm imm D.:> D.Nil -> Just $ do
+          ea <- memrrToEffectiveAddress memrr
+          th <- O.extractValue imm
+          G.addStmt (MC.ExecArchStmt (Dcbtst ea th))
+    _ -> Nothing
--- a/macaw-ppc/src/Data/Macaw/PPC/Semantics/PPC32.hs
+++ b/macaw-ppc/src/Data/Macaw/PPC/Semantics/PPC32.hs
@ -16,9 +16,9 @@ import           SemMC.Architecture.PPC32 ( PPC )
 import           SemMC.Architecture.PPC32.Opcodes ( allSemantics, allOpcodeInfo )

 import           Data.Macaw.SemMC.Generator ( Generator )
-import           Data.Macaw.PPC.Arch ( specialSemanticsCases )
+import           Data.Macaw.PPC.Arch ( ppcInstructionMatcher )
 import           Data.Macaw.PPC.PPCReg ( locToRegTH )
 import           Data.Macaw.PPC.Semantics.TH ( genExecInstruction )

 execInstruction :: MC.Value PPC ids (MT.BVType 32) -> Instruction -> Maybe (Generator PPC ids s ())
-execInstruction = $(genExecInstruction (Proxy @PPC) (locToRegTH (Proxy @PPC)) specialSemanticsCases (C.Sub C.Dict) allSemantics allOpcodeInfo)
+execInstruction = $(genExecInstruction (Proxy @PPC) (locToRegTH (Proxy @PPC)) 'ppcInstructionMatcher (C.Sub C.Dict) allSemantics allOpcodeInfo)
--- a/macaw-ppc/src/Data/Macaw/PPC/Semantics/PPC64.hs
+++ b/macaw-ppc/src/Data/Macaw/PPC/Semantics/PPC64.hs
@ -16,9 +16,9 @@ import           SemMC.Architecture.PPC64 ( PPC )
 import           SemMC.Architecture.PPC64.Opcodes ( allSemantics, allOpcodeInfo )

 import           Data.Macaw.SemMC.Generator ( Generator )
-import           Data.Macaw.PPC.Arch ( specialSemanticsCases )
+import           Data.Macaw.PPC.Arch ( ppcInstructionMatcher )
 import           Data.Macaw.PPC.PPCReg ( locToRegTH )
 import           Data.Macaw.PPC.Semantics.TH

 execInstruction :: MC.Value PPC ids (MT.BVType 64) -> Instruction -> Maybe (Generator PPC ids s ())
-execInstruction = $(genExecInstruction (Proxy @PPC) (locToRegTH (Proxy @PPC)) specialSemanticsCases (C.Sub C.Dict) allSemantics allOpcodeInfo)
+execInstruction = $(genExecInstruction (Proxy @PPC) (locToRegTH (Proxy @PPC)) 'ppcInstructionMatcher (C.Sub C.Dict) allSemantics allOpcodeInfo)
--- a/macaw-ppc/src/Data/Macaw/PPC/Semantics/TH.hs
+++ b/macaw-ppc/src/Data/Macaw/PPC/Semantics/TH.hs
@ -89,20 +89,25 @@ instructionMatcher :: (OrdF a, LF.LiftF a,
                       1 <= APPC.ArchRegWidth arch,
                       M.RegAddrWidth (PPCReg arch) ~ APPC.ArchRegWidth arch)
                   => (forall tp . L.Location arch tp -> Q Exp)
-                   -> [MatchQ]
+                   -> Name
+                   -- ^ The name of the architecture-specific instruction
+                   -- matcher to run before falling back to the generic one
                   -> Map.MapF (Witness c a) (PairF (ParameterizedFormula (Sym t) arch) (DT.CaptureInfo c a))
                   -> Q Exp
-instructionMatcher ltr specialCases formulas = do
+instructionMatcher ltr archSpecificMatcher formulas = do
  ipVarName <- newName "ipVal"
  opcodeVar <- newName "opcode"
  operandListVar <- newName "operands"
  let normalCases = map (mkSemanticsCase ltr ipVarName operandListVar) (Map.toList formulas)
  let fallthroughCase = match wildP (normalB [| error ("Unimplemented instruction: " ++ show $(varE opcodeVar)) |]) []
  let allCases = concat [ normalCases
-                        , specialCases
                        , [fallthroughCase]
                        ]
-  lamE [varP ipVarName, conP 'D.Instruction [varP opcodeVar, varP operandListVar]] (caseE (varE opcodeVar) allCases)
+  [| \ $(varP ipVarName) i@(D.Instruction $(varP opcodeVar) $(varP operandListVar)) ->
+        case $(varE archSpecificMatcher) i of
+          Just action -> Just action
+          Nothing -> $(caseE (varE opcodeVar) allCases)
+   |]

 -- | Generate a single case for one opcode of the case expression.
 --
@ -243,8 +248,8 @@ genExecInstruction :: (A.Architecture arch,
                       M.RegAddrWidth (PPCReg arch) ~ APPC.ArchRegWidth arch)
                   => proxy arch
                   -> (forall tp . L.Location arch tp -> Q Exp)
-                   -> [MatchQ]
-                   -- ^ Special cases to splice into the expression
+                   -> Name
+                   -- ^ The arch-specific instruction matcher
                   -> (forall sh . c sh C.:- BuildOperandList arch sh)
                   -- ^ A constraint implication to let us extract/weaken the
                   -- constraint in our 'Witness' to the required 'BuildOperandList'
@ -257,12 +262,12 @@ genExecInstruction :: (A.Architecture arch,
                   -- some TH to match them.  This comes from the semantics
                   -- definitions in semmc.
                   -> Q Exp
-genExecInstruction _ ltr specialCases impl semantics captureInfo = do
+genExecInstruction _ ltr archInsnMatcher impl semantics captureInfo = do
  Some ng <- runIO PN.newIONonceGenerator
  sym <- runIO (S.newSimpleBackend ng)
  formulas <- runIO (loadFormulas sym impl semantics)
  let formulasWithInfo = foldr (attachInfo formulas) Map.empty captureInfo
-  instructionMatcher ltr specialCases formulasWithInfo
+  instructionMatcher ltr archInsnMatcher formulasWithInfo
  where
    attachInfo m0 (Some ci) m =
      let co = DT.capturedOpcode ci
--- a/submodules/semmc
+++ b/submodules/semmc
@ -1 +1 @@
-Subproject commit 1a42fba97dea7e19fd2fff69a2def0fd423b2f72
+Subproject commit fc4cc3a0ba50ce6a2c5a6a14a3c8bbec60c3a971