use Seq over list in PartialModule (fixes #178) (#179)

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)

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,

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

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

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

unit-test/Tests/Metadata.hs

@@ -1,19 +1,18 @@
 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
 
 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