Pass DynFlags down to showSDocDebug

7 files changed, 83 insertions, 74 deletions

diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs
index 0ff440e6bf..021b0e4fd9 100644
--- a/compiler/codeGen/CgTicky.hs
+++ b/compiler/codeGen/CgTicky.hs
@@ -91,7 +91,8 @@ emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
 emitTickyCounter cl_info args on_stk
   = ifTicky $
     do	{ mod_name <- getModuleName
-	; fun_descr_lit <- newStringCLit (fun_descr mod_name)
+	; dflags <- getDynFlags
+	; fun_descr_lit <- newStringCLit (fun_descr dflags mod_name)
 	; arg_descr_lit <- newStringCLit arg_descr
 	; emitDataLits ticky_ctr_label 	-- Must match layout of StgEntCounter
 -- krc: note that all the fields are I32 now; some were I16 before, 
@@ -110,15 +111,15 @@ emitTickyCounter cl_info args on_stk
     name = closureName cl_info
     ticky_ctr_label = mkRednCountsLabel name NoCafRefs
     arg_descr = map (showTypeCategory . idType) args
-    fun_descr mod_name = ppr_for_ticky_name mod_name name
+    fun_descr dflags mod_name = ppr_for_ticky_name dflags mod_name name
 
 -- When printing the name of a thing in a ticky file, we want to
 -- give the module name even for *local* things.   We print
 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
-ppr_for_ticky_name :: Module -> Name -> String
-ppr_for_ticky_name mod_name name
-  | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
-  | otherwise	        = showSDocDebug (ppr name)
+ppr_for_ticky_name :: DynFlags -> Module -> Name -> String
+ppr_for_ticky_name dflags mod_name name
+  | isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name)))
+  | otherwise           = showSDocDebug dflags (ppr name)
 
 -- -----------------------------------------------------------------------------
 -- Ticky stack frames
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index da69030ddf..66dde86226 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -100,7 +100,7 @@ emitTickyCounter cl_info args
         ; let platform = targetPlatform dflags
               ticky_ctr_label = closureRednCountsLabel platform cl_info
               arg_descr = map (showTypeCategory . idType) args
-              fun_descr mod_name = ppr_for_ticky_name mod_name (closureName cl_info)
+              fun_descr mod_name = ppr_for_ticky_name dflags mod_name (closureName cl_info)
 	; fun_descr_lit <- newStringCLit (fun_descr mod_name)
 	; arg_descr_lit <- newStringCLit arg_descr
 	; emitDataLits ticky_ctr_label 	-- Must match layout of StgEntCounter
@@ -120,10 +120,10 @@ emitTickyCounter cl_info args
 -- When printing the name of a thing in a ticky file, we want to
 -- give the module name even for *local* things.   We print
 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
-ppr_for_ticky_name :: Module -> Name -> String
-ppr_for_ticky_name mod_name name
-  | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
-  | otherwise	        = showSDocDebug (ppr name)
+ppr_for_ticky_name :: DynFlags -> Module -> Name -> String
+ppr_for_ticky_name dflags mod_name name
+  | isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name)))
+  | otherwise           = showSDocDebug dflags (ppr name)
 
 -- -----------------------------------------------------------------------------
 -- Ticky stack frames
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 8f6ea05665..18c9a8cba9 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -1244,15 +1244,16 @@ tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding
 tcIfaceWrapper name ty info arity get_worker
   = do  { mb_wkr_id <- forkM_maybe doc get_worker
         ; us <- newUniqueSupply
+        ; dflags <- getDynFlags
         ; return (case mb_wkr_id of
                      Nothing     -> noUnfolding
-                     Just wkr_id -> make_inline_rule wkr_id us) }
+                     Just wkr_id -> make_inline_rule dflags wkr_id us) }
   where
     doc = text "Worker for" <+> ppr name
 
-    make_inline_rule wkr_id us 
+    make_inline_rule dflags wkr_id us 
         = mkWwInlineRule wkr_id
-                         (initUs_ us (mkWrapper ty strict_sig) wkr_id) 
+                         (initUs_ us (mkWrapper dflags ty strict_sig) wkr_id) 
                          arity
 
         -- Again we rely here on strictness info always appearing 
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index c68c900c22..4c51b304a9 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -390,8 +390,8 @@ doCorePass _      CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
 doCorePass _      CoreDoStrictness          = {-# SCC "Stranal" #-}
                                               doPassDM dmdAnalPgm
 
-doCorePass _      CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
-                                              doPassU wwTopBinds
+doCorePass dflags CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
+                                              doPassU (wwTopBinds dflags)
 
 doCorePass dflags CoreDoSpecialising        = {-# SCC "Specialise" #-}
                                               specProgram dflags
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index ec351ab7d8..e5013debd1 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -24,6 +24,7 @@ import IdInfo
 import Demand
 import UniqSupply
 import BasicTypes
+import DynFlags
 import VarEnv		( isEmptyVarEnv )
 import Maybes		( orElse )
 import WwLib
@@ -61,11 +62,11 @@ info for exported values).
 \end{enumerate}
 
 \begin{code}
-wwTopBinds :: UniqSupply -> CoreProgram -> CoreProgram
+wwTopBinds :: DynFlags -> UniqSupply -> CoreProgram -> CoreProgram
 
-wwTopBinds us top_binds
+wwTopBinds dflags us top_binds
   = initUs_ us $ do
-    top_binds' <- mapM wwBind top_binds
+    top_binds' <- mapM (wwBind dflags) top_binds
     return (concat top_binds')
 \end{code}
 
@@ -79,23 +80,24 @@ wwTopBinds us top_binds
 turn.  Non-recursive case first, then recursive...
 
 \begin{code}
-wwBind	:: CoreBind
+wwBind  :: DynFlags
+        -> CoreBind
 	-> UniqSM [CoreBind]	-- returns a WwBinding intermediate form;
 				-- the caller will convert to Expr/Binding,
 				-- as appropriate.
 
-wwBind (NonRec binder rhs) = do
-    new_rhs <- wwExpr rhs
-    new_pairs <- tryWW NonRecursive binder new_rhs
+wwBind dflags (NonRec binder rhs) = do
+    new_rhs <- wwExpr dflags rhs
+    new_pairs <- tryWW dflags NonRecursive binder new_rhs
     return [NonRec b e | (b,e) <- new_pairs]
       -- Generated bindings must be non-recursive
       -- because the original binding was.
 
-wwBind (Rec pairs)
+wwBind dflags (Rec pairs)
   = return . Rec <$> concatMapM do_one pairs
   where
-    do_one (binder, rhs) = do new_rhs <- wwExpr rhs
-                              tryWW Recursive binder new_rhs
+    do_one (binder, rhs) = do new_rhs <- wwExpr dflags rhs
+                              tryWW dflags Recursive binder new_rhs
 \end{code}
 
 @wwExpr@ basically just walks the tree, looking for appropriate
@@ -104,36 +106,36 @@ matching by looking for strict arguments of the correct type.
 @wwExpr@ is a version that just returns the ``Plain'' Tree.
 
 \begin{code}
-wwExpr :: CoreExpr -> UniqSM CoreExpr
+wwExpr :: DynFlags -> CoreExpr -> UniqSM CoreExpr
 
-wwExpr e@(Type {}) = return e
-wwExpr e@(Coercion {}) = return e
-wwExpr e@(Lit  {}) = return e
-wwExpr e@(Var  {}) = return e
+wwExpr _      e@(Type {}) = return e
+wwExpr _      e@(Coercion {}) = return e
+wwExpr _      e@(Lit  {}) = return e
+wwExpr _      e@(Var  {}) = return e
 
-wwExpr (Lam binder expr)
-  = Lam binder <$> wwExpr expr
+wwExpr dflags (Lam binder expr)
+  = Lam binder <$> wwExpr dflags expr
 
-wwExpr (App f a)
-  = App <$> wwExpr f <*> wwExpr a
+wwExpr dflags (App f a)
+  = App <$> wwExpr dflags f <*> wwExpr dflags a
 
-wwExpr (Tick note expr)
-  = Tick note <$> wwExpr expr
+wwExpr dflags (Tick note expr)
+  = Tick note <$> wwExpr dflags expr
 
-wwExpr (Cast expr co) = do
-    new_expr <- wwExpr expr
+wwExpr dflags (Cast expr co) = do
+    new_expr <- wwExpr dflags expr
     return (Cast new_expr co)
 
-wwExpr (Let bind expr)
-  = mkLets <$> wwBind bind <*> wwExpr expr
+wwExpr dflags (Let bind expr)
+  = mkLets <$> wwBind dflags bind <*> wwExpr dflags expr
 
-wwExpr (Case expr binder ty alts) = do
-    new_expr <- wwExpr expr
+wwExpr dflags (Case expr binder ty alts) = do
+    new_expr <- wwExpr dflags expr
     new_alts <- mapM ww_alt alts
     return (Case new_expr binder ty new_alts)
   where
     ww_alt (con, binders, rhs) = do
-        new_rhs <- wwExpr rhs
+        new_rhs <- wwExpr dflags rhs
         return (con, binders, new_rhs)
 \end{code}
 
@@ -237,7 +239,8 @@ so that it becomes active in an importing module at the same time that
 it appears in the first place in the defining module.
 
 \begin{code}
-tryWW	:: RecFlag
+tryWW   :: DynFlags
+        -> RecFlag
 	-> Id				-- The fn binder
 	-> CoreExpr			-- The bound rhs; its innards
 					--   are already ww'd
@@ -246,7 +249,7 @@ tryWW	:: RecFlag
 					-- the orig "wrapper" lives on);
 					-- if two, then a worker and a
 					-- wrapper.
-tryWW is_rec fn_id rhs
+tryWW dflags is_rec fn_id rhs
   | isNeverActive inline_act
 	-- No point in worker/wrappering if the thing is never inlined!
 	-- Because the no-inline prag will prevent the wrapper ever
@@ -259,11 +262,11 @@ tryWW is_rec fn_id rhs
   	-- See Note [Thunk splitting]
   = ASSERT2( isNonRec is_rec, ppr new_fn_id )	-- The thunk must be non-recursive
     checkSize new_fn_id rhs $ 
-    splitThunk new_fn_id rhs
+    splitThunk dflags new_fn_id rhs
 
   | is_fun && worthSplittingFun wrap_dmds res_info
   = checkSize new_fn_id rhs $
-    splitFun new_fn_id fn_info wrap_dmds res_info rhs
+    splitFun dflags new_fn_id fn_info wrap_dmds res_info rhs
 
   | otherwise
   = return [ (new_fn_id, rhs) ]
@@ -312,13 +315,13 @@ checkSize fn_id rhs thing_inside
     inline_rule = mkInlineUnfolding Nothing rhs
 
 ---------------------
-splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
+splitFun :: DynFlags -> Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
          -> UniqSM [(Id, CoreExpr)]
-splitFun fn_id fn_info wrap_dmds res_info rhs
+splitFun dflags fn_id fn_info wrap_dmds res_info rhs
   = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) 
     (do {
 	-- The arity should match the signature
-      (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
+      (work_demands, wrap_fn, work_fn) <- mkWwBodies dflags fun_ty wrap_dmds res_info one_shots
     ; work_uniq <- getUniqueM
     ; let
 	work_rhs = work_fn rhs
@@ -439,9 +442,9 @@ then the splitting will go deeper too.
 --     -->  x = let x = e in
 --              case x of (a,b) -> let x = (a,b)  in x
 
-splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)]
-splitThunk fn_id rhs = do
-    (_, wrap_fn, work_fn) <- mkWWstr [fn_id]
+splitThunk :: DynFlags -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
+splitThunk dflags fn_id rhs = do
+    (_, wrap_fn, work_fn) <- mkWWstr dflags [fn_id]
     return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
 \end{code}
 
@@ -501,12 +504,13 @@ unboxed thing to f, and have it reboxed in the error cases....]
 the function and the name of its worker, and we want to make its body (the wrapper).
 
 \begin{code}
-mkWrapper :: Type		-- Wrapper type
+mkWrapper :: DynFlags
+          -> Type		-- Wrapper type
 	  -> StrictSig		-- Wrapper strictness info
 	  -> UniqSM (Id -> CoreExpr)	-- Wrapper body, missing worker Id
 
-mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do
-    (_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo
+mkWrapper dflags fun_ty (StrictSig (DmdType _ demands res_info)) = do
+    (_, wrap_fn, _) <- mkWwBodies dflags fun_ty demands res_info noOneShotInfo
     return wrap_fn
 
 noOneShotInfo :: [Bool]
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 5a82b8ad9e..0ed650bff4 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -37,6 +37,7 @@ import UniqSupply
 import Unique
 import Util		( zipWithEqual )
 import Outputable
+import DynFlags
 import FastString
 \end{code}
 
@@ -109,7 +110,8 @@ the unusable strictness-info into the interfaces.
 @mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
 
 \begin{code}
-mkWwBodies :: Type				-- Type of original function
+mkWwBodies :: DynFlags
+       -> Type				-- Type of original function
 	   -> [Demand]				-- Strictness of original function
 	   -> DmdResult				-- Info about function result
 	   -> [Bool]				-- One-shot-ness of the function
@@ -128,10 +130,10 @@ mkWwBodies :: Type				-- Type of original function
 --			  let x = (a,b) in
 --			  E
 
-mkWwBodies fun_ty demands res_info one_shots
+mkWwBodies dflags fun_ty demands res_info one_shots
   = do	{ let arg_info = demands `zip` (one_shots ++ repeat False)
 	; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
-	; (work_args, wrap_fn_str,  work_fn_str) <- mkWWstr wrap_args
+	; (work_args, wrap_fn_str,  work_fn_str) <- mkWWstr dflags wrap_args
 
         -- Do CPR w/w.  See Note [Always do CPR w/w]
 	; (wrap_fn_cpr, work_fn_cpr,  cpr_res_ty) <- mkWWcpr res_ty res_info
@@ -320,7 +322,8 @@ That's why we carry the TvSubst through mkWWargs
 %************************************************************************
 
 \begin{code}
-mkWWstr :: [Var]				-- Wrapper args; have their demand info on them
+mkWWstr :: DynFlags
+        -> [Var]				-- Wrapper args; have their demand info on them
 						--  *Includes type variables*
         -> UniqSM ([Var],			-- Worker args
 		   CoreExpr -> CoreExpr,	-- Wrapper body, lacking the worker call
@@ -330,12 +333,12 @@ mkWWstr :: [Var]				-- Wrapper args; have their demand info on them
 		   CoreExpr -> CoreExpr)	-- Worker body, lacking the original body of the function,
 						-- and lacking its lambdas.
 						-- This fn does the reboxing
-mkWWstr []
+mkWWstr _ []
   = return ([], nop_fn, nop_fn)
 
-mkWWstr (arg : args) = do
-    (args1, wrap_fn1, work_fn1) <- mkWWstr_one arg
-    (args2, wrap_fn2, work_fn2) <- mkWWstr args
+mkWWstr dflags (arg : args) = do
+    (args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags arg
+    (args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
     return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
 
 ----------------------
@@ -344,8 +347,8 @@ mkWWstr (arg : args) = do
 --	  brings into scope work_args (via cases)
 --   * work_fn assumes work_args are in scope, a
 --	  brings into scope wrap_arg (via lets)
-mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-mkWWstr_one arg
+mkWWstr_one :: DynFlags -> Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
+mkWWstr_one dflags arg
   | isTyVar arg
   = return ([arg],  nop_fn, nop_fn)
 
@@ -355,7 +358,7 @@ mkWWstr_one arg
 	-- Absent case.  We can't always handle absence for arbitrary
         -- unlifted types, so we need to choose just the cases we can
 	-- (that's what mk_absent_let does)
-      Abs | Just work_fn <- mk_absent_let arg
+      Abs | Just work_fn <- mk_absent_let dflags arg
           -> return ([], nop_fn, work_fn)
 
 	-- Unpack case
@@ -369,7 +372,7 @@ mkWWstr_one arg
 	        unbox_fn       = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
 	        rebox_fn       = Let (NonRec arg con_app) 
 	        con_app        = mkProductBox unpk_args (idType arg)
-	      (worker_args, wrap_fn, work_fn) <- mkWWstr unpk_args_w_ds
+	      (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
 	      return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) 
 	  		   -- Don't pass the arg, rebox instead
 
@@ -533,8 +536,8 @@ every primitive type, so the function is partial.
     using a literal will do.]
 
 \begin{code}
-mk_absent_let :: Id -> Maybe (CoreExpr -> CoreExpr)
-mk_absent_let arg 
+mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
+mk_absent_let dflags arg
   | not (isUnLiftedType arg_ty)
   = Just (Let (NonRec arg abs_rhs))
   | Just tc <- tyConAppTyCon_maybe arg_ty
@@ -548,7 +551,7 @@ mk_absent_let arg
   where
     arg_ty  = idType arg
     abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
-    msg     = showSDocDebug (ppr arg <+> ppr (idType arg))
+    msg     = showSDocDebug dflags (ppr arg <+> ppr (idType arg))
 
 mk_seq_case :: Id -> CoreExpr -> CoreExpr
 mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 3f03d56408..126cd97c59 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -396,8 +396,8 @@ showSDocDumpOneLine :: SDoc -> String
 showSDocDumpOneLine d
  = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
 
-showSDocDebug :: SDoc -> String
-showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
+showSDocDebug :: DynFlags -> SDoc -> String
+showSDocDebug _ d = show (runSDoc d (initSDocContext PprDebug))
 
 showPpr :: Outputable a => DynFlags -> a -> String
 showPpr dflags = showSDoc dflags . ppr