Replace static CPR flags by dynamic -fcpr-depth

which can disable cpr altogether (=0), disable nested cpr (=1) or
finetune cpr.

Also includes a testcase for this.

10 files changed, 76 insertions, 52 deletions

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index c224572666..9aad3a7c3d 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -56,7 +56,6 @@ module Demand (
 
 #include "HsVersions.h"
 
-import StaticFlags
 import DynFlags
 import Outputable
 import Var ( Var )
@@ -803,22 +802,16 @@ seqCPRResult (RetProd rs) = seqListWith seqDmdResult rs
 -- Combined demand result                                             --
 ------------------------------------------------------------------------
 
--- [cprRes] lets us switch off CPR analysis
--- by making sure that everything uses TopRes
 topRes, convRes, botRes :: DmdResult
 topRes = Dunno NoCPR
 convRes = Converges NoCPR
 botRes = Diverges
 
-cprSumRes :: ConTag -> DmdResult
-cprSumRes tag | opt_CprOff = topRes
-              | otherwise  = Converges $ RetSum tag
+cprSumRes :: Int -> ConTag -> DmdResult
+cprSumRes depth tag = cutDmdResult depth $ Converges $ RetSum tag
 
-cprProdRes :: [DmdResult] -> DmdResult
-cprProdRes arg_ress
-  | opt_CprOff        = topRes
-  | opt_NestedCprOff  = Converges $ cutCPRResult flatCPRDepth $ RetProd arg_ress
-  | otherwise         = Converges $ cutCPRResult maxCPRDepth  $ RetProd arg_ress
+cprProdRes :: Int -> [DmdResult] -> DmdResult
+cprProdRes depth arg_ress = cutDmdResult depth $ Converges $ RetProd arg_ress
 
 getDmdResult :: DmdType -> DmdResult
 getDmdResult (DmdType _ [] r) = r       -- Only for data-typed arguments!
@@ -828,16 +821,6 @@ getDmdResult _                = topRes
 divergeDmdResult :: DmdResult -> DmdResult
 divergeDmdResult r = r `lubDmdResult` botRes
 
-maxCPRDepth :: Int
-maxCPRDepth = 3
-
--- This is the depth we use with -fnested-cpr-off, in order
--- to get precisely the same behaviour as before introduction of nested cpr
--- -fnested-cpr-off can eventually be removed if nested cpr is deemd to be
--- a good thing always.
-flatCPRDepth :: Int
-flatCPRDepth = 1
-
 -- With nested CPR, DmdResult can be arbitrarily deep; consider
 -- data Rec1 = Foo Rec2 Rec2
 -- data Rec2 = Bar Rec1 Rec1
@@ -847,17 +830,17 @@ flatCPRDepth = 1
 --
 -- So we need to forget information at a certain depth. We do that at all points
 -- where we are constructing new RetProd constructors.
+cutDmdResult :: Int -> DmdResult -> DmdResult
+cutDmdResult 0 _             = topRes
+cutDmdResult _ Diverges      = Diverges
+cutDmdResult n (Converges c) = Converges (cutCPRResult n c)
+cutDmdResult n (Dunno c)     = Dunno     (cutCPRResult n c)
+
 cutCPRResult :: Int -> CPRResult -> CPRResult
 cutCPRResult 0 _               = NoCPR
 cutCPRResult _ NoCPR           = NoCPR
 cutCPRResult _ (RetSum tag)    = RetSum tag
 cutCPRResult n (RetProd rs)    = RetProd (map (cutDmdResult (n-1)) rs)
-  where
-    cutDmdResult :: Int -> DmdResult -> DmdResult
-    cutDmdResult 0 _             = topRes
-    cutDmdResult _ Diverges      = Diverges
-    cutDmdResult n (Converges c) = Converges (cutCPRResult n c)
-    cutDmdResult n (Dunno c)     = Dunno     (cutCPRResult n c)
 
 -- Forget the CPR information, but remember if it converges or diverges
 -- Used for non-strict thunks and non-top-level things with sum type
@@ -1162,13 +1145,12 @@ nopDmdType = DmdType emptyDmdEnv [] topRes
 botDmdType = DmdType emptyDmdEnv [] botRes
 litDmdType = DmdType emptyDmdEnv [] convRes
 
-cprProdDmdType :: [DmdResult] -> DmdType
-cprProdDmdType arg_ress
-  = DmdType emptyDmdEnv [] $ cprProdRes arg_ress
+cprProdDmdType :: Int -> [DmdResult] -> DmdType
+cprProdDmdType depth arg_ress
+  = DmdType emptyDmdEnv [] $ cprProdRes depth arg_ress
 
-cprSumDmdType :: ConTag -> DmdType
-cprSumDmdType tag
-  = DmdType emptyDmdEnv [] $ cprSumRes tag
+cprSumDmdType :: Int -> ConTag -> DmdType
+cprSumDmdType depth tag = DmdType emptyDmdEnv [] $ cprSumRes depth tag
 
 isNopDmdType :: DmdType -> Bool
 isNopDmdType (DmdType env [] res)
@@ -1546,8 +1528,8 @@ nopSig, botSig :: StrictSig
 nopSig = StrictSig nopDmdType
 botSig = StrictSig botDmdType
 
-cprProdSig :: [DmdResult] -> StrictSig
-cprProdSig arg_ress = StrictSig (cprProdDmdType arg_ress)
+cprProdSig :: Int -> [DmdResult] -> StrictSig
+cprProdSig depth arg_ress = StrictSig (cprProdDmdType depth arg_ress)
 
 sigMayDiverge :: StrictSig -> StrictSig
 sigMayDiverge (StrictSig (DmdType env ds res)) = (StrictSig (DmdType env ds (divergeDmdResult res)))
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 615fdbb08b..81c2a07b4d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -758,6 +758,8 @@ data DynFlags = DynFlags {
 
   maxWorkerArgs         :: Int,
 
+  maxCprDepth           :: Int,
+
   ghciHistSize          :: Int,
 
   -- | MsgDoc output action: use "ErrUtils" instead of this if you can
@@ -1425,6 +1427,8 @@ defaultDynFlags mySettings =
 
         maxWorkerArgs = 10,
 
+        maxCprDepth = 3,
+
         ghciHistSize = 50, -- keep a log of length 50 by default
 
         log_action = defaultLogAction,
@@ -2427,6 +2431,8 @@ dynamic_flags = [
 
   , Flag "fmax-worker-args" (intSuffix (\n d -> d {maxWorkerArgs = n}))
 
+  , Flag "fcpr-depth" (intSuffix (\n d -> d {maxCprDepth = n}))
+
   , Flag "fghci-hist-size" (intSuffix (\n d -> d {ghciHistSize = n}))
 
         ------ Profiling ----------------------------------------------------
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index feb7235ac0..635e8ce38e 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -26,8 +26,6 @@ module StaticFlags (
 
         -- optimisation opts
         opt_NoStateHack,
-        opt_CprOff,
-        opt_NestedCprOff,
         opt_NoOptCoercion,
 
         -- For the parser
@@ -140,9 +138,7 @@ isStaticFlag f = f `elem` flagsStaticNames
 flagsStaticNames :: [String]
 flagsStaticNames = [
     "fno-state-hack",
-    "fno-opt-coercion",
-    "fcpr-off",
-    "fnested-cpr-off"
+    "fno-opt-coercion"
     ]
 
 -- We specifically need to discard static flags for clients of the
@@ -155,7 +151,6 @@ discardStaticFlags :: [String] -> [String]
 discardStaticFlags = filter (\x -> x `notElem` flags)
   where flags = [ "-fno-state-hack"
                 , "-fno-opt-coercion"
-                , "-fcpr-off"
                 , "-dppr-debug"
                 , "-dno-debug-output"
                 ]
@@ -198,12 +193,6 @@ opt_NoStateHack    :: Bool
 opt_NoStateHack    = lookUp  (fsLit "-fno-state-hack")
 
 -- Switch off CPR analysis in the demand analyser
-opt_CprOff         :: Bool
-opt_CprOff         = lookUp  (fsLit "-fcpr-off")
-
-opt_NestedCprOff   :: Bool
-opt_NestedCprOff   = lookUp  (fsLit "-fnested-cpr-off")
-
 opt_NoOptCoercion  :: Bool
 opt_NoOptCoercion  = lookUp  (fsLit "-fno-opt-coercion")
 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index e86e597f79..7dec582041 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -209,7 +209,7 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, bndrs, _)])
 
         -- Build a surely converging, CPR carrying signature for the builder,
         -- and for the components use what we get from the scrunitee
-        case_bndr_sig = cprProdSig comp_rets
+        case_bndr_sig = cprProdSig (maxCprDepth (ae_dflags env)) comp_rets
 
         env_w_tc              = env { ae_rec_tc = rec_tc' }
 	env_alt	              = extendAnalEnvs NotTopLevel env_w_tc $
@@ -240,7 +240,8 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
 	(alt_ty, alt')	      = dmdAnalAlt env_alt dmd alt
 	(alt_ty1, case_bndr') = annotateBndr env alt_ty case_bndr
 	(_, bndrs', _)	      = alt'
-	case_bndr_sig	      = cprProdSig (replicate (dataConRepArity dc) topRes)
+	case_bndr_sig	      = cprProdSig (maxCprDepth (ae_dflags env))
+                                           (replicate (dataConRepArity dc) topRes)
 		-- Inside the alternative, the case binder has the CPR property, and
                 -- is known to converge.
 		-- Meaning that a case on it will successfully cancel.
@@ -570,8 +571,8 @@ dmdAnalVarApp env dmd fun args
   , dataConRepArity con > 0
   , dataConRepArity con < 10
   , let cpr_info
-          | isProductTyCon (dataConTyCon con) = cprProdDmdType arg_rets
-          | otherwise                         = cprSumDmdType (dataConTag con)
+          | isProductTyCon (dataConTyCon con) = cprProdDmdType (maxCprDepth (ae_dflags env)) arg_rets
+          | otherwise                         = cprSumDmdType (maxCprDepth (ae_dflags env)) (dataConTag con)
         res_ty = foldl bothDmdType cpr_info arg_tys
   = -- pprTrace "dmdAnalVarApp" (vcat [ ppr con, ppr args, ppr n_val_args, ppr cxt_ds
     --                                , ppr arg_tys, ppr cpr_info, ppr res_ty]) $
@@ -1195,7 +1196,8 @@ extendSigsWithLam env id
        -- See Note [Initial CPR for strict binders]
   , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id
   = extendAnalEnv NotTopLevel env id $ sigMayDiverge $
-    cprProdSig (replicate (dataConRepArity dc) topRes)
+    cprProdSig (maxCprDepth (ae_dflags env))
+               (replicate (dataConRepArity dc) topRes)
 
   | otherwise 
   = env
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index b054fd98bd..0c10190fb3 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -1740,6 +1740,15 @@
           </row>
 
           <row>
+            <entry><option>-fcpr-depth=N</option></entry>
+            <entry>Analyze the result of functions for constructed product
+              results do that depth. Setting this to zero disables CPR, setting
+              this to one disables nested CPR. (default: 3)</entry>
+            <entry>dynamic</entry>
+            <entry>-</entry>
+          </row>
+
+          <row>
             <entry><option>-fno-opt-coercion</option></entry>
             <entry>Turn off the coercion optimiser</entry>
             <entry>static</entry>
diff --git a/testsuite/tests/stranal/sigs/InfiniteCPRDepth0.hs b/testsuite/tests/stranal/sigs/InfiniteCPRDepth0.hs
new file mode 100644
index 0000000000..41e9159556
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/InfiniteCPRDepth0.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fcpr-depth=0 #-}
+
+module InfiniteCPR where
+
+data Rec1 = Foo Rec2 Rec2
+data Rec2 = Bar Rec1 Rec1
+
+f a =
+    let x = Foo a y
+        y = Bar x x
+    in x
+
diff --git a/testsuite/tests/stranal/sigs/InfiniteCPRDepth0.stderr b/testsuite/tests/stranal/sigs/InfiniteCPRDepth0.stderr
new file mode 100644
index 0000000000..63ca4b6f06
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/InfiniteCPRDepth0.stderr
@@ -0,0 +1,5 @@
+
+==================== Strictness signatures ====================
+InfiniteCPR.f: <L,U>
+
+
diff --git a/testsuite/tests/stranal/sigs/InfiniteCPRDepth1.hs b/testsuite/tests/stranal/sigs/InfiniteCPRDepth1.hs
new file mode 100644
index 0000000000..50486374ff
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/InfiniteCPRDepth1.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fcpr-depth=1 #-}
+
+module InfiniteCPR where
+
+data Rec1 = Foo Rec2 Rec2
+data Rec2 = Bar Rec1 Rec1
+
+f a =
+    let x = Foo a y
+        y = Bar x x
+    in x
+
diff --git a/testsuite/tests/stranal/sigs/InfiniteCPRDepth1.stderr b/testsuite/tests/stranal/sigs/InfiniteCPRDepth1.stderr
new file mode 100644
index 0000000000..f116ee2e1a
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/InfiniteCPRDepth1.stderr
@@ -0,0 +1,5 @@
+
+==================== Strictness signatures ====================
+InfiniteCPR.f: <L,U>m(,)
+
+
diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T
index ea66fdcb0a..448dc8ea95 100644
--- a/testsuite/tests/stranal/sigs/all.T
+++ b/testsuite/tests/stranal/sigs/all.T
@@ -17,3 +17,5 @@ test('BottomFromInnerLambda', normal, compile, [''])
 test('DmdAnalGADTs', normal, compile, [''])
 test('CaseBinderCPR', normal, compile, [''])
 test('InfiniteCPR', normal, compile, [''])
+test('InfiniteCPRDepth0', normal, compile, [''])
+test('InfiniteCPRDepth1', normal, compile, [''])