Fix INLINE pragmas in desugarer

In #19969 we discovered that GHC has has a bug *forever* that means it
sometimes essentially discarded INLINE pragams.  This happened when you have
* Two more more mutually recursive functions
* Some of which (presumably not all!) have an INLINE pragma
* Completely monomorphic.

This hits a particular case in GHC.HsToCore.Binds.dsAbsBinds, which was
simply wrong -- it put the INLINE pragma on the wrong binder.

This patch fixes the bug, rather easily, by adjusting the
no-tyvar, no-dict case of GHC.HsToCore.Binds.dsAbsBinds.

I also discovered that the GHC.Core.Opt.Pipeline.shortOutIndirections
was not doing a good job for

    {-# INLINE lcl_id #-}
    lcl_id = BIG

    gbl_id = lcl_id

Here we want to transfer the stable unfolding to gbl_id (we do), but
we also want to remove it from lcl_id (we were not doing that).
Otherwise both Ids have large stable unfoldings.  Easily fixed.
Note [Transferring IdInfo] explains.

5 files changed, 100 insertions, 31 deletions

diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 6e2f3aceee..23908403c7 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -1028,28 +1028,36 @@ Instead, transfer IdInfo from lcl_id to exp_id, specifically
 
 Overwriting, rather than merging, seems to work ok.
 
-We also zap the InlinePragma on the lcl_id. It might originally
-have had a NOINLINE, which we have now transferred; and we really
-want the lcl_id to inline now that its RHS is trivial!
+For the lcl_id we
+
+* Zap the InlinePragma. It might originally have had a NOINLINE, which
+  we have now transferred; and we really want the lcl_id to inline now
+  that its RHS is trivial!
+
+* Zap any Stable unfolding.  agian, we want lcl_id = gbl_id to inline,
+  replacing lcl_id by gbl_id. That won't happen if lcl_id has its original
+  great big Stable unfolding
 -}
 
 transferIdInfo :: Id -> Id -> (Id, Id)
 -- See Note [Transferring IdInfo]
 transferIdInfo exported_id local_id
   = ( modifyIdInfo transfer exported_id
-    , local_id `setInlinePragma` defaultInlinePragma )
+    , modifyIdInfo zap_info local_id )
   where
     local_info = idInfo local_id
-    transfer exp_info = exp_info `setDmdSigInfo`    dmdSigInfo local_info
-                                 `setCprSigInfo`           cprSigInfo local_info
-                                 `setUnfoldingInfo`     unfoldingInfo local_info
-                                 `setInlinePragInfo`    inlinePragInfo local_info
-                                 `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info
+    transfer exp_info = exp_info `setDmdSigInfo`     dmdSigInfo local_info
+                                 `setCprSigInfo`     cprSigInfo local_info
+                                 `setUnfoldingInfo`  unfoldingInfo local_info
+                                 `setInlinePragInfo` inlinePragInfo local_info
+                                 `setRuleInfo`       addRuleInfo (ruleInfo exp_info) new_info
     new_info = setRuleInfoHead (idName exported_id)
                                (ruleInfo local_info)
         -- Remember to set the function-name field of the
         -- rules as we transfer them from one function to another
 
+    zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma
+                                 `setUnfoldingInfo`  noUnfolding
 
 
 dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 50a3c319f9..184dda1481 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -226,6 +226,9 @@ dsAbsBinds dflags tyvars dicts exports
     -- A very important common case: one exported variable
     -- Non-recursive bindings come through this way
     -- So do self-recursive bindings
+    --    gbl_id = wrap (/\tvs \dicts. let ev_binds
+    --                                 letrec bind_prs
+    --                                 in lcl_id)
   | [export] <- exports
   , ABE { abe_poly = global_id, abe_mono = local_id
         , abe_wrap = wrap, abe_prags = prags } <- export
@@ -259,26 +262,28 @@ dsAbsBinds dflags tyvars dicts exports
 
     -- Another common case: no tyvars, no dicts
     -- In this case we can have a much simpler desugaring
+    --    lcl_id{inl-prag} = rhs  -- Auxiliary binds
+    --    gbl_id = lcl_id |> co   -- Main binds
   | null tyvars, null dicts
-
-  = do { let mk_bind (ABE { abe_wrap = wrap
-                          , abe_poly = global
-                          , abe_mono = local
-                          , abe_prags = prags })
-              = do { core_wrap <- dsHsWrapper wrap
-                   ; return (makeCorePair dflags global
-                                          (isDefaultMethod prags)
-                                          0 (core_wrap (Var local))) }
-       ; main_binds <- mapM mk_bind exports
-
-       ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
+  = do { let mk_main :: ABExport GhcTc -> DsM (Id, CoreExpr)
+             mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id
+                          , abe_wrap = wrap })
+                     -- No SpecPrags (no dicts)
+                     -- Can't be a default method (default methods are singletons)
+               = do { core_wrap <- dsHsWrapper wrap
+                    ; return ( gbl_id `setInlinePragma` defaultInlinePragma
+                             , core_wrap (Var lcl_id)) }
+
+       ; main_prs <- mapM mk_main exports
+       ; return (force_vars, flattenBinds ds_ev_binds
+                              ++ mk_aux_binds bind_prs ++ main_prs ) }
 
     -- The general case
     -- See Note [Desugaring AbsBinds]
   | otherwise
-  = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
-                              | (lcl_id, rhs) <- bind_prs ]
+  = do { let aux_binds = Rec (mk_aux_binds bind_prs)
                 -- Monomorphic recursion possible, hence Rec
+
              new_force_vars = get_new_force_vars force_vars
              locals       = map abe_mono exports
              all_locals   = locals ++ new_force_vars
@@ -286,7 +291,7 @@ dsAbsBinds dflags tyvars dicts exports
              tup_ty       = exprType tup_expr
        ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
                             mkCoreLets ds_ev_binds $
-                            mkLet core_bind $
+                            mkLet aux_binds $
                             tup_expr
 
        ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs)
@@ -320,19 +325,21 @@ dsAbsBinds dflags tyvars dicts exports
                 , (poly_tup_id, poly_tup_rhs) :
                    concat export_binds_s) }
   where
+    mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]
+    mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs
+                            | (lcl_id, rhs) <- bind_prs
+                            , let lcl_w_inline = lookupVarEnv inline_env lcl_id
+                                                 `orElse` lcl_id ]
+
     inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
-                             -- the inline pragma from the source
-                             -- The type checker put the inline pragma
-                             -- on the *global* Id, so we need to transfer it
+                           -- the inline pragma from the source
+                           -- The type checker put the inline pragma
+                           -- on the *global* Id, so we need to transfer it
     inline_env
       = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
                  | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
                  , let prag = idInlinePragma gbl_id ]
 
-    add_inline :: Id -> Id    -- tran
-    add_inline lcl_id = lookupVarEnv inline_env lcl_id
-                        `orElse` lcl_id
-
     global_env :: IdEnv Id -- Maps local Id to its global exported Id
     global_env =
       mkVarEnv [ (local, global)
diff --git a/testsuite/tests/deSugar/should_compile/T19969.hs b/testsuite/tests/deSugar/should_compile/T19969.hs
new file mode 100644
index 0000000000..ad9546c84a
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T19969.hs
@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -dno-typeable-binds -O2 -fno-worker-wrapper #-}
+
+module T19969 where
+
+-- Three mutually recursive functions
+-- We want to inline g, h, keeping f as the loop breaker
+
+f x = reverse (g (x:: [Int])) :: [Int]
+
+{-# INLINE g #-}
+
+g x = reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (h x))))))))))))
+
+{-# INLINE h #-}
+h x = reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (f x))))))))))))
diff --git a/testsuite/tests/deSugar/should_compile/T19969.stderr b/testsuite/tests/deSugar/should_compile/T19969.stderr
new file mode 100644
index 0000000000..5e23785472
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T19969.stderr
@@ -0,0 +1,38 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 12, types: 18, coercions: 0, joins: 0/0}
+
+Rec {
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+f [Occ=LoopBreaker] :: [Int] -> [Int]
+[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []]
+f = \ (x :: [Int]) -> f x
+end Rec }
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
+[GblId,
+ Arity=1,
+ Str=<B>b,
+ Cpr=b,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True)
+         Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}]
+g = \ (x :: [Int]) -> f x
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
+[GblId,
+ Arity=1,
+ Str=<B>b,
+ Cpr=b,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True)
+         Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}]
+h = \ (x :: [Int]) -> f x
+
+
+
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index 888369b849..6e6f486b4a 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -110,3 +110,4 @@ test('T14815', [], makefile_test, ['T14815'])
 test('T13208', [], makefile_test, ['T13208'])
 test('T16615', normal, compile, ['-ddump-ds -dsuppress-uniques'])
 test('T18112', [grep_errmsg('cast')], compile, ['-ddump-ds'])
+test('T19969', normal, compile, ['-ddump-simpl -dsuppress-uniques'])