Fix dependencies among specialisations for imported Ids

This was a subtle one (Trac #4903).  See
  Note [Glom the bindings if imported functions are specialised]
in Speclialise.

Fundamentally, a specialised binding for an imported Id was being
declared non-recursive, whereas in fact it can become recursive
via a RULE.  Once it's specified non-recurive the OccAnal pass
treats that as gospel -- and that in turn led to infinite inlining.

Easily fixed by glomming all the specialised bindings in a Rec;
now the OccAnal will sort them out correctly.

1 files changed, 57 insertions, 13 deletions

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 9494c1b144..415378ac47 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -572,8 +572,12 @@ specProgram guts
 	     -- Specialise imported functions 
        ; (new_rules, spec_binds) <- specImports emptyVarSet rule_base uds
 
-       ; return (guts { mg_binds = spec_binds ++ binds'
-                      , mg_rules = local_rules ++ new_rules }) }
+       ; let final_binds | null spec_binds = binds'
+                         | otherwise       = Rec (flattenBinds spec_binds) : binds'
+    	   	   -- Note [Glom the bindings if imported functions are specialised]
+
+       ; return (guts { mg_binds = final_binds
+                      , mg_rules = new_rules ++ local_rules }) }
   where
 	-- We need to start with a Subst that knows all the things
 	-- that are in scope, so that the substitution engine doesn't
@@ -595,6 +599,7 @@ specImports :: VarSet	 	-- Don't specialise these ones
             -> UsageDetails	-- Calls for imported things, and floating bindings
             -> CoreM ( [CoreRule]   -- New rules
                      , [CoreBind] ) -- Specialised bindings and floating bindings
+-- See Note [Specialise imported INLINABLE things]
 specImports done rb uds
   = do { let import_calls = varEnvElts (ud_calls uds)
        ; (rules, spec_binds) <- go rb import_calls
@@ -613,8 +618,13 @@ specImport :: VarSet	    	    -- Don't specialise these
            -> CoreM ( [CoreRule]    -- New rules
                     , [CoreBind] )  -- Specialised bindings
 specImport done rb fn calls_for_fn
-  | not (fn `elemVarSet` done)
-  , isInlinablePragma (idInlinePragma fn)
+  | fn `elemVarSet` done
+  = return ([], [])     -- No warning.  This actually happens all the time
+    	   		-- when specialising a recursive function, becuase
+			-- the RHS of the specialised function contains a recursive
+			-- call to the original function
+
+  | isInlinablePragma (idInlinePragma fn)
   , Just rhs <- maybeUnfoldingTemplate (realIdUnfolding fn)
   = do {     -- Get rules from the external package state
        	     -- We keep doing this in case we "page-fault in" 
@@ -629,6 +639,7 @@ specImport done rb fn calls_for_fn
        ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
        	     -- After the rules kick in we may get recursion, but 
 	     -- we rely on a global GlomBinds to sort that out later
+             -- See Note [Glom the bindings if imported functions are specialised]
        
 	      -- Now specialise any cascaded calls
        ; (rules2, spec_binds2) <- specImports (extendVarSet done fn) 
@@ -642,8 +653,35 @@ specImport done rb fn calls_for_fn
     return ([], [])    
 \end{code}
 
-Avoiding recursive specialisation
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Specialise imported INLINABLE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We specialise INLINABLE things but not INLINE things.  The latter
+should be inlined bodily, so not much point in specialising them.
+Moreover, we risk lots of orphan modules from vigorous specialisation.
+
+Note [Glom the bindings if imported functions are specialised]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have an imported, *recursive*, INLINABLE function 
+   f :: Eq a => a -> a
+   f = /\a \d x. ...(f a d)...
+In the module being compiled we have
+   g x = f (x::Int)
+Now we'll make a specialised function
+   f_spec :: Int -> Int
+   f_spec = \x -> ...(f Int dInt)...
+   {-# RULE  f Int _ = f_spec #-}
+   g = \x. f Int dInt x
+Note that f_spec doesn't look recursive
+After rewriting with the RULE, we get
+   f_spec = \x -> ...(f_spec)...
+BUT since f_spec was non-recursive before it'll *stay* non-recursive.
+The occurrence analyser never turns a NonRec into a Rec.  So we must
+make sure that f_spec is recursive.  Easiest thing is to make all
+the specialisations for imported bindings recursive.
+
+
+Note [Avoiding recursive specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we specialise 'f' we may find new overloaded calls to 'g', 'h' in
 'f's RHS.  So we want to specialise g,h.  But we don't want to
 specialise f any more!  It's possible that f's RHS might have a
@@ -963,7 +1001,7 @@ specCalls :: Subst
 	    	    UsageDetails)	-- New usage details from the specialised RHSs
 
 -- This function checks existing rules, and does not create
--- duplicate ones. So the caller does not nneed to do this filtering.
+-- duplicate ones. So the caller does not need to do this filtering.
 -- See 'already_covered'
 
 specCalls subst rules_for_me calls_for_me fn rhs
@@ -985,12 +1023,16 @@ specCalls subst rules_for_me calls_for_me fn rhs
        ; return (spec_rules, spec_defns, plusUDList spec_uds) }
 
   | otherwise	-- No calls or RHS doesn't fit our preconceptions
-  = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn )
+  = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") 
+                                 <+> ppr fn $$ _trace_doc )
 	  -- Note [Specialisation shape]
     -- pprTrace "specDefn: none" (ppr fn $$ ppr calls_for_me) $
     return ([], [], emptyUDs)
-  
   where
+    _trace_doc = vcat [ ppr rhs_tyvars, ppr n_tyvars
+                      , ppr rhs_ids, ppr n_dicts
+                      , ppr (idInlineActivation fn) ]
+
     fn_type	       = idType fn
     fn_arity	       = idArity fn
     fn_unf             = realIdUnfolding fn	-- Ignore loop-breaker-ness here
@@ -1097,8 +1139,8 @@ specCalls subst rules_for_me calls_for_me fn rhs
 		spec_inl_prag 
 		  = case inl_prag of
                        InlinePragma { inl_inline = Inlinable } 
-                          -> inl_prag { inl_inline = NoInline }
-		       _ -> inl_prag
+                          -> inl_prag { inl_inline = EmptyInlineSpec }
+		       _  -> inl_prag
 
 		spec_unf
                   = case inlinePragmaSpec spec_inl_prag of
@@ -1521,13 +1563,15 @@ mkCallUDs f args
   || not ( dicts   `lengthIs` n_dicts)
   || not (any interestingDict dicts)	-- Note [Interesting dictionary arguments]
   -- See also Note [Specialisations already covered]
-  = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)]) 
+  = -- pprTrace "mkCallUDs: discarding" _trace_doc
     emptyUDs	-- Not overloaded, or no specialisation wanted
 
   | otherwise
-  = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)]) 
+  = -- pprTrace "mkCallUDs: keeping" _trace_doc
     singleCall f spec_tys dicts
   where
+    _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts
+                      , ppr (map interestingDict dicts)]
     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
     constrained_tyvars = tyVarsOfTheta theta 
     n_tyvars	       = length tyvars