From fb9f8859e5707f2c960540bac3efb8efc68ce6ec Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Tue, 3 Nov 2009 15:50:09 +0000
Subject: [PATCH] Add a (DEBUG-only) warning for top-level error thunks with
 uninformative strictness info

In the past I've seen this in an interface file

   foo = error "urk"

but *without* a bottoming strictness info on 'foo'. This WARN just
checks (non-fatally) for the bad case, so that we can track it down easily
---
 compiler/main/TidyPgm.lhs |   19 ++++++++++++++-----
 1 file changed, 14 insertions(+), 5 deletions(-)

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 2918875..fc40f5a 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -18,7 +18,7 @@ import CoreFVs
 import CoreTidy
 import CoreMonad
 import CoreUtils
-import CoreArity	( exprArity )
+import CoreArity	( exprArity, exprBotStrictness_maybe )
 import Class		( classSelIds )
 import VarEnv
 import VarSet
@@ -969,18 +969,27 @@ tidyTopPair :: Bool  -- show unfolding
 	-- in the IdInfo of one early in the group
 
 tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
-  = (bndr', rhs')
+  = WARN( not _bottom_exposed, ppr bndr1 )
+    (bndr1, rhs1)
   where
-    bndr' = mkGlobalId details name' ty' idinfo'
+    -- If the cheap-and-cheerful bottom analyser can see that
+    -- the RHS is bottom, it should jolly well be exposed
+    _bottom_exposed = case exprBotStrictness_maybe rhs of
+                        Nothing         -> True
+                        Just (arity, _) -> appIsBottom str arity
+        where
+          str = newStrictnessInfo idinfo `orElse` topSig
+
+    bndr1   = mkGlobalId details name' ty' idinfo'
     details = idDetails bndr	-- Preserve the IdDetails
     ty'	    = tidyTopType (idType bndr)
-    rhs'    = tidyExpr rhs_tidy_env rhs
+    rhs1    = tidyExpr rhs_tidy_env rhs
     idinfo  = idInfo bndr
     idinfo' = tidyTopIdInfo (isExternalName name')
 			    idinfo unfold_info
 			    arity caf_info
 
-    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs' (unfoldingInfo idinfo)
+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs1 (unfoldingInfo idinfo)
 		| otherwise   = noUnfolding
     -- NB: do *not* expose the worker if show_unfold is off,
     --     because that means this thing is a loop breaker or
-- 
1.7.10.4