Make noinline more reliable

This patch makes the desugarer rewrite
   noinline (f d)  -->   noinline f d

This makes 'noinline' much more reliable: see #18995

It's explained in the improved Note [noinlineId magic]
in GHC.Types.Id.Make

6 files changed, 112 insertions, 12 deletions

diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 460f8ad9ea..f8955ae977 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -768,7 +768,10 @@ cpeApp top_env expr
             -> UniqSM (Floats, CpeRhs)
     cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth
         | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and
+            -- See Note [lazyId magic] in GHC.Types.Id.Make
        || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a
+            -- See Note [noinlineId magic] in GHC.Types.Id.Make
+
         -- Consider the code:
         --
         --      lazy (f x) y
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 01085b3270..ac66b00813 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -494,6 +494,13 @@ mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg
                           -> v1        -- Note [Desugaring seq], points (2) and (3)
                    _      -> mkWildValBinder Many ty1
 
+mkCoreAppDs _ (Var f `App` Type _r) arg
+  | f `hasKey` noinlineIdKey   -- See Note [noinlineId magic] in GHC.Types.Id.Make
+  , (fun, args) <- collectArgs arg
+  , not (null args)
+  = (Var f `App` Type (exprType fun) `App` fun)
+    `mkCoreApps` args
+
 mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in GHC.Core.Make
 
 -- NB: No argument can be levity polymorphic
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 9aa91e3017..dd5657f419 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -1657,18 +1657,36 @@ Implementing 'lazy' is a bit tricky:
 
 Note [noinlineId magic]
 ~~~~~~~~~~~~~~~~~~~~~~~
-noinline :: forall a. a -> a
-
 'noinline' is used to make sure that a function f is never inlined,
-e.g., as in 'noinline f x'.  Ordinarily, the identity function with NOINLINE
-could be used to achieve this effect; however, this has the unfortunate
-result of leaving a (useless) call to noinline at runtime.  So we have
-a little bit of magic to optimize away 'noinline' after we are done
-running the simplifier.
-
-'noinline' needs to be wired-in because it gets inserted automatically
-when we serialize an expression to the interface format. See
-Note [Inlining and hs-boot files] in GHC.CoreToIface
+e.g., as in 'noinline f x'.  We won't inline f because we never inline
+lone variables (see Note [Lone variables] in GHC.Core.Unfold
+
+You might think that we could implement noinline like this:
+   {-# NOINLINE #-}
+   noinline :: forall a. a -> a
+   noinline x = x
+
+But actually we give 'noinline' a wired-in name for three distinct reasons:
+
+1. We don't want to leave a (useless) call to noinline in the final program,
+   to be executed at runtime. So we have a little bit of magic to
+   optimize away 'noinline' after we are done running the simplifier.
+   This is done in GHC.CoreToStg.Prep.cpeApp.
+
+2. 'noinline' sometimes gets inserted automatically when we serialize an
+   expression to the interface format, in GHC.CoreToIface.toIfaceVar.
+   See Note [Inlining and hs-boot files] in GHC.CoreToIface
+
+3. Given foo :: Eq a => [a] -> Bool, the expression
+     noinline foo x xs
+   where x::Int, will naturally desugar to
+      noinline @Int (foo @Int dEqInt) x xs
+   But now it's entirely possible htat (foo @Int dEqInt) will inline foo,
+   since 'foo' is no longer a lone variable -- see #18995
+
+   Solution: in the desugarer, rewrite
+      noinline (f x y)  ==>  noinline f x y
+   This is done in GHC.HsToCore.Utils.mkCoreAppDs.
 
 Note that noinline as currently implemented can hide some simplifications since
 it hides strictness from the demand analyser. Specifically, the demand analyser
diff --git a/testsuite/tests/simplCore/should_compile/T18995.hs b/testsuite/tests/simplCore/should_compile/T18995.hs
new file mode 100644
index 0000000000..052a03ea98
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T18995.hs
@@ -0,0 +1,6 @@
+module T18995 where
+
+import GHC.Magic ( noinline )
+
+foo :: IO ()
+foo = (noinline print) True
diff --git a/testsuite/tests/simplCore/should_compile/T18995.stderr b/testsuite/tests/simplCore/should_compile/T18995.stderr
new file mode 100644
index 0000000000..a1db26f6ec
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T18995.stderr
@@ -0,0 +1,66 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 19, types: 14, coercions: 12, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18995.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T18995.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18995.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18995.$trModule3 = GHC.Types.TrNameS T18995.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18995.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T18995.$trModule2 = "T18995"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18995.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18995.$trModule1 = GHC.Types.TrNameS T18995.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18995.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18995.$trModule
+  = GHC.Types.Module T18995.$trModule3 T18995.$trModule1
+
+-- RHS size: {terms: 4, types: 7, coercions: 12, joins: 0/0}
+foo :: IO ()
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+         WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 40 0}]
+foo
+  = noinline
+      @(forall a. Show a => a -> IO ())
+      (System.IO.print1
+       `cast` (forall (a :: <*>_N).
+               <Show a>_R
+               %<'Many>_N ->_R <a>_R
+               %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] <()>_R)
+               :: (forall {a}.
+                   Show a =>
+                   a
+                   -> GHC.Prim.State# GHC.Prim.RealWorld
+                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
+                  ~R# (forall {a}. Show a => a -> IO ())))
+      @Bool
+      GHC.Show.$fShowBool
+      GHC.Types.True
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 76f9567f3d..3bfc8c5c09 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -341,4 +341,4 @@ test('T18649', normal, compile, ['-O -ddump-rules -Wno-simplifiable-class-constr
 test('T18747A', normal, compile, [''])
 test('T18747B', normal, compile, [''])
 test('T18815', only_ways(['optasm']), makefile_test, ['T18815'])
-
+test('T18995', [ grep_errmsg(r'print') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])