Generalize ArchStmt.

base/src/Data/Macaw/Architecture/Info.hs

@@ -84,7 +84,7 @@ data ArchitectureInfo arch
        -- ^ Evaluates an architecture-specific function
      , absEvalArchStmt :: !(forall ids
                             .  AbsProcessorState (ArchReg arch) ids
-                            -> ArchStmt arch ids
+                            -> ArchStmt arch (Value arch ids)
                             -> AbsProcessorState (ArchReg arch) ids)
        -- ^ Evaluates an architecture-specific statement
      , postCallAbsState :: AbsBlockState (ArchReg arch)
@@ -117,7 +117,9 @@ data ArchitectureInfo arch
                          .  ArchFn arch (Value arch src) tp
                          -> Rewriter arch s src tgt (Value arch tgt tp))
        -- ^ This rewrites an architecture specific statement
-     , rewriteArchStmt :: (forall s src tgt . ArchStmt arch src -> Rewriter arch s src tgt ())
+     , rewriteArchStmt :: (forall s src tgt
+                           .  ArchStmt arch (Value arch src)
+                           -> Rewriter arch s src tgt ())
        -- ^ This rewrites an architecture specific statement
      , rewriteArchTermStmt :: (forall s src tgt . ArchTermStmt arch src
                                              -> Rewriter arch s src tgt (ArchTermStmt arch tgt))

base/src/Data/Macaw/CFG/Core.hs

@@ -59,6 +59,8 @@ module Data.Macaw.CFG.Core
   , PrettyF(..)
   , ArchConstraints
   , PrettyRegValue(..)
+  , IsArchFn(..)
+  , IsArchStmt(..)
     -- * Architecture type families
   , ArchFn
   , ArchReg
@@ -70,11 +72,9 @@ module Data.Macaw.CFG.Core
   , RegisterInfo(..)
   , asStackAddrOffset
     -- * References
-  , StmtHasRefs(..)
   , refsInValue
   , refsInApp
   , refsInAssignRhs
-  , IsArchFn(..)
     -- ** Synonyms
   , ArchAddrWidth
   , ArchAddrValue
@@ -201,7 +201,7 @@ type family ArchFn (arch :: *) :: (Type -> *) -> Type -> *
 --
 -- The second type parameter is the ids phantom type used to provide
 -- uniqueness of Nonce values that identify assignments.
-type family ArchStmt (arch :: *) :: * -> *
+type family ArchStmt (arch :: *) :: (Type -> *) -> *
 
 -- | A type family for defining architecture-specific statements that
 -- may have instruction-specific effects on control-flow and register state.
@@ -572,9 +572,26 @@ instance RegisterInfo (ArchReg arch) => Pretty (Value arch ids tp) where
 instance RegisterInfo (ArchReg arch) => Show (Value arch ids tp) where
   show = show . pretty
 
+-- | Typeclass for architecture-specific functions
+class IsArchFn (f :: (Type -> *) -> Type -> *)  where
+  -- | A function for pretty printing an archFn of a given type.
+  ppArchFn :: Applicative m
+           => (forall u . v u -> m Doc)
+              -- ^ Function for pretty printing vlaue.
+           -> f v tp
+           -> m Doc
+
+-- | Typeclass for architecture-specific statements
+class IsArchStmt (f :: (Type -> *) -> *)  where
+  -- | A function for pretty printing an architecture statement of a given type.
+  ppArchStmt :: (forall u . v u -> Doc)
+                -- ^ Function for pretty printing value.
+             -> f v
+             -> Doc
+
 type ArchConstraints arch
    = ( RegisterInfo (ArchReg arch)
-     , PrettyF  (ArchStmt arch)
+     , IsArchStmt (ArchStmt arch)
      , PrettyF  (ArchTermStmt arch)
      , FoldableFC (ArchFn arch)
      , IsArchFn (ArchFn arch)
@@ -701,7 +718,7 @@ data Stmt arch ids
      -- disassembler output if available (or empty string if unavailable)
    | Comment !Text
      -- ^ A user-level comment
-   | ExecArchStmt !(ArchStmt arch ids)
+   | ExecArchStmt !(ArchStmt arch (Value arch ids))
      -- ^ Execute an architecture specific statement
 
 ppStmt :: ArchConstraints arch
@@ -718,8 +735,7 @@ ppStmt ppOff stmt =
       <+> parens (hcat $ punctuate comma $ viewSome (ppValue 0) <$> vals)
     InstructionStart off mnem -> text "#" <+> ppOff off <+> text (Text.unpack mnem)
     Comment s -> text $ "# " ++ Text.unpack s
-    ExecArchStmt s -> prettyF s
+    ExecArchStmt s -> ppArchStmt (ppValue 10) s
-
 
 instance ArchConstraints arch => Show (Stmt arch ids) where
   show = show . ppStmt (\w -> text (show w))
@@ -727,19 +743,6 @@ instance ArchConstraints arch => Show (Stmt arch ids) where
 ------------------------------------------------------------------------
 -- References
 
--- | Return refernces in a stmt type.
-class StmtHasRefs f where
-  refsInStmt :: f ids -> Set (Some (AssignId ids))
-
--- | Typeclass for folding over architecture-specific values.
-class IsArchFn (f :: (k -> *) -> k -> *)  where
-  -- | A function for pretty printing an archFn of a given type.
-  ppArchFn :: Applicative m
-           => (forall u . v u -> m Doc)
-              -- ^ Function for pretty printing vlaue.
-           -> f v tp
-           -> m Doc
-
 refsInValue :: Value arch ids tp -> Set (Some (AssignId ids))
 refsInValue (AssignedValue (Assignment v _)) = Set.singleton (Some v)
 refsInValue _                                = Set.empty

base/src/Data/Macaw/CFG/DemandSet.hs

@@ -27,7 +27,7 @@ type AssignIdSet ids = Set (Some (AssignId ids))
 -- | This provides the architecture specific functions needed to
 -- resolve demand sets.
 data DemandContext arch ids
-   = DemandContext { addArchStmtDemands :: !(ArchStmt arch ids  -> DemandComp arch ids ())
+   = DemandContext { addArchStmtDemands :: !(ArchStmt arch (Value arch ids)  -> DemandComp arch ids ())
                    , addArchFnDemands   :: !(forall tp . ArchFn arch (Value arch ids) tp -> DemandComp arch ids ())
                    , archFnHasSideEffects :: !(forall v tp . ArchFn arch v tp -> Bool)
                      -- ^ This returns true if the architecture function has implicit

base/src/Data/Macaw/CFG/Rewriter.hs

@@ -45,7 +45,7 @@ data RewriteContext arch s src tgt
                                             .  ArchFn arch (Value arch src) tp
                                             -> Rewriter arch s src tgt (Value arch tgt tp))
                       -- ^ Rewriter for architecture-specific statements
-                    , rwctxArchStmt  :: !(ArchStmt arch src -> Rewriter arch s src tgt ())
+                    , rwctxArchStmt  :: !(ArchStmt arch (Value arch src) -> Rewriter arch s src tgt ())
                       -- ^ Rewriter for architecture-specific statements
                     , rwctxConstraints :: (forall a . (RegisterInfo (ArchReg arch) => a) -> a)
                       -- ^ Constraints needed during rewriting.
@@ -66,7 +66,8 @@ mkRewriteContext :: RegisterInfo (ArchReg arch)
                  -> (forall tp
                      .  ArchFn arch (Value arch src) tp
                      -> Rewriter arch s src tgt (Value arch tgt tp))
-                 -> (ArchStmt arch src -> Rewriter arch s src tgt ())
+                 -> (ArchStmt arch (Value arch src)
+                     -> Rewriter arch s src tgt ())
                  -> ST s (RewriteContext arch s src tgt)
 mkRewriteContext nonceGen archFn archStmt = do
   ref <- newSTRef MapF.empty
@@ -113,7 +114,7 @@ appendRewrittenStmt stmt = Rewriter $ do
   rwRevStmts .= stmts'
 
 -- | Add a statment to the list
-appendRewrittenArchStmt :: ArchStmt arch tgt -> Rewriter arch s src tgt ()
+appendRewrittenArchStmt :: ArchStmt arch (Value arch tgt) -> Rewriter arch s src tgt ()
 appendRewrittenArchStmt = appendRewrittenStmt . ExecArchStmt
 
 -- | Add an assignment statement that evaluates the right hand side and return the resulting value.

x86/src/Data/Macaw/X86.hs

@@ -925,7 +925,7 @@ getLoc (l0 :: ImpLocation ids tp) =
       ValueExpr <$> getReg (X87_FPUReg (F.mmxReg (fromIntegral idx)))
 
 addArchStmt :: X86Stmt (Value X86_64 ids) -> X86Generator st_s ids ()
-addArchStmt s = addStmt $ ExecArchStmt (X86Stmt s)
+addArchStmt = addStmt . ExecArchStmt
 
 addWriteLoc :: X86PrimLoc tp -> Value X86_64 ids tp -> X86Generator st_s ids ()
 addWriteLoc l v = addArchStmt $ WriteLoc l v
@@ -1483,7 +1483,7 @@ addValueListDemands = mapM_ (viewSome addValueDemands)
 
 x86DemandContext :: DemandContext X86_64 ids
 x86DemandContext =
-  DemandContext { addArchStmtDemands = addValueListDemands . valuesInX86Stmt
+  DemandContext { addArchStmtDemands = addValueListDemands . foldMapF  (\v -> [Some v])
                 , addArchFnDemands   = addValueListDemands . foldMapFC (\v -> [Some v])
                 , archFnHasSideEffects = x86PrimFnHasSideEffects
                 }

x86/src/Data/Macaw/X86/ArchTypes.hs

@@ -17,10 +17,7 @@ module Data.Macaw.X86.ArchTypes
   , X86PrimFn(..)
   , rewriteX86PrimFn
   , x86PrimFnHasSideEffects
-  , X86ArchStmt(..)
   , X86Stmt(..)
-  , ppX86Stmt
-  , valuesInX86Stmt
   , rewriteX86Stmt
   , X86TermStmt(..)
   , rewriteX86TermStmt
@@ -28,13 +25,10 @@ module Data.Macaw.X86.ArchTypes
   ) where
 
 import           Data.Bits
-import           Data.Foldable
 import           Data.Parameterized.NatRepr
 import           Data.Parameterized.Some
 import           Data.Parameterized.TraversableF
 import           Data.Parameterized.TraversableFC
-import           Data.Set (Set)
-import qualified Data.Set as Set
 import qualified Flexdis86 as F
 import           Text.PrettyPrint.ANSI.Leijen as PP hiding ((<$>))
 
@@ -46,10 +40,6 @@ import           Data.Macaw.X86.Monad (SIMDWidth(..), RepValSize(..), repValSize
 import           Data.Macaw.X86.X86Reg
 import           Data.Macaw.X86.X87ControlReg
 
-assignIdSetFromValues :: [Some (Value arch ids)] -> Set (Some (AssignId ids))
-assignIdSetFromValues = foldl' f Set.empty
-  where f s (Some v) = Set.union s (refsInValue v)
-
 ------------------------------------------------------------------------
 -- X86TermStmt
 
@@ -322,28 +312,26 @@ instance TraversableF X86Stmt where
       MemCopy bc v src dest dir -> MemCopy bc <$> go v <*> go src <*> go dest <*> go dir
       MemSet  v src dest dir    -> MemSet <$> go v <*> go src <*> go dest <*> go dir
 
-ppX86Stmt :: (forall tp . f tp -> Doc) -> X86Stmt f -> Doc
+instance IsArchStmt X86Stmt where
-ppX86Stmt pp stmt =
+  ppArchStmt pp stmt =
-  case stmt of
+    case stmt of
-    WriteLoc loc rhs -> pretty loc <+> text ":=" <+> pp rhs
+      WriteLoc loc rhs -> pretty loc <+> text ":=" <+> pp rhs
-    StoreX87Control addr -> pp addr <+> text ":= x87_control"
+      StoreX87Control addr -> pp addr <+> text ":= x87_control"
-    MemCopy sz cnt src dest rev ->
+      MemCopy sz cnt src dest rev ->
-        text "memcopy" <+> parens (hcat $ punctuate comma args)
+          text "memcopy" <+> parens (hcat $ punctuate comma args)
-      where args = [pretty sz, pp cnt, pp src, pp dest, pp rev]
+        where args = [pretty sz, pp cnt, pp src, pp dest, pp rev]
-    MemSet cnt val dest d ->
+      MemSet cnt val dest d ->
-        text "memset" <+> parens (hcat $ punctuate comma args)
+          text "memset" <+> parens (hcat $ punctuate comma args)
-      where args = [pp cnt, pp val, pp dest, pp d]
+        where args = [pp cnt, pp val, pp dest, pp d]
 
 ------------------------------------------------------------------------
 -- X86_64
 
-newtype X86ArchStmt ids = X86Stmt (X86Stmt (Value X86_64 ids))
-
 data X86_64
 
 type instance ArchReg  X86_64 = X86Reg
 type instance ArchFn   X86_64 = X86PrimFn
-type instance ArchStmt X86_64 = X86ArchStmt
+type instance ArchStmt X86_64 = X86Stmt
 type instance ArchTermStmt X86_64 = X86TermStmt
 
 rewriteX86PrimFn :: X86PrimFn (Value X86_64 src) tp
@@ -363,21 +351,10 @@ rewriteX86PrimFn f =
     _ -> do
       evalRewrittenArchFn =<< traverseFC rewriteValue f
 
-instance PrettyF X86ArchStmt where
+rewriteX86Stmt :: X86Stmt (Value X86_64 src) -> Rewriter X86_64 s src tgt ()
-  prettyF (X86Stmt s) = ppX86Stmt pretty s
+rewriteX86Stmt f = do
-
-valuesInX86Stmt :: X86ArchStmt ids -> [Some (Value X86_64 ids)]
-valuesInX86Stmt (X86Stmt s) = foldMapF (\v -> [Some v]) s
-
-instance StmtHasRefs X86ArchStmt where
-  refsInStmt = assignIdSetFromValues . valuesInX86Stmt
-
-
-
-rewriteX86Stmt :: X86ArchStmt src -> Rewriter X86_64 s src tgt ()
-rewriteX86Stmt (X86Stmt f) = do
   s <- traverseF rewriteValue f
-  appendRewrittenArchStmt (X86Stmt s)
+  appendRewrittenArchStmt s
 
 rewriteX86TermStmt :: X86TermStmt src -> Rewriter X86_64 s src tgt (X86TermStmt tgt)
 rewriteX86TermStmt f =