Pass DynFlags down to showSDocDebug

2 files changed, 63 insertions, 56 deletions

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)]