Simon Peyton Jones pushed to branch wip/T27737 at Glasgow Haskell Compiler / GHC

Commits:

6 changed files:

Changes:

  • compiler/GHC/Core.hs
    ... ... @@ -1720,10 +1720,19 @@ isEmptyFloatBinds = isNilOL
    1720 1720
    1721 1721 
     data FloatBind
    1722 1722 
       = FloatLet  CoreBind
    1723 
    +      -- let(rec) x = e
    1724 
    +      -- Invariant: satisfies the let-can-float invariant
    1725 
    +
    1723 1726 
       | FloatCase CoreExpr CoreBndr AltCon [CoreBndr]
    1724 1727 
           -- case e of y { C ys -> ... }
    1725 1728 
           -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels
    1729 
    +
    1726 1730 
       | FloatTick CoreTickish
    1731 
    +      -- tick<t> ...
    1732 
    +      -- Invariant: the tick is always soft-scoped (tickishHasSoftScope holds)
    1733 
    +      -- Why? We are floating these FloatBinds outwards, bringing more code under
    1734 
    +      -- the bindigns; that is only OK for soft-scoped ticks.
    1735 
    +      -- See Note [Scoping ticks and counting ticks] in GHC.Types.Tickish
    1727 1736
    1728 1737 
     floatsBinders :: FloatBinds -> [Var]
    1729 1738 
     floatsBinders fs = foldr ((++) . floatBinders) [] fs

  • compiler/GHC/Core/Opt/Simplify/Env.hs
    ... ... @@ -38,7 +38,7 @@ module GHC.Core.Opt.Simplify.Env (
    38 38
    39 39 
             -- * Floats
    40 40 
             SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,
    41 
    -        mkFloatBind, addLetFloats, addJoinFloats, addFloats,
    41 
    +        mkFloatBind, addLetFloats, addJoinFloats, addFloats, addFloatBindsF,
    42 42 
             extendFloats, wrapFloats,
    43 43 
             isEmptyJoinFloats, isEmptyLetFloats,
    44 44 
             doFloatFromRhs, getTopFloatBinds,
    ... ... @@ -79,6 +79,7 @@ import GHC.Types.Var.Set
    79 79 
     import GHC.Types.Id as Id
    80 80 
     import GHC.Types.InlinePragma ( ActivationGhc, CompilerPhase, isActiveInPhase )
    81 81 
     import GHC.Types.Basic
    82 
    +import GHC.Types.Tickish ( CoreTickish, tickishCounts, tickishHasSoftScope )
    82 83 
     import GHC.Types.Unique.FM      ( pprUniqFM )
    83 84
    84 85 
     import GHC.Data.OrdList
    ... ... @@ -745,45 +746,56 @@ setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst
    745 746
    746 747 
     Note [LetFloats]
    747 748 
     ~~~~~~~~~~~~~~~~
    748 
    -The LetFloats is a bunch of bindings, classified by a FloatFlag.
    749 
    +The LetFloats is a bunch of FloatBinds, collectively classified by a FloatFlag.
    749 750
    750 
    -The `FloatFlag` contains summary information about the bindings, see the data
    751 
    -type declaration of `FloatFlag`
    751 
    +The `FloatFlag` contains summary information about the bindings: see the data
    752 
    +type declaration of `FloatFlag`. A FloatBind can take one of three forms:
    753 
    +FloatLet, FloatCase, and FloatTick.  We discuss the FloatFlag for each form.
    752 754
    755 
    +Note [FloatFlag for FloatLet]  -- see `getFF_Let`
    756 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    753 757 
     Examples
    754 758
    755 
    -  NonRec x (y:ys)       FltLifted
    756 
    -  Rec [(x,rhs)]         FltLifted
    757 
    -
    758 
    -  NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?
    759 
    -  NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n
    760 
    -
    761 
    -  NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge
    762 
    -  NonRec x# (a /# b)    FltCareful  -- Might fail; does not satisfy let-can-float invariant
    763 
    -  NonRec x# (f y)       FltCareful  -- Might diverge; does not satisfy let-can-float invariant
    764 
    -
    765 
    -A binding that does not satisfy the let-can-float invariant (the last two
    766 
    -examples above) is represented by a FloatCase, not a FloatLet:
    767 
    -  FloatCase (a /# b) x# DEFAULT []
    768 
    -That is done once and for all by `unitLetFloat`, so a FloatLet in a LetFloats
    769 
    -is always a valid let-binding, and `wrapFloats` does not need to check.
    770 
    -Such bindings can arise from `makeTrivial`, because an argument need not
    771 
    -satisfy the let-can-float invariant.  They also arise because
    772 
    -exprOkForSpeculation is conservative: e.g. it says False for (# s, x #)
    773 
    -where x is lifted, because it checks the arguments against the
    774 
    -(representation-polymorphic) type of the unboxed-tuple worker.
    775 
    -
    776 
    -However, a FloatLet can still be FltCareful: the first FltCareful example
    777 
    -above, NonRec x* (f y), where x* is lifted but has a strict demand
    778 
    -(isStrUsedDmd).  That is a perfectly valid (lazy) let-binding, but its demand
    779 
    -info is valid only where it is.  If we floated it out of the RHS of a lazy
    780 
    -binding
    781 
    -     let v = let x* = f y in x*+1 in body
    782 
    - ==> let x* = f y; v = x*+1 in body
    783 
    -then x's demand info would be a lie, and CorePrep, which case-binds a let
    784 
    -whose binder has a strict demand, would evaluate (f y) eagerly.  Hence
    785 
    -FltCareful, which doFloatFromRhs allows to float only out of a strict binding.
    786 
    -
    759 
    +    NonRec x (y:ys)       FltLifted
    760 
    +    Rec [(x,rhs)]         FltLifted
    761 
    +
    762 
    +    NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?
    763 
    +    NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n
    764 
    +
    765 
    +    NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge
    766 
    +    NonRec x# (a /# b)    FltCareful  -- Might fail; does not satisfy let-can-float invariant
    767 
    +    NonRec x# (f y)       FltCareful  -- Might diverge; does not satisfy let-can-float invariant
    768 
    +
    769 
    +    NonRec s "foo"#       FltLifted   -- Literal string can go to top level
    770 
    +
    771 
    +* (FFL1) Note that a FloatLet can still be FltCareful: the first FltCareful example
    772 
    +  above, NonRec x* (f y), where x* is lifted but has a strict demand
    773 
    +  (isStrUsedDmd).  That is a perfectly valid (lazy) let-binding, but its demand
    774 
    +  info is valid only where it is.  If we floated it out of the RHS of a lazy
    775 
    +  binding
    776 
    +       let v = let x* = f y in x*+1 in body
    777 
    +   ==> let x* = f y; v = x*+1 in body
    778 
    +  then x's demand info would be a lie, and CorePrep, which case-binds a let
    779 
    +  whose binder has a strict demand, would evaluate (f y) eagerly.  Hence
    780 
    +  FltCareful, which doFloatFromRhs allows to float only out of a strict binding.
    781 
    +
    782 
    +* (FFL2) A literal-string binding is marked FltLifted (a bit of a mis-nomer
    783 
    +  because it's not a lifted type) because it can go to top level.
    784 
    +  See Note [Core top-level string literals] in GHC.Core.
    785 
    +
    786 
    +* A binding that does not satisfy the let-can-float invariant (the last two
    787 
    +  examples above) is represented by a FloatCase, not a FloatLet:
    788 
    +    FloatCase (a /# b) x# DEFAULT []
    789 
    +  That is done once and for all by `unitLetFloat`, so a FloatLet in a LetFloats
    790 
    +  is always a valid let-binding, and `wrapFloats` does not need to check.
    791 
    +  Such bindings can arise from `makeTrivial`, because an argument need not
    792 
    +  satisfy the let-can-float invariant.  They also arise because
    793 
    +  exprOkForSpeculation is conservative: e.g. it says False for (# s, x #)
    794 
    +  where x is lifted, because it checks the arguments against the
    795 
    +  (representation-polymorphic) type of the unboxed-tuple worker.
    796 
    +
    797 
    +Note [FloatFlag for FloatCase]  -- see `getFF_Case`
    798 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    787 799 
     As well as let-bindings, a LetFloats can contain single-alternative case
    788 800 
     floats (FloatCase), for example
    789 801 
       case e of b { (# a, c #) -> <hole> }
    ... ... @@ -795,12 +807,29 @@ These are classified just like a strict binding:
    795 807 
     Being strict they are never FltLifted, so they never float to top level or into
    796 808 
     a recursive group.
    797 809
    798 
    -Currently, we never put a FloatTick in a LetFloats.
    810 
    +Note [FloatFlag for FloatTick]  -- see `getFF_Tick`
    811 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    812 
    +A LetFloats can contain a FloatTick for soft-scoped ticks (only -- see the
    813 
    +invariant on FloatTick in GHC.Core).
    814 
    +
    815 
    +* We certainly don't want a tick to go to top level, or into a recursive group,
    816 
    +  so its FloatFlag is never FltLifted.
    817 
    +
    818 
    +* A /non-counting/ tick (e.g. a source note) is FltOkSpec.  Floating it out of
    819 
    +  the RHS of a lazy binding
    820 
    +       let x = tick<t> (let y = e1 in e2) in body
    821 
    +   ==> tick<t> (let y = e1 in let x = e2 in body)
    822 
    +  just brings more code (here `body`) under the tick, which is fine for a
    823 
    +  soft-scoped tick.
    824 
    +
    825 
    +* A /counting/ tick (e.g. an HPC tick) is FltCareful.  Floating it out of a lazy
    826 
    +  RHS would change when (and how often) it is counted: when the let is
    827 
    +  executed rather than when `x` is evaluated.
    799 828 
     -}
    800 829
    801 830 
     data LetFloats = LetFloats FloatBinds FloatFlag
    802 831 
                      -- See Note [LetFloats]
    803 
    -                 -- Contains only FloatLet and FloatCase; never FloatTick
    832 
    +                 -- Invariant: every FloatLet satisfies the let-can-float invariant
    804 833
    805 834 
     type JoinFloat  = OutBind
    806 835 
     type JoinFloats = OrdList JoinFloat
    ... ... @@ -817,7 +846,7 @@ data FloatFlag
    817 846 
                     --        *and* ok-for-speculation
    818 847 
                     -- Hence ok to float out of the RHS
    819 848 
                     -- of a lazy non-recursive let binding
    820 
    -                -- (but not to top level, or into a rec group)
    849 
    +                -- (but /not/ to top level, or into a rec group)
    821 850 
                     -- NB: consequence: all bindings satisfy let-can-float invariant
    822 851
    823 852 
       | FltCareful  -- At least one binding is strict (or unlifted)
    ... ... @@ -899,37 +928,50 @@ emptyJoinFloats = nilOL
    899 928 
     isEmptyJoinFloats :: JoinFloats -> Bool
    900 929 
     isEmptyJoinFloats = isNilOL
    901 930
    931 
    +getFF :: FloatBind -> FloatFlag
    932 
    +getFF (FloatCase e _ _ _) = getFF_Case e
    933 
    +getFF (FloatLet b)        = getFF_Let b
    934 
    +getFF (FloatTick t)       = getFF_Tick t
    935 
    +
    936 
    +getFF_Let :: CoreBind -> FloatFlag
    937 
    +-- See Note [FloatFlag for FloatLet]
    938 
    +getFF_Let (Rec {})        = FltLifted
    939 
    +getFF_Let (NonRec bndr rhs)
    940 
    +  | not (isStrictId bndr)    = FltLifted   -- Lazy lifted let
    941 
    +  | exprIsTickedString rhs   = FltLifted   -- See (FFL2)
    942 
    +  | exprOkForSpeculation rhs = FltOkSpec   -- Unlifted, or strict lifted, and ok-for-spec (e.g. HNF)
    943 
    +  | otherwise                = FltCareful  -- See (FFL1) Strict, e.g. let x* = factorial y
    944 
    +
    945 
    +getFF_Case :: CoreExpr -> FloatFlag   -- The CoreExpr is the scrutinee
    946 
    +-- Note [FloatFlag for FloatCase]
    947 
    +getFF_Case scrut | exprOkForSpeculation scrut = FltOkSpec
    948 
    +                 | otherwise                  = FltCareful
    949 
    +
    950 
    +getFF_Tick :: CoreTickish -> FloatFlag
    951 
    +-- See Note [FloatFlag for FloatTick]
    952 
    +getFF_Tick t | tickishCounts t = FltCareful
    953 
    +             | otherwise       = FltOkSpec
    954 
    +
    902 955 
     unitLetFloat :: OutBind -> LetFloats
    903 956 
     -- This key function constructs a singleton float with the right form
    904 957 
     -- If the binding does not satisfy the let-can-float invariant, it
    905 958 
     -- makes a FloatCase. See Note [LetFloats]
    906 
    -unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $
    907 
    -                    mk_float bind
    908 
    -  where
    909 
    -    mk_float bind@(Rec {})       = let_float FltLifted bind
    910 
    -    mk_float bind@(NonRec bndr rhs)
    911 
    -      | not (isStrictId bndr)    = let_float FltLifted bind
    912 
    -      | exprIsTickedString rhs   = let_float FltLifted bind
    913 
    -          -- String literals can be floated freely.
    914 
    -          -- See Note [Core top-level string literals] in GHC.Core.
    915 
    -      | exprOkForSpeculation rhs = let_float FltOkSpec bind  -- Unlifted, and lifted but ok-for-spec (eg HNF)
    916 
    -      | needsCaseBinding (idType bndr) rhs
    917 
    -      = pprTrace "TMP-unitLetFloat-case" (ppr bind) $
    918 
    -        LetFloats (unitOL (FloatCase rhs bndr DEFAULT [])) FltCareful
    919 
    -          -- Unlifted, and not ok-for-spec: does not satisfy let-can-float invariant
    920 
    -      | otherwise                = let_float FltCareful bind
    921 
    -
    922 
    -    let_float flag bind = LetFloats (unitOL (FloatLet bind)) flag
    959 
    +unitLetFloat bind
    960 
    +  | NonRec bndr rhs <- bind
    961 
    +  , needsCaseBinding (idType bndr) rhs
    962 
    +  = -- This should never happen, but currently does because of #27910
    963 
    +    LetFloats (unitOL (FloatCase rhs bndr DEFAULT [])) FltCareful
    964 
    +
    965 
    +  | otherwise
    966 
    +  = assert (all (not . isJoinId) (bindersOf bind)) $
    967 
    +    LetFloats (unitOL (FloatLet bind)) (getFF_Let bind)
    923 968
    924 969 
     unitCaseFloat :: OutExpr -> OutId -> AltCon -> [OutVar] -> LetFloats
    925 970 
     -- Constructs a singleton single-alternative case float
    926 971 
     --   case scrut of bndr { con bndrs -> <hole> }
    927 972 
     -- See Note [LetFloats]
    928 973 
     unitCaseFloat scrut bndr con bndrs
    929 
    -  = LetFloats (unitOL (FloatCase scrut bndr con bndrs)) flag
    930 
    -  where
    931 
    -    flag | exprOkForSpeculation scrut = FltOkSpec
    932 
    -         | otherwise                  = FltCareful
    974 
    +  = LetFloats (unitOL (FloatCase scrut bndr con bndrs)) (getFF_Case scrut)
    933 975
    934 976 
     unitJoinFloat :: OutBind -> JoinFloats
    935 977 
     unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $
    ... ... @@ -978,12 +1020,34 @@ addLetFloats :: SimplFloats -> LetFloats -> SimplFloats
    978 1020 
     -- Add the let-floats for env2 to env1;
    979 1021 
     -- *plus* the in-scope set for env2, which is bigger
    980 1022 
     -- than that for env1
    981 
    -addLetFloats floats let_floats
    1023 
    +addLetFloats floats let_floats@(LetFloats fbs _)
    982 1024 
       = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats
    983 
    -           , sfInScope   = sfInScope floats `extendInScopeFromLF` let_floats }
    984 
    -
    985 
    -extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet
    986 
    -extendInScopeFromLF in_scope (LetFloats binds _)
    1025 
    +           , sfInScope   = sfInScope floats `extendInScopeFromFB` fbs }
    1026 
    +
    1027 
    +addFloatBindsF :: FloatBinds -> SimplFloats -> SimplFloats
    1028 
    +-- (addFloatBindsF new_fbs floats) adds `new_fbs` /outside/ `floats`;
    1029 
    +-- i.e. `new_fbs` scope over `floats`
    1030 
    +-- Precondition: every FloatLet in `new_fbs` satisfies the let-can-float
    1031 
    +-- invariant (see the FloatBind declaration in GHC.Core), so we can add
    1032 
    +-- them directly; see Note [LetFloats]
    1033 
    +addFloatBindsF new_fbs floats@(SimplFloats { sfLetFloats = LetFloats lf_fbs lf_ff
    1034 
    +                                           , sfInScope = in_scope })
    1035 
    +  | isNilOL new_fbs
    1036 
    +  = floats
    1037 
    +  | otherwise
    1038 
    +  = assertPpr (all ok_float new_fbs) (ppr new_fbs) $
    1039 
    +    floats { sfLetFloats = LetFloats (new_fbs `appOL` lf_fbs)
    1040 
    +                                     (foldr (andFF . getFF) lf_ff new_fbs)
    1041 
    +           , sfInScope   = in_scope `extendInScopeFromFB` new_fbs }
    1042 
    +  where
    1043 
    +    -- Check the invariants on FloatBind; see its declaration in GHC.Core
    1044 
    +    ok_float (FloatLet (NonRec b r))
    1045 
    +      | isId b, not (isCoVar b) = not (needsCaseBinding (idType b) r)
    1046 
    +    ok_float (FloatTick t)      = tickishHasSoftScope t
    1047 
    +    ok_float _                  = True
    1048 
    +
    1049 
    +extendInScopeFromFB :: InScopeSet -> FloatBinds -> InScopeSet
    1050 
    +extendInScopeFromFB in_scope binds
    987 1051 
       = foldlOL extend in_scope binds
    988 1052 
       where
    989 1053 
         extend in_scope (FloatLet bind)        = in_scope `extendInScopeSetBind` bind

  • compiler/GHC/Core/Opt/Simplify/Iteration.hs
    ... ... @@ -66,7 +66,7 @@ import GHC.Builtin.WiredIn.Ids( seqId )
    66 66 
     import qualified GHC.Data.List.Infinite as Inf
    67 67 
     import GHC.Data.Maybe   ( isNothing, orElse, mapMaybe )
    68 68 
     import GHC.Data.FastString
    69 
    -import GHC.Data.OrdList ( fromOL )  -- TMP
    69 
    +import GHC.Data.OrdList ( unitOL )
    70 70 
     import GHC.Unit.Module ( moduleName )
    71 71 
     import GHC.Utils.Outputable
    72 72 
     import GHC.Utils.Panic
    ... ... @@ -1287,7 +1287,8 @@ simplExprF1 env expr@(Lam {}) cont
    1287 1287 
             -- and likewise drop counts all binders (incl type lambdas)
    1288 1288
    1289 1289 
     simplExprF1 env expr@(Case scrut bndr _ alts) cont
    1290 
    -  | Just (inner, outer) <- splitContForNoCaseCase env cont
    1290 
    +  | Just (inner, outer) <- splitContForNoCaseCase env (isSingleton alts) cont
    1291 
    +       -- isSingleton: push casts inside only if there is just one alternative
    1291 1292 
            -- See (COC-INV) in Note [sm_case_case: switching off case continuations]
    1292 1293 
       = do { (floats, expr') <- simplExprF env expr inner
    1293 1294 
            ; rebuildWithFloats env floats expr' outer }
    ... ... @@ -1314,9 +1315,12 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont
    1314 1315 
              tick (PreInlineUnconditionally bndr)
    1315 1316 
            ; simplExprF env' body cont }
    1316 1317
    1317 
    -simplExprF1 env expr@(Let {}) cont
    1318 
    -  | Just (inner, outer) <- splitContForNoCaseCase env cont
    1318 
    +simplExprF1 env expr@(Let bind _) cont
    1319 
    +  | Just (inner, outer) <- splitContForNoCaseCase env (not (mightBeJoinBind bind)) cont
    1319 1320 
            -- See (COC-INV) in Note [sm_case_case: switching off case continuations]
    1321 
    +       -- mightBeJoinBind: do not push a cast into a join point's RHS, because
    1322 
    +       -- then we'd have to push it to every jump, including those in
    1323 
    +       -- multi-alternative cases, where we don't want to push casts
    1320 1324 
       = do { (floats, expr') <- simplExprF env expr inner
    1321 1325 
            ; rebuildWithFloats env floats expr' outer }
    1322 1326
    ... ... @@ -1342,13 +1346,22 @@ simplExprF1 env (Let (Rec pairs) body) cont
    1342 1346 
         simplRecE env pairs body cont
    1343 1347
    1344 1348
    1345 
    -splitContForNoCaseCase :: SimplEnv -> SimplCont
    1349 
    +mightBeJoinBind :: InBind -> Bool
    1350 
    +-- True if joinPointBind_maybe might succeed; cheap and conservative
    1351 
    +mightBeJoinBind bind = any might_be_join (bindersOf bind)
    1352 
    +  where
    1353 
    +    might_be_join b = isId b && (isJoinId b || isAlwaysTailCalled (idOccInfo b))
    1354 
    +
    1355 
    +splitContForNoCaseCase :: SimplEnv
    1356 
    +                       -> Bool   -- True <=> casts may go in `inner`
    1357 
    +                       -> SimplCont
    1346 1358 
                            -> Maybe (SimplCont, SimplCont)
    1347 1359 
     -- When seCaseCase is off, this function splits `cont` into (inner, outer),
    1348 
    --- where `inner` has only applications, and `outer` is non-trivial
    1349 
    -splitContForNoCaseCase env cont
    1360 
    +-- where `inner` has only applications (and perhaps casts), and `outer` is
    1361 
    +-- non-trivial.  See splitContArgs for the Bool.
    1362 
    +splitContForNoCaseCase env push_casts cont
    1350 1363 
       | seCaseCase env = Nothing
    1351 
    -  | otherwise      = splitContArgs cont
    1364 
    +  | otherwise      = splitContArgs push_casts cont
    1352 1365
    1353 1366 
     {- Note [Avoiding space leaks in OutType]
    1354 1367 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -1503,10 +1516,16 @@ simplTick env tickish expr cont
    1503 1516 
       -- push the continuation inside the tick.  This has the effect of moving the
    1504 1517 
       -- tick to the outside of a case or application context, allowing the normal
    1505 1518 
       -- 'case' and 'application' optimisations to fire.
    1519 
    +  --
    1520 
    +  -- We return the tick as a FloatTick, /outside/ the floats from `expr`.
    1521 
    +  -- So all the code that was covered by the tick (including the floats,
    1522 
    +  -- notably single-alternative case floats) remains covered, as soft scope
    1523 
    +  -- requires; and yet `expr'` is exposed to the caller, e.g. for
    1524 
    +  -- case-of-known-constructor in rebuildWithFloats.
    1525 
    +  -- See Note [FloatFlag for FloatTick] in GHC.Core.Opt.Simplify.Env
    1506 1526 
       | tickishHasSoftScope tickish
    1507 1527 
       = do { (floats, expr') <- simplExprF env expr cont
    1508 
    -       ; return (floats, mkTick tickish expr')
    1509 
    -       }
    1528 
    +       ; return (unitOL (FloatTick tickish) `addFloatBindsF` floats, expr') }
    1510 1529
    1511 1530 
       -- Push tick inside if the context looks like this will allow us to
    1512 1531 
       -- do a case-of-case - see Note [case-of-scc-of-case]
    ... ... @@ -2431,7 +2450,7 @@ simplOutId env fun cont
    2431 2450 
       , ApplyToTy  { sc_cont = cont2 } <- cont1
    2432 2451 
       , ApplyToVal { sc_cont = cont3, sc_arg = arg, sc_env = arg_se
    2433 2452 
                    , sc_cast = arg_mco, sc_hole_ty = fun_ty } <- cont2
    2434 
    -  = case splitContForNoCaseCase env cont3 of
    2453 
    +  = case splitContForNoCaseCase env True cont3 of
    2435 2454 
           Nothing -> do { e' <- simplRunRW env fun arg arg_se arg_mco fun_ty cont3
    2436 2455 
                         ; return (emptyFloats env, e') }
    2437 2456 
           Just (ink,outk) -> do { e' <- simplRunRW env fun arg arg_se arg_mco fun_ty ink
    ... ... @@ -2838,14 +2857,10 @@ fireRuleAFTER env rule_match arg_specs cont
    2838 2857 
       | RM { rm_rule = rule, rm_rhs = rhs, rm_args = rhs_args
    2839 2858 
            , rm_floats = float_bs } <- rule_match
    2840 2859 
       = do { let env' = env `addNewInScopeIds` floatsBinders float_bs
    2841 
    -       ; (floats, e') <- simplExprF env' rhs $
    2842 
    -                         pushOutArgs (exprType rhs) rhs_args $
    2843 
    -                         pushArgSpecs (drop (ruleArity rule) arg_specs) cont
    2844 
    -       ; return $
    2845 
    -         if isEmptyFloatBinds float_bs  -- Not very pretty
    2846 
    -         then (floats, e')
    2847 
    -         else (emptyFloats env', GHC.Core.Make.wrapFloats float_bs $
    2848 
    -                                 wrapFloats floats e') }
    2860 
    +       ; addFloatBinds (contHoleScaling cont) float_bs $
    2861 
    +         simplExprF env' rhs $
    2862 
    +         pushOutArgs (exprType rhs) rhs_args $
    2863 
    +         pushArgSpecs (drop (ruleArity rule) arg_specs) cont }
    2849 2864
    2850 2865
    2851 2866 
     tryRules :: SimplEnv -> [CoreRule]
    ... ... @@ -3553,7 +3568,6 @@ robust here. (Otherwise, there's a danger that we'll simply drop the
    3553 3568
    3554 3569 
     Note [Scaling in case-of-case]
    3555 3570 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    3556 
    -
    3557 3571 
     When two cases commute, if done naively, the multiplicities will be wrong:
    3558 3572
    3559 3573 
       case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]
    ... ... @@ -3991,22 +4005,22 @@ All this should happen in one sweep.
    3991 4005
    3992 4006 
     Note [FloatBinds from constructor wrappers]
    3993 4007 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    3994 
    -If we have FloatBinds coming from the constructor wrapper
    3995 
    -(as in Note [exprIsConApp_maybe on data constructors with wrappers]),
    3996 
    -we cannot float past them. We'd need to float the FloatBind
    3997 
    -together with the simplify floats, unfortunately the
    3998 
    -simplifier doesn't have case-floats. The simplest thing we can
    3999 
    -do is to wrap all the floats here. The next iteration of the
    4000 
    -simplifier will take care of all these cases and lets.
    4008 
    +exprIsConApp_maybe may return FloatBinds, e.g. coming from a constructor
    4009 
    +wrapper (as in Note [exprIsConApp_maybe on data constructors with wrappers]),
    4010 
    +or from looking through lets and single-alternative cases in the scrutinee.
    4011 
    +These floats scope over the result of case-of-known-constructor.
    4012 
    +
    4013 
    +Since the Simplifier's floats can contain case-floats as well as let-floats
    4014 
    +(see Note [LetFloats] in GHC.Core.Opt.Simplify.Env), we simply add them to
    4015 
    +the SimplFloats, outside the floats from simplifying the alternative; see
    4016 
    +knownConCase_maybe.  We do not wrap them around the result, because then a
    4017 
    +subsequent case-of-known-constructor on the result would have to walk
    4018 
    +through them all over again, which can be quadratic (#27737).
    4001 4019
    4002 4020 
     Given data T = MkT !Bool, this allows us to simplify
    4003 4021 
     case $WMkT b of { MkT x -> f x }
    4004 4022 
     to
    4005 4023 
     case b of { b' -> f b' }.
    4006 
    -
    4007 
    -We could try and be more clever (like maybe `wfloats` only contains
    4008 
    -let binders, so we could float them). But the need for the extra
    4009 
    -complication is not clear.
    4010 4024 
     -}
    4011 4025
    4012 4026 
     knownConCase_maybe :: (SimplAltFlag, SimplEnv)
    ... ... @@ -4033,58 +4047,27 @@ knownConCase_maybe (saf,env) scrut case_bndr alts cont
    4033 4047 
             -- as well as when it's an explicit constructor application
    4034 4048 
       , let env0 = setInScopeSet env in_scope'
    4035 4049 
       = Just $
    4036 
    -    (if isEmptyFloatBinds wfloats then id else
    4037 
    -       pprTrace "TMP-knownCon" (vcat [ text "nfloats" <+> ppr (length (fromOL wfloats))
    4038 
    -                                     , text "scrut" <+> ppr scrut ])) $
    4039 4050 
         do  { tick (KnownBranch case_bndr)
    4040 4051 
             ; let -- case_bndr_unf: see Note [Do not duplicate constructor applications]
    4041 4052 
                   case_bndr_rhs | exprIsTrivial scrut = scrut
    4042 4053 
                                 | otherwise           = con_app
    4043 4054 
                   con_app = Var (dataConWorkId con) `mkTyApps` ty_args
    4044 4055 
                                                     `mkApps`   other_args
    4045 
    -        ; wrapDataConFloats env wfloats case_bndr cont $
    4056 
    +          -- The wfloats scope over the result
    4057 
    +          -- See Note [FloatBinds from constructor wrappers]
    4058 
    +        ; addFloatBinds hole_scaling wfloats $
    4046 4059 
               case findAlt (DataAlt con) alts of
    4047 4060 
                 Nothing                   -> missingAlt env0 case_bndr alts cont
    4048 4061 
                 Just (Alt DEFAULT bs rhs) -> simpl_rhs env0 case_bndr_rhs bs rhs
    4049 4062 
                 Just (Alt _       bs rhs) -> knownCon env0 scrut con other_args
    4050 
    -                                                  case_bndr bs rhs cont
    4051 
    -        }
    4063 
    +                                                  case_bndr bs rhs cont }
    4052 4064
    4053 4065 
       | otherwise
    4054 4066 
       = Nothing
    4055 4067 
       where
    4056 
    -    simpl_rhs env case_bndr_rhs bs rhs
    4057 
    -      = assert (null bs) $
    4058 
    -        do { (floats1, env') <- simplAuxBind (saf,env) case_bndr case_bndr_rhs
    4059 
    -               -- scrut is a constructor application,
    4060 
    -               -- hence satisfies let-can-float invariant
    4061 
    -           ; (floats2, expr') <- simplExprF env' rhs cont
    4062 
    -           ; return (floats1 `addFloats` floats2, expr') }
    4063 
    -
    4064 
    -wrapDataConFloats :: SimplEnv -> FloatBinds -> InId -> SimplCont
    4065 
    -                 -> SimplM (SimplFloats, OutExpr)
    4066 
    -                 -> SimplM (SimplFloats, OutExpr)
    4067 
    --- See Note [FloatBinds from constructor wrappers]
    4068 
    -wrapDataConFloats env wfloats case_bndr cont thing_inside
    4069 
    -  | isEmptyFloatBinds wfloats
    4070 
    -  = thing_inside
    4071 
    -  | otherwise
    4072 
    -  = do { (floats, expr) <- thing_inside
    4073 
    -       ; return ( emptyFloats env
    4074 
    -                , GHC.Core.Make.wrapFloats (fmap scale_float wfloats) $
    4075 
    -                  wrapFloats floats expr ) }
    4076 
    -  where
    4077 
    -    -- scale_float scales case-floats by the multiplicity of the continuation hole
    4078 
    -    -- (see Note [Scaling in case-of-case]).
    4079 
    -    -- Let floats are _not_ scaled, because they are aliases anyway.
    4080 
    -    scale_float (GHC.Core.FloatCase scrut case_bndr con vars)
    4081 
    -      = GHC.Core.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)
    4082 
    -    scale_float flt@(GHC.Core.FloatLet {})  = flt
    4083 
    -    scale_float flt@(GHC.Core.FloatTick {}) = flt
    4084 
    -
    4085 
    -    scale_id id = scaleVarBy holeScaling id
    4086 
    -
    4087 
    -    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr
    4068 
    +    hole_scaling = idMult case_bndr `mkMultMul` contHoleScaling cont
    4069 
    +     -- See Note [Scaling in case-of-case]
    4070 
    +     -- This is the contHoleScaling of the original Select continuation
    4088 4071 
          -- We are in the following situation
    4089 4072 
          --   case[p] case[q] u of { D x -> C v } of { C x -> w }
    4090 4073 
          -- And we are producing case[??] u of { D x -> w[x\v]}
    ... ... @@ -4100,6 +4083,33 @@ wrapDataConFloats env wfloats case_bndr cont thing_inside
    4100 4083 
          -- Which is ill-typed with respect to linearity. So it needs to be a
    4101 4084 
          -- case[Many].
    4102 4085
    4086 
    +    simpl_rhs env case_bndr_rhs bs rhs
    4087 
    +      = assert (null bs) $
    4088 
    +        do { (floats1, env') <- simplAuxBind (saf,env) case_bndr case_bndr_rhs
    4089 
    +               -- scrut is a constructor application,
    4090 
    +               -- hence satisfies let-can-float invariant
    4091 
    +           ; (floats2, expr') <- simplExprF env' rhs cont
    4092 
    +           ; return (floats1 `addFloats` floats2, expr') }
    4093 
    +
    4094 
    +addFloatBinds :: Mult -> FloatBinds
    4095 
    +              -> SimplM (SimplFloats, a) -> SimplM (SimplFloats, a)
    4096 
    +-- (addFloatBinds scaling fbs thing_inside) adds `fbs` outside the floats
    4097 
    +-- returned by `thing_inside`.  The `scaling` is the multiplicity of the
    4098 
    +-- continuation hole, by which case-floats are scaled, because they now
    4099 
    +-- scope over that continuation: see Note [Scaling in case-of-case].
    4100 
    +-- Let floats do not need this treatment
    4101 
    +addFloatBinds scaling fbs thing_inside
    4102 
    +  | isEmptyFloatBinds fbs     -- Short cut
    4103 
    +  = thing_inside
    4104 
    +  | otherwise
    4105 
    +  = do { (floats, res) <- thing_inside
    4106 
    +       ; return (fmap scale_float fbs `addFloatBindsF` floats, res) }
    4107 
    +  where
    4108 
    +    scale_float (FloatCase scrut b con vars)
    4109 
    +      = FloatCase scrut (scale_id b) con (map scale_id vars)
    4110 
    +    scale_float flt = flt
    4111 
    +
    4112 
    +    scale_id id = scaleVarBy scaling id
    4103 4113
    4104 4114 
     knownCon :: SimplEnv
    4105 4115 
              -> OutExpr                                  -- The scrutinee

  • compiler/GHC/Core/Opt/Simplify/Utils.hs
    ... ... @@ -632,19 +632,24 @@ contOutArgs env cont
    632 632 
         -- No more arguments
    633 633 
         go _ = []
    634 634
    635 
    -splitContArgs :: SimplCont -> Maybe (SimplCont, SimplCont)
    636 
    --- Splits `cont` into (inner, outer), where `inner` has only
    637 
    --- applications and casts, and `outer` is non-trivial
    638 
    -splitContArgs cont@(ApplyToTy { sc_cont = cont1 })
    639 
    -  = do { (inner, outer) <- splitContArgs cont1
    635 
    +splitContArgs :: Bool -> SimplCont -> Maybe (SimplCont, SimplCont)
    636 
    +-- (splitContArgs push_casts cont) splits `cont` into (inner, outer), where
    637 
    +-- `inner` has only applications, and casts if `push_casts` is True;
    638 
    +-- and `outer` is non-trivial.
    639 
    +-- The caller sets `push_casts` to False if `inner` will be pushed into many
    640 
    +-- case alternatives: pushing a cast into each of them duplicates the
    641 
    +-- coercion, which can be big (T5642)
    642 
    +splitContArgs push_casts cont@(ApplyToTy { sc_cont = cont1 })
    643 
    +  = do { (inner, outer) <- splitContArgs push_casts cont1
    640 644 
            ; return (cont { sc_cont = inner }, outer) }
    641 
    -splitContArgs cont@(ApplyToVal { sc_cont = cont1 })
    642 
    -  = do { (inner, outer) <- splitContArgs cont1
    645 
    +splitContArgs push_casts cont@(ApplyToVal { sc_cont = cont1 })
    646 
    +  = do { (inner, outer) <- splitContArgs push_casts cont1
    643 647 
            ; return (cont { sc_cont = inner }, outer) }
    644 
    -splitContArgs cont@(CastIt { sc_cont = cont1 })
    645 
    -  = do { (inner, outer) <- splitContArgs cont1
    648 
    +splitContArgs push_casts cont@(CastIt { sc_cont = cont1 })
    649 
    +  | push_casts
    650 
    +  = do { (inner, outer) <- splitContArgs push_casts cont1
    646 651 
            ; return (cont { sc_cont = inner }, outer) }
    647 
    -splitContArgs outer
    652 
    +splitContArgs _ outer
    648 653 
       | contIsStop outer = Nothing
    649 654 
       | otherwise        = -- pprTrace "splitContHoleType" (ppr hole_ty) $
    650 655 
                            return (mkBoringStop hole_ty, outer)

  • testsuite/tests/dmdanal/should_compile/T20510.stderr
    1 1
    2 2 
     ==================== Exitification transformation ====================
    3 3 
     Result size of Exitification transformation
    4 
    -  = {terms: 50, types: 22, coercions: 0, joins: 2/2}
    4 
    +  = {terms: 33, types: 15, coercions: 0, joins: 2/2}
    5 5
    6 6 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    7 7 
     lvl :: Int
    ... ... @@ -11,7 +11,7 @@ lvl :: Int
    11 11 
              Guidance=IF_ARGS [] 10 10}]
    12 12 
     lvl = GHC.Internal.Types.I# 0#
    13 13
    14 
    --- RHS size: {terms: 32, types: 14, coercions: 0, joins: 2/2}
    14 
    +-- RHS size: {terms: 29, types: 12, coercions: 0, joins: 2/2}
    15 15 
     small :: Int -> Int
    16 16 
     [LclIdX,
    17 17 
      Arity=1,
    ... ... @@ -22,7 +22,7 @@ small :: Int -> Int
    22 22 
              Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
    23 23 
              Tmpl= \ (x [Dmd=S!P(SL)] :: Int) ->
    24 24 
                      joinrec {
    25 
    -                   go [InlPrag=[2], Occ=T[2], Dmd=LC(S,C(1,!P(L)))]
    25 
    +                   go [InlPrag=[2], Occ=Many(T[2]), Dmd=LC(S,C(1,!P(L)))]
    26 26 
                          :: Int -> Int -> Int
    27 27 
                        [LclId[JoinId(2)(Nothing)],
    28 28 
                         Arity=2,
    ... ... @@ -54,11 +54,11 @@ small :: Int -> Int
    54 54 
                                 Guidance=IF_ARGS [0 51] 63 10}]
    55 55 
                        $wgo (ww [Occ=Once2] :: GHC.Internal.Prim.Int#)
    56 56 
                             (ww [Occ=Once1!, Dmd=SL] :: GHC.Internal.Prim.Int#)
    57 
    -                     = case ww of ds {
    57 
    +                     = case ww of wild {
    58 58 
                              __DEFAULT ->
    59 59 
                                jump go
    60 
    -                             (GHC.Internal.Types.I# (GHC.Internal.Prim.+# ww ds))
    61 
    -                             (GHC.Internal.Types.I# (GHC.Internal.Prim.-# ds 1#));
    60 
    +                             (GHC.Internal.Types.I# (GHC.Internal.Prim.+# ww wild))
    61 
    +                             (GHC.Internal.Types.I# (GHC.Internal.Prim.-# wild 1#));
    62 62 
                              0# ->
    63 63 
                                case x of { GHC.Internal.Types.I# y [Occ=Once1] ->
    64 64 
                                GHC.Internal.Types.I# (GHC.Internal.Prim.*# ww y)
    ... ... @@ -67,13 +67,12 @@ small :: Int -> Int
    67 67 
                      jump go lvl x}]
    68 68 
     small
    69 69 
       = \ (x [Dmd=S!P(SL)] :: Int) ->
    70 
    +      case x of { GHC.Internal.Types.I# ww [Dmd=SL] ->
    70 71 
           join {
    71 72 
             exit :: GHC.Internal.Prim.Int# -> Int
    72 73 
             [LclId[JoinId(1)(Nothing)]]
    73 74 
             exit (ww :: GHC.Internal.Prim.Int#)
    74 
    -          = case x of { GHC.Internal.Types.I# y ->
    75 
    -            GHC.Internal.Types.I# (GHC.Internal.Prim.*# ww y)
    76 
    -            } } in
    75 
    +          = GHC.Internal.Types.I# (GHC.Internal.Prim.*# ww ww) } in
    77 76 
           joinrec {
    78 77 
             $wgo [InlPrag=[2], Occ=LoopBreaker]
    79 78 
               :: GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> Int
    ... ... @@ -82,56 +81,17 @@ small
    82 81 
              Str=<L><SL>,
    83 82 
              Unf=Unf{Src=<vanilla>, TopLvl=False,
    84 83 
                      Value=True, ConLike=True, WorkFree=True, Expandable=True,
    85 
    -                 Guidance=IF_ARGS [0 32] 43 10}]
    84 
    +                 Guidance=IF_ARGS [0 32] 33 10}]
    86 85 
             $wgo (ww :: GHC.Internal.Prim.Int#)
    87 86 
                  (ww [Dmd=SL] :: GHC.Internal.Prim.Int#)
    88 
    -          = case ww of ds {
    87 
    +          = case ww of wild {
    89 88 
                   __DEFAULT ->
    90 89 
                     jump $wgo
    91 
    -                  (GHC.Internal.Prim.+# ww ds) (GHC.Internal.Prim.-# ds 1#);
    90 
    +                  (GHC.Internal.Prim.+# ww wild) (GHC.Internal.Prim.-# wild 1#);
    92 91 
                   0# -> jump exit ww
    93 92 
                 }; } in
    94 
    -      case x of { GHC.Internal.Types.I# ww [Dmd=SL] -> jump $wgo 0# ww }
    95 
    -
    96 
    --- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    97 
    -$trModule :: GHC.Internal.Prim.Addr#
    98 
    -[LclId,
    99 
    - Unf=Unf{Src=<vanilla>, TopLvl=True,
    100 
    -         Value=True, ConLike=True, WorkFree=True, Expandable=True,
    101 
    -         Guidance=IF_ARGS [] 20 0}]
    102 
    -$trModule = "main"#
    103 
    -
    104 
    --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    105 
    -$trModule :: GHC.Internal.Types.TrName
    106 
    -[LclId,
    107 
    - Unf=Unf{Src=<vanilla>, TopLvl=True,
    108 
    -         Value=True, ConLike=True, WorkFree=True, Expandable=True,
    109 
    -         Guidance=IF_ARGS [] 10 10}]
    110 
    -$trModule = GHC.Internal.Types.TrNameS $trModule
    111 
    -
    112 
    --- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    113 
    -$trModule :: GHC.Internal.Prim.Addr#
    114 
    -[LclId,
    115 
    - Unf=Unf{Src=<vanilla>, TopLvl=True,
    116 
    -         Value=True, ConLike=True, WorkFree=True, Expandable=True,
    117 
    -         Guidance=IF_ARGS [] 30 0}]
    118 
    -$trModule = "T20510"#
    119 
    -
    120 
    --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    121 
    -$trModule :: GHC.Internal.Types.TrName
    122 
    -[LclId,
    123 
    - Unf=Unf{Src=<vanilla>, TopLvl=True,
    124 
    -         Value=True, ConLike=True, WorkFree=True, Expandable=True,
    125 
    -         Guidance=IF_ARGS [] 10 10}]
    126 
    -$trModule = GHC.Internal.Types.TrNameS $trModule
    127 
    -
    128 
    --- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    129 
    -T20510.$trModule :: GHC.Internal.Types.Module
    130 
    -[LclIdX,
    131 
    - Unf=Unf{Src=<vanilla>, TopLvl=True,
    132 
    -         Value=True, ConLike=True, WorkFree=True, Expandable=True,
    133 
    -         Guidance=IF_ARGS [] 10 10}]
    134 
    -T20510.$trModule = GHC.Internal.Types.Module $trModule $trModule
    93 
    +      jump $wgo 0# ww
    94 
    +      }
    135 95
    136 96
    137 97

  • testsuite/tests/show-bytecode/show-bytecode-hpc.stdout
    ... ... @@ -59,135 +59,133 @@ objects:
    59 59 
         arity: 0
    60 60 
         literals: label ‘_hpc_tickboxes_Example_hpc’
    61 61 
         used items: named item ‘primes’
    62 
    -  object ‘primes2_@name_suffix@’:
    62 
    +  object ‘primes’:
    63 63 
         arity: 0
    64 
    -    literals: label ‘_hpc_tickboxes_Example_hpc’
    65 
    -    used items:
    66 
    -      object ‘primes2_sat_@name_suffix@’:
    67 
    -        arity: 0
    68 
    -        literals: label ‘_hpc_tickboxes_Example_hpc’
    69 
    -        used items:
    70 
    -          object ‘primes2_sat_@name_suffix@’:
    71 
    -            arity: 0
    72 
    -            literals:
    73 
    -              label ‘_hpc_tickboxes_Example_hpc’
    74 
    -              word 3
    75 
    -              info table of ‘IS’
    76 
    -            used items:
    77 
    -              named item ‘$fNumNatural’
    78 
    -              named item ‘fromInteger’
    79 
    -          named item ‘$fEnumNatural’
    80 
    -          named item ‘enumFrom’
    81 
    -      object ‘primes2_sat_@name_suffix@’:
    82 
    -        arity: 0
    83 
    -        literals: label ‘_hpc_tickboxes_Example_hpc’
    84 
    -        used items: named item ‘isPrime_@name_suffix@’
    85 
    -      named item ‘filter’
    86 
    -  object ‘isPrime_@name_suffix@’:
    87 
    -    arity: 1
    88 64 
         literals:
    89 65 
           label ‘_hpc_tickboxes_Example_hpc’
    66 
    +      info table of ‘(:)’
    90 67 
         used items:
    91 
    -      object ‘isPrime_sat_@name_suffix@’:
    68 
    +      object ‘isPrime_@name_suffix@’:
    92 69 
             arity: 1
    93 
    -        literals: label ‘_hpc_tickboxes_Example_hpc’
    70 
    +        literals:
    71 
    +          label ‘_hpc_tickboxes_Example_hpc’
    94 72 
             used items:
    95 
    -          object ‘isPrime_sat_@name_suffix@’:
    73 
    +          object ‘isPrime_primes_sat_@name_suffix@’:
    96 74 
                 arity: 1
    97 75 
                 literals: label ‘_hpc_tickboxes_Example_hpc’
    98 76 
                 used items:
    99 
    -              object ‘isPrime_sat_@name_suffix@’:
    100 
    -                arity: 0
    101 
    -                literals: label ‘_hpc_tickboxes_Example_hpc’
    102 
    -                used items: named item ‘primes’
    103 
    -              object ‘isPrime_sat_@name_suffix@’:
    77 
    +              object ‘isPrime_primes_sat_@name_suffix@’:
    104 78 
                     arity: 1
    105 79 
                     literals: label ‘_hpc_tickboxes_Example_hpc’
    106 80 
                     used items:
    107 
    -                  object ‘isPrime_sat_@name_suffix@’:
    81 
    +                  object ‘isPrime_primes_sat_@name_suffix@’:
    108 82 
                         arity: 0
    109 83 
                         literals: label ‘_hpc_tickboxes_Example_hpc’
    110 
    -                    used items:
    111 
    -                      object ‘v_@name_suffix@’:
    112 
    -                        arity: 0
    113 
    -                        literals: label ‘_hpc_tickboxes_Example_hpc’
    114 
    -                        used items:
    115 
    -                          named item ‘$fIntegralInteger’
    116 
    -                          named item ‘$fNumNatural’
    117 
    -                          named item ‘(^)’
    118 
    -                      object ‘v1_@name_suffix@’:
    119 
    -                        arity: 0
    120 
    -                        literals:
    121 
    -                          label ‘_hpc_tickboxes_Example_hpc’
    122 
    -                          word 2
    123 
    -                          info table of ‘IS’
    124 
    -                        used items: <none>
    125 
    -                      object ‘pap_@name_suffix@’:
    126 
    -                        arity: 3
    127 
    -                        literals: <none>
    128 
    -                        used items: <none>
    129 
    -                  object ‘isPrime_sat_@name_suffix@’:
    84 
    +                    used items: named item ‘primes’
    85 
    +                  object ‘isPrime_primes_sat_@name_suffix@’:
    130 86 
                         arity: 1
    131 87 
                         literals: label ‘_hpc_tickboxes_Example_hpc’
    132 88 
                         used items:
    133 
    -                      object ‘v_@name_suffix@’:
    89 
    +                      object ‘isPrime_primes_sat_@name_suffix@’:
    134 90 
                             arity: 0
    135 91 
                             literals: label ‘_hpc_tickboxes_Example_hpc’
    136 92 
                             used items:
    137 
    -                          named item ‘$fOrdNatural’
    138 
    -                          named item ‘(<=)’
    139 
    -                      object ‘v1_@name_suffix@’:
    93 
    +                          object ‘v_@name_suffix@’:
    94 
    +                            arity: 0
    95 
    +                            literals: label ‘_hpc_tickboxes_Example_hpc’
    96 
    +                            used items:
    97 
    +                              named item ‘$fIntegralInteger’
    98 
    +                              named item ‘$fNumNatural’
    99 
    +                              named item ‘(^)’
    100 
    +                          object ‘v1_@name_suffix@’:
    101 
    +                            arity: 0
    102 
    +                            literals:
    103 
    +                              label ‘_hpc_tickboxes_Example_hpc’
    104 
    +                              word 2
    105 
    +                              info table of ‘IS’
    106 
    +                            used items: <none>
    107 
    +                          object ‘pap_@name_suffix@’:
    108 
    +                            arity: 3
    109 
    +                            literals: <none>
    110 
    +                            used items: <none>
    111 
    +                      object ‘isPrime_primes_sat_@name_suffix@’:
    140 112 
                             arity: 1
    141 113 
                             literals: label ‘_hpc_tickboxes_Example_hpc’
    142 
    -                        used items: <none>
    114 
    +                        used items:
    115 
    +                          object ‘v_@name_suffix@’:
    116 
    +                            arity: 0
    117 
    +                            literals: label ‘_hpc_tickboxes_Example_hpc’
    118 
    +                            used items:
    119 
    +                              named item ‘$fOrdNatural’
    120 
    +                              named item ‘(<=)’
    121 
    +                          object ‘v1_@name_suffix@’:
    122 
    +                            arity: 1
    123 
    +                            literals: label ‘_hpc_tickboxes_Example_hpc’
    124 
    +                            used items: <none>
    125 
    +                          object ‘pap_@name_suffix@’:
    126 
    +                            arity: 3
    127 
    +                            literals: <none>
    128 
    +                            used items: <none>
    129 
    +                      named item ‘(.)’
    130 
    +                  named item ‘takeWhile’
    131 
    +              object ‘isPrime_primes_sat_@name_suffix@’:
    132 
    +                arity: 1
    133 
    +                literals: label ‘_hpc_tickboxes_Example_hpc’
    134 
    +                used items:
    135 
    +                  object ‘v_@name_suffix@’:
    136 
    +                    arity: 0
    137 
    +                    literals: label ‘_hpc_tickboxes_Example_hpc’
    138 
    +                    used items:
    143 139 
                           object ‘pap_@name_suffix@’:
    144 
    -                        arity: 3
    140 
    +                        arity: 2
    145 141 
                             literals: <none>
    146 
    -                        used items: <none>
    147 
    -                  named item ‘(.)’
    148 
    -              named item ‘takeWhile’
    149 
    -          object ‘isPrime_sat_@name_suffix@’:
    150 
    -            arity: 1
    142 
    +                        used items:
    143 
    +                          named item ‘$fIntegralNatural’
    144 
    +                          named item ‘divides’
    145 
    +                  object ‘v1_@name_suffix@’:
    146 
    +                    arity: 1
    147 
    +                    literals: label ‘_hpc_tickboxes_Example_hpc’
    148 
    +                    used items: <none>
    149 
    +                  object ‘pap_@name_suffix@’:
    150 
    +                    arity: 3
    151 
    +                    literals: <none>
    152 
    +                    used items: <none>
    153 
    +              named item ‘$fFoldableList’
    154 
    +              named item ‘any’
    155 
    +          named item ‘not’
    156 
    +      object ‘primes_sat_@name_suffix@’:
    157 
    +        arity: 1
    158 
    +        literals: label ‘_hpc_tickboxes_Example_hpc’
    159 
    +        used items:
    160 
    +          object ‘primes_sat_@name_suffix@’:
    161 
    +            arity: 0
    151 162 
                 literals: label ‘_hpc_tickboxes_Example_hpc’
    152 163 
                 used items:
    153 
    -              object ‘v_@name_suffix@’:
    164 
    +              object ‘primes_sat_@name_suffix@’:
    154 165 
                     arity: 0
    155 
    -                literals: label ‘_hpc_tickboxes_Example_hpc’
    166 
    +                literals:
    167 
    +                  label ‘_hpc_tickboxes_Example_hpc’
    168 
    +                  word 3
    169 
    +                  info table of ‘IS’
    156 170 
                     used items:
    157 
    -                  object ‘pap_@name_suffix@’:
    158 
    -                    arity: 2
    159 
    -                    literals: <none>
    160 
    -                    used items:
    161 
    -                      named item ‘$fIntegralNatural’
    162 
    -                      named item ‘divides’
    163 
    -              object ‘v1_@name_suffix@’:
    164 
    -                arity: 1
    165 
    -                literals: label ‘_hpc_tickboxes_Example_hpc’
    166 
    -                used items: <none>
    167 
    -              object ‘pap_@name_suffix@’:
    168 
    -                arity: 3
    169 
    -                literals: <none>
    170 
    -                used items: <none>
    171 
    -          named item ‘$fFoldableList’
    172 
    -          named item ‘any’
    173 
    -      named item ‘not’
    174 
    -  object ‘primes’:
    175 
    -    arity: 0
    176 
    -    literals:
    177 
    -      label ‘_hpc_tickboxes_Example_hpc’
    178 
    -      info table of ‘(:)’
    179 
    -    used items:
    180 
    -      named item ‘primes2_@name_suffix@’
    181 
    -      named item ‘primes1_@name_suffix@’
    182 
    -  object ‘primes1_@name_suffix@’:
    183 
    -    arity: 0
    184 
    -    literals:
    185 
    -      label ‘_hpc_tickboxes_Example_hpc’
    186 
    -      word 2
    187 
    -      info table of ‘IS’
    188 
    -    used items:
    189 
    -      named item ‘$fNumNatural’
    190 
    -      named item ‘fromInteger’
    171 
    +                  named item ‘$fNumNatural’
    172 
    +                  named item ‘fromInteger’
    173 
    +              named item ‘$fEnumNatural’
    174 
    +              named item ‘enumFrom’
    175 
    +          object ‘primes_sat_@name_suffix@’:
    176 
    +            arity: 1
    177 
    +            literals: label ‘_hpc_tickboxes_Example_hpc’
    178 
    +            used items: <none>
    179 
    +          named item ‘filter’
    180 
    +      object ‘primes_sat_@name_suffix@’:
    181 
    +        arity: 0
    182 
    +        literals:
    183 
    +          label ‘_hpc_tickboxes_Example_hpc’
    184 
    +          word 2
    185 
    +          info table of ‘IS’
    186 
    +        used items:
    187 
    +          named item ‘$fNumNatural’
    188 
    +          named item ‘fromInteger’
    191 189 
       object ‘fibonaccisPtr’:
    192 190 
         arity: 0
    193 191 
         literals:
    ... ... @@ -245,63 +243,59 @@ objects:
    245 243 
         arity: 0
    246 244 
         literals: label ‘_hpc_tickboxes_Example_hpc’
    247 245 
         used items: named item ‘fibonaccis’
    248 
    -  object ‘positiveFibonaccis1_@name_suffix@’:
    246 
    +  object ‘fibonaccis’:
    249 247 
         arity: 0
    250 248 
         literals:
    251 249 
           label ‘_hpc_tickboxes_Example_hpc’
    252 250 
           info table of ‘(:)’
    253 251 
         used items:
    254 
    -      named item ‘positiveFibonaccis2_@name_suffix@’
    255 
    -      named item ‘positiveFibonaccis_@name_suffix@’
    256 
    -  object ‘positiveFibonaccis2_@name_suffix@’:
    257 
    -    arity: 0
    258 
    -    literals: label ‘_hpc_tickboxes_Example_hpc’
    259 
    -    used items:
    260 
    -      object ‘positiveFibonaccis2_sat_@name_suffix@’:
    261 
    -        arity: 0
    262 
    -        literals: label ‘_hpc_tickboxes_Example_hpc’
    263 
    -        used items: named item ‘positiveFibonaccis1_@name_suffix@’
    264 
    -      object ‘positiveFibonaccis2_sat_@name_suffix@’:
    265 
    -        arity: 0
    252 
    +      object ‘positiveFibonaccis_@name_suffix@’:
    253 
    +        arity: 1
    254 
    +        literals:
    255 
    +          label ‘_hpc_tickboxes_Example_hpc’
    256 
    +          info table of ‘(:)’
    257 
    +        used items:
    258 
    +          object ‘positiveFibonaccis_fibonaccis_sat_@name_suffix@’:
    259 
    +            arity: 1
    260 
    +            literals: label ‘_hpc_tickboxes_Example_hpc’
    261 
    +            used items:
    262 
    +              object ‘positiveFibonaccis_fibonaccis_sat_@name_suffix@’:
    263 
    +                arity: 1
    264 
    +                literals: label ‘_hpc_tickboxes_Example_hpc’
    265 
    +                used items: <none>
    266 
    +              object ‘positiveFibonaccis_fibonaccis_sat_@name_suffix@’:
    267 
    +                arity: 0
    268 
    +                literals: label ‘_hpc_tickboxes_Example_hpc’
    269 
    +                used items: named item ‘fibonaccis’
    270 
    +              object ‘positiveFibonaccis_fibonaccis_sat_@name_suffix@’:
    271 
    +                arity: 0
    272 
    +                literals: label ‘_hpc_tickboxes_Example_hpc’
    273 
    +                used items:
    274 
    +                  named item ‘$fNumNatural’
    275 
    +                  named item ‘(+)’
    276 
    +              named item ‘zipWith’
    277 
    +          object ‘positiveFibonaccis_fibonaccis_sat_@name_suffix@’:
    278 
    +            arity: 0
    279 
    +            literals:
    280 
    +              label ‘_hpc_tickboxes_Example_hpc’
    281 
    +              word 1
    282 
    +              info table of ‘IS’
    283 
    +            used items:
    284 
    +              named item ‘$fNumNatural’
    285 
    +              named item ‘fromInteger’
    286 
    +      object ‘fibonaccis_sat_@name_suffix@’:
    287 
    +        arity: 1
    266 288 
             literals: label ‘_hpc_tickboxes_Example_hpc’
    267 
    -        used items: named item ‘fibonaccis’
    268 
    -      object ‘positiveFibonaccis2_sat_@name_suffix@’:
    289 
    +        used items: <none>
    290 
    +      object ‘fibonaccis_sat_@name_suffix@’:
    269 291 
             arity: 0
    270 
    -        literals: label ‘_hpc_tickboxes_Example_hpc’
    292 
    +        literals:
    293 
    +          label ‘_hpc_tickboxes_Example_hpc’
    294 
    +          word 0
    295 
    +          info table of ‘IS’
    271 296 
             used items:
    272 297 
               named item ‘$fNumNatural’
    273 
    -          named item ‘(+)’
    274 
    -      named item ‘zipWith’
    275 
    -  object ‘fibonaccis’:
    276 
    -    arity: 0
    277 
    -    literals:
    278 
    -      label ‘_hpc_tickboxes_Example_hpc’
    279 
    -      info table of ‘(:)’
    280 
    -    used items:
    281 
    -      named item ‘fibonaccis2_@name_suffix@’
    282 
    -      named item ‘fibonaccis1_@name_suffix@’
    283 
    -  object ‘fibonaccis2_@name_suffix@’:
    284 
    -    arity: 0
    285 
    -    literals: label ‘_hpc_tickboxes_Example_hpc’
    286 
    -    used items: named item ‘positiveFibonaccis1_@name_suffix@’
    287 
    -  object ‘positiveFibonaccis_@name_suffix@’:
    288 
    -    arity: 0
    289 
    -    literals:
    290 
    -      label ‘_hpc_tickboxes_Example_hpc’
    291 
    -      word 1
    292 
    -      info table of ‘IS’
    293 
    -    used items:
    294 
    -      named item ‘$fNumNatural’
    295 
    -      named item ‘fromInteger’
    296 
    -  object ‘fibonaccis1_@name_suffix@’:
    297 
    -    arity: 0
    298 
    -    literals:
    299 
    -      label ‘_hpc_tickboxes_Example_hpc’
    300 
    -      word 0
    301 
    -      info table of ‘IS’
    302 
    -    used items:
    303 
    -      named item ‘$fNumNatural’
    304 
    -      named item ‘fromInteger’
    298 
    +          named item ‘fromInteger’
    305 299 
       object ‘$dTypeable2_@name_suffix@’:
    306 300 
         arity: 0
    307 301 
         literals: <none>

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/a9fdc56f3402665cecde73d79d6ae05de6b33db8 at 1791564118