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

Commits:

8 changed files:

Changes:

  • compiler/GHC/Core/Opt/Simplify/Iteration.hs
    ... ... @@ -474,14 +474,14 @@ leaving a simpler job for demand-analysis worker/wrapper. See #19874.
    474 474
    475 475 
     Wrinkles
    476 476
    477 
    -1. We must /not/ do cast w/w on
    477 
    +(CWW1) We must /not/ do cast w/w on
    478 478 
          f = g |> co
    479 479 
        otherwise it'll just keep repeating forever! You might think this
    480 480 
        is avoided because the call to tryCastWorkerWrapper is guarded by
    481 
    -   preInlineUnconditinally, but I'm worried that a loop-breaker or an
    482 
    -   exported Id might say False to preInlineUnonditionally.
    481 
    +   preInlineUnconditionally, but I'm worried that a loop-breaker or an
    482 
    +   exported Id might say False to preInlineUnconditionally.
    483 483
    484 
    -2. We need to be careful with inline/noinline pragmas:
    484 
    +(CWW2) We need to be careful with inline/noinline pragmas:
    485 485 
            rec { {-# NOINLINE f #-}
    486 486 
                  f = (...g...) |> co
    487 487 
                ; g = ...f... }
    ... ... @@ -496,15 +496,15 @@ Wrinkles
    496 496 
                f = $wf |> co
    497 497 
              ; g = ...f... }
    498 498 
        and that is bad: the whole point is that we want to inline that
    499 
    -   cast!  We want to transfer the pagma to $wf:
    499 
    +   cast!  We want to transfer the pragma to $wf:
    500 500 
           rec { {-# NOINLINE $wf #-}
    501 501 
                 $wf = ...g...
    502 502 
               ; f = $wf |> co
    503 503 
               ; g = ...f... }
    504 504 
        c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.
    505 505
    506 
    -3. We should still do cast w/w even if `f` is INLINEABLE.  E.g.
    507 
    -      {- f: Stable unfolding = <stable-big> -}
    506 
    +(CWW3) We should still do cast w/w even if `f` is INLINEABLE.  E.g.
    507 
    +      {- f: Stable unfolding (arity 2) = <stable-big> -}
    508 508 
           f = (\xy. <big-body>) |> co
    509 509 
        Then we want to w/w to
    510 510 
           {- $wf: Stable unfolding = <stable-big> |> sym co -}
    ... ... @@ -513,15 +513,43 @@ Wrinkles
    513 513 
        Notice that the stable unfolding moves to the worker!  Now demand analysis
    514 514 
        will work fine on $wf, whereas it has trouble with the original f.
    515 515 
        c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap.
    516 
    -   This point also applies to strong loopbreakers with INLINE pragmas, see
    517 
    -   wrinkle (4).
    518 516
    519 
    -4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence
    520 
    -   hasInlineUnfolding in tryCastWorkerWrapper, which responds False to
    521 
    -   loop-breakers) because they'll definitely be inlined anyway, cast and
    522 
    -   all. And if we do cast w/w for an INLINE function with arity zero, we get
    517 
    +(CWW4) We should /not/ do cast w/w for INLINE functions (hence `hasInlineUnfolding`
    518 
    +   in `tryCastWorkerWrapper`) because they'll definitely be inlined anyway, cast
    519 
    +   and all.
    520 
    +
    521 
    +   Moreover, if we do cast w/w for an INLINE function with arity zero, we get
    523 522 
        something really silly: we inline that "worker" right back into the wrapper!
    524 
    -   Worse than a no-op, because we have then lost the stable unfolding.
    523 
    +   In fact it is Much Worse than a no-op, because we have then lost the stable
    524 
    +   unfolding --- aargh (see #26903).  E.g. similar example to (CWW3)
    525 
    +      {- g: Stable unfolding (arity 0) = <stable-big> -}   NB arity 0!
    526 
    +      g = (\xy. <big-body>) |> co
    527 
    +   If we w/w to this:
    528 
    +      {- $wg: Stable unfolding (arity 0) = <stable-big> |> sym co -}
    529 
    +      $wg = \xy. <big-body>
    530 
    +      g = $wg |> co
    531 
    +   then we'll inline $wg at the call site in `g` giving
    532 
    +      {- $wg: Stable unfolding (arity 0) = <stable-big> |> sym co -}
    533 
    +      $wg = \xy. <big-body>
    534 
    +      g = (<stable-big> |> sym co) |> co
    535 
    +   and now we'll drop `$wg` as dead and we have lost the unfolding on `g`.
    536 
    +   (We could /also/ give the binding `g = $wf |> co` a stable unfolding. Then
    537 
    +   things would work right; but there is also no point in doing the cast
    538 
    +   worker/wrapper in the first place.)
    539 
    +
    540 
    +   NB: you might wonder about a loop-breaker with an INLINE pragma; after all, a
    541 
    +   loop breaker won't "definitely be inlined anyway", so arguably we should not
    542 
    +   disable cast w/w/ for it.  But a Rec group can /look/ recursive at an early
    543 
    +   stage, and subsequently /become/ non-recursive after some simplification.
    544 
    +   (This is common in instance decls; see Note [Checking for INLINE loop breakers]
    545 
    +   in GHC.Core.Lint.)  So the danger is that we'll permanently lose that stable
    546 
    +   unfolding that we specifically wanted (#26903).  Simple solution: disable cast
    547 
    +   w/w for /any/ INLINE function.  See the defn
    548 
    +   of `GHC.Types.Id.Info.hasInlineUnfolding`.
    549 
    +
    550 
    +   The danger is that an INLINE pragma on a genuninely-recursive function
    551 
    +   will kill worker-wrapper.  Well, so be it.  They are pretty suspicious anyway;
    552 
    +   see Note [Checking for INLINE loop breakers].
    525 553
    526 554 
     All these wrinkles are exactly like worker/wrapper for strictness analysis:
    527 555 
       f is the wrapper and must inline like crazy
    ... ... @@ -586,11 +614,11 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
    586 614 
       | BC_Let top_lvl is_rec <- bind_cxt  -- Not join points
    587 615 
       , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform
    588 616 
                             --            a DFunUnfolding in mk_worker_unfolding
    589 
    -  , not (exprIsTrivial rhs)        -- Not x = y |> co; Wrinkle 1
    590 
    -  , not (hasInlineUnfolding info)  -- Not INLINE things: Wrinkle 4
    591 
    -  , typeHasFixedRuntimeRep work_ty    -- Don't peel off a cast if doing so would
    592 
    -                                      -- lose the underlying runtime representation.
    593 
    -                                      -- See Note [Preserve RuntimeRep info in cast w/w]
    617 
    +  , not (exprIsTrivial rhs)          -- Not x = y |> co; see (CWW1)
    618 
    +  , not (hasInlineUnfolding info)    -- Not INLINE things: see (CWW4)
    619 
    +  , typeHasFixedRuntimeRep work_ty   -- Don't peel off a cast if doing so would
    620 
    +                                     -- lose the underlying runtime representation.
    621 
    +                                     -- See Note [Preserve RuntimeRep info in cast w/w]
    594 622 
       , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings
    595 623 
                                                        -- See Note [OPAQUE pragma]
    596 624 
       = do  { uniq <- getUniqueM
    ... ... @@ -637,13 +665,13 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
    637 665 
                                   `setArityInfo`      work_arity
    638 666 
                -- We do /not/ want to transfer OccInfo, Rules
    639 667 
                -- Note [Preserve strictness in cast w/w]
    640 
    -           -- and Wrinkle 2 of Note [Cast worker/wrapper]
    668 
    +           -- and (CWW2) of Note [Cast worker/wrapper]
    641 669
    642 670 
         ----------- Worker unfolding -----------
    643 671 
         -- Stable case: if there is a stable unfolding we have to compose with (Sym co);
    644 672 
         --   the next round of simplification will do the job
    645 673 
         -- Non-stable case: use work_rhs
    646 
    -    -- Wrinkle 3 of Note [Cast worker/wrapper]
    674 
    +    -- See (CWW4) of Note [Cast worker/wrapper]
    647 675 
         mk_worker_unfolding top_lvl work_id work_rhs
    648 676 
           = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers
    649 677 
                unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })

  • compiler/GHC/Core/Opt/WorkWrap.hs
    ... ... @@ -179,8 +179,9 @@ several liked-named Ids bouncing around at the same time---absolute
    179 179 
     mischief.)
    180 180
    181 181 
     Notice that we refrain from w/w'ing an INLINE function even if it is
    182 
    -in a recursive group.  It might not be the loop breaker.  (We could
    183 
    -test for loop-breaker-hood, but I'm not sure that ever matters.)
    182 
    +in a recursive group.  It might not be the loop breaker.  (We used to
    183 
    +test for loop-breaker-hood, but see (CWW4) in Note [Cast worker/wrapper]
    184 
    +in GHC.Core.Opt.Simplify.Iteration.)
    184 185
    185 186 
     Note [Worker/wrapper for INLINABLE functions]
    186 187 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  • compiler/GHC/Driver/Config/Core/Lint.hs
    ... ... @@ -132,8 +132,6 @@ perPassFlags dflags pass
    132 132 
                           -- there may be some INLINE knots still tied, which is tiresomely noisy
    133 133 
                           CoreDoSimplify cfg
    134 134 
                             | SimplPhase InitialPhase <- sm_phase (so_mode cfg)
    135 
    -                        -> True
    136 
    -                        | otherwise
    137 135 
                             -> False
    138 136 
                           _              -> True
    139 137

  • compiler/GHC/Types/Id/Info.hs
    ... ... @@ -610,7 +610,12 @@ hasInlineUnfolding :: IdInfo -> Bool
    610 610 
     -- ^ True of a /non-loop-breaker/ Id that has a /stable/ unfolding that is
    611 611 
     --   (a) always inlined; that is, with an `UnfWhen` guidance, or
    612 612 
     --   (b) a DFunUnfolding which never needs to be inlined
    613 
    -hasInlineUnfolding info = isInlineUnfolding (unfoldingInfo info)
    613 
    +--
    614 
    +-- Very important that this work with `realUnfoldingInfo` and so returns
    615 
    +-- True even for a loop-breaker that has an INLINE pragma.
    616 
    +-- See (CWW4) in Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify.Iteration
    617 
    +-- for discussion, and #26903 for the dire consequences of getting this wrong.
    618 
    +hasInlineUnfolding info = isInlineUnfolding (realUnfoldingInfo info)
    614 619
    615 620 
     setArityInfo :: IdInfo -> ArityInfo -> IdInfo
    616 621 
     setArityInfo info ar =

  • testsuite/tests/simplCore/should_compile/T26903.hs
    1 
    +{-# LANGUAGE DefaultSignatures #-}
    2 
    +module T26903 where
    3 
    +
    4 
    +newtype T a = MkT [a]
    5 
    +
    6 
    +class C a where
    7 
    +  op :: [a] -> [a] -> T a
    8 
    +
    9 
    +  -- This default method
    10 
    +  --  * Has an INLINE pragma
    11 
    +  --  * Is too big to inline without a pragma
    12 
    +  --  * Has arity zero
    13 
    +  {-# INLINE[1] op #-}
    14 
    +  default op :: Ord a => [a] -> [a] -> T a
    15 
    +  op = \xs ys -> MkT $ if xs>ys then reverse (reverse (reverse (reverse xs)))
    16 
    +                                else reverse (reverse (reverse (reverse (xs ++ ys))))
    17 
    +
    18 
    +instance C Int where {}
    19 
    +
    20 
    +test :: [Int] -> T Int
    21 
    +test xs = op [] xs
    22 
    +  -- We expect to see `op` inlined into the RHS of `test`
    23 
    +

  • testsuite/tests/simplCore/should_compile/T26903.stderr
    1 
    +
    2 
    +==================== Tidy Core ====================
    3 
    +Result size of Tidy Core
    4 
    +  = {terms: 127, types: 130, coercions: 48, joins: 0/0}
    5 
    +
    6 
    +$dmop
    7 
    +  = (\ @a _ $dOrd xs ys ->
    8 
    +       case $fOrdList_$ccompare $dOrd xs ys of {
    9 
    +         __DEFAULT ->
    10 
    +           reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [];
    11 
    +         GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) []
    12 
    +       })
    13 
    +    `cast` <Co:20> :: ...
    14 
    +
    15 
    +$fCInt_$cop
    16 
    +  = (\ xs ys ->
    17 
    +       case $fOrdList_$s$ccompare xs ys of {
    18 
    +         __DEFAULT ->
    19 
    +           reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [];
    20 
    +         GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) []
    21 
    +       })
    22 
    +    `cast` <Co:11> :: ...
    23 
    +
    24 
    +$fCInt1
    25 
    +  = \ xs ys ->
    26 
    +      case $fOrdList_$s$ccompare xs ys of {
    27 
    +        __DEFAULT ->
    28 
    +          reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [];
    29 
    +        GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) []
    30 
    +      }
    31 
    +
    32 
    +$fCInt = C:C ($fCInt1 `cast` <Co:11> :: ...)
    33 
    +
    34 
    +test4 = reverse1 [] []
    35 
    +
    36 
    +test3 = reverse1 test4 []
    37 
    +
    38 
    +test2 = reverse1 test3 []
    39 
    +
    40 
    +test1 = reverse1 test2 []
    41 
    +
    42 
    +test
    43 
    +  = \ xs ->
    44 
    +      case $fOrdList_$s$ccompare [] xs of {
    45 
    +        __DEFAULT ->
    46 
    +          (reverse1 (reverse1 (reverse1 (reverse1 (++ [] xs) []) []) []) [])
    47 
    +          `cast` <Co:3> :: ...;
    48 
    +        GT -> test1 `cast` <Co:3> :: ...
    49 
    +      }
    50 
    +
    51 
    +
    52 
    +

  • testsuite/tests/simplCore/should_compile/T8331.stderr
    ... ... @@ -56,11 +56,11 @@
    56 56 
                           ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> ST s b))
    57 57 
     "SPEC $c>> @(ST s) @_"
    58 58 
         forall (@s) (@r) ($dMonad :: Monad (ST s)).
    59 
    -      $fMonadReaderT1 @(ST s) @r $dMonad
    59 
    +      $fMonadReaderT_$c>> @(ST s) @r $dMonad
    60 60 
           = $fMonadAbstractIOSTReaderT_$s$c>> @s @r
    61 61 
     "SPEC $c>>= @(ST s) @_"
    62 62 
         forall (@s) (@r) ($dMonad :: Monad (ST s)).
    63 
    -      $fMonadReaderT2 @(ST s) @r $dMonad
    63 
    +      $fMonadReaderT1 @(ST s) @r $dMonad
    64 64 
           = ($fMonadAbstractIOSTReaderT2 @s @r)
    65 65 
             `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N).
    66 66 
                     <ReaderT r (ST s) a>_R

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -581,3 +581,4 @@ test('T26722', [grep_errmsg(r'SPEC')], compile, ['-O -dno-typeable-binds'])
    581 581
    582 582 
     test('T26805', [grep_errmsg(r'fromInteger')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques'])
    583 583 
     test('T26826', normal, compile, ['-O'])
    584 
    +test('T26903', [grep_errmsg(r'reverse')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques -dsuppress-all'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help