Pass DynFlags down to showSDocDump

To help with this, we now also pass DynFlags around inside the SpecM
monad.

6 files changed, 98 insertions, 60 deletions

diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 3ae25b4652..4f9d1b507c 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -79,7 +79,8 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do
   ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
   ; srt_info <- getSRTInfo srt
   ; mod_name <- getModuleName
-  ; let descr         = closureDescription mod_name name
+  ; dflags   <- getDynFlags
+  ; let descr         = closureDescription dflags mod_name name
 	closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
 	closure_label = mkLocalClosureLabel name (idCafInfo id)
     	cg_id_info    = litIdInfo id lf_info (CmmLabel closure_label)
@@ -288,8 +289,9 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
 	; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 	; mod_name <- getModuleName
 	; c_srt <- getSRTInfo srt
+	; dflags <- getDynFlags
 	; let	name  = idName bndr
-		descr = closureDescription mod_name name
+		descr = closureDescription dflags mod_name name
 		fv_details :: [(NonVoid Id, VirtualHpOffset)]
 		(tot_wds, ptr_wds, fv_details)
 		   = mkVirtHeapOffsets (isLFThunk lf_info)
@@ -336,10 +338,11 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload
   = do	-- AHA!  A STANDARD-FORM THUNK
   {	-- LAY OUT THE OBJECT
     mod_name <- getModuleName
+  ; dflags <- getDynFlags
   ; let (tot_wds, ptr_wds, payload_w_offsets)
 	    = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
 
-	descr = closureDescription mod_name (idName bndr)
+	descr = closureDescription dflags mod_name (idName bndr)
 	closure_info = mkClosureInfo False 	-- Not static
 				     bndr lf_info tot_wds ptr_wds
 				     NoC_SRT	-- No SRT for a std-form closure
@@ -685,13 +688,14 @@ link_caf _is_upd = do
 -- name of the data constructor itself.  Otherwise it is determined by
 -- @closureDescription@ from the let binding information.
 
-closureDescription :: Module		-- Module
+closureDescription :: DynFlags
+           -> Module		-- Module
 		   -> Name		-- Id of closure binding
 		   -> String
 	-- Not called for StgRhsCon which have global info tables built in
 	-- CgConTbls.lhs with a description generated from the data constructor
-closureDescription mod_name name
-  = showSDocDump (char '<' <>
+closureDescription dflags mod_name name
+  = showSDocDump dflags (char '<' <>
 		    (if isExternalName name
 		      then ppr name -- ppr will include the module name prefix
 		      else pprModule mod_name <> char '.' <> ppr name) <>
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index c717e4b300..8f62ed439e 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -896,7 +896,7 @@ tryUnfolding dflags id lone_variable
 			-- uf_arity will typically be equal to (idArity id), 
 			-- but may be less for InlineRules
  | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
- = pprTrace ("Considering inlining: " ++ showSDocDump (ppr id))
+ = pprTrace ("Considering inlining: " ++ showSDocDump dflags (ppr id))
 		 (vcat [text "arg infos" <+> ppr arg_infos,
 			text "uf arity" <+> ppr uf_arity,
 			text "interesting continuation" <+> ppr cont_info,
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 41ff505727..a176e6ce38 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -363,54 +363,54 @@ runCorePasses passes guts
     do_pass guts pass
        = do { dflags <- getDynFlags
             ; liftIO $ showPass dflags pass
-            ; guts' <- doCorePass pass guts
+            ; guts' <- doCorePass dflags pass guts
             ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
             ; return guts' }
 
-doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
-doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
-                                       simplifyPgm pass
+doCorePass :: DynFlags -> CoreToDo -> ModGuts -> CoreM ModGuts
+doCorePass _      pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
+                                              simplifyPgm pass
 
-doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}
-                                       doPass cseProgram
+doCorePass _      CoreCSE                   = {-# SCC "CommonSubExpr" #-}
+                                              doPass cseProgram
 
-doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
-                                       doPassD liberateCase
+doCorePass _      CoreLiberateCase          = {-# SCC "LiberateCase" #-}
+                                              doPassD liberateCase
 
-doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
-                                       doPass floatInwards
+doCorePass _      CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
+                                              doPass floatInwards
 
-doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
-                                       doPassDUM (floatOutwards f)
+doCorePass _      (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
+                                              doPassDUM (floatOutwards f)
 
-doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
-                                       doPassU doStaticArgs
+doCorePass _      CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
+                                              doPassU doStaticArgs
 
-doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}
-                                       doPassDM dmdAnalPgm
+doCorePass _      CoreDoStrictness          = {-# SCC "Stranal" #-}
+                                              doPassDM dmdAnalPgm
 
-doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
-                                       doPassU wwTopBinds
+doCorePass _      CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
+                                              doPassU wwTopBinds
 
-doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
-                                       specProgram
+doCorePass dflags CoreDoSpecialising        = {-# SCC "Specialise" #-}
+                                              specProgram dflags
 
-doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
-                                       specConstrProgram
+doCorePass _      CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
+                                              specConstrProgram
 
-doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
-                                       vectorise
+doCorePass _      CoreDoVectorisation       = {-# SCC "Vectorise" #-}
+                                              vectorise
 
-doCorePass CoreDoPrintCore              = observe   printCore
-doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
-doCorePass CoreDoNothing                = return
-doCorePass (CoreDoPasses passes)        = runCorePasses passes
+doCorePass _      CoreDoPrintCore              = observe   printCore
+doCorePass _      (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
+doCorePass _      CoreDoNothing                = return
+doCorePass _      (CoreDoPasses passes)        = runCorePasses passes
 
 #ifdef GHCI
-doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
+doCorePass _      (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
 #endif
 
-doCorePass pass = pprPanic "doCorePass" (ppr pass)
+doCorePass _      pass = pprPanic "doCorePass" (ppr pass)
 \end{code}
 
 %************************************************************************
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 726d0d5642..44286b4725 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1425,7 +1425,7 @@ completeCall env var cont
       	  pprDefiniteTrace "Inlining done:" (ppr var) stuff
         else stuff
       | otherwise
-      = pprDefiniteTrace ("Inlining done: " ++ showSDocDump (ppr var))
+      = pprDefiniteTrace ("Inlining done: " ++ showSDocDump dflags (ppr var))
            (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
                   text "Cont:  " <+> ppr cont])
            stuff
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 94c7170966..6892c9c6ad 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -20,17 +20,20 @@ import CoreSyn
 import Rules
 import CoreUtils        ( exprIsTrivial, applyTypeToArgs )
 import CoreFVs          ( exprFreeVars, exprsFreeVars, idFreeVars )
-import UniqSupply       ( UniqSM, initUs_, MonadUnique(..) )
+import UniqSupply
 import Name
 import MkId             ( voidArgId, realWorldPrimId )
 import Maybes           ( catMaybes, isJust )
 import BasicTypes
 import HscTypes
 import Bag
+import DynFlags
 import Util
 import Outputable
 import FastString
+import State
 
+import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified FiniteMap as Map
@@ -561,17 +564,17 @@ Hence, the invariant is this:
 %************************************************************************
 
 \begin{code}
-specProgram :: ModGuts -> CoreM ModGuts
-specProgram guts
+specProgram :: DynFlags -> ModGuts -> CoreM ModGuts
+specProgram dflags guts
   = do { hpt_rules <- getRuleBase
        ; let local_rules = mg_rules guts
              rule_base = extendRuleBaseList hpt_rules (mg_rules guts)
 
              -- Specialise the bindings of this module
-       ; (binds', uds) <- runSpecM (go (mg_binds guts))
+       ; (binds', uds) <- runSpecM dflags (go (mg_binds guts))
 
              -- Specialise imported functions
-       ; (new_rules, spec_binds) <- specImports emptyVarSet rule_base uds
+       ; (new_rules, spec_binds) <- specImports dflags emptyVarSet rule_base uds
 
        ; let final_binds | null spec_binds = binds'
                          | otherwise       = Rec (flattenBinds spec_binds) : binds'
@@ -593,7 +596,8 @@ specProgram guts
                          (bind', uds') <- specBind top_subst bind uds
                          return (bind' ++ binds', uds')
 
-specImports :: VarSet           -- Don't specialise these ones
+specImports :: DynFlags
+            -> 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)
@@ -601,24 +605,25 @@ specImports :: VarSet           -- Don't specialise these ones
             -> CoreM ( [CoreRule]   -- New rules
                      , [CoreBind] ) -- Specialised bindings and floating bindings
 -- See Note [Specialise imported INLINABLE things]
-specImports done rb uds
+specImports dflags done rb uds
   = do { let import_calls = varEnvElts (ud_calls uds)
        ; (rules, spec_binds) <- go rb import_calls
        ; return (rules, wrapDictBinds (ud_binds uds) spec_binds) }
   where
     go _ [] = return ([], [])
     go rb (CIS fn calls_for_fn : other_calls)
-      = do { (rules1, spec_binds1) <- specImport done rb fn (Map.toList calls_for_fn)
+      = do { (rules1, spec_binds1) <- specImport dflags done rb fn (Map.toList calls_for_fn)
            ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
            ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
 
-specImport :: VarSet                -- Don't specialise these
+specImport :: DynFlags
+           -> VarSet                -- Don't specialise these
                                     -- See Note [Avoiding recursive specialisation]
            -> RuleBase              -- Rules from this module
            -> Id -> [CallInfo]      -- Imported function and calls for it
            -> CoreM ( [CoreRule]    -- New rules
                     , [CoreBind] )  -- Specialised bindings
-specImport done rb fn calls_for_fn
+specImport dflags done rb fn calls_for_fn
   | fn `elemVarSet` done
   = return ([], [])     -- No warning.  This actually happens all the time
                         -- when specialising a recursive function, becuase
@@ -635,7 +640,7 @@ specImport done rb fn calls_for_fn
        ; let full_rb = unionRuleBase rb (eps_rule_base eps)
              rules_for_fn = getRules full_rb fn
 
-       ; (rules1, spec_pairs, uds) <- runSpecM $
+       ; (rules1, spec_pairs, uds) <- runSpecM dflags $
               specCalls emptySubst 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
@@ -643,9 +648,9 @@ specImport done rb fn calls_for_fn
              -- See Note [Glom the bindings if imported functions are specialised]
 
               -- Now specialise any cascaded calls
-       ; (rules2, spec_binds2) <- specImports (extendVarSet done fn)
-                                              (extendRuleBaseList rb rules1)
-                                              uds
+       ; (rules2, spec_binds2) <- specImports dflags (extendVarSet done fn)
+                                                     (extendRuleBaseList rb rules1)
+                                                     uds
 
        ; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) }
 
@@ -1127,10 +1132,11 @@ specCalls subst rules_for_me calls_for_me fn rhs
 
            ; spec_f <- newSpecIdSM fn spec_id_ty
            ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
+           ; dflags <- getDynFlags
            ; let
                 -- The rule to put in the function's specialisation is:
                 --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b
-                rule_name = mkFastString ("SPEC " ++ showSDocDump (ppr fn <+> ppr spec_ty_args))
+                rule_name = mkFastString ("SPEC " ++ showSDocDump dflags (ppr fn <+> ppr spec_ty_args))
                 spec_env_rule = mkRule True {- Auto generated -} is_local
                                   rule_name
                                   inl_act       -- Note [Auto-specialisation and RULES]
@@ -1782,11 +1788,39 @@ deleteCallsFor bs calls = delVarEnvList calls bs
 %************************************************************************
 
 \begin{code}
-type SpecM a = UniqSM a
-
-runSpecM:: SpecM a -> CoreM a
-runSpecM spec = do { us <- getUniqueSupplyM
-                   ; return (initUs_ us spec) }
+newtype SpecM a = SpecM (State SpecState a)
+
+data SpecState = SpecState {
+                     spec_uniq_supply :: UniqSupply,
+                     spec_dflags :: DynFlags
+                 }
+
+instance Monad SpecM where
+    SpecM x >>= f = SpecM $ do y <- x
+                               case f y of
+                                   SpecM z ->
+                                       z
+    return x = SpecM $ return x
+    fail str = SpecM $ fail str
+
+instance MonadUnique SpecM where
+    getUniqueSupplyM
+        = SpecM $ do st <- get
+                     let (us1, us2) = splitUniqSupply $ spec_uniq_supply st
+                     put $ st { spec_uniq_supply = us2 }
+                     return us1
+
+instance HasDynFlags SpecM where
+    getDynFlags = SpecM $ liftM spec_dflags get
+
+runSpecM :: DynFlags -> SpecM a -> CoreM a
+runSpecM dflags (SpecM spec)
+    = do us <- getUniqueSupplyM
+         let initialState = SpecState {
+                                spec_uniq_supply = us,
+                                spec_dflags = dflags
+                            }
+         return $ evalState spec initialState
 
 mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
 mapAndCombineSM _ []     = return ([], emptyUDs)
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 364786e212..c0b77bb9bd 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -388,8 +388,8 @@ showSDocUnqual _ d
 showsPrecSDoc :: Int -> SDoc -> ShowS
 showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
 
-showSDocDump :: SDoc -> String
-showSDocDump d 
+showSDocDump :: DynFlags -> SDoc -> String
+showSDocDump _ d
  = Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultDumpStyle))
 
 showSDocDumpOneLine :: SDoc -> String