[commit: ghc] wip/T8598: Do not forget CPR information after an IO action (a2f7d68)

[git at git.haskell.org]

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

On branch  : wip/T8598
Link       : http://ghc.haskell.org/trac/ghc/changeset/a2f7d686fbbcd822a59211b16142d151b99ffa43/ghc

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

commit a2f7d686fbbcd822a59211b16142d151b99ffa43
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Dec 6 17:58:29 2013 +0000

    Do not forget CPR information after an IO action
    
    but do forget about certain divergence, if required. Fixes one part of
    ticket #8598.


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

a2f7d686fbbcd822a59211b16142d151b99ffa43
 compiler/basicTypes/Demand.lhs |   31 +++++++++++++++++++------------
 compiler/stranal/DmdAnal.lhs   |    2 +-
 2 files changed, 20 insertions(+), 13 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index cd844a1..f03de42 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -19,7 +19,7 @@ module Demand (
         peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,
 
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdEnv, bothDmdType,
-        topDmdType, botDmdType, mkDmdType, mkTopDmdType, 
+        topDmdType, botDmdType, exitDmdType, mkDmdType, mkTopDmdType,
 
         DmdEnv, emptyDmdEnv,
 
@@ -715,14 +715,15 @@ splitProdDmd_maybe (JD {strd = s, absd = u})
 data CPRResult = NoCPR              -- Top of the lattice
                | RetProd            -- Returns a constructor from a product type
                | RetSum ConTag      -- Returns a constructor from a sum type with this tag
-               | BotCPR             -- Returns a constructor with any tag
-                                    -- Bottom of the domain
+               | ExitCPR            -- Exits cleanly
+               | BotCPR             -- Diverges
                deriving( Eq, Show )
 
 lubCPR :: CPRResult -> CPRResult -> CPRResult
 lubCPR BotCPR      r           = r
-lubCPR RetProd     BotCPR      = RetProd
-lubCPR (RetSum t)  BotCPR      = RetSum t
+lubCPR r           BotCPR      = r
+lubCPR ExitCPR     r           = r
+lubCPR r           ExitCPR     = r
 lubCPR (RetSum t1) (RetSum t2)
   | t1 == t2                   = RetSum t1
 lubCPR RetProd     RetProd     = RetProd
@@ -730,12 +731,14 @@ lubCPR _ _                     = NoCPR
 
 bothCPR :: CPRResult -> CPRResult -> CPRResult
 -- See Note [Asymmetry of 'both' for DmdType and DmdResult]
-bothCPR _ BotCPR = BotCPR   -- If either diverges, we diverge
-bothCPR r _      = r
+bothCPR _ BotCPR  = BotCPR   -- If either diverges, we diverge
+bothCPR _ ExitCPR = ExitCPR  -- If either exists, we exit
+bothCPR r _      = r        -- otherwise, the second argument is irrelevant
 
 instance Outputable DmdResult where
   ppr RetProd    = char 'm'
   ppr (RetSum n) = char 'm' <> int n
+  ppr ExitCPR    = char 'e'
   ppr BotCPR     = char 'b'
   ppr NoCPR      = empty   -- Keep these distinct from Demand letters
 
@@ -755,8 +758,9 @@ seqDmdResult r = r `seq` ()
 
 -- [cprRes] lets us switch off CPR analysis
 -- by making sure that everything uses TopRes
-topRes, botRes :: DmdResult
+topRes, exitRes, botRes :: DmdResult
 topRes = NoCPR
+exitRes = ExitCPR
 botRes = BotCPR
 
 cprSumRes :: ConTag -> DmdResult
@@ -1030,9 +1034,10 @@ instance Outputable DmdType where
 emptyDmdEnv :: VarEnv Demand
 emptyDmdEnv = emptyVarEnv
 
-topDmdType, botDmdType :: DmdType
-topDmdType = DmdType emptyDmdEnv [] topRes
-botDmdType = DmdType emptyDmdEnv [] botRes
+topDmdType, exitDmdType, botDmdType :: DmdType
+topDmdType  = DmdType emptyDmdEnv [] topRes
+exitDmdType = DmdType emptyDmdEnv [] exitRes
+botDmdType  = DmdType emptyDmdEnv [] botRes
 
 cprProdDmdType :: DmdType
 cprProdDmdType = DmdType emptyDmdEnv [] cprProdRes
@@ -1583,6 +1588,7 @@ instance Binary CPRResult where
     put_ bh RetProd      = putByte bh 1
     put_ bh NoCPR        = putByte bh 2
     put_ bh BotCPR       = putByte bh 3
+    put_ bh ExitCPR      = putByte bh 4
 
     get  bh = do
             h <- getByte bh
@@ -1590,5 +1596,6 @@ instance Binary CPRResult where
               0 -> do { n <- get bh; return (RetSum n) }
               1 -> return RetProd
               2 -> return NoCPR
-              _ -> return BotCPR
+              3 -> return BotCPR
+              _ -> return ExitCPR
 \end{code}
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 99eb7ac..094f74a 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -332,7 +332,7 @@ dmdAnalAlt env dmd (con,bndrs,rhs)
 	(rhs_ty, rhs')   = dmdAnal env dmd rhs
         rhs_ty'          = addDataConPatDmds con bndrs rhs_ty
 	(alt_ty, bndrs') = annotateBndrs env rhs_ty' bndrs
-	final_alt_ty | io_hack_reqd = alt_ty `lubDmdType` topDmdType
+	final_alt_ty | io_hack_reqd = alt_ty `lubDmdType` exitDmdType
 		     | otherwise    = alt_ty
 
 	-- There's a hack here for I/O operations.  Consider