Do arity trimming at bindings, rather than in exprArity

Sometimes there are very large casts, and coercionRKind
can be slow.

9 files changed, 227 insertions, 79 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 9275229375..76d961c91e 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -670,10 +670,11 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
        -- Check that the binder's arity is within the bounds imposed by
        -- the type and the strictness signature. See Note [exprArity invariant]
        -- and Note [Trimming arity]
-       ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder)
+
+       ; checkL (typeArity (idType binder) >= idArity binder)
            (text "idArity" <+> ppr (idArity binder) <+>
            text "exceeds typeArity" <+>
-           ppr (length (typeArity (idType binder))) <> colon <+>
+           ppr (typeArity (idType binder)) <> colon <+>
            ppr binder)
 
        ; case splitDmdSig (idDmdSig binder) of
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index b615202e65..ed08f6c70d 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -11,7 +11,8 @@
 
 -- | Arity and eta expansion
 module GHC.Core.Opt.Arity
-   ( manifestArity, joinRhsArity, exprArity, typeArity
+   ( manifestArity, joinRhsArity, exprArity
+   , typeArity, typeOneShots
    , exprEtaExpandArity, findRhsArity
    , etaExpand, etaExpandAT
    , exprBotStrictness_maybe
@@ -19,7 +20,7 @@ module GHC.Core.Opt.Arity
 
    -- ** ArityType
    , ArityType(..), mkBotArityType, mkTopArityType, expandableArityType
-   , arityTypeArity, maxWithArity, idArityType
+   , arityTypeArity, maxWithArity, minWithArity, idArityType
 
    -- ** Join points
    , etaExpandToJoinPoint, etaExpandToJoinPointRule
@@ -119,14 +120,17 @@ joinRhsArity _         = 0
 ---------------
 exprArity :: CoreExpr -> Arity
 -- ^ An approximate, fast, version of 'exprEtaExpandArity'
+-- We do /not/ guarantee that exprArity e <= typeArity e
+-- You may need to do arity trimming after calling exprArity
+-- See Note [Arity trimming]
+-- (If we do arity trimming here we have to do it at every cast.
 exprArity e = go e
   where
     go (Var v)                     = idArity v
     go (Lam x e) | isId x          = go e + 1
                  | otherwise       = go e
     go (Tick t e) | not (tickishIsCode t) = go e
-    go (Cast e co)                 = trim_arity (go e) (coercionRKind co)
-                                        -- See Note [exprArity invariant]
+    go (Cast e _)                  = go e
     go (App e (Type _))            = go e
     go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
         -- See Note [exprArity for applications]
@@ -134,15 +138,15 @@ exprArity e = go e
 
     go _                           = 0
 
-    trim_arity :: Arity -> Type -> Arity
-    trim_arity arity ty = arity `min` length (typeArity ty)
-
 ---------------
-typeArity :: Type -> [OneShotInfo]
+typeArity :: Type -> Arity
+typeArity = length . typeOneShots
+
+typeOneShots :: Type -> [OneShotInfo]
 -- How many value arrows are visible in the type?
 -- We look through foralls, and newtypes
--- See Note [exprArity invariant]
-typeArity ty
+-- See Note [typeArity invariants]
+typeOneShots ty
   = go initRecTc ty
   where
     go rec_nts ty
@@ -183,33 +187,64 @@ exprBotStrictness_maybe e
     sig ar = mkClosedDmdSig (replicate ar topDmd) botDiv
 
 {-
-Note [exprArity invariant]
+Note [typeArity invariants]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
-exprArity has the following invariants:
+We have the following invariants around typeArity
+
+  (1) In any binding x = e,
+      idArity f <= typeArity (idType f)
 
-  (1) If typeArity (exprType e) = n,
+  (2) If typeArity (exprType e) = n,
       then manifestArity (etaExpand e n) = n
 
       That is, etaExpand can always expand as much as typeArity says
       So the case analysis in etaExpand and in typeArity must match
 
-  (2) exprArity e <= typeArity (exprType e)
-
-  (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n
-
-      That is, if exprArity says "the arity is n" then etaExpand really
-      can get "n" manifest lambdas to the top.
-
 Why is this important?  Because
+
   - In GHC.Iface.Tidy we use exprArity to fix the *final arity* of
     each top-level Id, and in
+
   - In CorePrep we use etaExpand on each rhs, so that the visible lambdas
     actually match that arity, which in turn means
     that the StgRhs has the right number of lambdas
 
-An alternative would be to do the eta-expansion in GHC.Iface.Tidy, at least
-for top-level bindings, in which case we would not need the trim_arity
-in exprArity.  That is a less local change, so I'm going to leave it for today!
+Suppose we have
+   f :: Int -> Int -> Int
+   f x y = x+y    -- Arity 2
+
+   g :: F Int
+   g = case x of { True  -> f |> co1
+                 ; False -> g |> co2 }
+
+Now, we can't eta-expand g to have arity 2, because etaExpand, which works
+off the /type/ of the expression, doesn't know how to make an eta-expanded
+binding
+   g = (\a b. case x of ...) |> co
+because can't make up `co` or the types of `a` and `b`.
+
+So invariant (1) ensures that every binding has an arity that is no greater
+than the typeArity of the RHS; and invariant (2) ensures that etaExpand
+and handle what typeArity says.
+
+Note [Arity trimming]
+~~~~~~~~~~~~~~~~~~~~~
+Arity trimming, implemented by minWithArity, directly implements
+invariant (1) of Note [typeArity invariants]. Failing to do so, and
+hence breaking invariant (1) led to #5441.
+
+How to trim?  If we end in topDiv, it's easy.  But we must take great care with
+dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"),
+we'll get \??.⊥.  We absolutely must not trim that to \?.⊥, because that
+claims that ((\x y. error "urk") |> co) diverges when given one argument,
+which it absolutely does not. And Bad Things happen if we think something
+returns bottom when it doesn't (#16066).
+
+So, if we need to trim a dead-ending arity type, switch (conservatively) to
+topDiv.
+
+Historical note: long ago, we unconditionally switched to topDiv when we
+encountered a cast, but that is far too conservative: see #5475
 
 Note [Newtype classes and eta expansion]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -601,6 +636,9 @@ expandableArityType at = arityTypeArity at > 0
 isDeadEndArityType :: ArityType -> Bool
 isDeadEndArityType (AT _ div) = isDeadEndDiv div
 
+-----------------------
+infixl 2 `maxWithArity`, `minWithArity`
+
 -- | Expand a non-bottoming arity type so that it has at least the given arity.
 maxWithArity :: ArityType -> Arity -> ArityType
 maxWithArity at@(AT oss div) !ar
@@ -610,12 +648,13 @@ maxWithArity at@(AT oss div) !ar
 
 -- | Trim an arity type so that it has at most the given arity.
 -- Any excess 'OneShotInfo's are truncated to 'topDiv', even if they end in
--- 'ABot'.
+-- 'ABot'.  See Note [Arity trimming]
 minWithArity :: ArityType -> Arity -> ArityType
 minWithArity at@(AT oss _) ar
   | oss `lengthAtMost` ar = at
   | otherwise             = AT (take ar oss) topDiv
 
+----------------------
 takeWhileOneShot :: ArityType -> ArityType
 takeWhileOneShot (AT oss div)
   | isDeadEndDiv div = AT (takeWhile isOneShotInfo oss) topDiv
@@ -669,7 +708,9 @@ findRhsArity opts bndr rhs old_arity
         next_at = step cur_at
 
     step :: ArityType -> ArityType
-    step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $
+    step at = -- pprTrace "step" (vcat [ ppr bndr <+> ppr at <+> ppr (arityType env rhs)
+              --                      , ppr (idType bndr)
+              --                      , ppr (typeArity (idType bndr)) ]) $
               arityType env rhs
       where
         env = extendSigEnv (findRhsArityEnv opts) bndr at
@@ -1010,15 +1051,6 @@ myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of
 ----------------
 arityType :: ArityEnv -> CoreExpr -> ArityType
 
-arityType env (Cast e co)
-  = minWithArity (arityType env e) co_arity -- See Note [Arity trimming]
-  where
-    co_arity = length (typeArity (coercionRKind co))
-    -- See Note [exprArity invariant] (2); must be true of
-    -- arityType too, since that is how we compute the arity
-    -- of variables, and they in turn affect result of exprArity
-    -- #5441 is a nice demo
-
 arityType env (Var v)
   | v `elemVarSet` ae_joins env
   = botArityType  -- See Note [Eta-expansion and join points]
@@ -1027,6 +1059,9 @@ arityType env (Var v)
   | otherwise
   = idArityType v
 
+arityType env (Cast e _)
+  = arityType env e
+
         -- Lambdas; increase arity
 arityType env (Lam x e)
   | isId x    = arityLam x (arityType env' e)
@@ -1051,14 +1086,17 @@ arityType env (App fun arg )
 arityType env (Case scrut bndr _ alts)
   | exprIsDeadEnd scrut || null alts
   = botArityType    -- Do not eta expand. See (1) in Note [Dealing with bottom]
+
   | not (pedanticBottoms env)  -- See (2) in Note [Dealing with bottom]
   , myExprIsCheap env scrut (Just (idType bndr))
   = alts_type
+
   | exprOkForSpeculation scrut
   = alts_type
 
   | otherwise                  -- In the remaining cases we may not push
   = takeWhileOneShot alts_type -- evaluation of the scrutinee in
+
   where
     env' = delInScope env bndr
     arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs
@@ -1168,7 +1206,7 @@ idArityType v
   = AT (take (idArity v) one_shots) topDiv
   where
     one_shots :: [OneShotInfo]  -- One-shot-ness derived from the type
-    one_shots = typeArity (idType v)
+    one_shots = typeOneShots (idType v)
 
 {-
 %************************************************************************
@@ -1277,7 +1315,7 @@ Consider
 We'll get an ArityType for foo of \?1.T.
 
 Then we want to eta-expand to
-  foo = \x. (\eta{os}. (case x of ...as before...) eta) |> some_co
+  foo = (\x. \eta{os}. (case x of ...as before...) eta)) |> some_co
 
 That 'eta' binder is fresh, and we really want it to have the
 one-shot flag from the inner \s{os}.  By expanding with the
diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs
index 656d6a9fc1..67b9a88875 100644
--- a/compiler/GHC/Core/Opt/CallArity.hs
+++ b/compiler/GHC/Core/Opt/CallArity.hs
@@ -17,7 +17,7 @@ import GHC.Types.Var.Env
 import GHC.Types.Basic
 import GHC.Core
 import GHC.Types.Id
-import GHC.Core.Opt.Arity ( typeArity )
+import GHC.Core.Opt.Arity ( typeArity, typeOneShots )
 import GHC.Core.Utils ( exprIsCheap, exprIsTrivial )
 import GHC.Data.Graph.UnVar
 import GHC.Types.Demand
@@ -544,7 +544,7 @@ callArityAnal arity int (Let bind e)
 -- Which bindings should we look at?
 -- See Note [Which variables are interesting]
 isInteresting :: Var -> Bool
-isInteresting v = not $ null (typeArity (idType v))
+isInteresting v = not $ null $ typeOneShots $ idType v
 
 interestingBinds :: CoreBind -> [Var]
 interestingBinds = filter isInteresting . bindersOf
@@ -700,7 +700,7 @@ callArityRecEnv any_boring ae_rhss ae_body
 trimArity :: Id -> Arity -> Arity
 trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]
   where
-    max_arity_by_type = length (typeArity (idType v))
+    max_arity_by_type = typeArity (idType v)
     max_arity_by_strsig
         | isDeadEndDiv result_info = length demands
         | otherwise = a
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index b01e6f502a..59d18fefaf 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -125,8 +125,7 @@ isInterestingTopLevelFn :: Id -> Bool
 -- If there was a gain, that regression might be acceptable.
 -- Plus, we could use LetUp for thunks and share some code with local let
 -- bindings.
-isInterestingTopLevelFn id =
-  typeArity (idType id) `lengthExceeds` 0
+isInterestingTopLevelFn id = typeArity (idType id) > 0
 
 {- Note [Stamp out space leaks in demand analysis]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 0ea3c1f3f6..d83f7f7719 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -38,7 +38,7 @@ import GHC.Core.Ppr     ( pprCoreExpr )
 import GHC.Core.Unfold
 import GHC.Core.Unfold.Make
 import GHC.Core.Utils
-import GHC.Core.Opt.Arity ( ArityType(..)
+import GHC.Core.Opt.Arity ( ArityType(..), typeArity
                           , pushCoTyArg, pushCoValArg
                           , etaExpandAT )
 import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )
@@ -605,7 +605,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
                                                    -- See Note [OPAQUE pragma]
   = do  { uniq <- getUniqueM
         ; let work_name = mkSystemVarName uniq occ_fs
-              work_id   = mkLocalIdWithInfo work_name Many rhs_ty worker_info
+              work_id   = mkLocalIdWithInfo work_name Many work_ty work_info
               is_strict = isStrictId bndr
 
         ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict
@@ -636,14 +636,15 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
   where
     mode   = getMode env
     occ_fs = getOccFS bndr
-    rhs_ty = coercionLKind co
+    work_ty = coercionLKind co
     info   = idInfo bndr
+    work_arity = arityInfo info `min` typeArity work_ty
 
-    worker_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info
-                                `setCprSigInfo`     cprSigInfo info
-                                `setDemandInfo`     demandInfo info
-                                `setInlinePragInfo` inlinePragInfo info
-                                `setArityInfo`      arityInfo info
+    work_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info
+                              `setCprSigInfo`     cprSigInfo info
+                              `setDemandInfo`     demandInfo info
+                              `setInlinePragInfo` inlinePragInfo info
+                              `setArityInfo`      work_arity
            -- We do /not/ want to transfer OccInfo, Rules
            -- Note [Preserve strictness in cast w/w]
            -- and Wrinkle 2 of Note [Cast worker/wrapper]
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index ac85ebb623..8b26945d05 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -1807,9 +1807,13 @@ tryEtaExpandRhs env bndr rhs
     dflags    = sm_dflags mode
     arityOpts = initArityOpts dflags
     old_arity = exprArity rhs
+    ty_arity  = typeArity (idType bndr)
 
     arity_type = findRhsArity arityOpts bndr rhs old_arity
                  `maxWithArity` idCallArity bndr
+                 `minWithArity` ty_arity
+    -- minWithArity: see Note [Arity trimming] in GHC.Core.Opt.Arity
+
     new_arity = arityTypeArity arity_type
 
     -- See Note [Which RHSs do we eta-expand?]
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 053fd2dcf9..d6fd70e8db 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -697,16 +697,13 @@ data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks
 -- Convert the RHS of a binding from Core to STG. This is a wrapper around
 -- coreToStgExpr that can handle value lambdas.
 coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
-coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr
-coreToPreStgRhs expr@(Lam _ _) =
-    let
-        (args, body) = myCollectBinders expr
-        args'        = filterStgBinders args
-    in
-        extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
-          body' <- coreToStgExpr body
-          return (PreStgRhs args' body')
-coreToPreStgRhs expr = PreStgRhs [] <$> coreToStgExpr expr
+coreToPreStgRhs expr
+  = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $
+    do { body' <- coreToStgExpr body
+       ; return (PreStgRhs args' body') }
+  where
+   (args, body) = myCollectBinders expr
+   args'        = filterStgBinders args
 
 -- Generate a top-level RHS. Any new cost centres generated for CAFs will be
 -- appended to `CollectedCCs` argument.
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 7616c9458c..f7282faa83 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -28,9 +28,9 @@ import GHC.Core.Unfold.Make
 import GHC.Core.FVs
 import GHC.Core.Tidy
 import GHC.Core.Seq     (seqBinds)
-import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe )
+import GHC.Core.Opt.Arity   ( exprArity, typeArity,, exprBotStrictness_maybe )
 import GHC.Core.InstEnv
-import GHC.Core.Type     ( tidyTopType )
+import GHC.Core.Type     ( Type, tidyTopType )
 import GHC.Core.DataCon
 import GHC.Core.TyCon
 import GHC.Core.Class
@@ -1218,8 +1218,8 @@ tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)
     details  = idDetails cbv_bndr -- Preserve the IdDetails
     ty'      = tidyTopType (idType cbv_bndr)
     rhs1     = tidyExpr rhs_tidy_env rhs
-    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)
-                             show_unfold
+    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' ty'
+                             rhs rhs1 (idInfo cbv_bndr) show_unfold
 
 -- tidyTopIdInfo creates the final IdInfo for top-level
 -- binders.  The delicate piece:
@@ -1228,27 +1228,27 @@ tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)
 --      Indeed, CorePrep must eta expand where necessary to make
 --      the manifest arity equal to the claimed arity.
 --
-tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr
-              -> IdInfo -> Bool -> IdInfo
-tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
+tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> Type
+              -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo
+tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
   | not is_external     -- For internal Ids (not externally visible)
   = vanillaIdInfo       -- we only need enough info for code generation
                         -- Arity and strictness info are enough;
                         --      c.f. GHC.Core.Tidy.tidyLetBndr
         `setArityInfo`      arity
-        `setDmdSigInfo` final_sig
-        `setCprSigInfo`        final_cpr
-        `setUnfoldingInfo`  minimal_unfold_info  -- See Note [Preserve evaluatedness]
+        `setDmdSigInfo`     final_sig
+        `setCprSigInfo`     final_cpr
+        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]
                                                  -- in GHC.Core.Tidy
 
   | otherwise           -- Externally-visible Ids get the whole lot
   = vanillaIdInfo
-        `setArityInfo`         arity
-        `setDmdSigInfo`    final_sig
-        `setCprSigInfo`           final_cpr
-        `setOccInfo`           robust_occ_info
-        `setInlinePragInfo`    (inlinePragInfo idinfo)
-        `setUnfoldingInfo`     unfold_info
+        `setArityInfo`       arity
+        `setDmdSigInfo`      final_sig
+        `setCprSigInfo`      final_cpr
+        `setOccInfo`         robust_occ_info
+        `setInlinePragInfo`  inlinePragInfo idinfo
+        `setUnfoldingInfo`   unfold_info
                 -- NB: we throw away the Rules
                 -- They have already been extracted by findExternalRules
   where
@@ -1311,4 +1311,112 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
     -- did was to let-bind a non-atomic argument and then float
     -- it to the top level. So it seems more robust just to
     -- fix it here.
-    arity = exprArity orig_rhs
+    arity = exprArity orig_rhs `min` typeArity rhs_ty
+            -- orig_rhs: using tidy_rhs would make a black hole, since
+            --           exprArity uses the arities of Ids inside the rhs
+            -- typeArity: see Note [typeArity invariants]
+            --            in GHC.Core.Opt.Arity
+
+{-
+************************************************************************
+*                                                                      *
+                  Old, dead, type-trimming code
+*                                                                      *
+************************************************************************
+
+We used to try to "trim off" the constructors of data types that are
+not exported, to reduce the size of interface files, at least without
+-O.  But that is not always possible: see the old Note [When we can't
+trim types] below for exceptions.
+
+Then (#7445) I realised that the TH problem arises for any data type
+that we have deriving( Data ), because we can invoke
+   Language.Haskell.TH.Quote.dataToExpQ
+to get a TH Exp representation of a value built from that data type.
+You don't even need {-# LANGUAGE TemplateHaskell #-}.
+
+At this point I give up. The pain of trimming constructors just
+doesn't seem worth the gain.  So I've dumped all the code, and am just
+leaving it here at the end of the module in case something like this
+is ever resurrected.
+
+
+Note [When we can't trim types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The basic idea of type trimming is to export algebraic data types
+abstractly (without their data constructors) when compiling without
+-O, unless of course they are explicitly exported by the user.
+
+We always export synonyms, because they can be mentioned in the type
+of an exported Id.  We could do a full dependency analysis starting
+from the explicit exports, but that's quite painful, and not done for
+now.
+
+But there are some times we can't do that, indicated by the 'no_trim_types' flag.
+
+First, Template Haskell.  Consider (#2386) this
+        module M(T, makeOne) where
+          data T = Yay String
+          makeOne = [| Yay "Yep" |]
+Notice that T is exported abstractly, but makeOne effectively exports it too!
+A module that splices in $(makeOne) will then look for a declaration of Yay,
+so it'd better be there.  Hence, brutally but simply, we switch off type
+constructor trimming if TH is enabled in this module.
+
+Second, data kinds.  Consider (#5912)
+     {-# LANGUAGE DataKinds #-}
+     module M() where
+     data UnaryTypeC a = UnaryDataC a
+     type Bug = 'UnaryDataC
+We always export synonyms, so Bug is exposed, and that means that
+UnaryTypeC must be too, even though it's not explicitly exported.  In
+effect, DataKinds means that we'd need to do a full dependency analysis
+to see what data constructors are mentioned.  But we don't do that yet.
+
+In these two cases we just switch off type trimming altogether.
+
+mustExposeTyCon :: Bool         -- Type-trimming flag
+                -> NameSet      -- Exports
+                -> TyCon        -- The tycon
+                -> Bool         -- Can its rep be hidden?
+-- We are compiling without -O, and thus trying to write as little as
+-- possible into the interface file.  But we must expose the details of
+-- any data types whose constructors or fields are exported
+mustExposeTyCon no_trim_types exports tc
+  | no_trim_types               -- See Note [When we can't trim types]
+  = True
+
+  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to
+                                -- figure out whether it was mentioned in the type
+                                -- of any other exported thing)
+  = True
+
+  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors
+  = True                        -- won't lead to the need for further exposure
+
+  | isFamilyTyCon tc            -- Open type family
+  = True
+
+  -- Below here we just have data/newtype decls or family instances
+
+  | null data_cons              -- Ditto if there are no data constructors
+  = True                        -- (NB: empty data types do not count as enumerations
+                                -- see Note [Enumeration types] in GHC.Core.TyCon
+
+  | any exported_con data_cons  -- Expose rep if any datacon or field is exported
+  = True
+
+  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))
+  = True   -- Expose the rep for newtypes if the rep is an FFI type.
+           -- For a very annoying reason.  'Foreign import' is meant to
+           -- be able to look through newtypes transparently, but it
+           -- can only do that if it can "see" the newtype representation
+
+  | otherwise
+  = False
+  where
+    data_cons = tyConDataCons tc
+    exported_con con = any (`elemNameSet` exports)
+                           (dataConName con : dataConFieldLabels con)
+-}
+>>>>>>> Do arity trimming at bindings, rather than in exprArity
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index d562d0937f..b93289c519 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -364,7 +364,7 @@ bestOneShot NoOneShotInfo os         = os
 bestOneShot OneShotLam    _          = OneShotLam
 
 pprOneShotInfo :: OneShotInfo -> SDoc
-pprOneShotInfo NoOneShotInfo = empty
+pprOneShotInfo NoOneShotInfo = text "NoOS"
 pprOneShotInfo OneShotLam    = text "OneShot"
 
 instance Outputable OneShotInfo where