Do not forget CPR information after an IO action
authorJoachim Breitner <mail@joachim-breitner.de>
Fri, 6 Dec 2013 17:58:29 +0000 (17:58 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 9 Dec 2013 15:42:09 +0000 (15:42 +0000)
but do forget about certain divergence, if required. Fixes one part of
ticket #8598.

The added function (deferAfterIO) can maybe be merged with existing
code, but given the ongoing work in the nested-cpr branch, I defer that
work.

compiler/basicTypes/Demand.lhs
compiler/stranal/DmdAnal.lhs

index cd844a1..ff6c59f 100644 (file)
@@ -35,7 +35,7 @@ module Demand (
 
         evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, 
         splitDmdTy, splitFVs,
-        deferDmd, deferType, deferAndUse, deferEnv, modifyEnv,
+        deferDmd, deferType, deferAndUse, deferAfterIO, deferEnv, modifyEnv,
 
         splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd,
         dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
@@ -1086,6 +1086,23 @@ useType (DmdType fv ds res_ty) = DmdType (useEnv fv) ds res_ty
 useEnv :: DmdEnv -> DmdEnv
 useEnv fv = mapVarEnv useDmd fv
 
+-- When e is evaluated after executing an IO action, and d is e's demand, then
+-- what of this demand should we consider, given that the IO action can cleanly
+-- exit?
+-- * We have to kill all strictness demands (i.e. lub with a lazy demand)
+-- * We can keep demand information (i.e. lub with an absent deman)
+-- * We have to kill definite divergence
+-- * We can keep CPR information.
+-- See Note [IO hack in the demand analyser]
+deferAfterIO :: DmdType -> DmdType
+deferAfterIO d@(DmdType _ _ res) =
+    case d `lubDmdType` topDmdType of
+        DmdType fv ds _ -> DmdType fv ds (defer_res res)
+  where
+  defer_res BotCPR  = NoCPR
+  defer_res r       = r
+
+
 modifyEnv :: Bool                       -- No-op if False
           -> (Demand -> Demand)         -- The zapper
           -> DmdEnv -> DmdEnv           -- Env1 and Env2
index 0ceb7c9..cadc04c 100644 (file)
@@ -335,7 +335,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 = deferAfterIO alt_ty
                     | otherwise    = alt_ty
 
        -- There's a hack here for I/O operations.  Consider