Attempt to speed up compiler with DList

11 files changed, 143 insertions, 94 deletions

diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
index f4834376ed..9e4f604a0e 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -----------------------------------------------------------------------------
 --
@@ -52,6 +53,7 @@ import StgSyn
 import Id
 import TyCon             ( PrimRep(..), primRepSizeB )
 import BasicTypes        ( RepArity )
+import qualified DList as DL
 import DynFlags
 import Module
 
@@ -362,19 +364,21 @@ just more arguments that we are passing on the stack (cml_args).
 -- pushing on the stack for "extra" arguments to a function which requires
 -- fewer arguments than we currently have.
 slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
-slowArgs _ [] = []
-slowArgs dflags args -- careful: reps contains voids (V), but args does not
-  | gopt Opt_SccProfilingOn dflags
-              = save_cccs ++ this_pat ++ slowArgs dflags rest_args
-  | otherwise =              this_pat ++ slowArgs dflags rest_args
+slowArgs dflags args = DL.toList (go dflags args)
   where
-    (arg_pat, n)            = slowCallPattern (map fst args)
-    (call_args, rest_args)  = splitAt n args
+    go _ [] = DL.empty
+    go dflags args -- careful: reps contains voids (V), but args does not
+      | gopt Opt_SccProfilingOn dflags
+                  = save_cccs DL.++ this_pat DL.++ go dflags rest_args
+      | otherwise =                 this_pat DL.++ go dflags rest_args
+      where
+        (arg_pat, n)                          = slowCallPattern (map fst args)
+        (DL.fromList -> call_args, rest_args) = splitAt n args
 
-    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
-    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args
-    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]
-    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
+        stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
+        this_pat   = DL.cons (N, Just (mkLblExpr stg_ap_pat)) call_args
+        save_cccs  = DL.fromList [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]
+        save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
 
 -------------------------------------------------------------------------
 ----        Laying out objects on the heap and stack
@@ -427,9 +431,12 @@ mkVirtHeapOffsetsWithPadding dflags header things =
     ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
     ( tot_wds
     , bytesToWordsRoundUp dflags bytes_of_ptrs
-    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
+    , DL.toList paddings_out
     )
   where
+    paddings_out = DL.concat ptrs_w_offsets DL.++ DL.concat non_ptrs_w_offsets
+                                            DL.++ final_pad
+
     hdr_words = case header of
       NoHeader -> 0
       StdHeader -> fixedHdrSizeW dflags
@@ -447,9 +454,9 @@ mkVirtHeapOffsetsWithPadding dflags header things =
 
     final_pad_size = tot_wds * word_size - tot_bytes
     final_pad
-        | final_pad_size > 0 = [(Padding final_pad_size
-                                         (hdr_bytes + tot_bytes))]
-        | otherwise          = []
+        | final_pad_size > 0 = DL.singleton $
+                                 Padding final_pad_size (hdr_bytes + tot_bytes)
+        | otherwise          = DL.empty
 
     word_size = wORD_SIZE dflags
 
@@ -474,10 +481,11 @@ mkVirtHeapOffsetsWithPadding dflags header things =
         field_off = FieldOff (NonVoid thing) final_offset
 
         with_padding field_off
-            | padding == 0 = [field_off]
-            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)
-                             , field_off
-                             ]
+            | padding == 0 = DL.singleton field_off
+            | otherwise    = DL.fromList 
+                               [ Padding padding (hdr_bytes + bytes_so_far)
+                               , field_off
+                               ]
 
 
 mkVirtHeapOffsets
@@ -538,10 +546,12 @@ mkArgDescr dflags args
          Nothing      -> ArgGen  arg_bits
 
 argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr
-argBits _      []           = []
-argBits dflags (P   : args) = False : argBits dflags args
-argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
-                    ++ argBits dflags args
+argBits dflags args = DL.toList (go dflags args)
+  where
+    go _      []           = DL.empty
+    go dflags (P   : args) = DL.cons False (go dflags args)
+    go dflags (arg : args) = DL.replicate (argRepSizeW dflags arg) True
+                       DL.++ go dflags args
 
 ----------------------
 stdPattern :: [ArgRep] -> Maybe Int
diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index 291c95abe8..5695c7e782 100644
--- a/compiler/basicTypes/Avail.hs
+++ b/compiler/basicTypes/Avail.hs
@@ -36,6 +36,8 @@ import NameSet
 
 import FieldLabel
 import Binary
+import qualified DList as DL
+import DList ( DList )
 import ListSetOps
 import Outputable
 import Util
@@ -178,7 +180,7 @@ availFlds (AvailTC _ _ fs) = fs
 availFlds _                = []
 
 availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]
-availsNamesWithOccs = concatMap availNamesWithOccs
+availsNamesWithOccs = DL.toList . DL.concatMap availNamesWithOccs'
 
 -- | 'Name's made available by the availability information, paired with
 -- the 'OccName' used to refer to each one.
@@ -189,10 +191,14 @@ availsNamesWithOccs = concatMap availNamesWithOccs
 --
 -- See Note [Representing fields in AvailInfo].
 availNamesWithOccs :: AvailInfo -> [(Name, OccName)]
-availNamesWithOccs (Avail n) = [(n, nameOccName n)]
-availNamesWithOccs (AvailTC _ ns fs)
-  = [ (n, nameOccName n) | n <- ns ] ++
-    [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]
+availNamesWithOccs = DL.toList . availNamesWithOccs'
+
+availNamesWithOccs' :: AvailInfo -> DList (Name, OccName)
+availNamesWithOccs' (Avail n) = DL.singleton (n, nameOccName n)
+availNamesWithOccs' (AvailTC _ ns fs) = ns' DL.++ fs'
+  where
+    ns' = DL.fromList [ (n, nameOccName n) | n <- ns ]
+    fs' = DL.fromList [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]
 
 -- -----------------------------------------------------------------------------
 -- Utility
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 1b387020f5..2517bdeb01 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -36,6 +36,7 @@ import Outputable
 import SMRep
 import CoreSyn (Tickish)
 import qualified Unique as U
+import qualified DList as DL
 
 import Hoopl.Block
 import Hoopl.Graph
@@ -655,18 +656,22 @@ data CmmTickScope
 
 -- | Output all scope paths.
 scopeToPaths :: CmmTickScope -> [[U.Unique]]
-scopeToPaths GlobalScope           = [[]]
-scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)
-scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2
+scopeToPaths s = DL.toList (go s)
+  where
+    go GlobalScope           = DL.singleton []
+    go (SubScope u s)        = fmap (u:) (go s)
+    go (CombinedScope s1 s2) = go s1 DL.++ go s2
 
 -- | Returns the head uniques of the scopes. This is based on the
 -- assumption that the @Unique@ of @SubScope@ identifies the
 -- underlying super-scope. Used for efficient equality and comparison,
 -- see below.
 scopeUniques :: CmmTickScope -> [U.Unique]
-scopeUniques GlobalScope           = []
-scopeUniques (SubScope u _)        = [u]
-scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2
+scopeUniques s = DL.toList (go s)
+  where
+    go GlobalScope           = DL.empty
+    go (SubScope u _)        = DL.singleton u
+    go (CombinedScope s1 s2) = go s1 DL.++ go s2
 
 -- Equality and order is based on the head uniques defined above. We
 -- take care to short-cut the (extremely) common cases.
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 6f551c009f..7ddeeeeb9c 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -2765,7 +2765,7 @@ lintAnnots pname pass guts = do
     when (not (null diffs)) $ CoreMonad.putMsg $ vcat
       [ lint_banner "warning" pname
       , text "Core changes with annotations:"
-      , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs
+      , withPprStyle (defaultDumpStyle dflags) . nest 2 . vcat . toList $ diffs
       ]
   -- Return actual new guts
   return nguts
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 919e2300be..71b2c587c2 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -111,6 +111,7 @@ import Literal
 import DataCon
 import Module
 import BasicTypes
+import qualified DList as DL
 import DynFlags
 import Outputable
 import Util
@@ -2108,7 +2109,7 @@ bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 
 -- | 'bindersOf' applied to a list of binding groups
 bindersOfBinds :: [Bind b] -> [b]
-bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
+bindersOfBinds = DL.toList . DL.concat . fmap (DL.fromList . bindersOf)
 
 rhssOfBind :: Bind b -> [Expr b]
 rhssOfBind (NonRec _ rhs) = [rhs]
@@ -2120,9 +2121,11 @@ rhssOfAlts alts = [e | (_,_,e) <- alts]
 -- | Collapse all the bindings in the supplied groups into a single
 -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
 flattenBinds :: [Bind b] -> [(b, Expr b)]
-flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
-flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
-flattenBinds []                   = []
+flattenBinds = DL.toList . go
+  where
+    go (NonRec b r : binds) = DL.cons (b,r) (go binds)
+    go (Rec prs1   : binds) = (DL.fromList prs1) DL.++ go binds
+    go []                   = DL.empty
 
 -- | We often want to strip off leading lambdas before getting down to
 -- business. Variants are 'collectTyBinders', 'collectValBinders',
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 50fdcd9c7b..e5365436e1 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -84,6 +84,8 @@ import TyCon
 import Unique
 import Outputable
 import TysPrim
+import qualified DList as DL
+import DList ( DList )
 import DynFlags
 import FastString
 import Maybes
@@ -2144,12 +2146,12 @@ eqTickish _ l r = l == r
 -- | Finds differences between core expressions, modulo alpha and
 -- renaming. Setting @top@ means that the @IdInfo@ of bindings will be
 -- checked for differences as well.
-diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
-diffExpr _   env (Var v1)   (Var v2)   | rnOccL env v1 == rnOccR env v2 = []
-diffExpr _   _   (Lit lit1) (Lit lit2) | lit1 == lit2                   = []
-diffExpr _   env (Type t1)  (Type t2)  | eqTypeX env t1 t2              = []
+diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> DList SDoc
+diffExpr _   env (Var v1)   (Var v2)   | rnOccL env v1 == rnOccR env v2 = DL.empty
+diffExpr _   _   (Lit lit1) (Lit lit2) | lit1 == lit2                   = DL.empty
+diffExpr _   env (Type t1)  (Type t2)  | eqTypeX env t1 t2              = DL.empty
 diffExpr _   env (Coercion co1) (Coercion co2)
-                                       | eqCoercionX env co1 co2        = []
+                                       | eqCoercionX env co1 co2        = DL.empty
 diffExpr top env (Cast e1 co1)  (Cast e2 co2)
   | eqCoercionX env co1 co2                = diffExpr top env e1 e2
 diffExpr top env (Tick n1 e1)   e2
@@ -2162,25 +2164,25 @@ diffExpr top env (Tick n1 e1)   (Tick n2 e2)
  -- generated names, which are allowed to differ.
 diffExpr _   _   (App (App (Var absent) _) _)
                  (App (App (Var absent2) _) _)
-  | isBottomingId absent && isBottomingId absent2 = []
+  | isBottomingId absent && isBottomingId absent2 = DL.empty
 diffExpr top env (App f1 a1)    (App f2 a2)
-  = diffExpr top env f1 f2 ++ diffExpr top env a1 a2
+  = diffExpr top env f1 f2 DL.++ diffExpr top env a1 a2
 diffExpr top env (Lam b1 e1)  (Lam b2 e2)
   | eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination
   = diffExpr top (rnBndr2 env b1 b2) e1 e2
 diffExpr top env (Let bs1 e1) (Let bs2 e2)
   = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])
-    in ds ++ diffExpr top env' e1 e2
+    in ds DL.++ diffExpr top env' e1 e2
 diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
   | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2
     -- See Note [Empty case alternatives] in TrieMap
-  = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)
+  = diffExpr top env e1 e2 DL.++ DL.concat (zipWith diffAlt a1 a2)
   where env' = rnBndr2 env b1 b2
         diffAlt (c1, bs1, e1) (c2, bs2, e2)
-          | c1 /= c2  = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]
+          | c1 /= c2  = DL.singleton (text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2)
           | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2
 diffExpr _  _ e1 e2
-  = [fsep [ppr e1, text "/=", ppr e2]]
+  = DL.singleton (fsep [ppr e1, text "/=", ppr e2])
 
 -- | Finds differences between core bindings, see @diffExpr@.
 --
@@ -2193,10 +2195,10 @@ diffExpr _  _ e1 e2
 -- which we then speculatively match by ordering them. It's by no means
 -- perfect, but gets the job done well enough.
 diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
-          -> ([SDoc], RnEnv2)
+          -> (DList SDoc, RnEnv2)
 diffBinds top env binds1 = go (length binds1) env binds1
  where go _    env []     []
-          = ([], env)
+          = (DL.empty, env)
        go fuel env binds1 binds2
           -- No binds left to compare? Bail out early.
           | null binds1 || null binds2
@@ -2225,23 +2227,24 @@ diffBinds top env binds1 = go (length binds1) env binds1
        -- now we just return the comparison results when we pair up
        -- the binds in a pseudo-random order.
        warn env binds1 binds2 =
-         concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++
-         unmatched "unmatched left-hand:" (drop l binds1') ++
+         DL.concatMap (uncurry (diffBind env)) (zip binds1' binds2') DL.++
+         unmatched "unmatched left-hand:" (drop l binds1') DL.++
          unmatched "unmatched right-hand:" (drop l binds2')
         where binds1' = sortBy (comparing fst) binds1
               binds2' = sortBy (comparing fst) binds2
               l = min (length binds1') (length binds2')
-       unmatched _   [] = []
-       unmatched txt bs = [text txt $$ ppr (Rec bs)]
+       unmatched _   [] = DL.empty
+       unmatched txt bs = DL.singleton (text txt $$ ppr (Rec bs))
        diffBind env (bndr1,expr1) (bndr2,expr2)
-         | ds@(_:_) <- diffExpr top env expr1 expr2
+         | ds <- diffExpr top env expr1 expr2
+         , not (null ds)
          = locBind "in binding" bndr1 bndr2 ds
          | otherwise
          = diffIdInfo env bndr1 bndr2
 
 -- | Find differences in @IdInfo@. We will especially check whether
 -- the unfoldings match, if present (see @diffUnfold@).
-diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]
+diffIdInfo :: RnEnv2 -> Var -> Var -> DList SDoc
 diffIdInfo env bndr1 bndr2
   | arityInfo info1 == arityInfo info2
     && cafInfo info1 == cafInfo info2
@@ -2254,21 +2257,21 @@ diffIdInfo env bndr1 bndr2
   = locBind "in unfolding of" bndr1 bndr2 $
     diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2)
   | otherwise
-  = locBind "in Id info of" bndr1 bndr2
-    [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]
+  = locBind "in Id info of" bndr1 bndr2 . DL.singleton $ 
+    fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]
   where info1 = idInfo bndr1; info2 = idInfo bndr2
 
 -- | Find differences in unfoldings. Note that we will not check for
 -- differences of @IdInfo@ in unfoldings, as this is generally
 -- redundant, and can lead to an exponential blow-up in complexity.
-diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
-diffUnfold _   NoUnfolding    NoUnfolding                 = []
-diffUnfold _   BootUnfolding  BootUnfolding               = []
-diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []
+diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> DList SDoc
+diffUnfold _   NoUnfolding    NoUnfolding                 = DL.empty
+diffUnfold _   BootUnfolding  BootUnfolding               = DL.empty
+diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = DL.empty
 diffUnfold env (DFunUnfolding bs1 c1 a1)
                (DFunUnfolding bs2 c2 a2)
   | c1 == c2 && equalLength bs1 bs2
-  = concatMap (uncurry (diffExpr False env')) (zip a1 a2)
+  = DL.concatMap (uncurry (diffExpr False env')) (zip a1 a2)
   where env' = rnBndrs2 env bs1 bs2
 diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)
                (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2)
@@ -2276,11 +2279,11 @@ diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)
     && wf1 == wf2 && x1 == x2 && g1 == g2
   = diffExpr False env t1 t2
 diffUnfold _   uf1 uf2
-  = [fsep [ppr uf1, text "/=", ppr uf2]]
+  = DL.singleton $ fsep [ppr uf1, text "/=", ppr uf2]
 
 -- | Add location information to diff messages
-locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]
-locBind loc b1 b2 diffs = map addLoc diffs
+locBind :: String -> Var -> Var -> DList SDoc -> DList SDoc
+locBind loc b1 b2 diffs = fmap addLoc diffs
   where addLoc d            = d $$ nest 2 (parens (text loc <+> bindLoc))
         bindLoc | b1 == b2  = ppr b1
                 | otherwise = ppr b1 <> char '/' <> ppr b2
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index dbfc6f52fd..e1a8ac016e 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -64,6 +64,7 @@ import Maybes
 import OrdList
 import Bag
 import BasicTypes
+import qualified DList as DL
 import DynFlags
 import FastString
 import Util
@@ -110,10 +111,14 @@ dsTopLHsBinds binds
 -- | Desugar all other kind of bindings, Ids of strict binds are returned to
 -- later be forced in the binding group body, see Note [Desugar Strict binds]
 dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
-dsLHsBinds binds
-  = do { ds_bs <- mapBagM dsLHsBind binds
-       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
-                         id ([], []) ds_bs) }
+dsLHsBinds binds = do
+  let bindsToDL (str, bnds) = (DL.fromList str, DL.fromList bnds)
+  ds_bs <- mapBagM (fmap bindsToDL . dsLHsBind) binds
+  let 
+    (strictDL, bindingDL) =
+      foldBag (\(a, a') (b, b') -> (a DL.++ b, a' DL.++ b'))
+              id (DL.empty, DL.empty) ds_bs
+  return (DL.toList strictDL, DL.toList bindingDL)
 
 ------------------------
 dsLHsBind :: LHsBind GhcTc
diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs
index ed9f4cd371..024dcba8cd 100644
--- a/compiler/deSugar/DsUsage.hs
+++ b/compiler/deSugar/DsUsage.hs
@@ -11,6 +11,7 @@ module DsUsage (
 
 import GhcPrelude
 
+import qualified DList as DL
 import DynFlags
 import HscTypes
 import TcRnTypes
@@ -111,18 +112,16 @@ mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged
   = do
     eps <- hscEPS hsc_env
     hashes <- mapM getFileHash dependent_files
-    plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules
-    let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
-                                       dir_imp_mods used_names
-        usages = mod_usages ++ [ UsageFile { usg_file_path = f
-                                           , usg_file_hash = hash }
-                               | (f, hash) <- zip dependent_files hashes ]
-                            ++ [ UsageMergedRequirement
-                                    { usg_mod = mod,
-                                      usg_mod_hash = hash
-                                    }
-                               | (mod, hash) <- merged ]
-                            ++ concat plugin_usages
+    plugin_usages <- DL.concatMapA (mkPluginUsage hsc_env) pluginModules
+    let mod_usages = DL.fromList $ mk_mod_usage_info (eps_PIT eps) hsc_env
+                                                     this_mod dir_imp_mods
+                                                     used_names
+        usage_files = DL.fromList $ 
+                        uncurry UsageFile <$> zip dependent_files hashes
+        usage_mergedreqs = DL.fromList $ 
+                             uncurry UsageMergedRequirement <$> merged
+        usages = DL.toList $ mod_usages DL.++ usage_files DL.++ usage_mergedreqs
+                                        DL.++ plugin_usages
     usages `seqList` return usages
     -- seq the list of Usages returned: occasionally these
     -- don't get evaluated for a while and we can end up hanging on to
@@ -163,7 +162,7 @@ One way to improve this is to either:
     compare implementation hashes for recompilation. Creation of implementation
     hashes is however potentially expensive.
 -}
-mkPluginUsage :: HscEnv -> ModIface -> IO [Usage]
+mkPluginUsage :: HscEnv -> ModIface -> IO (DL.DList Usage)
 mkPluginUsage hsc_env pluginModule
   = case lookupPluginModuleWithSuggestions dflags pNm Nothing of
     LookupFound _ pkg -> do
@@ -196,7 +195,7 @@ mkPluginUsage hsc_env pluginModule
               ++ unlines paths
              )
              (ppr pNm)
-        _  -> mapM hashFile (nub files)
+        _  -> DL.fromList <$> mapM hashFile (nub files)
     _ -> do
       foundM <- findPluginModule hsc_env pNm
       case foundM of
@@ -206,7 +205,7 @@ mkPluginUsage hsc_env pluginModule
         Found ml _ -> do
           pluginObject <- hashFile (ml_obj_file ml)
           depObjects   <- catMaybes <$> mapM lookupObjectFile deps
-          return (nub (pluginObject : depObjects))
+          return . DL.fromList $ nub (pluginObject : depObjects)
         _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm)
   where
     dflags   = hsc_dflags hsc_env
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index 82de14346e..34b8a6d0b5 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -101,7 +101,7 @@ assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
   return CompiledByteCode
     { bc_bcos = bcos'
     , bc_itbls =  itblenv
-    , bc_ffis = concat (map protoBCOFFIs proto_bcos)
+    , bc_ffis = concatMap protoBCOFFIs proto_bcos
     , bc_strs = top_strs ++ ptrs
     , bc_breaks = modbreaks
     }
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 4a8e138daf..60087a148f 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -21,6 +21,7 @@ import GHCi
 import GHCi.FFI
 import GHCi.RemoteTypes
 import BasicTypes
+import qualified DList as DL
 import DynFlags
 import Outputable
 import GHC.Platform
@@ -1110,10 +1111,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
           binds = Map.toList p
           -- NB: unboxed tuple cases bind the scrut binder to the same offset
           -- as one of the alt binders, so we have to remove any duplicates here:
-          rel_slots = nub $ map fromIntegral $ concat (map spread binds)
-          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
-                              | otherwise                      = []
-                where rel_offset = trunc16W $ bytesToWords dflags (d - offset)
+          rel_slots = nub . DL.toList $ DL.concatMap spread binds
+          spread (id, offset) | isFollowableArg (bcIdArgRep id) = DL.singleton rel_offset
+                              | otherwise                       = DL.empty
+                where rel_offset = fromIntegral . trunc16W $ bytesToWords dflags (d - offset)
 
      alt_stuff <- mapM codeAlt alts
      alt_final <- mkMultiBranch maybe_ncons alt_stuff
diff --git a/compiler/utils/DList.hs b/compiler/utils/DList.hs
index 1215bb7a4b..18e2274439 100644
--- a/compiler/utils/DList.hs
+++ b/compiler/utils/DList.hs
@@ -36,6 +36,7 @@ module DList
   , cons
   , snoc
   , append
+  , (++)
   , concat
   , replicate
   , list
@@ -44,9 +45,11 @@ module DList
   , unfoldr
   , foldr
   , map
+  , concatMap
+  , concatMapA
   ) where
 
-import Prelude hiding (concat, foldr, map, head, tail, replicate)
+import Prelude hiding (concat, foldr, map, head, tail, replicate, (++), concatMap)
 import qualified Data.List as List
 import Control.Monad as M
 import Data.Function (on)
@@ -94,7 +97,7 @@ newtype DList a = DL { unDL :: [a] -> [a] }
 
 -- | Convert a list to a dlist
 fromList    :: [a] -> DList a
-fromList    = DL . (++)
+fromList    = DL . (List.++)
 {-# INLINE fromList #-}
 
 -- | Convert a dlist to a list
@@ -145,6 +148,12 @@ append       :: DList a -> DList a -> DList a
 append xs ys = DL (unDL xs . unDL ys)
 {-# INLINE append #-}
 
+-- | /O(1)/. 'append' in operator form.
+(++)         :: DList a -> DList a -> DList a
+(++)         = append
+{-# INLINE (++) #-}
+infixr 5 ++
+
 -- | /O(spine)/. Concatenate dlists
 concat       :: [DList a] -> DList a
 concat       = List.foldr append empty
@@ -189,6 +198,14 @@ map          :: (a -> b) -> DList a -> DList b
 map f        = foldr (cons . f) empty
 {-# INLINE map #-}
 
+-- | /O(n)/. concatMap for difference lists.
+concatMap :: (Foldable t) => (a -> DList b) -> t a -> DList b
+concatMap f xs = F.foldr (append . f) empty xs
+
+-- | /O(n)/. Applicative 'concatMap'.
+concatMapA :: (Foldable t, Applicative f) => (a -> f (DList b)) -> t a -> f (DList b)
+concatMapA f xs = F.foldr (\x acc -> append <$> f x <*> acc) (pure empty) xs
+
 instance Eq a => Eq (DList a) where
     (==) = (==) `on` toList