[commit: ghc] wip/12368: WwLib: Add strictness signature to "let x = absentError …" (6b4f035)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/12368
Link       : http://ghc.haskell.org/trac/ghc/changeset/6b4f0359f5dfa8c357423b07c5ba0345cd185734/ghc

>---------------------------------------------------------------

commit 6b4f0359f5dfa8c357423b07c5ba0345cd185734
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jul 26 12:08:59 2016 +0200

    WwLib: Add strictness signature to "let x = absentError …"
    
    indicating that it is bottom. This should help making the "empty cases"
    lint error give less false alarms.


>---------------------------------------------------------------

6b4f0359f5dfa8c357423b07c5ba0345cd185734
 compiler/basicTypes/Demand.hs |  9 ++++++---
 compiler/stranal/WwLib.hs     | 14 +++++++++-----
 2 files changed, 15 insertions(+), 8 deletions(-)

diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 2ada6b3..d79fa6e 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -35,7 +35,8 @@ module Demand (
         vanillaCprProdRes, cprSumRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
         trimCPRInfo, returnsCPR_maybe,
-        StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
+        StrictSig(..), mkStrictSig, mkClosedStrictSig,
+        nopSig, botSig, exnSig, cprProdSig,
         isTopSig, hasDemandEnvSig,
         splitStrictSig, strictSigDmdEnv,
         increaseStrictSigArity,
@@ -1264,9 +1265,10 @@ emptyDmdEnv = emptyVarEnv
 -- (lazy, absent, no CPR information, no termination information).
 -- Note that it is ''not'' the top of the lattice (which would be "may use everything"),
 -- so it is (no longer) called topDmd
-nopDmdType, botDmdType :: DmdType
+nopDmdType, botDmdType, exnDmdType :: DmdType
 nopDmdType = DmdType emptyDmdEnv [] topRes
 botDmdType = DmdType emptyDmdEnv [] botRes
+exnDmdType = DmdType emptyDmdEnv [] exnRes
 
 cprProdDmdType :: Arity -> DmdType
 cprProdDmdType arity
@@ -1691,9 +1693,10 @@ isBottomingSig :: StrictSig -> Bool
 -- True if the signature diverges or throws an exception
 isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res
 
-nopSig, botSig :: StrictSig
+nopSig, botSig, exnSig :: StrictSig
 nopSig = StrictSig nopDmdType
 botSig = StrictSig botDmdType
+exnSig = StrictSig exnDmdType
 
 cprProdSig :: Arity -> StrictSig
 cprProdSig arity = StrictSig (cprProdDmdType arity)
diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs
index 812252c..5d9d7f6 100644
--- a/compiler/stranal/WwLib.hs
+++ b/compiler/stranal/WwLib.hs
@@ -709,7 +709,7 @@ every primitive type, so the function is partial.
 mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
 mk_absent_let dflags arg
   | not (isUnliftedType arg_ty)
-  = Just (Let (NonRec arg abs_rhs))
+  = Just (Let (NonRec lifted_arg abs_rhs))
   | Just tc <- tyConAppTyCon_maybe arg_ty
   , Just lit <- absentLiteralOf tc
   = Just (Let (NonRec arg (Lit lit)))
@@ -719,10 +719,14 @@ mk_absent_let dflags arg
   = WARN( True, text "No absent value for" <+> ppr arg_ty )
     Nothing
   where
-    arg_ty  = idType arg
-    abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
-    msg     = showSDoc (gopt_set dflags Opt_SuppressUniques)
-                       (ppr arg <+> ppr (idType arg))
+    arg_ty     = idType arg
+    abs_rhs    = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
+    lifted_arg = arg `setIdStrictness` exnSig
+              -- Note in strictness signature that this is bottoming
+              -- (for the sake of the "empty case scrutinee not known to
+              -- diverge for sure lint" warning
+    msg        = showSDoc (gopt_set dflags Opt_SuppressUniques)
+                          (ppr arg <+> ppr (idType arg))
               -- We need to suppress uniques here because otherwise they'd
               -- end up in the generated code as strings. This is bad for
               -- determinism, because with different uniques the strings