diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 288 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 47 | ||||
| -rw-r--r-- | compiler/GHC/Types/Demand.hs | 108 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/T18304.hs | 67 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/all.T | 6 |
5 files changed, 303 insertions, 213 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index c373b5cecb..29fa61a5fc 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -62,9 +62,10 @@ dmdAnalTopBind :: AnalEnv -> CoreBind -> (AnalEnv, CoreBind) dmdAnalTopBind env (NonRec id rhs) - = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs') + = ( extendAnalEnv TopLevel env id sig + , NonRec (setIdStrictness id sig) rhs') where - ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs + ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs dmdAnalTopBind env (Rec pairs) = (env', Rec pairs') @@ -216,10 +217,8 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) -- Only one alternative with a product constructor | let tycon = dataConTyCon dc , isJust (isDataProductTyCon_maybe tycon) - , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon = let - env_alt = env { ae_rec_tc = rec_tc' } - (rhs_ty, rhs') = dmdAnal env_alt dmd rhs + (rhs_ty, rhs') = dmdAnal env dmd rhs (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr id_dmds = addCaseBndrDmd case_bndr_dmd dmds @@ -299,8 +298,9 @@ dmdAnal' env dmd (Let (NonRec id rhs) body) dmdAnal' env dmd (Let (NonRec id rhs) body) = (body_ty2, Let (NonRec id2 rhs') body') where - (lazy_fv, id1, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs - env1 = extendAnalEnv NotTopLevel env id1 (idStrictness id1) + (lazy_fv, sig, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs + id1 = setIdStrictness id sig + env1 = extendAnalEnv NotTopLevel env id sig (body_ty, body') = dmdAnal env1 dmd body (body_ty1, id2) = annotateBndr env body_ty id1 body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables] @@ -509,95 +509,11 @@ dmdTransform env var dmd = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $ unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) -{- -************************************************************************ +{- ********************************************************************* * * -\subsection{Bindings} + Binding right-hand sides * * -************************************************************************ --} - --- Recursive bindings -dmdFix :: TopLevelFlag - -> AnalEnv -- Does not include bindings for this binding - -> CleanDemand - -> [(Id,CoreExpr)] - -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info - -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs - where - bndrs = map fst orig_pairs - - -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs - - -- If fixed-point iteration does not yield a result we use this instead - -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - abort = (env, lazy_fv', zapped_pairs) - where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs) - -- Note [Lazy and unleashable free variables] - non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs' - lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs - zapped_pairs = zapIdStrictness pairs' - - -- The fixed-point varies the idStrictness field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - loop n pairs - | found_fixpoint = (final_anal_env, lazy_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' - where - found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs - first_round = n == 1 - (lazy_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) - step first_round pairs = (lazy_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv) - - ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, lazy_fv) (id,rhs) - = ((env', lazy_fv'), (id', rhs')) - where - (lazy_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs - lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 - env' = extendAnalEnv top_lvl env id (idStrictness id') - - - zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ] - -{- -Note [Safe abortion in the fixed-point iteration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Fixed-point iteration may fail to terminate. But we cannot simply give up and -return the environment and code unchanged! We still need to do one additional -round, for two reasons: - - * To get information on used free variables (both lazy and strict!) - (see Note [Lazy and unleashable free variables]) - * To ensure that all expressions have been traversed at least once, and any left-over - strictness annotations have been updated. - -This final iteration does not add the variables to the strictness signature -environment, which effectively assigns them 'nopSig' (see "getStrictness") - --} +********************************************************************* -} -- Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). @@ -615,30 +531,26 @@ dmdAnalRhsLetDown :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive -> AnalEnv -> CleanDemand -> Id -> CoreExpr - -> (DmdEnv, Id, CoreExpr) + -> (DmdEnv, StrictSig, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. +-- See Note [NOINLINE and strictness] dmdAnalRhsLetDown rec_flag env let_dmd id rhs - = (lazy_fv, id', rhs') + = (lazy_fv, sig, rhs') where - rhs_arity = idArity id - rhs_dmd - -- See Note [Demand analysis for join points] - -- See Note [Invariants on join points] invariant 2b, in GHC.Core - -- rhs_arity matches the join arity of the join point - | isJoinId id - = mkCallDmds rhs_arity let_dmd - | otherwise - -- NB: rhs_arity - -- See Note [Demand signatures are computed for a threshold demand based on idArity] - = mkRhsDmd env rhs_arity rhs - (DmdType rhs_fv rhs_dmds rhs_div, rhs') - = dmdAnal env rhs_dmd rhs - sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) - id' = -- pprTrace "dmdAnalRhsLetDown" (ppr id <+> ppr sig) $ - setIdStrictness id sig - -- See Note [NOINLINE and strictness] - + rhs_arity = idArity id + rhs_dmd -- See Note [Demand analysis for join points] + -- See Note [Invariants on join points] invariant 2b, in GHC.Core + -- rhs_arity matches the join arity of the join point + | isJoinId id + = mkCallDmds rhs_arity let_dmd + | otherwise + -- NB: rhs_arity + -- See Note [Demand signatures are computed for a threshold demand based on idArity] + = mkRhsDmd env rhs_arity rhs + + (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs + sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) -- See Note [Aggregated demand for cardinality] rhs_fv1 = case rec_flag of @@ -912,14 +824,152 @@ That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where behaviour -- see #17932. Happily it turns out now to be entirely unnecessary: we get good results with C(C(C(S))). So I simply deleted the special case. +-} -************************************************************************ +{- ********************************************************************* * * -\subsection{Strictness signatures and types} + Fixpoints * * -************************************************************************ +********************************************************************* -} + +-- Recursive bindings +dmdFix :: TopLevelFlag + -> AnalEnv -- Does not include bindings for this binding + -> CleanDemand + -> [(Id,CoreExpr)] + -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info + +dmdFix top_lvl env let_dmd orig_pairs + = loop 1 initial_pairs + where + bndrs = map fst orig_pairs + + -- See Note [Initialising strictness] + initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_pairs + + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + abort = (env, lazy_fv', zapped_pairs) + where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs) + -- Note [Lazy and unleashable free variables] + non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs' + lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs + zapped_pairs = zapIdStrictness pairs' + + -- The fixed-point varies the idStrictness field of the binders, and terminates if that + -- annotation does not change any more. + loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id) + -- | (id,_)<- pairs]) $ + loop' n pairs + + loop' n pairs + | found_fixpoint = (final_anal_env, lazy_fv, pairs') + | n == 10 = abort + | otherwise = loop (n+1) pairs' + where + found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs + first_round = n == 1 + (lazy_fv, pairs') = step first_round pairs + final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') + + step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) + step first_round pairs = (lazy_fv, pairs') + where + -- In all but the first iteration, delete the virgin flag + start_env | first_round = env + | otherwise = nonVirgin env + + start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv) + + ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs + -- mapAccumL: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + + my_downRhs (env, lazy_fv) (id,rhs) + = ((env', lazy_fv'), (id', rhs')) + where + (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs + lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 + env' = extendAnalEnv top_lvl env id sig + id' = setIdStrictness id sig + + zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] + zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ] + +{- Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, for two reasons: + + * To get information on used free variables (both lazy and strict!) + (see Note [Lazy and unleashable free variables]) + * To ensure that all expressions have been traversed at least once, and any left-over + strictness annotations have been updated. + +This final iteration does not add the variables to the strictness signature +environment, which effectively assigns them 'nopSig' (see "getStrictness") + +Note [Trimming a demand to a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are two reasons we sometimes trim a demand to match a type. + 1. GADTs + 2. Recursive products and widening + +More on both below. But the botttom line is: we really don't want to +have a binder whose demand is more deeply-nested than its type +"allows". So in findBndrDmd we call trimToType and findTypeShape to +trim the demand on the binder to a form that matches the type + +Now to the reasons. For (1) consider + f :: a -> Bool + f x = case ... of + A g1 -> case (x |> g1) of (p,q) -> ... + B -> error "urk" + +where A,B are the constructors of a GADT. We'll get a U(U,U) demand +on x from the A branch, but that's a stupid demand for x itself, which +has type 'a'. Indeed we get ASSERTs going off (notably in +splitUseProdDmd, #8569). + +For (2) consider + data T = MkT Int T -- A recursive product + f :: Int -> T -> Int + f 0 _ = 0 + f _ (MkT n t) = f n t + +Here f is lazy in T, but its *usage* is infinite: U(U,U(U,U(U, ...))). +Notice that this happens becuase T is a product type, and is recrusive. +If we are not careful, we'll fail to iterate to a fixpoint in dmdFix, +and bale out entirely, which is inefficient and over-conservative. + +Worse, as we discovered in #18304, the size of the usages we compute +can grow /exponentially/, so even 10 iterations costs far too much. +Especially since we then discard the result. + +To avoid this we use the same findTypeShape function as for (1), but +arrange that it trims the demand if it encounters the same type constructor +twice (or three times, etc). We use our standard RecTcChecker mechanism +for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape. + +This is usually call "widening". We could do it just in dmdFix, but +since are doing this findTypeShape business /anyway/ because of (1), +and it has all the right information to hand, it's extremely +convenient to do it there. + -} +{- ********************************************************************* +* * + Strictness signatures and types +* * +********************************************************************* -} + unitDmdType :: DmdEnv -> DmdType unitDmdType dmd_env = DmdType dmd_env [] topDiv @@ -1133,7 +1183,6 @@ data AnalEnv , ae_sigs :: SigEnv , ae_virgin :: Bool -- True on first iteration only -- See Note [Initialising strictness] - , ae_rec_tc :: RecTcChecker , ae_fam_envs :: FamInstEnvs } @@ -1157,7 +1206,6 @@ emptyAnalEnv dflags fam_envs = AE { ae_dflags = dflags , ae_sigs = emptySigEnv , ae_virgin = True - , ae_rec_tc = initRecTc , ae_fam_envs = fam_envs } @@ -1199,7 +1247,7 @@ findBndrsDmds env dmd_ty bndrs | otherwise = go dmd_ty bs findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) --- See Note [Trimming a demand to a type] in GHC.Types.Demand +-- See Note [Trimming a demand to a type] findBndrDmd env arg_of_dfun dmd_ty id = (dmd_ty', dmd') where diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 8be03f30c5..4c4a5ced8a 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -231,7 +231,7 @@ A simplified example is #11565#comment:6 Current strategy is very simple: don't perform w/w transformation at all if the result produces a wrapper with arity higher than -fmax-worker-args -and the number arguments before w/w. +and the number arguments before w/w (see #18122). It is a bit all or nothing, consider @@ -248,6 +248,7 @@ solve f. But we can get a lot of args from deeply-nested products: This is harder to spot on an arg-by-arg basis. Previously mkWwStr was given some "fuel" saying how many arguments it could add; when we ran out of fuel it would stop w/wing. + Still not very clever because it had a left-right bias. ************************************************************************ @@ -998,23 +999,35 @@ deepSplitCprType_maybe _ _ _ = Nothing findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type -- The data type TypeShape is defined in GHC.Types.Demand --- See Note [Trimming a demand to a type] in GHC.Types.Demand +-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal findTypeShape fam_envs ty - | Just (tc, tc_args) <- splitTyConApp_maybe ty - , Just con <- isDataProductTyCon_maybe tc - = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args) - - | Just (_, res) <- splitFunTy_maybe ty - = TsFun (findTypeShape fam_envs res) - - | Just (_, ty') <- splitForAllTy_maybe ty - = findTypeShape fam_envs ty' - - | Just (_, ty') <- topNormaliseType_maybe fam_envs ty - = findTypeShape fam_envs ty' - - | otherwise - = TsUnk + = go (setRecTcMaxBound 2 initRecTc) ty + -- You might think this bound of 2 is low, but actually + -- I think even 1 would be fine. This only bites for recursive + -- product types, which are rare, and we really don't want + -- to look deep into such products -- see #18034 + where + go rec_tc ty + | Just (_, res) <- splitFunTy_maybe ty + = TsFun (go rec_tc res) + + | Just (tc, tc_args) <- splitTyConApp_maybe ty + , Just con <- isDataProductTyCon_maybe tc + , Just rec_tc <- if isTupleTyCon tc + then Just rec_tc + else checkRecTc rec_tc tc + -- We treat tuples specially because they can't cause loops. + -- Maybe we should do so in checkRecTc. + = TsProd (map (go rec_tc) (dataConInstArgTys con tc_args)) + + | Just (_, ty') <- splitForAllTy_maybe ty + = go rec_tc ty' + + | Just (_, ty') <- topNormaliseType_maybe fam_envs ty + = go rec_tc ty' + + | otherwise + = TsUnk {- ************************************************************************ diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index fe3c30e311..077d6d913e 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -46,7 +46,7 @@ module GHC.Types.Demand ( splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, - TypeShape(..), peelTsFuns, trimToType, + TypeShape(..), trimToType, useCount, isUsedOnce, reuseEnv, zapUsageDemand, zapUsageEnvSig, @@ -809,24 +809,34 @@ data StrictPair a b = !a :*: !b strictPairToTuple :: StrictPair a b -> (a, b) strictPairToTuple (x :*: y) = (x, y) -data TypeShape = TsFun TypeShape - | TsProd [TypeShape] - | TsUnk +splitProdDmd_maybe :: Demand -> Maybe [Demand] +-- Split a product into its components, iff there is any +-- useful information to be extracted thereby +-- The demand is not necessarily strict! +splitProdDmd_maybe (JD { sd = s, ud = u }) + = case (s,u) of + (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u + -> Just (mkJointDmds sx ux) + (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s + -> Just (mkJointDmds sx ux) + (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) + _ -> Nothing + +{- ********************************************************************* +* * + TypeShape and demand trimming +* * +********************************************************************* -} -instance Outputable TypeShape where - ppr TsUnk = text "TsUnk" - ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) - ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) --- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and --- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise. -peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape -peelTsFuns 0 ts = Just ts -peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts -peelTsFuns _ _ = Nothing +data TypeShape -- See Note [Trimming a demand to a type] + -- in GHC.Core.Opt.DmdAnal + = TsFun TypeShape + | TsProd [TypeShape] + | TsUnk trimToType :: Demand -> TypeShape -> Demand --- See Note [Trimming a demand to a type] +-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal trimToType (JD { sd = ms, ud = mu }) ts = JD (go_ms ms ts) (go_mu mu ts) where @@ -852,72 +862,18 @@ trimToType (JD { sd = ms, ud = mu }) ts | equalLength mus tss = UProd (zipWith go_mu mus tss) go_u _ _ = Used -{- -Note [Trimming a demand to a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f :: a -> Bool - f x = case ... of - A g1 -> case (x |> g1) of (p,q) -> ... - B -> error "urk" - -where A,B are the constructors of a GADT. We'll get a U(U,U) demand -on x from the A branch, but that's a stupid demand for x itself, which -has type 'a'. Indeed we get ASSERTs going off (notably in -splitUseProdDmd, #8569). - -Bottom line: we really don't want to have a binder whose demand is more -deeply-nested than its type. There are various ways to tackle this. -When processing (x |> g1), we could "trim" the incoming demand U(U,U) -to match x's type. But I'm currently doing so just at the moment when -we pin a demand on a binder, in GHC.Core.Opt.DmdAnal.findBndrDmd. - - -Note [Threshold demands] -~~~~~~~~~~~~~~~~~~~~~~~~ -Threshold usage demand is generated to figure out if -cardinality-instrumented demands of a binding's free variables should -be unleashed. See also [Aggregated demand for cardinality]. - -Note [Replicating polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some demands can be considered as polymorphic. Generally, it is -applicable to such beasts as tops, bottoms as well as Head-Used and -Head-stricts demands. For instance, - -S ~ S(L, ..., L) - -Also, when top or bottom is occurred as a result demand, it in fact -can be expanded to saturate a callee's arity. --} +instance Outputable TypeShape where + ppr TsUnk = text "TsUnk" + ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) + ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) -splitProdDmd_maybe :: Demand -> Maybe [Demand] --- Split a product into its components, iff there is any --- useful information to be extracted thereby --- The demand is not necessarily strict! -splitProdDmd_maybe (JD { sd = s, ud = u }) - = case (s,u) of - (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u - -> Just (mkJointDmds sx ux) - (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s - -> Just (mkJointDmds sx ux) - (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) - _ -> Nothing -{- -************************************************************************ + +{- ********************************************************************* * * Termination * * -************************************************************************ - -Divergence: Dunno - / - Diverges - -In a fixpoint iteration, start from Diverges --} +********************************************************************* -} -- | Divergence lattice. Models a subset lattice of the following exhaustive -- set of divergence results: diff --git a/testsuite/tests/perf/compiler/T18304.hs b/testsuite/tests/perf/compiler/T18304.hs new file mode 100644 index 0000000000..5902f52355 --- /dev/null +++ b/testsuite/tests/perf/compiler/T18304.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE RecordWildCards, PatternGuards #-} +{-# OPTIONS_GHC -Wunused-binds #-} + +module Text.HTML.TagSoup.Specification + (dat, Out(..) ) +where + +-- Code taken from the tagsoup library, which is BSD-3-licensed. + +import Data.Char (isAlpha, isAlphaNum, isDigit, toLower) + +data TypeTag = TypeNormal -- <foo + | TypeXml -- <?foo + | TypeDecl -- <!foo + | TypeScript -- <script + deriving Eq + + +type Parser = S -> [Out] + +-- 8.2.4.1 Data state +dat :: S -> [Out] +dat S{..} = tagName TypeXml tl + +-- 8.2.4.5 Tag name state +tagName :: TypeTag -> S -> [Out] +tagName typ S{..} = case hd of + 'a' -> beforeAttName typ tl + +-- 8.2.4.6 Before attribute name state +beforeAttName :: TypeTag -> S -> [Out] +beforeAttName typ S{..} = case hd of + _ | hd `elem` "=" -> beforeAttValue typ s -- NEIL + +-- 8.2.4.9 Before attribute value state +beforeAttValue :: TypeTag -> S -> [Out] +beforeAttValue typ S{..} = case hd of + 'a' -> beforeAttValue typ tl + '&' -> attValueUnquoted typ s + +-- 8.2.4.12 Attribute value (unquoted) state +attValueUnquoted :: TypeTag -> Parser +attValueUnquoted typ S{..} = case hd of + '?' -> neilXmlTagClose tl + 'a' -> beforeAttName typ tl + 'b' -> attValueUnquoted typ tl + +-- seen "?", expecting ">" +neilXmlTagClose :: S -> [Out] +neilXmlTagClose S{..} = case hd of + '>' -> dat tl + _ -> beforeAttName TypeXml s + +----- +-- Text.HTML.TagSoup.Implementation +----- + +data Out = SomeOut + + +data S = S + { s :: S + , tl :: S + ,hd :: Char + ,eof :: Bool + } + diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 912a172c85..611d8b4390 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -358,3 +358,9 @@ test('T16190', ['T16190.hs', '-v0']) test('T16473', normal, makefile_test, ['T16473']) + +test ('T18304', + [ collect_compiler_stats('bytes allocated',2) + ], + compile, + ['-v0 -O']) |