Commit 42953902 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot
Browse files

Trim the demand for recursive product types

Ticket #18304 showed that we need to be very careful
when exploring the demand (esp usage demand) on recursive
product types.

This patch solves the problem by trimming the demand on such types --
in effect, a form of "widening".

See the Note [Trimming a demand to a type] in DmdAnal, which explains
how I did this by piggy-backing on an existing mechansim for trimming
demands becuase of GADTs.  The significant payload of this patch is
very small indeed:

* Make GHC.Core.Opt.WorkWrap.Utils.typeShape use RecTcChecker to
  avoid looking through recursive types.

But on the way

* I found that ae_rec_tc was entirely inoperative and did nothing.
  So I removed it altogether from DmdAnal.

* I moved some code around in DmdAnal and Demand.
  (There are no actual changes in dmdFix.)

* I changed the API of DmsAnal.dmdAnalRhsLetDown to return
  a StrictSig rather than a decorated Id

* I removed the dead function peelTsFuns from Demand

Performance effects:

Nofib: 0.0% changes.  Not surprising, because they don't
       use recursive products

Perf tests

T12227:
  1% increase in compiler allocation, becuase $cto gets w/w'd.
  It did not w/w before because it takes a deeply nested
  argument, so the worker gets too many args, so we abandon w/w
  altogether (see GHC.Core.Opt.WorkWrap.Utils.isWorkerSmallEnough)

  With this patch we trim the demands.  That is not strictly
  necessary (since these Generic type constructors are like
  tuples -- they can't cause a loop) but the net result is that
  we now w/w $cto which is fine.

UniqLoop:
  16% decrease in /runtime/ allocation. The UniqSupply is a
  recursive product, so currently we abandon all strictness on
  'churn'.  With this patch 'churn' gets useful strictness, and
  we w/w it.  Hooray

Metric Decrease:
    UniqLoop

Metric Increase:
    T12227
parent 456e17f0
......@@ -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
......
......@@ -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
{-
************************************************************************
......
......@@ -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:
......
{-# 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