Cleanups to remove redundent class constraints; simplify interface invariants.

src/Data/Macaw/Architecture/Info.hs

@@ -40,8 +40,9 @@ type ReadAddrFn w
 -- A block is defined as a contiguous region of code with a single known
 -- entrance and potentially multiple exits.
 --
--- This returns the list of blocks, one past the end of the last instruction successfully
--- disassembled, and any potential error that prematurely terminated translating the block.
+-- This returns the list of blocks, the number of bytes in the blocks,
+-- and any potential error that prematurely terminated translating the
+-- block.
 type DisassembleFn arch
    = forall ids
    .  NonceGenerator (ST ids) ids
@@ -57,7 +58,7 @@ type DisassembleFn arch
       -- from.
       --
       -- This is used for things like the height of the x87 stack.
-   -> ST ids ([Block arch ids], SegmentedAddr (ArchAddrWidth arch), Maybe String)
+   -> ST ids ([Block arch ids], MemWord (ArchAddrWidth arch), Maybe String)
 
 -- | This records architecture specific functions for analysis.
 data ArchitectureInfo arch

src/Data/Macaw/CFG.hs

@@ -580,6 +580,7 @@ instance ShowF (ArchReg arch) => Show (Value arch ids tp) where
 class ( RegisterInfo (ArchReg arch)
       , PrettyF  (ArchStmt arch)
       )  => ArchConstraints arch where
+
   -- | A function for pretty printing an archFn of a given type.
   ppArchFn :: Applicative m
            => (forall u . Value arch ids u -> m Doc)

src/Data/Macaw/Discovery.hs

@@ -21,14 +21,13 @@ This provides information about code discovered in binaries.
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Data.Macaw.Discovery
-       ( -- * Top level
-         cfgFromAddrs
-         -- * DiscoveryInfo
-       , State.DiscoveryState
+       ( -- * DiscoveryInfo
+         State.DiscoveryState
        , State.memory
        , State.exploredFunctions
        , State.symbolNames
        , State.ppDiscoveryStateBlocks
+       , cfgFromAddrs
        , markAddrsAsFunction
        , analyzeFunction
        , exploreMemPointers
@@ -784,7 +783,7 @@ transfer addr = do
       prev_block_map <- use $ curFunInfo . parsedBlocks
       let not_at_block = (`Map.notMember` prev_block_map)
       let ab = foundAbstractState finfo
-      (bs, next_ip, maybeError) <- liftST $ disassembleFn info nonce_gen mem not_at_block addr ab
+      (bs, sz, maybeError) <- liftST $ disassembleFn info nonce_gen mem not_at_block addr ab
       -- Build state for exploring this.
       case maybeError of
         Just e -> do
@@ -793,11 +792,7 @@ transfer addr = do
           pure ()
 
       withArchConstraints info $ do
-
-      assert (segmentIndex (addrSegment next_ip) == segmentIndex (addrSegment addr)) $ do
-      assert (next_ip^.addrOffset > addr^.addrOffset) $ do
       let block_map = Map.fromList [ (labelIndex (blockLabel b), b) | b <- bs ]
-      let sz = next_ip^.addrOffset - addr^.addrOffset
       transferBlocks sz block_map $ initAbsProcessorState mem (foundAbstractState finfo)
 
 ------------------------------------------------------------------------

src/Data/Macaw/Discovery/State.hs

@@ -64,7 +64,6 @@ import           Data.Maybe (fromMaybe, mapMaybe)
 import           Data.Parameterized.Classes
 import           Data.Parameterized.Some
 import           Data.Set (Set)
-import qualified Data.Set as Set
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Vector as V
@@ -138,13 +137,27 @@ checkSymbolName sym_nm =
 -- symbol names.
 --
 -- It returns either an error message or the map.
-symbolAddrMap :: Map (SegmentedAddr w) BSC.ByteString
+symbolAddrMap :: forall w
+              .  Map (SegmentedAddr w) BSC.ByteString
               -> Either String (SymbolAddrMap w)
+{-
 symbolAddrMap symbols
-  | Set.size symbol_names /= Map.size symbols =
-      Left "internal: duplicate symbol names in symbol name map"
-  where symbol_names :: Set BSC.ByteString
-        symbol_names = Set.fromList (Map.elems symbols)
+  | Map.size symbol_names /= Map.size symbols = do
+      let l = filter isMulti (Map.toList symbol_names)
+       in Left $ "Duplicate symbol names in symbol name map:\n" ++ show l
+  where symbol_names :: Map BSC.ByteString [SegmentedAddr w]
+        symbol_names = foldl insPair Map.empty (Map.toList symbols)
+
+        isMulti :: (BSC.ByteString, [SegmentedAddr w])
+                -> Bool
+        isMulti (_,[_]) = False
+        isMulti (_,_)   = True
+
+        insPair :: Map BSC.ByteString [SegmentedAddr w]
+                -> (SegmentedAddr w, BSC.ByteString)
+                -> Map BSC.ByteString [SegmentedAddr w]
+        insPair m (a,nm) = Map.insertWith (++) nm [a] m
+-}
 symbolAddrMap symbols = do
    mapM_ checkSymbolName (Map.elems symbols)
    pure $! SymbolAddrMap symbols
@@ -378,11 +391,12 @@ ppDiscoveryStateBlocks info = withDiscoveryArchConstraints info $
 
 -- | Create empty discovery information.
 emptyDiscoveryState :: Memory (ArchAddrWidth arch)
-                   -> SymbolAddrMap (ArchAddrWidth arch)
-                      -- ^ Map from addresses
-                   -> ArchitectureInfo arch
-                      -- ^ architecture/OS specific information
-                   -> DiscoveryState arch
+                       -- ^ State of memory
+                    -> SymbolAddrMap (ArchAddrWidth arch)
+                       -- ^ Map from addresses
+                    -> ArchitectureInfo arch
+                       -- ^ architecture/OS specific information
+                    -> DiscoveryState arch
 emptyDiscoveryState mem symbols info =
   DiscoveryState
   { memory             = mem
@@ -393,7 +407,6 @@ emptyDiscoveryState mem symbols info =
   , _unexploredFunctions = []
   }
 
-
 -- | Map each jump table start to the address just after the end.
 globalDataMap :: Simple Lens (DiscoveryState arch)
                              (Map (ArchSegmentedAddr arch)

src/Data/Macaw/Memory.hs

@@ -176,10 +176,11 @@ class MemWidth w where
   -- | Read an address with the given endianess.
   addrRead :: Endianness -> BS.ByteString -> Maybe (MemWord w)
 
--- | Returns add
+-- | Returns number of bits in address.
 addrBitSize :: MemWidth w => p w -> Int
 addrBitSize w = 8 * addrSize w
 
+-- | Convert word64 @x@ into mem word @x mod 2^w-1@.
 memWord :: forall w . MemWidth w => Word64 -> MemWord w
 memWord x = MemWord (x .&. addrWidthMod p)
   where p :: Proxy w
@@ -479,11 +480,10 @@ lookupSegment m i = Map.lookup i (memAllSegments m)
 -- | Return list of segmented address values in memory.
 --
 -- Each address includes the value and the base.
-memAsAddrPairs :: MemWidth w
-               => Memory w
+memAsAddrPairs :: Memory w
                -> Endianness
                -> [(SegmentedAddr w, SegmentedAddr w)]
-memAsAddrPairs mem end = do
+memAsAddrPairs mem end = addrWidthClass (memAddrWidth mem) $ do
   seg <- memSegments mem
   (contents_offset,r) <- contentsList (segmentContents seg)
   let addr = SegmentedAddr seg contents_offset
@@ -511,8 +511,8 @@ readonlySegments :: Memory w -> [MemSegment w]
 readonlySegments = filter (Perm.isReadonly . segmentFlags) . memSegments
 
 -- | Given an absolute address, this returns a segment and offset into the segment.
-absoluteAddrSegment :: MemWidth w => Memory w -> MemWord w -> Maybe (SegmentedAddr w)
-absoluteAddrSegment mem addr =
+absoluteAddrSegment :: Memory w -> MemWord w -> Maybe (SegmentedAddr w)
+absoluteAddrSegment mem addr = addrWidthClass (memAddrWidth mem) $
   case Map.lookupLE addr (memAbsoluteSegments mem) of
     Just (base, seg) | addr < base + segmentSize seg ->
       Just $! SegmentedAddr { addrSegment = seg
@@ -521,12 +521,11 @@ absoluteAddrSegment mem addr =
     _ -> Nothing
 
 -- | Read an address from the value in the segment or report a memory error.
-readAddr :: MemWidth w
-         => Memory w
+readAddr :: Memory w
          -> Endianness
          -> SegmentedAddr w
          -> Either (MemoryError w) (SegmentedAddr w)
-readAddr mem end addr = do
+readAddr mem end addr = addrWidthClass (memAddrWidth mem) $ do
   let sz = fromIntegral (addrSize addr)
   case lookupRange (addr^.addrOffset) (segmentContents (addrSegment addr)) of
     Just (MemWord offset, ByteRegion bs)
@@ -565,7 +564,6 @@ showInsertError (OverlapSegment _base _seg) =
 showInsertError (IndexAlreadyUsed seg) =
   "has the same index as another segment (" ++ show (segmentIndex seg) ++ ")."
 
-
 insertAbsoluteSegmentMap :: MemWidth w
                          => MemSegment w
                          -> AbsoluteSegmentMap w
@@ -592,11 +590,10 @@ insertAllSegmentMap seg m =
 
 -- | Insert segment into memory or fail if this overlaps with another
 -- segment in memory.
-insertMemSegment :: MemWidth w
-                 => MemSegment w
+insertMemSegment :: MemSegment w
                  -> Memory w
                  -> Either (InsertError w) (Memory w)
-insertMemSegment seg mem = do
+insertMemSegment seg mem = addrWidthClass (memAddrWidth mem) $ do
   absMap <- insertAbsoluteSegmentMap seg (memAbsoluteSegments mem)
   allMap <- insertAllSegmentMap      seg (memAllSegments mem)
   pure $ mem { memAbsoluteSegments = absMap
@@ -605,29 +602,29 @@ insertMemSegment seg mem = do
 
 -- | Return segment if range is entirely contained within a single segment
 -- and 'Nothing' otherwise.
-segmentOfRange :: MemWidth w
-               => MemWord w -- ^ Start of range
+segmentOfRange :: MemWord w -- ^ Start of range
                -> MemWord w -- ^ One past last index in range.
                -> Memory w
                -> Maybe (MemSegment w)
-segmentOfRange base end mem =
+segmentOfRange base end mem = addrWidthClass (memAddrWidth mem) $ do
   case Map.lookupLE base (memAbsoluteSegments mem) of
     Just (seg_base, seg) | end <= seg_base + segmentSize seg -> Just seg
     _ -> Nothing
 
 -- | Return true if address satisfies permissions check.
-addrPermissions :: MemWidth w => MemWord w -> Memory w -> Perm.Flags
-addrPermissions addr mem =
+addrPermissions :: MemWord w -> Memory w -> Perm.Flags
+addrPermissions addr mem =  addrWidthClass (memAddrWidth mem) $
   case Map.lookupLE addr (memAbsoluteSegments mem) of
     Just (base, seg) | addr < base + segmentSize seg -> segmentFlags seg
     _ -> Perm.none
 
 -- | Indicates if address is a code pointer.
-isCodeAddr :: MemWidth w => Memory w -> MemWord w -> Bool
-isCodeAddr mem val = addrPermissions val mem `Perm.hasPerm` Perm.execute
+isCodeAddr :: Memory w -> MemWord w -> Bool
+isCodeAddr mem val =
+  addrPermissions val mem `Perm.hasPerm` Perm.execute
 
 -- | Indicates if address is an address in code segment or null.
-isCodeAddrOrNull :: MemWidth w => Memory w -> MemWord w -> Bool
+isCodeAddrOrNull :: Memory w -> MemWord w -> Bool
 isCodeAddrOrNull _ (MemWord 0) = True
 isCodeAddrOrNull mem a = isCodeAddr mem a
 

src/Data/Macaw/Memory/ElfLoader.hs

@@ -8,9 +8,15 @@ Operations for creating a view of memory from an elf file.
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 module Data.Macaw.Memory.ElfLoader
   ( SectionIndexMap
+  , ElfWordWidth
+  , cancelElfWordType
+  , cancelElfWordWidth
   , memoryForElfSegments
   , memoryForElfSections
     -- * High-level exports
@@ -35,6 +41,8 @@ import qualified Data.Map.Strict as Map
 import           Data.Maybe
 import           Data.Parameterized.Some
 import qualified Data.Vector as V
+import           Data.Word
+import           GHC.TypeLits
 import           System.IO
 
 import           Data.Macaw.Memory
@@ -260,7 +268,12 @@ mkSymbolRef (sym, mverId) =
             , symbolVersion = mkSymbolVersion <$> mverId
             }
 
--- | Creates a relocation map for the givenphdr
+-- | Return the width of an elf word.
+type family ElfWordWidth (w :: *) :: Nat where
+  ElfWordWidth Word32 = 32
+  ElfWordWidth Word64 = 64
+
+-- | Creates a relocation map from the contents of a dynamic section.
 relocMapOfDynamic :: ElfData
                   -> RelaWidth w
                   -> ElfMachine
@@ -311,13 +324,29 @@ insertElfSegment shdrMap contents relocMap phdr = do
         mlsIndexMap %= Map.insert elfIdx pair
       _ -> fail "Unexpected shdr interval"
 
+
+elfAddrWidth :: ElfClass v -> AddrWidthRepr (ElfWordWidth v)
+elfAddrWidth ELFCLASS32 = Addr32
+elfAddrWidth ELFCLASS64 = Addr64
+
+cancelElfWordType :: ElfClass v
+                  -> ((ElfWordType (ElfWordWidth v) ~ v, Integral v, Bits v, MemWidth (ElfWordWidth v)) => a)
+                  -> a
+cancelElfWordType ELFCLASS32 x = x
+cancelElfWordType ELFCLASS64 x = x
+
+cancelElfWordWidth :: AddrWidthRepr w
+                   -> ((ElfWordWidth (ElfWordType w) ~ w) => a)
+                   -> a
+cancelElfWordWidth Addr32 x = x
+cancelElfWordWidth Addr64 x = x
+
 -- | Load an elf file into memory.  This uses the Elf segments for loading.
-memoryForElfSegments :: forall w
-                     .  Integral (ElfWordType w)
-                     => AddrWidthRepr w
-                     -> Elf (ElfWordType w)
-                     -> Either String (SectionIndexMap (ElfWordType w) w, Memory w)
-memoryForElfSegments w e = addrWidthClass w $ do
+memoryForElfSegments :: forall v
+                     .  Elf v
+                     -> Either String (SectionIndexMap v (ElfWordWidth v), Memory (ElfWordWidth v))
+memoryForElfSegments e = cancelElfWordType (elfClass e) $ do
+  let w = elfAddrWidth (elfClass e)
   runExcept $ fmap memLoaderPair $ flip execStateT (initState w) $ do
     let l   = elfLayout e
     let d   = elfLayoutData l
@@ -333,7 +362,7 @@ memoryForElfSegments w e = addrWidthClass w $ do
            in relocMapOfDynamic d (relaWidthOfAddr w) (elfMachine e) virtMap dynContents
         _ -> throwError "Multiple dynamic sections"
 
-    let intervals :: ElfFileSectionMap (ElfWordType w)
+    let intervals :: ElfFileSectionMap v
         intervals = IMap.fromList $
           [ (IntervalCO start end, sec)
           | shdr <- Map.elems (l^.shdrs)
@@ -364,11 +393,10 @@ insertElfSection sec =
 -- | Load allocated Elf sections into memory.
 -- Normally, Elf uses segments for loading, but the segment information
 -- tends to be more precise.
-memoryForElfSections :: (Integral (ElfWordType w), Bits (ElfWordType w))
-                     => AddrWidthRepr w
-                     -> Elf (ElfWordType w)
-                     -> Either String (SectionIndexMap (ElfWordType w) w, Memory w)
-memoryForElfSections w e = addrWidthClass w $
+memoryForElfSections :: Elf v
+                     -> Either String (SectionIndexMap v (ElfWordWidth v), Memory (ElfWordWidth v))
+memoryForElfSections e = cancelElfWordType (elfClass e) $ do
+  let w = elfAddrWidth (elfClass e)
   runExcept $ fmap memLoaderPair $ flip execStateT (initState w) $ do
     traverseOf_ elfSections insertElfSection e
 
@@ -404,14 +432,12 @@ loadExecutable :: FilePath -> IO (Some Memory)
 loadExecutable path = do
   se <- readElf path
   case se of
-    Elf64 e -> either fail (return . Some . snd) $
-      memoryForElfSegments Addr64 e
-    Elf32 e -> either fail (return . Some . snd) $
-      memoryForElfSegments Addr32 e
+    Elf64 e -> either fail (return . Some . snd) $ memoryForElfSegments e
+    Elf32 e -> either fail (return . Some . snd) $ memoryForElfSegments e
 
 loadElfBySection :: FilePath -> IO (Some Memory)
 loadElfBySection path = do
   se <- readElf path
   case se of
-    Elf64 e -> either fail (return . Some . snd) $ memoryForElfSections Addr64 e
-    Elf32 e -> either fail (return . Some . snd) $ memoryForElfSections Addr32 e
+    Elf64 e -> either fail (return . Some . snd) $ memoryForElfSections e
+    Elf32 e -> either fail (return . Some . snd) $ memoryForElfSections e