Add -fcross-module-specialise flag
authorBen Gamari <ben@smart-cactus.org>
Sun, 28 Jun 2015 16:32:07 +0000 (18:32 +0200)
committerBen Gamari <ben@smart-cactus.org>
Sun, 28 Jun 2015 16:32:07 +0000 (18:32 +0200)
Summary:
As of 7.10.1 we specialize INLINEABLE identifiers defined in other
modules. This can expose issues (compiler bugs or otherwise) in some cases
(e.g. Trac #10491) and therefore we now provide a way for the user to disable
this optimization.

Test Plan: Successfully compile Splice.hs from Trac #10491.

Reviewers: simonpj, austin

Reviewed By: simonpj

Subscribers: simonpj, thomie, bgamari

Differential Revision: https://phabricator.haskell.org/D999

GHC Trac Issues: #10491

1  2 
compiler/specialise/Specialise.hs

@@@ -13,7 -13,7 +13,7 @@@ import I
  import TcType hiding( substTy, extendTvSubstList )
  import Type   hiding( substTy, extendTvSubstList )
  import Coercion( Coercion )
 -import Module( Module )
 +import Module( Module, HasModule(..) )
  import CoreMonad
  import qualified CoreSubst
  import CoreUnfold
@@@ -571,6 -571,7 +571,7 @@@ Hence, the invariant is this
  ************************************************************************
  -}
  
+ -- | Specialise calls to type-class overloaded functions occuring in a program.
  specProgram :: ModGuts -> CoreM ModGuts
  specProgram guts@(ModGuts { mg_module = this_mod
                            , mg_rules = local_rules
    = do { dflags <- getDynFlags
  
               -- Specialise the bindings of this module
 -       ; (binds', uds) <- runSpecM dflags (go binds)
 +       ; (binds', uds) <- runSpecM dflags this_mod (go binds)
  
               -- Specialise imported functions
         ; hpt_rules <- getRuleBase
         ; let rule_base = extendRuleBaseList hpt_rules local_rules
-        ; (new_rules, spec_binds) <- specImports dflags this_mod emptyVarSet rule_base uds
  
-        ; let final_binds | null spec_binds = binds'
-                          | otherwise       = Rec (flattenBinds spec_binds) : binds'
+        ; (new_rules, spec_binds) <- specImports dflags this_mod emptyVarSet
+                                                 rule_base (ud_calls uds)
+              -- Don't forget to wrap the specialized bindings with bindings
+              -- for the needed dictionaries.
+              -- See Note [Wrap bindings returned by specImports]
+        ; let spec_binds' = wrapDictBinds (ud_binds uds) spec_binds
+        ; 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
                           (bind', uds') <- specBind top_subst bind uds
                           return (bind' ++ binds', uds')
  
+ {-
+ Note [Wrap bindings returned by specImports]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ 'specImports' returns a set of specialized bindings. However, these are lacking
+ necessary floated dictionary bindings, which are returned by
+ UsageDetails(ud_binds). These dictionaries need to be brought into scope with
+ 'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,
+ for instance, the 'specImports' call in 'specProgram'.
+ Note [Disabling cross-module specialisation]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ Since GHC 7.10 we have performed specialisation of INLINEABLE bindings living
+ in modules outside of the current module. This can sometimes uncover user code
+ which explodes in size when aggressively optimized. The
+ -fno-cross-module-specialise option was introduced to allow users to being
+ bitten by such instances to revert to the pre-7.10 behavior.
+ See Trac #10491
+ -}
+ -- | Specialise a set of calls to imported bindings
  specImports :: DynFlags
              -> Module
              -> VarSet           -- Don't specialise these ones
                                  -- See Note [Avoiding recursive specialisation]
              -> RuleBase         -- Rules from this module and the home package
                                  -- (but not external packages, which can change)
-             -> UsageDetails     -- Calls for imported things, and floating bindings
+             -> CallDetails      -- Calls for imported things, and floating bindings
              -> CoreM ( [CoreRule]   -- New rules
-                      , [CoreBind] ) -- Specialised bindings and floating bindings
- specImports dflags this_mod done rule_base uds
-   = do { let import_calls = varEnvElts (ud_calls uds)
+                      , [CoreBind] ) -- Specialised bindings
+                                     -- See Note [Wrapping bindings returned by specImports]
+ specImports dflags this_mod done rule_base cds
+   -- See Note [Disabling cross-module specialisation]
+   | not $ gopt Opt_CrossModuleSpecialise dflags =
+     return ([], [])
+   | otherwise =
+     do { let import_calls = varEnvElts cds
         ; (rules, spec_binds) <- go rule_base import_calls
-        ; return (rules, wrapDictBinds (ud_binds uds) spec_binds) }
+        ; return (rules, spec_binds) }
    where
+     go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])
      go _ [] = return ([], [])
      go rb (CIS fn calls_for_fn : other_calls)
        = do { (rules1, spec_binds1) <- specImport dflags this_mod done rb fn $
@@@ -652,11 -690,10 +690,11 @@@ specImport dflags this_mod done rb fn c
               -- more rules as we go along
         ; hsc_env <- getHscEnv
         ; eps <- liftIO $ hscEPS hsc_env
 +       ; vis_orphs <- getVisibleOrphanMods
         ; let full_rb = unionRuleBase rb (eps_rule_base eps)
 -             rules_for_fn = getRules full_rb fn
 +             rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn
  
 -       ; (rules1, spec_pairs, uds) <- runSpecM dflags $
 +       ; (rules1, spec_pairs, uds) <- runSpecM dflags this_mod $
                specCalls (Just this_mod) emptySpecEnv rules_for_fn calls_for_fn fn rhs
         ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
               -- After the rules kick in we may get recursion, but
         ; (rules2, spec_binds2) <- -- pprTrace "specImport" (ppr fn $$ ppr uds $$ ppr rhs) $
                                    specImports dflags this_mod (extendVarSet done fn)
                                                       (extendRuleBaseList rb rules1)
-                                                      uds
+                                                      (ud_calls uds)
+              -- Don't forget to wrap the specialized bindings with bindings
+              -- for the needed dictionaries
+              -- See Note [Wrap bindings returned by specImports]
+        ; let final_binds = wrapDictBinds (ud_binds uds)
+                                          (spec_binds2 ++ spec_binds1)
  
-        ; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) }
+        ; return (rules2 ++ rules1, final_binds) }
  
    | otherwise
    = WARN( True, hang (ptext (sLit "specImport discarding:") <+> ppr fn <+> dcolon <+> ppr (idType fn))
@@@ -1188,7 -1231,6 +1232,7 @@@ specCalls mb_mod env rules_for_me calls
  
             ; spec_f <- newSpecIdSM fn spec_id_ty
             ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body)
 +           ; this_mod <- getModule
             ; let
                  -- The rule to put in the function's specialisation is:
                  --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b
                              -- otherwise uniques end up there, making builds
                              -- less deterministic (See #4012 comment:61 ff)
  
 -                spec_env_rule = mkRule True {- Auto generated -} is_local
 +                spec_env_rule = mkRule
 +                                  this_mod
 +                                  True {- Auto generated -}
 +                                  is_local
                                    rule_name
                                    inl_act       -- Note [Auto-specialisation and RULES]
                                    (idName fn)
@@@ -1960,7 -1999,6 +2004,7 @@@ newtype SpecM a = SpecM (State SpecStat
  
  data SpecState = SpecState {
                       spec_uniq_supply :: UniqSupply,
 +                     spec_module :: Module,
                       spec_dflags :: DynFlags
                   }
  
@@@ -1995,15 -2033,11 +2039,15 @@@ instance MonadUnique SpecM wher
  instance HasDynFlags SpecM where
      getDynFlags = SpecM $ liftM spec_dflags get
  
 -runSpecM :: DynFlags -> SpecM a -> CoreM a
 -runSpecM dflags (SpecM spec)
 +instance HasModule SpecM where
 +    getModule = SpecM $ liftM spec_module get
 +
 +runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a
 +runSpecM dflags this_mod (SpecM spec)
      = do us <- getUniqueSupplyM
           let initialState = SpecState {
                                  spec_uniq_supply = us,
 +                                spec_module = this_mod,
                                  spec_dflags = dflags
                              }
           return $ evalState spec initialState