summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2020-12-16 12:48:52 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-12-19 02:14:42 -0500
commit173112cad82630b02eb91acb1f5fb91a96fa02b9 (patch)
treec9a154eb05c3189bc53ecf6569b869db6fdce342
parentc2430398481f5aab12fd94e6549c7b9bbd1e43fe (diff)
downloadhaskell-173112cad82630b02eb91acb1f5fb91a96fa02b9.tar.gz
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
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs3
-rw-r--r--compiler/GHC/HsToCore/Utils.hs7
-rw-r--r--compiler/GHC/Types/Id/Make.hs40
-rw-r--r--testsuite/tests/simplCore/should_compile/T18995.hs6
-rw-r--r--testsuite/tests/simplCore/should_compile/T18995.stderr66
-rw-r--r--testsuite/tests/simplCore/should_compile/all.T2
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'])