More wibbleswip/T18993

6 files changed, 47 insertions, 28 deletions

diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 67b5353d71..ff9a6eff45 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -1895,8 +1895,7 @@ This turned up in #7542.
 
 tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
 tryEtaReduce bndrs body
-  = let res = go (reverse bndrs) body refl_co
-    in pprTrace "tryEtaReduce" (ppr bndrs $$ ppr body $$ ppr res) res
+  = go (reverse bndrs) body refl_co
   where
     refl_co = mkRepReflCo (exprType body)
     incoming_arity = count isId bndrs
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 16906df1c1..bc7531c130 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -92,14 +92,15 @@ little dance in action; the full Simplifier is a lot more complicated.
 data SimpleOpts = SimpleOpts
    { so_uf_opts :: !UnfoldingOpts   -- ^ Unfolding options
    , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
+   , so_eta_red :: !Bool            -- ^ Eta reduction on?
    }
 
 -- | Default options for the Simple optimiser.
 defaultSimpleOpts :: SimpleOpts
 defaultSimpleOpts = SimpleOpts
    { so_uf_opts = defaultUnfoldingOpts
-   , so_co_opts = OptCoercionOpts
-      { optCoercionEnabled = False }
+   , so_co_opts = OptCoercionOpts { optCoercionEnabled = False }
+   , so_eta_red = False
    }
 
 simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
@@ -182,11 +183,8 @@ simpleOptPgm opts this_mod binds rules =
 type SimpleClo = (SimpleOptEnv, InExpr)
 
 data SimpleOptEnv
-  = SOE { soe_co_opt_opts :: !OptCoercionOpts
-             -- ^ Options for the coercion optimiser
-
-        , soe_uf_opts :: !UnfoldingOpts
-             -- ^ Unfolding options
+  = SOE { soe_opts :: {-# UNPACK #-} ! SimpleOpts
+             -- ^ Simplifier options
 
         , soe_inl   :: IdEnv SimpleClo
              -- ^ Deals with preInlineUnconditionally; things
@@ -204,12 +202,9 @@ instance Outputable SimpleOptEnv where
                    <+> text "}"
 
 emptyEnv :: SimpleOpts -> SimpleOptEnv
-emptyEnv opts = SOE
-   { soe_inl         = emptyVarEnv
-   , soe_subst       = emptySubst
-   , soe_co_opt_opts = so_co_opts opts
-   , soe_uf_opts     = so_uf_opts opts
-   }
+emptyEnv opts = SOE { soe_inl   = emptyVarEnv
+                    , soe_subst = emptySubst
+                    , soe_opts  = opts  }
 
 soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
 soeZapSubst env@(SOE { soe_subst = subst })
@@ -282,7 +277,7 @@ simple_opt_expr env expr
         (env', b') = subst_opt_bndr env b
 
     ----------------------
-    go_co co = optCoercion (soe_co_opt_opts env) (getTCvSubst subst) co
+    go_co co = optCoercion (so_co_opts (soe_opts env)) (getTCvSubst subst) co
 
     ----------------------
     go_alt env (Alt con bndrs rhs)
@@ -297,7 +292,8 @@ simple_opt_expr env expr
        where
          (env', b') = subst_opt_bndr env b
     go_lam env bs' e
-       | Just etad_e <- tryEtaReduce bs e' = etad_e
+       | so_eta_red (soe_opts env)
+       , Just etad_e <- tryEtaReduce bs e' = etad_e
        | otherwise                         = mkLams bs e'
        where
          bs = reverse bs'
@@ -422,7 +418,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
     (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
 
   | Coercion co <- in_rhs
-  , let out_co = optCoercion (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co
+  , let out_co = optCoercion (so_co_opts (soe_opts env)) (getTCvSubst (soe_subst rhs_env)) co
   = assert (isCoVar in_bndr)
     (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
 
@@ -654,7 +650,7 @@ add_info env old_bndr top_level new_rhs new_bndr
  | otherwise        = lazySetIdInfo new_bndr new_info
  where
    subst    = soe_subst env
-   uf_opts  = soe_uf_opts env
+   uf_opts  = so_uf_opts (soe_opts env)
    old_info = idInfo old_bndr
 
    -- Add back in the rules and unfolding which were
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 57b59d0a66..b8f18de5c0 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -549,7 +549,7 @@ coreToStgApp f args ticks = do
                 -- Some primitive operator that might be implemented as a library call.
                 -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps
                 -- we require that primop applications be saturated.
-                PrimOpId op      -> assertPpr saturated (ppr f <+> ppr args) $
+                PrimOpId op      -> -- assertPpr saturated (ppr f <+> ppr args) $
                                     StgOpApp (StgPrimOp op) args' res_ty
 
                 -- A call to some primitive Cmm function.
diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs
index 2d4135a847..bd9790312b 100644
--- a/compiler/GHC/Driver/Config.hs
+++ b/compiler/GHC/Driver/Config.hs
@@ -29,6 +29,7 @@ initSimpleOpts :: DynFlags -> SimpleOpts
 initSimpleOpts dflags = SimpleOpts
    { so_uf_opts = unfoldingOpts dflags
    , so_co_opts = initOptCoercionOpts dflags
+   , so_eta_red = gopt Opt_DoEtaReduction dflags
    }
 
 -- | Extract BCO options from DynFlags
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 1c990cba9f..67fe339265 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -564,7 +564,8 @@ hasNoBinding :: Id -> Bool
 -- exception to this is unboxed tuples and sums datacons, which definitely have
 -- no binding
 hasNoBinding id = case Var.idDetails id of
-                        PrimOpId _       -> True    -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps
+--                        PrimOpId _       -> True    -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps
+-- Omit this: #19982
                         FCallId _        -> True
                         DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
                         _                -> isCompulsoryUnfolding (idUnfolding id)
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index f5eaf757e2..5635ff747d 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -612,18 +612,40 @@ gen_latex_doc (Info defaults entries)
            latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs)
            latex_encode (c:cs) = c:(latex_encode cs)
 
+{- Note [OPTIONS_GHC in GHC.PrimopWrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In PrimopWrappers we set some crucial GHC options
+
+* Eta reduction: -fno-do-eta-reduction
+  In PrimopWrappers we builds a wrapper for each primop, thus
+      plusInt# = \a b. plusInt# a b
+  That's a pretty odd definition, becaues it looks recursive. What
+  actually happens is that it makes a curried, top-level bindings for
+  `plusInt#`.  When we compile PrimopWrappers, the code generator spots
+  (plusInt# a b) and generates an add instruction.
+
+  Its very important that we don't eta-reduce this to
+      plusInt# = plusInt#
+  because then the special rule in the code generator doesn't fire.
+
+* Worker-wrapper: performing WW on this module is harmful even, two reasons:
+  1. Inferred strictness signatures are all bottom (because of the apparent
+     recursion), which is a lie
+  2. Doing the worker/wrapper split based on that information will
+     introduce references to absentError, which isn't available at
+     this point.
+
+  We prevent strictness analyis and w/w by simply doing -O0.  It's
+  a very simple module and there is no optimisation to be done
+-}
+
 gen_wrappers :: Info -> String
 gen_wrappers (Info _ entries)
    =    "{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}\n"
         -- Dependencies on Prelude must be explicit in libraries/base, but we
         -- don't need the Prelude here so we add NoImplicitPrelude.
-     ++ "{-# OPTIONS_GHC -Wno-deprecations -O0 #-}\n"
-        -- No point in optimising this at all.
-        -- Performing WW on this module is harmful even, two reasons:
-        --   1. Inferred strictness signatures are all bottom, which is a lie
-        --   2. Doing the worker/wrapper split based on that information will
-        --      introduce references to absentError,
-        --      which isn't available at this point.
+     ++ "{-# OPTIONS_GHC -Wno-deprecations -O0 -fno-do-eta-reduction #-}\n"
+        -- Very important OPTIONS_GHC!  See Note [OPTIONS_GHC in GHC.PrimopWrappers]
      ++ "module GHC.PrimopWrappers where\n"
      ++ "import qualified GHC.Prim\n"
      ++ "import GHC.Tuple ()\n"