Commit ba18dfd3 authored by Alexis Williams's avatar Alexis Williams

Attempt to speed up compiler with DList

parent ecbce050
{-# 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
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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',
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
}
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment