[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Fix nasty bug in occurrence analyser

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Sun Jul 28 21:30:44 UTC 2024



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
f6b4c1c9 by Simon Peyton Jones at 2024-07-27T09:45:44-04:00
Fix nasty bug in occurrence analyser

As #25096 showed, the occurrence analyser was getting one-shot info
flat out wrong.

This commit does two things:

* It fixes the bug and actually makes the code a bit tidier too.
  The work is done in the new function
     GHC.Core.Opt.OccurAnal.mkRhsOccEnv,
  especially the bit that prepares the `occ_one_shots` for the RHS.

  See Note [The OccEnv for a right hand side]

* When floating out a binding we must be conservative about one-shot
  info.  But we were zapping the entire demand info, whereas we only
  really need zap the /top level/ cardinality.

  See Note [Floatifying demand info when floating]
  in GHC.Core.Opt.SetLevels

For some reason there is a 2.2% improvement in compile-time allocation
for CoOpt_Read.  Otherwise nickels and dimes.

Metric Decrease:
    CoOpt_Read

- - - - -
646ee207 by Torsten Schmits at 2024-07-27T09:46:20-04:00
add missing cell in flavours table

- - - - -
ec2eafdb by Ben Gamari at 2024-07-28T20:51:12+02:00
users-guide: Drop mention of dead __PARALLEL_HASKELL__ macro

This has not existed for over a decade.

- - - - -
a4b07a2c by Arnaud Spiwack at 2024-07-28T17:30:20-04:00
Add tests for 25081

- - - - -
0844f774 by Arnaud Spiwack at 2024-07-28T17:30:20-04:00
Scale multiplicity in list comprehension

Fixes #25081

- - - - -


22 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Utils/Outputable.hs
- docs/users_guide/phases.rst
- hadrian/doc/flavours.md
- + testsuite/tests/linear/should_compile/LinearListComprehension.hs
- testsuite/tests/linear/should_compile/all.T
- + testsuite/tests/linear/should_fail/T25081.hs
- + testsuite/tests/linear/should_fail/T25081.stderr
- testsuite/tests/linear/should_fail/all.T
- testsuite/tests/simplCore/should_compile/T21286.stderr
- testsuite/tests/simplCore/should_compile/spec-inline.stderr
- + testsuite/tests/simplCore/should_run/T25096.hs
- + testsuite/tests/simplCore/should_run/T25096.stdout
- testsuite/tests/simplCore/should_run/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -1039,10 +1039,10 @@ dmdTransform env var sd
       TopLevel
         | isInterestingTopLevelFn var
         -- Top-level things will be used multiple times or not at
-        -- all anyway, hence the multDmd below: It means we don't
+        -- all anyway, hence the `floatifyDmd`: it means we don't
         -- have to track whether @var@ is used strictly or at most
-        -- once, because ultimately it never will.
-        -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness
+        -- once, because ultimately it never will
+        -> addVarDmd fn_ty var (floatifyDmd (C_11 :* sd))
         | otherwise
         -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later
   -- Everything else:


=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1035,8 +1035,6 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
   | otherwise
   = (adj_rhs_uds : adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )
   where
-    is_join_point = isJoinPoint mb_join
-
     --------- Right hand side ---------
     -- For join points, set occ_encl to OccVanilla, via setTailCtxt.  If we have
     --    join j = Just (f x) in ...
@@ -1044,12 +1042,9 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
     --    let y = f x in join j = Just y in ...
     -- That's that OccRhs would do; but there's no point because
     -- j will never be scrutinised.
-    env1 | is_join_point = setTailCtxt env
-         | otherwise     = setNonTailCtxt rhs_ctxt env  -- Zap occ_join_points
+    rhs_env  = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs
     rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf
 
-    -- See Note [Sources of one-shot information]
-    rhs_env = addOneShotsFromDmd bndr env1
     -- See Note [Join arity prediction based on joinRhsArity]
     -- Match join arity O from mb_join_arity with manifest join arity M as
     -- returned by of occAnalLamTail. It's totally OK for them to mismatch;
@@ -1059,16 +1054,15 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
     final_bndr_with_rules
       | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]
       | otherwise         = bndr `setIdSpecialisation` mkRuleInfo rules'
-                                 `setIdUnfolding` unf2
+                                 `setIdUnfolding` unf1
     final_bndr_no_rules
       | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]
-      | otherwise         = bndr `setIdUnfolding` unf2
+      | otherwise         = bndr `setIdUnfolding` unf1
 
     --------- Unfolding ---------
     -- See Note [Join points and unfoldings/rules]
     unf = idUnfolding bndr
     WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf
-    unf2 = markNonRecUnfoldingOneShots mb_join unf1
     adj_unf_uds = adjustTailArity mb_join unf_tuds
 
     --------- Rules ---------
@@ -1143,10 +1137,8 @@ occAnalRec !_ lvl
   | isDeadOcc occ  -- Check for dead code: see Note [Dead code]
   = WUD body_uds binds
   | otherwise
-  = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
+  = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr
         !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
-        !unf'  = markNonRecUnfoldingOneShots mb_join (idUnfolding tagged_bndr)
-        !bndr' = tagged_bndr `setIdUnfolding` unf'
     in WUD (body_uds `andUDs` rhs_uds')
            (NonRec bndr' rhs' : binds)
   where
@@ -1751,10 +1743,9 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
     -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage
     -- until occAnalRec. In effect, we pretend that the RHS becomes a
     -- non-recursive join point and fix up later with adjustTailUsage.
-    rhs_env | isJoinId bndr = setTailCtxt env
-            | otherwise     = setNonTailCtxt OccRhs env
-            -- If bndr isn't an /existing/ join point, it's safe to zap the
-            -- occ_join_points, because they can't occur in RHS.
+    rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs
+            -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint),
+            -- it's safe to zap the occ_join_points, because they can't occur in RHS.
     WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs
       -- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders
 
@@ -2168,7 +2159,7 @@ occAnalLamTail env expr
     in WTUD (TUD (joinRhsArity expr) usage) expr'
 
 occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
--- Does not markInsidLam etc for the outmost batch of lambdas
+-- Does not markInsideLam etc for the outmost batch of lambdas
 occ_anal_lam_tail env expr@(Lam {})
   = go env [] expr
   where
@@ -2309,20 +2300,8 @@ occAnalRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
 
 occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)
 
-{- Note [Join point RHSs]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   x = e
-   join j = Just x
-
-We want to inline x into j right away, so we don't want to give
-the join point a RhsCtxt (#14137).  It's not a huge deal, because
-the FloatIn pass knows to float into join point RHSs; and the simplifier
-does not float things out of join point RHSs.  But it's a simple, cheap
-thing to do.  See #14137.
-
-Note [Occurrences in stable unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Occurrences in stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
     f p = BIG
     {-# INLINE g #-}
@@ -2358,16 +2337,32 @@ So we have a fast-path that keeps the old tree if the occ_bs_env is
 empty.   This just saves a bit of allocation and reconstruction; not
 a big deal.
 
-This fast path exposes a tricky cornder, though (#22761). Supose we have
+Two tricky corners:
+
+* Dead bindings (#22761). Supose we have
     Unfolding = \x. let y = foo in x+1
-which includes a dead binding for `y`. In occAnalUnfolding we occ-anal
-the unfolding and produce /no/ occurrences of `foo` (since `y` is
-dead).  But if we discard the occ-analysed syntax tree (which we do on
-our fast path), and use the old one, we still /have/ an occurrence of
-`foo` -- and that can lead to out-of-scope variables (#22761).
+  which includes a dead binding for `y`. In occAnalUnfolding we occ-anal
+  the unfolding and produce /no/ occurrences of `foo` (since `y` is
+  dead).  But if we discard the occ-analysed syntax tree (which we do on
+  our fast path), and use the old one, we still /have/ an occurrence of
+  `foo` -- and that can lead to out-of-scope variables (#22761).
+
+  Solution: always keep occ-analysed trees in unfoldings and rules, so they
+  have no dead code.  See Note [OccInfo in unfoldings and rules] in GHC.Core.
+
+* One-shot binders. Consider
+     {- f has Stable unfolding \p q -> blah
+        Demand on f is LC(L,C(1,!P(L)); that is, one-shot in its second ar -}
+     f = \x y. blah
+
+   Now we `mkRhsOccEnv` will build an OccEnv for f's RHS that has
+          occ_one_shots = [NoOneShortInfo, OneShotLam]
+   This will put OneShotLam on the \y.  And it'll put it on the \q.  But the
+   noBinderSwap check will mean that we discard this new occ-anal'd unfolding
+   and keep the old one, with no OneShotInfo.
 
-Solution: always keep occ-analysed trees in unfoldings and rules, so they
-have no dead code.  See Note [OccInfo in unfoldings and rules] in GHC.Core.
+   This looks a little inconsistent, but the Stable unfolding is just used for
+   inlinings; OneShotInfo isn't a lot of use here.
 
 Note [Cascading inlines]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2598,7 +2593,7 @@ occAnalArgs !env fun args !one_shots
             | otherwise
             = case one_shots of
                 []                -> (env_args, []) -- Fast path; one_shots is often empty
-                (os : one_shots') -> (addOneShots os env_args, one_shots')
+                (os : one_shots') -> (setOneShots os env_args, one_shots')
 
 {-
 Applications are dealt with specially because we want
@@ -2910,42 +2905,125 @@ setScrutCtxt !env alts
      -- non-default alternative.  That in turn influences
      -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!
 
+{- Note [The OccEnv for a right hand side]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+How do we create the OccEnv for a RHS (in mkRhsOccEnv)?
+
+For a non-join point binding, x = rhs
+
+  * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles
+
+  * occ_join_points: zap them!
+
+  * occ_one_shots: initialise from the idDemandInfo;
+    see Note [Sources of one-shot information]
+
+For a join point binding,  j x = rhs
+
+  * occ_encl: Consider
+       x = e
+       join j = Just x
+    We want to inline x into j right away, so we don't want to give the join point
+    a OccRhs (#14137); we want OccVanilla.  It's not a huge deal, because the
+    FloatIn pass knows to float into join point RHSs; and the simplifier does not
+    float things out of join point RHSs.  But it's a simple, cheap thing to do.
+
+  * occ_join_points: no need to zap.
+
+  * occ_one_shots: we start with one-shot-info from the context, which indeed
+    applies to the /body/ of the join point, after walking past the binders.
+    So we add to the front a OneShotInfo for each value-binder of the join
+    point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point
+    binders caused #25096.)
+
+    For the join point binders themselves, of a /non-recursive/ join point,
+    we make the binder a OneShotLam.  Again see `extendOneShotsForJoinPoint`.
+
+    These one-shot infos then get attached to the binder by `occAnalLamTail`.
+-}
+
 setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv
 setNonTailCtxt ctxt !env
   = env { occ_encl        = ctxt
         , occ_one_shots   = []
-        , occ_join_points = zapped_jp_env }
-  where
-    -- zapped_jp_env is basically just emptyVarEnv (hence zapped).  See (W3) of
-    -- Note [Occurrence analysis for join points] Zapping improves efficiency,
-    -- slightly, if you accidentally introduce a bug, in which you zap [jx :-> uds] and
-    -- then find an occurrence of jx anyway, you might lose those uds, and
-    -- that might mean we don't record all occurrencs, and that means we
-    -- duplicate a redex....  a very nasty bug (which I encountered!).  Hence
-    -- this DEBUG code which doesn't remove jx from the envt; it just gives it
-    -- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch
-    -- this bug before it does any damage.
-#ifdef DEBUG
-    zapped_jp_env = mapVarEnv (\ _ -> emptyVarEnv) (occ_join_points env)
-#else
-    zapped_jp_env = emptyVarEnv
-#endif
+        , occ_join_points = zapJoinPointInfo (occ_join_points env) }
 
 setTailCtxt :: OccEnv -> OccEnv
-setTailCtxt !env
-  = env { occ_encl = OccVanilla }
+setTailCtxt !env = env { occ_encl = OccVanilla }
     -- Preserve occ_one_shots, occ_join points
     -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):
-    --    see Note [Join point RHSs]
 
-addOneShots :: OneShots -> OccEnv -> OccEnv
-addOneShots os !env
+mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv
+-- See Note [The OccEnv for a right hand side]
+-- For a join point:
+--   - Keep occ_one_shots, occ_joinPoints from the context
+--   - But push enough OneShotInfo onto occ_one_shots to account
+--     for the join-point value binders
+--   - Set occ_encl to OccVanilla
+-- For non-join points
+--   - Zap occ_one_shots and occ_join_points
+--   - Set occ_encl to specified OccEncl
+mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points })
+            is_rec encl jp_hood bndr rhs
+  | JoinPoint join_arity <- jp_hood
+  = env { occ_encl        = OccVanilla
+        , occ_one_shots   = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots
+        , occ_join_points = ctxt_join_points }
+
+  | otherwise
+  = env { occ_encl        = encl
+        , occ_one_shots   = argOneShots (idDemandInfo bndr)
+                            -- argOneShots: see Note [Sources of one-shot information]
+        , occ_join_points = zapJoinPointInfo ctxt_join_points }
+
+zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo
+-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped).
+-- See (W3) of Note [Occurrence analysis for join points]
+--
+-- Zapping improves efficiency, slightly, if you accidentally introduce a bug,
+-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you
+-- might lose those uds, and that might mean we don't record all occurrencs, and
+-- that means we duplicate a redex....  a very nasty bug (which I encountered!).
+-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it
+-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this
+-- bug before it does any damage.
+#ifdef DEBUG
+zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info
+#else
+zapJoinPointInfo _       = emptyVarEnv
+#endif
+
+extendOneShotsForJoinPoint
+  :: RecFlag -> JoinArity -> CoreExpr
+  -> [OneShotInfo] -> [OneShotInfo]
+-- Push enough OneShortInfos on the front of ctxt_one_shots
+-- to account for the value lambdas of the join point
+extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots
+  = go join_arity rhs
+  where
+    -- For a /non-recursive/ join point we can mark all
+    -- its join-lambda as one-shot; and it's a good idea to do so
+    -- But not so for recursive ones
+    os = case is_rec of
+           NonRecursive -> OneShotLam
+           Recursive    -> NoOneShotInfo
+
+    go 0 _        = ctxt_one_shots
+    go n (Lam b rhs)
+      | isId b    = os : go (n-1) rhs
+      | otherwise =      go (n-1) rhs
+    go _ _        = []  -- Not enough lambdas.  This can legitimately happen.
+                        -- e.g.    let j = case ... in j True
+                        -- This will become an arity-1 join point after the
+                        -- simplifier has eta-expanded it; but it may not have
+                        -- enough lambdas /yet/. (Lint checks that JoinIds do
+                        -- have enough lambdas.)
+
+setOneShots :: OneShots -> OccEnv -> OccEnv
+setOneShots os !env
   | null os   = env  -- Fast path for common case
   | otherwise = env { occ_one_shots = os }
 
-addOneShotsFromDmd :: Id -> OccEnv -> OccEnv
-addOneShotsFromDmd bndr = addOneShots (argOneShots (idDemandInfo bndr))
-
 isRhsEnv :: OccEnv -> Bool
 isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
                                           OccRhs -> True
@@ -3732,17 +3810,10 @@ adjustNonRecRhs :: JoinPointHood
                 -> WithUsageDetails CoreExpr
 -- ^ This function concentrates shared logic between occAnalNonRecBind and the
 -- AcyclicSCC case of occAnalRec.
---   * It applies 'markNonRecJoinOneShots' to the RHS
---   * and returns the adjusted rhs UsageDetails combined with the body usage
+-- It returns the adjusted rhs UsageDetails combined with the body usage
 adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs)
-  = WUD rhs_uds' rhs'
-  where
-    --------- Marking (non-rec) join binders one-shot ---------
-    !rhs' | JoinPoint ja <- mb_join_arity = markNonRecJoinOneShots ja rhs
-          | otherwise                     = rhs
+  = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs
 
-    --------- Adjusting right-hand side usage ---------
-    rhs_uds' = adjustTailUsage mb_join_arity rhs_wuds
 
 adjustTailUsage :: JoinPointHood
                 -> WithTailUsageDetails CoreExpr    -- Rhs usage, AFTER occAnalLamTail
@@ -3760,33 +3831,6 @@ adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails
 adjustTailArity mb_rhs_ja (TUD ja usage)
   = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage
 
-markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr
--- For a /non-recursive/ join point we can mark all
--- its join-lambda as one-shot; and it's a good idea to do so
-markNonRecJoinOneShots join_arity rhs
-  = go join_arity rhs
-  where
-    go 0 rhs         = rhs
-    go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b)
-                           (go (n-1) rhs)
-    go _ rhs         = rhs  -- Not enough lambdas.  This can legitimately happen.
-                            -- e.g.    let j = case ... in j True
-                            -- This will become an arity-1 join point after the
-                            -- simplifier has eta-expanded it; but it may not have
-                            -- enough lambdas /yet/. (Lint checks that JoinIds do
-                            -- have enough lambdas.)
-
-markNonRecUnfoldingOneShots :: JoinPointHood -> Unfolding -> Unfolding
--- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding
-markNonRecUnfoldingOneShots mb_join_arity unf
-  | JoinPoint ja <- mb_join_arity
-  , CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf
-  , isStableSource src
-  , let !tmpl' = markNonRecJoinOneShots ja tmpl
-  = unf{uf_tmpl=tmpl'}
-  | otherwise
-  = unf
-
 type IdWithOccInfo = Id
 
 tagLamBinders :: UsageDetails        -- Of scope


=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1874,7 +1874,6 @@ cloneLetVars is_rec
           env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
           dest_lvl vs
   = do { let vs1  = map zap vs
-                      -- See Note [Zapping the demand info]
        ; (subst', vs2) <- case is_rec of
                             NonRecursive -> cloneBndrs      subst vs1
                             Recursive    -> cloneRecIdBndrs subst vs1
@@ -1887,9 +1886,12 @@ cloneLetVars is_rec
        ; return (env', vs2) }
   where
     zap :: Var -> Var
-    zap v | isId v    = zap_join (zapIdDemandInfo v)
+    -- See Note [Floatifying demand info when floating]
+    -- and Note [Zapping JoinId when floating]
+    zap v | isId v    = zap_join (floatifyIdDemandInfo v)
           | otherwise = v
 
+    -- See Note [Zapping JoinId when floating]
     zap_join | isTopLvl dest_lvl = zapJoinId
              | otherwise         = id
 
@@ -1898,16 +1900,38 @@ add_id id_env (v, v1)
   | isTyVar v = delVarEnv    id_env v
   | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1)
 
-{-
-Note [Zapping the demand info]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-VERY IMPORTANT: we must zap the demand info if the thing is going to
-float out, because it may be less demanded than at its original
-binding site.  Eg
-   f :: Int -> Int
-   f x = let v = 3*4 in v+x
-Here v is strict; but if we float v to top level, it isn't any more.
-
-Similarly, if we're floating a join point, it won't be one anymore, so we zap
-join point information as well.
+{- Note [Zapping JoinId when floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we are floating a join point, it won't be one anymore, so we zap
+the join point information.
+
+Note [Floatifying demand info when floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When floating we must lazify the outer demand info on the Id
+because it may be less demanded than at its original binding site.
+For example:
+     f :: Int -> Int
+     f x = let v = 3*4 in v+x
+Here v is strict and used at most once; but if we float v to top level,
+that isn't true any more. Specifically, we lose track of v's cardinality info:
+  * if `f` is called multiple times, then `v` is used more than once
+  * if `f` is never called, then `v` is never evaluated.
+
+But NOTE that we only need to adjust the /top-level/ cardinality info.
+For example
+     let x = (e1,e2)
+     in ...(case x of (a,b) -> a+b)...
+If we float x outwards, it may no longer be strict, but IF it is ever
+evaluated THEN its components will be evaluated.  So we to lazify and
+many-ify its demand-info, not discard it entirely.
+
+Same if we have
+     let f = \x y . blah
+     in ...(f a b)...(f c d)...
+Here `f` will get a demand like SC(S,C(1,L)). If we float it out, we can
+keep that `1C` called-once inner demand. It's only the outer strictness
+that we kill.
+
+Conclusion: to floatify a demand, just do `multDmd C_0N` to reflect the
+fact that `v` may be used any number of times, from zero upwards.
 -}


=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -971,7 +971,7 @@ addLetBndrInfo new_bndr new_arity_type new_unf
 
     -- Demand info: Note [Setting the demand info]
     info3 | isEvaldUnfolding new_unf
-          = zapDemandInfo info2 `orElse` info2
+          = lazifyDemandInfo info2 `orElse` info2
           | otherwise
           = info2
 


=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1485,11 +1485,12 @@ specBind top_lvl env (NonRec fn rhs) do_body
              -- This is important: see Note [Update unfolding after specialisation]
              -- And in any case cloneBndrSM discards non-Stable unfoldings
 
-             fn3 = zapIdDemandInfo fn2
+             fn3 = floatifyIdDemandInfo fn2
              -- We zap the demand info because the binding may float,
              -- which would invalidate the demand info (see #17810 for example).
              -- Destroying demand info is not terrible; specialisation is
              -- always followed soon by demand analysis.
+             -- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels
 
              body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds
                                    `extendInScope` fn3


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -502,6 +502,32 @@ tcGuardStmt _ stmt _ _
 --      coercion matching stuff in them.  It's hard to avoid the
 --      potential for non-trivial coercions in tcMcStmt
 
+{-
+Note [Binding in list comprehension isn't linear]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In principle, [ y | () <- xs, y <- [0,1]] could be linear in `xs`.
+But, the way the desugaring works, we get something like
+
+case xs of
+  () : xs ' -> letrec next_stmt = … xs' …
+
+In the current typing rules for letrec in Core, next_stmt is necessarily of
+multiplicity Many and so is every free variable, including xs'. Which, in turns,
+requires xs to be of multiplicity Many.
+
+Rodrigo Mesquita worked out, in his master thesis, how to make letrecs having
+non-Many multiplicities. But it's a fair bit of work to implement.
+
+Since nobody actually cares about [ y | () <- xs, y <- [0,1]] being linear, then
+we just conservatively make it unrestricted instead.
+
+If we're to change that, we have to be careful that [ y | _ <- xs, y <- [0,1]]
+isn't linear in `xs` since the elements of `xs` are ignored. So we'd still have
+to call `tcScalingUsage` on `xs` in `tcLcStmt`, we'd just have to create a fresh
+multiplicity variable. We'd also use the same multiplicity variable in the call
+to `tcCheckPat` instead of `unrestricted`.
+-}
+
 tcLcStmt :: TyCon       -- The list type constructor ([])
          -> TcExprStmtChecker
 
@@ -513,20 +539,24 @@ tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
 -- A generator, pat <- rhs
 tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside
  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
-        ; rhs'   <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])
+          -- About the next `tcScalingUsage ManyTy` and unrestricted
+          -- see Note [Binding in list comprehension isn't linear]
+        ; rhs'   <- tcScalingUsage ManyTy $ tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])
         ; (pat', thing)  <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
+                            tcScalingUsage ManyTy $
                             thing_inside elt_ty
         ; return (mkTcBindStmt pat' rhs', thing) }
 
 -- A boolean guard
 tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
   = do  { rhs'  <- tcCheckMonoExpr rhs boolTy
-        ; thing <- thing_inside elt_ty
+        ; thing <- tcScalingUsage ManyTy $ thing_inside elt_ty
         ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 -- ParStmt: See notes with tcMcStmt and Note [Scoping in parallel list comprehensions]
 tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
-  = do  { env <- getLocalRdrEnv
+  = tcScalingUsage ManyTy $ -- parallel list comprehension never desugars to something linear.
+    do  { env <- getLocalRdrEnv
         ; (pairs', thing) <- loop env [] bndr_stmts_s
         ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
   where
@@ -552,7 +582,8 @@ tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
                               , trS_bndrs =  bindersMap
                               , trS_by = by, trS_using = using }) elt_ty thing_inside
-  = do { let (bndr_names, n_bndr_names) = unzip bindersMap
+  = tcScalingUsage ManyTy $ -- Transform statements are too complex: just make everything multiplicity Many
+    do { let (bndr_names, n_bndr_names) = unzip bindersMap
              unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
              -- The inner 'stmts' lack a LastStmt, so the element type
              --  passed in to tcStmtsAndThen is never looked at


=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -38,7 +38,7 @@ module GHC.Types.Demand (
     -- *** Demands used in PrimOp signatures
     lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
     -- ** Other @Demand@ operations
-    oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd,
+    oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, floatifyDmd,
     peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, strictCallArity,
     mkWorkerDemand, subDemandIfEvaluated,
     -- ** Extracting one-shot information
@@ -608,22 +608,22 @@ multCard (Card a) (Card b)
 --
 -- Examples (using Note [Demand notation]):
 --
---   * 'seq' puts demand @1A@ on its first argument: It evaluates the argument
---     strictly (@1@), but not any deeper (@A@).
---   * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument
+--   * 'seq' puts demand `1A` on its first argument: It evaluates the argument
+--     strictly (`1`), but not any deeper (`A`).
+--   * 'fst' puts demand `1P(1L,A)` on its argument: It evaluates the argument
 --     pair strictly and the first component strictly, but no nested info
---     beyond that (@L@). Its second argument is not used at all.
---   * '$' puts demand @1C(1,L)@ on its first argument: It calls (@C@) the
---     argument function with one argument, exactly once (@1@). No info
---     on how the result of that call is evaluated (@L@).
---   * 'maybe' puts demand @MC(M,L)@ on its second argument: It evaluates
+--     beyond that (`L`). Its second argument is not used at all.
+--   * '$' puts demand `1C(1,L)` on its first argument: It calls (`C`) the
+--     argument function with one argument, exactly once (`1`). No info
+--     on how the result of that call is evaluated (`L`).
+--   * 'maybe' puts demand `MC(M,L)` on its second argument: It evaluates
 --     the argument function at most once ((M)aybe) and calls it once when
 --     it is evaluated.
---   * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@
---     multiplied by two, so we get @S@ (used at least once, possibly multiple
+--   * `fst p + fst p` puts demand `SP(SL,A)` on `p`: It's `1P(1L,A)`
+--     multiplied by two, so we get `S` (used at least once, possibly multiple
 --     times).
 --
--- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled
+-- This data type is quite similar to `'Scaled' 'SubDemand'`, but it's scaled
 -- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of
 -- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and
 -- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there
@@ -1013,6 +1013,11 @@ strictifyDictDmd _  dmd = dmd
 lazifyDmd :: Demand -> Demand
 lazifyDmd = multDmd C_01
 
+-- | Adjust the demand on a binding that may float outwards
+-- See Note [Floatifying demand info when floating]
+floatifyDmd :: Demand -> Demand
+floatifyDmd = multDmd C_0N
+
 -- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@.
 mkCalledOnceDmd :: SubDemand -> SubDemand
 mkCalledOnceDmd sd = mkCall C_11 sd
@@ -2651,7 +2656,12 @@ So, L can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand',
 but it's always clear from context which "overload" is meant. It's like
 return-type inference of e.g. 'read'.
 
-Examples are in the haddock for 'Demand'.
+Examples are in the haddock for 'Demand'.  Here are some more:
+   SA                 Strict, but does not look at subcomponents (`seq`)
+   SP(L,L)            Strict boxed pair, components lazy
+   S!P(L,L)           Strict unboxed pair, components lazy
+   LP(SA,SA)          Lazy pair, but if it is evaluated will evaluated its components
+   LC(1C(L))          Lazy, but if called will apply the result exactly once
 
 This is the syntax for demand signatures:
 


=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -54,7 +54,7 @@ module GHC.Types.Id (
         setIdExported, setIdNotExported,
         globaliseId, localiseId,
         setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
-        zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
+        zapLamIdInfo, floatifyIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
         zapIdUsedOnceInfo, zapIdTailCallInfo,
         zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding,
         transferPolyIdInfo, scaleIdBy, scaleVarBy,
@@ -969,12 +969,11 @@ setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id
 updOneShotInfo :: Id -> OneShotInfo -> Id
 -- Combine the info in the Id with new info
 updOneShotInfo id one_shot
-  | do_upd    = setIdOneShotInfo id one_shot
-  | otherwise = id
-  where
-    do_upd = case (idOneShotInfo id, one_shot) of
-                (NoOneShotInfo, _) -> True
-                (OneShotLam,    _) -> False
+  | OneShotLam <- one_shot
+  , NoOneShotInfo <- idOneShotInfo id
+  = setIdOneShotInfo id OneShotLam
+  | otherwise
+  = id
 
 -- The OneShotLambda functions simply fiddle with the IdInfo flag
 -- But watch out: this may change the type of something else
@@ -991,8 +990,9 @@ zapLamIdInfo = zapInfo zapLamInfo
 zapFragileIdInfo :: Id -> Id
 zapFragileIdInfo = zapInfo zapFragileInfo
 
-zapIdDemandInfo :: Id -> Id
-zapIdDemandInfo = zapInfo zapDemandInfo
+floatifyIdDemandInfo :: Id -> Id
+-- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels
+floatifyIdDemandInfo = zapInfo floatifyDemandInfo
 
 zapIdUsageInfo :: Id -> Id
 zapIdUsageInfo = zapInfo zapUsageInfo


=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -35,7 +35,8 @@ module GHC.Types.Id.Info (
 
         -- ** Zapping various forms of Info
         zapLamInfo, zapFragileInfo,
-        zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
+        lazifyDemandInfo, floatifyDemandInfo,
+        zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
         zapTailCallInfo, zapCallArityInfo, trimUnfolding,
 
         -- ** The ArityInfo type
@@ -855,11 +856,21 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
 
     is_safe_dmd dmd = not (isStrUsedDmd dmd)
 
--- | Remove all demand info on the 'IdInfo'
-zapDemandInfo :: IdInfo -> Maybe IdInfo
-zapDemandInfo info = Just (info {demandInfo = topDmd})
-
--- | Remove usage (but not strictness) info on the 'IdInfo'
+-- | Lazify (remove the top-level demand, only) the demand in `IdInfo`
+-- Keep nested demands; see Note [Floatifying demand info when floating]
+-- in GHC.Core.Opt.SetLevels
+lazifyDemandInfo :: IdInfo -> Maybe IdInfo
+lazifyDemandInfo info@(IdInfo { demandInfo = dmd })
+  = Just (info {demandInfo = lazifyDmd dmd })
+
+-- | Floatify the demand in `IdInfo`
+-- But keep /nested/ demands; see Note [Floatifying demand info when floating]
+-- in GHC.Core.Opt.SetLevels
+floatifyDemandInfo :: IdInfo -> Maybe IdInfo
+floatifyDemandInfo info@(IdInfo { demandInfo = dmd })
+  = Just (info {demandInfo = floatifyDmd dmd })
+
+-- | Remove usage (but not strictness) info on the `IdInfo`
 zapUsageInfo :: IdInfo -> Maybe IdInfo
 zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
 


=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -1261,7 +1261,7 @@ data BindingSite
 
 data JoinPointHood
   = JoinPoint {-# UNPACK #-} !Int   -- The JoinArity (but an Int here because
-  | NotJoinPoint                    -- synonym JoinArity is defined in Types.Basic
+  | NotJoinPoint                    -- synonym JoinArity is defined in Types.Basic)
   deriving( Eq )
 
 isJoinPoint :: JoinPointHood -> Bool


=====================================
docs/users_guide/phases.rst
=====================================
@@ -515,14 +515,6 @@ defined by your local GHC installation, the following trick is useful:
     Only defined when :ghc-flag:`-fignore-asserts` is specified.
     This can be used to create your own assertions, see :ref:`assertions`
 
-``__PARALLEL_HASKELL__``
-    .. index::
-       single: __PARALLEL_HASKELL__
-
-    Only defined when ``-parallel`` is in use! This symbol is defined
-    when pre-processing Haskell (input) and pre-processing C (GHC
-    output).
-
 ``os_HOST_OS=1``
     This define allows conditional compilation based on the Operating
     System, where⟨os⟩ is the name of the current Operating System (eg.


=====================================
hadrian/doc/flavours.md
=====================================
@@ -108,6 +108,7 @@ when compiling the `compiler` library, and `hsGhc` when compiling/linking the GH
   </tr>
   <tr>
     <th>release (same as perf with -haddock)</td>
+    <td></td>
     <td>-O<br>-H64m</td>
     <td>-O<br>-H64m</td>
     <td></td>


=====================================
testsuite/tests/linear/should_compile/LinearListComprehension.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE LinearTypes #-}
+
+module LinearListComprehension where
+
+-- Probably nobody actually cares if monad comprehension realised that it can be
+-- linear in the first statement. But it can, so we might as well.
+
+guard :: a %1 -> (a %1 -> Bool) %1 -> [Int]
+guard x g = [ y | g x, y <- [0,1] ]
+
+-- This isn't correct syntax, but a singleton list comprehension would
+-- presumably work too
+-- last :: a %1 -> [a]
+-- last x = [ x | ]


=====================================
testsuite/tests/linear/should_compile/all.T
=====================================
@@ -45,3 +45,4 @@ test('LinearRecUpd', normal, compile, [''])
 test('T23814', normal, compile, [''])
 test('LinearLet', normal, compile, [''])
 test('LinearLetPoly', normal, compile, [''])
+test('LinearListComprehension', normal, compile, ['-dlinear-core-lint'])


=====================================
testsuite/tests/linear/should_fail/T25081.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE ParallelListComp #-}
+{-# LANGUAGE TransformListComp #-}
+
+module T25081 where
+
+dup_last :: a %1 -> [a]
+dup_last x = [ x | _ <- [0,1]]
+
+dup_bind :: a %1 -> [()]
+dup_bind x = [ () | _ <- [0,1], _ <- [x]]
+
+dup_guard :: a %1 -> (a %1 -> Bool) -> [()]
+dup_guard x g = [ () | _ <- [0,1], g x ]
+
+guard_last :: a %1 -> [a]
+guard_last x = [ x | False]
+
+guard_bind :: a %1 -> [()]
+guard_bind x = [ () | False, _ <- [x]]
+
+guard_guard :: a %1 -> (a %1 -> Bool) %1 -> [()]
+guard_guard x g = [ () | False, g x ]
+
+-- This could, in principle, be linear. But see Note [Binding in list
+-- comprehension isn't linear] in GHC.Tc.Gen.Match.
+first_bind :: [()] %1 -> [Int]
+first_bind xs = [ y | () <- xs, y <- [0,1]]
+
+parallel :: a %1 -> [(a, Bool)]
+parallel x = [(y,z) | y <- [x] | z <- [True]]
+
+parallel_guard :: a %1 -> (a %1 -> Bool) -> [(Int, Bool)]
+parallel_guard x g = [(y, z) | g x, y <- [0,1] | z <- [True, False]]
+
+transform :: a %1 -> (a %1 -> Bool) -> [a]
+transform x g = [y | g x, y <- [0, 1], then take 2]


=====================================
testsuite/tests/linear/should_fail/T25081.stderr
=====================================
@@ -0,0 +1,65 @@
+T25081.hs:8:10: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘x’
+    • In an equation for ‘dup_last’: dup_last x = [x | _ <- [0, 1]]
+
+T25081.hs:11:10: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘x’
+    • In an equation for ‘dup_bind’:
+          dup_bind x = [() | _ <- [0, 1], _ <- [x]]
+
+T25081.hs:14:11: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘x’
+    • In an equation for ‘dup_guard’:
+          dup_guard x g = [() | _ <- [0, 1], g x]
+
+T25081.hs:17:12: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘x’
+    • In an equation for ‘guard_last’: guard_last x = [x | False]
+
+T25081.hs:20:12: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘x’
+    • In an equation for ‘guard_bind’:
+          guard_bind x = [() | False, _ <- [x]]
+
+T25081.hs:23:13: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘x’
+    • In an equation for ‘guard_guard’:
+          guard_guard x g = [() | False, g x]
+
+T25081.hs:23:15: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘g’
+    • In an equation for ‘guard_guard’:
+          guard_guard x g = [() | False, g x]
+
+T25081.hs:28:12: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘xs’
+    • In an equation for ‘first_bind’:
+          first_bind xs = [y | () <- xs, y <- [0, 1]]
+
+T25081.hs:31:10: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘x’
+    • In an equation for ‘parallel’:
+          parallel x = [(y, z) | y <- [x] |  z <- [True]]
+
+T25081.hs:34:16: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘x’
+    • In an equation for ‘parallel_guard’:
+          parallel_guard x g
+            = [(y, z) | g x, y <- [0, 1] |  z <- [True, False]]
+
+T25081.hs:37:11: error: [GHC-18872]
+    • Couldn't match type ‘Many’ with ‘One’
+        arising from multiplicity of ‘x’
+    • In an equation for ‘transform’:
+          transform x g = [y | g x, y <- [0, 1], then take 2]
+


=====================================
testsuite/tests/linear/should_fail/all.T
=====================================
@@ -51,3 +51,4 @@ test('LinearLet7', normal, compile_fail, [''])
 test('LinearLet8', normal, compile_fail, [''])
 test('LinearLet9', normal, compile_fail, [''])
 test('LinearLet10', normal, compile_fail, [''])
+test('T25081', normal, compile_fail, [''])


=====================================
testsuite/tests/simplCore/should_compile/T21286.stderr
=====================================
@@ -7,10 +7,10 @@ Rule fired: Class op fromInteger (BUILTIN)
 Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
 Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
 Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
+Rule fired: SPEC/T21286 g @Int (T21286)
 Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
 Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
 Rule fired: SPEC/T21286 g @Int (T21286)
-Rule fired: SPEC/T21286 g @Int (T21286)
 Rule fired: ==# (BUILTIN)
 Rule fired: tagToEnum# (BUILTIN)
 Rule fired: tagToEnum# (BUILTIN)


=====================================
testsuite/tests/simplCore/should_compile/spec-inline.stderr
=====================================
@@ -88,7 +88,7 @@ Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int
                  GHC.Types.I# ww
                  }}]
 Roman.foo_go
-  = \ (u :: Maybe Int) (ds :: Maybe Int) ->
+  = \ (u :: Maybe Int) (ds [OS=OneShot] :: Maybe Int) ->
       case Roman.$wgo u ds of ww { __DEFAULT -> GHC.Types.I# ww }
 
 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}


=====================================
testsuite/tests/simplCore/should_run/T25096.hs
=====================================
@@ -0,0 +1,20 @@
+module Main where
+
+import System.IO.Unsafe
+import Control.Monad
+
+main :: IO ()
+main = do
+  foo "test" 10
+
+foo :: String -> Int -> IO ()
+foo x n = go n
+  where
+    oops = unsafePerformIO (putStrLn "Once" >> pure (cycle x))
+
+    go 0 = return ()
+    go n = do
+      -- `oops` should be shared between loop iterations
+      let p  = take n oops
+      let !_ = unsafePerformIO (putStrLn p >> pure ())
+      go (n-1)


=====================================
testsuite/tests/simplCore/should_run/T25096.stdout
=====================================
@@ -0,0 +1,11 @@
+Once
+testtestte
+testtestt
+testtest
+testtes
+testte
+testt
+test
+tes
+te
+t


=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -115,3 +115,4 @@ test('T23134', normal, compile_and_run, ['-O0 -fcatch-nonexhaustive-cases'])
 test('T23289', normal, compile_and_run, [''])
 test('T23056', [only_ways(['ghci-opt'])], ghci_script, ['T23056.script'])
 test('T24725', normal, compile_and_run, ['-O -dcore-lint'])
+test('T25096', normal, compile_and_run, ['-O -dcore-lint'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/96f19ddde4297e7faec781bc1cd6a2f8e9283950...0844f77469755f3dd72db9f1648b04e5ae2c994b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/96f19ddde4297e7faec781bc1cd6a2f8e9283950...0844f77469755f3dd72db9f1648b04e5ae2c994b
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240728/1129eede/attachment-0001.html>


More information about the ghc-commits mailing list