diff --git a/llvm-disasm/LLVMDis.hs b/llvm-disasm/LLVMDis.hs index 22dca7c6..08e822b8 100644 --- a/llvm-disasm/LLVMDis.hs +++ b/llvm-disasm/LLVMDis.hs @@ -10,7 +10,7 @@ import Text.PrettyPrint (Style(..), renderStyle, style) import Control.Monad (when) import Data.Graph.Inductive.Graph (nmap, emap) import Data.Graph.Inductive.Dot (fglToDotString, showDot) -import Data.Monoid (mconcat, Endo(..)) +import Data.Monoid (Endo(..)) import Text.Show.Pretty (pPrint) import System.Console.GetOpt (ArgOrder(..), ArgDescr(..), OptDescr(..), getOpt, usageInfo) diff --git a/llvm-pretty-bc-parser.cabal b/llvm-pretty-bc-parser.cabal index b91c850e..493ca0d5 100644 --- a/llvm-pretty-bc-parser.cabal +++ b/llvm-pretty-bc-parser.cabal @@ -99,6 +99,7 @@ test-suite unit-test -threaded -- other-extensions: OverloadedStrings, ... build-depends: base -any, + containers >= 0.4, HUnit -any, QuickCheck -any, generic-random -any, diff --git a/src/Data/LLVM/BitCode/IR/Function.hs b/src/Data/LLVM/BitCode/IR/Function.hs index ad3bb62a..697b7b07 100644 --- a/src/Data/LLVM/BitCode/IR/Function.hs +++ b/src/Data/LLVM/BitCode/IR/Function.hs @@ -139,7 +139,7 @@ data PartialDefine = PartialDefine , partialBlockId :: !Int , partialSymtab :: ValueSymtab , partialMetadata :: Map.Map PKindMd PValMd - , partialGlobalMd :: [PartialUnnamedMd] + , partialGlobalMd :: !(Seq.Seq PartialUnnamedMd) , partialComdatName :: Maybe String } deriving Show @@ -161,12 +161,12 @@ emptyPartialDefine proto = do , partialName = protoSym proto , partialArgs = zipWith Typed tys names , partialVarArgs = va - , partialBody = Seq.empty - , partialBlock = Seq.empty + , partialBody = mempty + , partialBlock = mempty , partialBlockId = 0 , partialSymtab = symtab - , partialMetadata = Map.empty - , partialGlobalMd = [] + , partialMetadata = mempty + , partialGlobalMd = mempty , partialComdatName = protoComdat proto } @@ -1047,7 +1047,7 @@ parseFunctionBlockEntry _ _ d (valueSymtabBlockId -> Just _) = do parseFunctionBlockEntry globals t d (metadataBlockId -> Just es) = do (_, (globalUnnamedMds, localUnnamedMds), _, _, _) <- parseMetadataBlock globals t es if (null localUnnamedMds) - then return d { partialGlobalMd = globalUnnamedMds ++ partialGlobalMd d } + then return d { partialGlobalMd = globalUnnamedMds <> partialGlobalMd d } else return d -- silently drop unexpected local unnamed metadata parseFunctionBlockEntry globals t d (metadataAttachmentBlockId -> Just es) = do diff --git a/src/Data/LLVM/BitCode/IR/Metadata.hs b/src/Data/LLVM/BitCode/IR/Metadata.hs index 52551f65..88343dff 100644 --- a/src/Data/LLVM/BitCode/IR/Metadata.hs +++ b/src/Data/LLVM/BitCode/IR/Metadata.hs @@ -45,10 +45,13 @@ import Data.List (mapAccumL, foldl') import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Sequence as Seq +import Data.Sequence (Seq) import Data.Word (Word8,Word32,Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack, callStack) +import Data.Bifunctor (bimap) @@ -267,8 +270,8 @@ nameMetadata val pm = case pmNextName pm of -- cost is O(n^2*log(n)) where -- * n^2 comes from looking at every 'PValMd' inside every 'PartialUnnamedMd' -- * log(n) is the cost of looking them up in a 'Map'. -dedupMetadata :: [PartialUnnamedMd] -> [PartialUnnamedMd] -dedupMetadata pumd = map (helper (mkPartialUnnamedMdMap pumd)) pumd +dedupMetadata :: Seq PartialUnnamedMd -> Seq PartialUnnamedMd +dedupMetadata pumd = helper (mkPartialUnnamedMdMap pumd) <$> pumd where helper pumdMap pum = let pumdMap' = Map.delete (pumValues pum) pumdMap -- don't self-reference in pum { pumValues = maybeTransform pumdMap' (pumValues pum) } @@ -286,14 +289,15 @@ dedupMetadata pumd = map (helper (mkPartialUnnamedMdMap pumd)) pumd Just idex -> ValMdRef idex Nothing -> v - mkPartialUnnamedMdMap :: [PartialUnnamedMd] -> Map PValMd Int + mkPartialUnnamedMdMap :: Seq PartialUnnamedMd -> Map PValMd Int mkPartialUnnamedMdMap = foldl' (\mp part -> Map.insert (pumValues part) (pumIndex part) mp) Map.empty -- Finalizing --------------------------------------------------------------- -namedEntries :: PartialMetadata -> [NamedMd] -namedEntries = map (uncurry NamedMd) +namedEntries :: PartialMetadata -> Seq NamedMd +namedEntries = Seq.fromList + . map (uncurry NamedMd) . Map.toList . pmNamedEntries @@ -316,8 +320,8 @@ finalizePValMd :: PValMd -> Finalize ValMd finalizePValMd = relabel (const requireBbEntryName) -- | Partition unnamed entries into global and function local unnamed entries. -unnamedEntries :: PartialMetadata -> ([PartialUnnamedMd], [PartialUnnamedMd]) -unnamedEntries pm = partitionEithers (mapMaybe resolveNode (IntMap.toList (mtNodes mt))) +unnamedEntries :: PartialMetadata -> (Seq PartialUnnamedMd, Seq PartialUnnamedMd) +unnamedEntries pm = bimap Seq.fromList Seq.fromList (partitionEithers (mapMaybe resolveNode (IntMap.toList (mtNodes mt)))) where mt = pmEntries pm @@ -343,8 +347,8 @@ type PFnMdAttachments = Map.Map PKindMd PValMd type PGlobalAttachments = Map.Map Symbol (Map.Map KindMd PValMd) type ParsedMetadata = - ( [NamedMd] - , ([PartialUnnamedMd],[PartialUnnamedMd]) + ( Seq NamedMd + , (Seq PartialUnnamedMd, Seq PartialUnnamedMd) , InstrMdAttachments , PFnMdAttachments , PGlobalAttachments diff --git a/src/Data/LLVM/BitCode/IR/Module.hs b/src/Data/LLVM/BitCode/IR/Module.hs index fe6b1da3..6055993f 100644 --- a/src/Data/LLVM/BitCode/IR/Module.hs +++ b/src/Data/LLVM/BitCode/IR/Module.hs @@ -19,11 +19,11 @@ import Text.LLVM.AST import qualified Codec.Binary.UTF8.String as UTF8 (decode) import Control.Monad (foldM,guard,when,forM_) -import Data.List (sortBy) -import Data.Ord (comparing) +import Data.List (sortOn) import qualified Data.Foldable as F import qualified Data.Map as Map import qualified Data.Sequence as Seq +import Data.Sequence (Seq) import qualified Data.Traversable as T @@ -36,12 +36,12 @@ data PartialModule = PartialModule , partialDeclares :: DeclareList , partialDataLayout :: DataLayout , partialInlineAsm :: InlineAsm - , partialComdat :: Seq.Seq (String,SelectionKind) + , partialComdat :: !(Seq (String,SelectionKind)) , partialAliasIx :: !Int , partialAliases :: AliasList - , partialNamedMd :: [NamedMd] - , partialUnnamedMd :: [PartialUnnamedMd] - , partialSections :: Seq.Seq String + , partialNamedMd :: !(Seq NamedMd) + , partialUnnamedMd :: !(Seq PartialUnnamedMd) + , partialSections :: !(Seq String) , partialSourceName :: !(Maybe String) } @@ -76,8 +76,8 @@ finalizeModule pm = label "finalizeModule" $ do return emptyModule { modSourceName = partialSourceName pm , modDataLayout = partialDataLayout pm - , modNamedMd = partialNamedMd pm - , modUnnamedMd = sortBy (comparing umIndex) unnamed + , modNamedMd = F.toList (partialNamedMd pm) + , modUnnamedMd = sortOn umIndex (F.toList unnamed) , modGlobals = F.toList globals , modDefines = F.toList defines , modTypes = types @@ -137,9 +137,9 @@ parseModuleBlockEntry pm (moduleCodeFunction -> Just r) = do parseModuleBlockEntry pm (functionBlockId -> Just es) = label "FUNCTION_BLOCK_ID" $ do let unnamedGlobalsCount = length (partialUnnamedMd pm) def <- parseFunctionBlock unnamedGlobalsCount es - let def' = def { partialGlobalMd = [] } + let def' = def { partialGlobalMd = mempty } return pm { partialDefines = partialDefines pm Seq.|> def' - , partialUnnamedMd = partialGlobalMd def ++ partialUnnamedMd pm + , partialUnnamedMd = partialGlobalMd def <> partialUnnamedMd pm } parseModuleBlockEntry pm (paramattrBlockId -> Just _) = do @@ -157,8 +157,8 @@ parseModuleBlockEntry pm (metadataBlockId -> Just es) = label "METADATA_BLOCK_ID let globalsSoFar = length (partialUnnamedMd pm) (ns,(gs,_),_,_,atts) <- parseMetadataBlock globalsSoFar vt es return $ addGlobalAttachments atts pm - { partialNamedMd = partialNamedMd pm ++ ns - , partialUnnamedMd = partialUnnamedMd pm ++ gs + { partialNamedMd = partialNamedMd pm <> ns + , partialUnnamedMd = partialUnnamedMd pm <> gs } parseModuleBlockEntry pm (valueSymtabBlockId -> Just _es) = do @@ -330,7 +330,7 @@ parseFunProto r pm = label "FUNCTION" $ do if sid == 0 then return Nothing else do let sid' = sid - 1 - when (sid' >= Seq.length (partialSections pm)) + when (sid' >= length (partialSections pm)) (fail "invalid section name index") return (Just (Seq.index (partialSections pm) sid')) @@ -339,7 +339,7 @@ parseFunProto r pm = label "FUNCTION" $ do -- push the function type _ <- pushValue (Typed ty (ValSymbol name)) let lkMb t x - | Seq.length t > x = Just (Seq.index t x) + | length t > x = Just (Seq.index t x) | otherwise = Nothing comdat <- if length (recordFields r) >= 12 then do comdatID <- field 12 numeric diff --git a/unit-test/Tests/Metadata.hs b/unit-test/Tests/Metadata.hs index 08feb109..46799f94 100644 --- a/unit-test/Tests/Metadata.hs +++ b/unit-test/Tests/Metadata.hs @@ -1,9 +1,8 @@ module Tests.Metadata (tests) where +import qualified Data.Sequence as Seq import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import Test.Tasty.QuickCheck (testProperty) -import Test.QuickCheck ((==>)) import Data.LLVM.Internal import Text.LLVM.AST @@ -11,9 +10,9 @@ import Text.LLVM.AST import Tests.Instances() tests :: TestTree -tests = testGroup "Metadata" $ +tests = testGroup "Metadata" [ testCase "test dedup metadata" $ - [] @?= dedupMetadata [] + mempty @?= dedupMetadata mempty -- The first two should remain unchanged, but the third duplicates information in -- the second, so should be updated to hold a reference to it. @@ -22,13 +21,14 @@ tests = testGroup "Metadata" $ val1 = mkPum 1 (ValMdString "str") val2 = mkPum 2 (ValMdDebugInfo (DebugInfoExpression (DIExpression []))) val3 = mkPum 3 (ValMdNode [Just (pumValues val2)]) + deduped = dedupMetadata (Seq.fromList [val1, val2, val3]) in [ testCase "1" $ - val1 @?= dedupMetadata [val1, val2, val3] !! 0 + Just val1 @?= deduped Seq.!? 0 , testCase "2" $ - val2 @?= dedupMetadata [val1, val2, val3] !! 1 + Just val2 @?= deduped Seq.!? 1 , testCase "3" $ - mkPum 3 (ValMdNode [Just (ValMdRef 2)]) @?= - dedupMetadata [val1, val2, val3] !! 2 + Just (mkPum 3 (ValMdNode [Just (ValMdRef 2)])) @?= + deduped Seq.!? 2 ] -- Deduplication should not changes: references or strings