Implement -fexpose-all-unfoldings, and fix a non-termination bug

The -fexpose-all-unfoldings flag arranges to put unfoldings for *everything*
in the interface file.  Of course,  this makes the file a lot bigger, but
it also makes it complete, and that's great for supercompilation; or indeed
any whole-program work.

Consequences:
  * Interface files need to record loop-breaker-hood.  (Previously,
    loop breakers were never exposed, so that info wasn't necessary.)
    Hence a small interface file format change. 

  * When inlining, must check loop-breaker-hood. (Previously, loop
    breakers didn't have an unfolding at all, so no need to check.)

  * Ditto in exprIsConApp_maybe.  Roman actually tripped this bug, 
    because a DFun, which had an unfolding, was also a loop breaker

  * TidyPgm.tidyIdInfo must be careful to preserve loop-breaker-hood

So Id.idUnfolding checks for loop-breaker-hood and returns NoUnfolding
if so. When you want the unfolding regardless of loop-breaker-hood, 
use Id.realIdUnfolding.

I have not documented the flag yet, because it's experimental.  Nor
have I tested it thoroughly.  But with the flag off (the normal case)
everything should work.

4 files changed, 42 insertions, 21 deletions

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 323e2692c2..ce023d729e 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1161,8 +1161,9 @@ instance Binary IfaceInfoItem where
     put_ bh (HsStrictness ab) = do
 	    putByte bh 1
 	    put_ bh ab
-    put_ bh (HsUnfold ad) = do
+    put_ bh (HsUnfold lb ad) = do
 	    putByte bh 2
+	    put_ bh lb
 	    put_ bh ad
     put_ bh (HsInline ad) = do
 	    putByte bh 3
@@ -1176,8 +1177,9 @@ instance Binary IfaceInfoItem where
 		      return (HsArity aa)
 	      1 -> do ab <- get bh
 		      return (HsStrictness ab)
-	      2 -> do ad <- get bh
-		      return (HsUnfold ad)
+	      2 -> do lb <- get bh
+		      ad <- get bh
+                      return (HsUnfold lb ad)
 	      3 -> do ad <- get bh
 		      return (HsInline ad)
 	      _ -> do return HsNoCafRefs
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 2e2967d89b..4311e65306 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -202,7 +202,8 @@ data IfaceInfoItem
   = HsArity	 Arity
   | HsStrictness StrictSig
   | HsInline     InlinePragma
-  | HsUnfold	 IfaceUnfolding
+  | HsUnfold	 Bool		  -- True <=> isNonRuleLoopBreaker is true
+		 IfaceUnfolding   -- See Note [Expose recursive functions] 
   | HsNoCafRefs
 
 -- NB: Specialisations and rules come in separately and are
@@ -256,6 +257,13 @@ data IfaceBinding
 data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo
 \end{code}
 
+Note [Expose recursive functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For supercompilation we want to put *all* unfoldings in the interface
+file, even for functions that are recursive (or big).  So we need to
+know when an unfolding belongs to a loop-breaker so that we can refrain
+from inlining it (except during supercompilation).
+
 Note [IdInfo on nested let-bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Occasionally we want to preserve IdInfo on nested let bindings. The one
@@ -660,7 +668,8 @@ instance Outputable IfaceIdInfo where
   ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}")
 
 instance Outputable IfaceInfoItem where
-  ppr (HsUnfold unf)  	 = ptext (sLit "Unfolding:") <+> ppr unf
+  ppr (HsUnfold lb unf)  = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)")) 
+                           <> colon <+> ppr unf
   ppr (HsInline prag)    = ptext (sLit "Inline:") <+> ppr prag
   ppr (HsArity arity)    = ptext (sLit "Arity:") <+> int arity
   ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
@@ -786,8 +795,8 @@ freeNamesIfIdInfo NoInfo = emptyNameSet
 freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
 
 freeNamesItem :: IfaceInfoItem -> NameSet
-freeNamesItem (HsUnfold u)     = freeNamesIfUnfold u
-freeNamesItem _                = emptyNameSet
+freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
+freeNamesItem _              = emptyNameSet
 
 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
 freeNamesIfUnfold (IfCoreUnfold e)     = freeNamesIfExpr e
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 0bfdae7b1d..4da21d8d91 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1471,7 +1471,8 @@ toIfaceIdInfo id_info
 			_other			      -> Nothing
 
     ------------  Unfolding  --------------
-    unfold_hsinfo = toIfUnfolding (unfoldingInfo id_info)
+    unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) 
+    loop_breaker  = isNonRuleLoopBreaker (occInfo id_info)
 					
     ------------  Inline prag  --------------
     inline_prag = inlinePragInfo id_info
@@ -1479,20 +1480,25 @@ toIfaceIdInfo id_info
                   | otherwise = Just (HsInline inline_prag)
 
 --------------------------
-toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
+toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
   = case guidance of
-	InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w)))
-	InlineRule { ir_sat = InlSat }        -> Just (HsUnfold (IfInlineRule arity True  (toIfaceExpr rhs)))
-	InlineRule { ir_sat = InlUnSat }      -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs)))
-	UnfoldNever         -> Nothing
-	UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs)))
-
-toIfUnfolding (DFunUnfolding _con ops)
-  = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops)))
+	InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold lb (IfWrapper arity (idName w)))
+	InlineRule { ir_sat = InlSat }        -> Just (HsUnfold lb (IfInlineRule arity True  (toIfaceExpr rhs)))
+	InlineRule { ir_sat = InlUnSat }      -> Just (HsUnfold lb (IfInlineRule arity False (toIfaceExpr rhs)))
+	UnfoldIfGoodArgs {} -> vanilla_unfold
+	UnfoldNever         -> vanilla_unfold	-- Yes, even if guidance is UnfoldNever, expose the unfolding
+			       			-- If we didn't want to expose the unfolding, TidyPgm would
+			       			-- have stuck in NoUnfolding.  For supercompilation we want 
+						-- to see that unfolding!
+  where
+    vanilla_unfold = Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs)))
+
+toIfUnfolding lb (DFunUnfolding _con ops)
+  = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
       -- No need to serialise the data constructor; 
       -- we can recover it from the type of the dfun
-toIfUnfolding _
+toIfUnfolding _ _
   = Nothing
 
 --------------------------
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 689dd4b1e8..e1588a1ec1 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -40,6 +40,7 @@ import DataCon
 import TysWiredIn
 import TysPrim		( anyTyConOfKind )
 import Var              ( TyVar )
+import BasicTypes	( nonRuleLoopBreaker )
 import qualified Var
 import VarEnv
 import Name
@@ -993,8 +994,11 @@ tcIdInfo ignore_prags name ty info
     tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
 
 	-- The next two are lazy, so they don't transitively suck stuff in
-    tcPrag info (HsUnfold if_unf)  = do { unf <- tcUnfolding name ty info if_unf
-				        ; return (info `setUnfoldingInfoLazily` unf) }
+    tcPrag info (HsUnfold lb if_unf) 
+      = do { unf <- tcUnfolding name ty info if_unf
+    	   ; let info1 | lb        = info `setOccInfo` nonRuleLoopBreaker
+	     	       | otherwise = info
+	   ; return (info1 `setUnfoldingInfoLazily` unf) }
 \end{code}
 
 \begin{code}