Improve TidyPgm.hasCafRefs to account for Integer literals (Trac #8525)

See Note [Disgusting computation of CafRefs] in TidyPgm.

Also affects CoreUtils.rhsIsStatic.

The real solution here is to compute CAF and arity information
from the STG-program, and feed it back to tidied program for
the interface file and later GHCi clients.  A battle for another
day.

But at least this commit reduces the number of gratuitous CAFs, and
hence SRT entries.  And kills off a batch of ASSERT failures.

compiler/coreSyn/CorePrep.hs

@@ -1109,6 +1109,8 @@ canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
     -- the new binding is static. However it can't mention
     -- any non-static things or it would *already* be Caffy
     rhs_ok = rhsIsStatic platform (\_ -> False)
+                         (\i -> pprPanic "rhsIsStatic" (integer i))
+                         -- Integer literals should not show up 
 
 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec strict_or_unlifted floats rhs

compiler/coreSyn/CoreUtils.hs

@@ -1964,7 +1964,12 @@ and 'execute' it rather than allocating it statically.
 -- | This function is called only on *top-level* right-hand sides.
 -- Returns @True@ if the RHS can be allocated statically in the output,
 -- with no thunks involved at all.
-rhsIsStatic :: Platform -> (Name -> Bool) -> CoreExpr -> Bool
+rhsIsStatic :: Platform
+            -> (Name -> Bool)         -- Which names are dynamic
+            -> (Integer -> CoreExpr)  -- Desugaring for integer literals (disgusting)
+                                      -- C.f. Note [Disgusting computation of CafRefs]
+                                      --      in TidyPgm
+            -> CoreExpr -> Bool
 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
 -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
 -- update flag on it and (iii) in DsExpr to decide how to expand
@@ -2019,19 +2024,19 @@ rhsIsStatic :: Platform -> (Name -> Bool) -> CoreExpr -> Bool
 --
 --    c) don't look through unfolding of f in (f x).
 
-rhsIsStatic platform is_dynamic_name rhs = is_static False rhs
+rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
   where
   is_static :: Bool     -- True <=> in a constructor argument; must be atomic
             -> CoreExpr -> Bool
 
-  is_static False (Lam b e)             = isRuntimeVar b || is_static False e
-  is_static in_arg (Tick n e)           = not (tickishIsCode n)
-                                            && is_static in_arg e
-  is_static in_arg (Cast e _)           = is_static in_arg e
-  is_static _      (Coercion {})        = True   -- Behaves just like a literal
-  is_static _      (Lit (LitInteger {})) = False
-  is_static _      (Lit (MachLabel {})) = False
-  is_static _      (Lit _)              = True
+  is_static False  (Lam b e)              = isRuntimeVar b || is_static False e
+  is_static in_arg (Tick n e)             = not (tickishIsCode n)
+                                              && is_static in_arg e
+  is_static in_arg (Cast e _)             = is_static in_arg e
+  is_static _      (Coercion {})          = True   -- Behaves just like a literal
+  is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i)
+  is_static _      (Lit (MachLabel {}))   = False
+  is_static _      (Lit _)                = True
         -- A MachLabel (foreign import "&foo") in an argument
         -- prevents a constructor application from being static.  The
         -- reason is that it might give rise to unresolvable symbols

compiler/main/TidyPgm.hs

@@ -1105,7 +1105,8 @@ tidyTopBinds :: HscEnv
 tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
   = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
        integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
-       return $ tidy mkIntegerId integerSDataCon init_env binds
+       let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon
+       return $ tidy cvt_integer init_env binds
   where
     dflags = hsc_dflags hsc_env
 
@@ -1113,37 +1114,35 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
 
     this_pkg = thisPackage dflags
 
-    tidy _           _                 env []     = (env, [])
-    tidy mkIntegerId integerSDataCon env (b:bs)
+    tidy _           env []     = (env, [])
+    tidy cvt_integer env (b:bs)
         = let (env1, b')  = tidyTopBind dflags this_pkg this_mod
-                            mkIntegerId integerSDataCon unfold_env env b
-              (env2, bs') = tidy mkIntegerId integerSDataCon env1 bs
+                                        cvt_integer unfold_env env b
+              (env2, bs') = tidy cvt_integer env1 bs
           in  (env2, b':bs')
 
 ------------------------
 tidyTopBind  :: DynFlags
              -> PackageKey
              -> Module
-             -> Id
-             -> Maybe DataCon
+             -> (Integer -> CoreExpr)
              -> UnfoldEnv
              -> TidyEnv
              -> CoreBind
              -> (TidyEnv, CoreBind)
 
-tidyTopBind dflags this_pkg this_mod mkIntegerId integerSDataCon unfold_env
+tidyTopBind dflags this_pkg this_mod cvt_integer unfold_env
             (occ_env,subst1) (NonRec bndr rhs)
   = (tidy_env2,  NonRec bndr' rhs')
   where
     Just (name',show_unfold) = lookupVarEnv unfold_env bndr
-    caf_info      = hasCafRefs dflags this_pkg this_mod
-                    (mkIntegerId, integerSDataCon, subst1) (idArity bndr) rhs
+    caf_info      = hasCafRefs dflags this_pkg this_mod (subst1, cvt_integer) (idArity bndr) rhs
     (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs)
     subst2        = extendVarEnv subst1 bndr bndr'
     tidy_env2     = (occ_env, subst2)
 
-tidyTopBind dflags this_pkg this_mod mkIntegerId integerSDataCon unfold_env
-            (occ_env,subst1) (Rec prs)
+tidyTopBind dflags this_pkg this_mod cvt_integer unfold_env
+            (occ_env, subst1) (Rec prs)
   = (tidy_env2, Rec prs')
   where
     prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)
@@ -1161,8 +1160,8 @@ tidyTopBind dflags this_pkg this_mod mkIntegerId integerSDataCon unfold_env
         -- the group may refer indirectly to a CAF (because then, they all do).
     caf_info
         | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod
-                               (mkIntegerId, integerSDataCon, subst1)
-                               (idArity bndr) rhs)
+                                          (subst1, cvt_integer)
+                                          (idArity bndr) rhs)
              | (bndr,rhs) <- prs ] = MayHaveCafRefs
         | otherwise                = NoCafRefs
 
@@ -1296,18 +1295,32 @@ hence the size of the SRTs) down, we could also look at the expression and
 decide whether it requires a small bounded amount of heap, so we can ignore
 it as a CAF.  In these cases however, we would need to use an additional
 CAF list to keep track of non-collectable CAFs.
+
+Note [Disgusting computation of CafRefs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We compute hasCafRefs here, because IdInfo is supposed to be finalised
+after TidyPgm.  But CorePrep does some transformations that affect CAF-hood.
+So we have to *predict* the result here, which is revolting.
+
+In particular CorePrep expands Integer literals.  So in the prediction code
+here we resort to applying the same expansion (cvt_integer). Ugh!
 -}
 
+type CafRefEnv = (VarEnv Id, Integer -> CoreExpr)
+  -- The env finds the Caf-ness of the Id
+  -- The Integer -> CoreExpr is the desugaring function for Integer literals
+  -- See Note [Disgusting computation of CafRefs]
+
 hasCafRefs :: DynFlags -> PackageKey -> Module
-           -> (Id, Maybe DataCon, VarEnv Var) -> Arity -> CoreExpr
+           -> CafRefEnv -> Arity -> CoreExpr
            -> CafInfo
-hasCafRefs dflags this_pkg this_mod p arity expr
+hasCafRefs dflags this_pkg this_mod p@(_,cvt_integer) arity expr
   | is_caf || mentions_cafs = MayHaveCafRefs
   | otherwise               = NoCafRefs
  where
-  mentions_cafs = isFastTrue (cafRefsE dflags p expr)
+  mentions_cafs   = isFastTrue (cafRefsE p expr)
   is_dynamic_name = isDllName dflags this_pkg this_mod
-  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr)
+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr)
 
   -- NB. we pass in the arity of the expression, which is expected
   -- to be calculated by exprArity.  This is because exprArity
@@ -1315,35 +1328,34 @@ hasCafRefs dflags this_pkg this_mod p arity expr
   -- CorePrep later on, and we don't want to duplicate that
   -- knowledge in rhsIsStatic below.
 
-cafRefsE :: DynFlags -> (Id, Maybe DataCon, VarEnv Id) -> Expr a -> FastBool
-cafRefsE _      p (Var id)            = cafRefsV p id
-cafRefsE dflags p (Lit lit)           = cafRefsL dflags p lit
-cafRefsE dflags p (App f a)           = fastOr (cafRefsE dflags p f) (cafRefsE dflags p) a
-cafRefsE dflags p (Lam _ e)           = cafRefsE dflags p e
-cafRefsE dflags p (Let b e)           = fastOr (cafRefsEs dflags p (rhssOfBind b)) (cafRefsE dflags p) e
-cafRefsE dflags p (Case e _bndr _ alts) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) (rhssOfAlts alts)
-cafRefsE dflags p (Tick _n e)         = cafRefsE dflags p e
-cafRefsE dflags p (Cast e _co)        = cafRefsE dflags p e
-cafRefsE _      _ (Type _)            = fastBool False
-cafRefsE _      _ (Coercion _)        = fastBool False
-
-cafRefsEs :: DynFlags -> (Id, Maybe DataCon, VarEnv Id) -> [Expr a] -> FastBool
-cafRefsEs _      _ []     = fastBool False
-cafRefsEs dflags p (e:es) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) es
-
-cafRefsL :: DynFlags -> (Id, Maybe DataCon, VarEnv Id) -> Literal -> FastBool
+cafRefsE :: CafRefEnv -> Expr a -> FastBool
+cafRefsE p (Var id)            = cafRefsV p id
+cafRefsE p (Lit lit)           = cafRefsL p lit
+cafRefsE p (App f a)           = fastOr (cafRefsE p f) (cafRefsE p) a
+cafRefsE p (Lam _ e)           = cafRefsE p e
+cafRefsE p (Let b e)           = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e
+cafRefsE p (Case e _bndr _ alts) = fastOr (cafRefsE p e) (cafRefsEs p) (rhssOfAlts alts)
+cafRefsE p (Tick _n e)         = cafRefsE p e
+cafRefsE p (Cast e _co)        = cafRefsE p e
+cafRefsE _ (Type _)            = fastBool False
+cafRefsE _ (Coercion _)        = fastBool False
+
+cafRefsEs :: CafRefEnv -> [Expr a] -> FastBool
+cafRefsEs _ []     = fastBool False
+cafRefsEs p (e:es) = fastOr (cafRefsE p e) (cafRefsEs p) es
+
+cafRefsL :: CafRefEnv -> Literal -> FastBool
 -- Don't forget that mk_integer id might have Caf refs!
 -- We first need to convert the Integer into its final form, to
 -- see whether mkInteger is used.
-cafRefsL dflags p@(mk_integer, sdatacon, _) (LitInteger i _)
-    = cafRefsE dflags p (cvtLitInteger dflags mk_integer sdatacon i)
-cafRefsL _      _ _                         = fastBool False
-
-cafRefsV :: (Id, Maybe DataCon, VarEnv Id) -> Id -> FastBool
-cafRefsV (_, _, p) id
-  | not (isLocalId id)            = fastBool (mayHaveCafRefs (idCafInfo id))
-  | Just id' <- lookupVarEnv p id = fastBool (mayHaveCafRefs (idCafInfo id'))
-  | otherwise                     = fastBool False
+cafRefsL p@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i)
+cafRefsL _                  _                = fastBool False
+
+cafRefsV :: CafRefEnv -> Id -> FastBool
+cafRefsV (subst, _) id
+  | not (isLocalId id)                = fastBool (mayHaveCafRefs (idCafInfo id))
+  | Just id' <- lookupVarEnv subst id = fastBool (mayHaveCafRefs (idCafInfo id'))
+  | otherwise                         = fastBool False
 
 fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool
 -- hack for lazy-or over FastBool.

testsuite/tests/lib/integer/all.T

@@ -3,8 +3,7 @@ test('integerConversions', normal, compile_and_run, [''])
 # skip ghci as it doesn't support unboxed tuples
 test('integerGmpInternals', [reqlib('integer-gmp'), omit_ways('ghci')], compile_and_run, [''])
 test('integerConstantFolding',
-     [ extra_clean(['integerConstantFolding.simpl'])
-     , when(compiler_debugged(), expect_broken(8525))],
+     extra_clean(['integerConstantFolding.simpl']),
      run_command,
      ['$MAKE -s --no-print-directory integerConstantFolding'])
 test('fromToInteger',