Add flag to control loopification

It is off by default, which is meant to be a workaround for #8275.
Once #8275 is fixed we will enable this option by default.

3 files changed, 12 insertions, 4 deletions

diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 04297b4258..627c189f12 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -527,9 +527,10 @@ getCallMethod :: DynFlags
               -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?
               -> CallMethod
 
-getCallMethod _ _ id _ n_args _cg_loc (Just (self_loop_id, block_id, args))
-  | id == self_loop_id, n_args == length args
+getCallMethod dflags _ id _ n_args _cg_loc (Just (self_loop_id, block_id, args))
+  | gopt Opt_Loopification dflags, id == self_loop_id, n_args == length args
   -- If these patterns match then we know that:
+  --   * loopification optimisation is turned on
   --   * function is performing a self-recursive call in a tail position
   --   * number of parameters of the function matches functions arity.
   -- See Note [Self-recursive tail calls] in StgCmmExpr for more details
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index c7fddd49dc..2f2cdbba14 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -744,7 +744,12 @@ cgIdApp fun_id args = do
 --     recursive tail call when (a) environment stores information about
 --     possible self tail-call; (b) that tail call is to a function currently
 --     being compiled; (c) number of passed arguments is equal to function's
---     arity.
+--     arity. (d) loopification is turned on via -floopification command-line
+--     option.
+--
+--   * Command line option to control turn loopification on and off is
+--     implemented in DynFlags
+--
 
 
 emitEnter :: CmmExpr -> FCode ReturnKind
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ada18b5c19..6f528a28b4 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -310,6 +310,7 @@ data GeneralFlag
    | Opt_FunToThunk               -- allow WwLib.mkWorkerArgs to remove all value lambdas
    | Opt_DictsStrict                     -- be strict in argument dictionaries
    | Opt_DmdTxDictSel              -- use a special demand transformer for dictionary selectors
+   | Opt_Loopification                  -- See Note [Self-recursive tail calls]
 
    -- Interface files
    | Opt_IgnoreInterfacePragmas
@@ -2606,7 +2607,8 @@ fFlags = [
   ( "kill-absence",                     Opt_KillAbsence, nop),
   ( "kill-one-shot",                    Opt_KillOneShot, nop),
   ( "dicts-strict",                     Opt_DictsStrict, nop ),
-  ( "dmd-tx-dict-sel",                  Opt_DmdTxDictSel, nop )
+  ( "dmd-tx-dict-sel",                  Opt_DmdTxDictSel, nop ),
+  ( "loopification",                    Opt_Loopification, nop )
   ]
 
 -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@