Pass DynFlags down to showSDoc

compiler/basicTypes/MkId.lhs

@@ -69,6 +69,7 @@ import PrelNames
 import BasicTypes       hiding ( SuccessFlag(..) )
 import Util
 import Pair
+import DynFlags
 import Outputable
 import FastString
 import ListSetOps
@@ -761,14 +762,14 @@ mkPrimOpId prim_op
 -- details of the ccall, type and all.  This means that the interface 
 -- file reader can reconstruct a suitable Id
 
-mkFCallId :: Unique -> ForeignCall -> Type -> Id
-mkFCallId uniq fcall ty
+mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
+mkFCallId dflags uniq fcall ty
   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
     -- A CCallOpId should have no free type variables; 
     -- when doing substitutions won't substitute over it
     mkGlobalId (FCallId fcall) name ty info
   where
-    occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
+    occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))
     -- The "occurrence name" of a ccall is the full info about the
     -- ccall; it is encoded, but may have embedded spaces etc!
 

compiler/cmm/CmmOpt.hs

@@ -20,6 +20,7 @@ import OldCmm
 import OldPprCmm
 import CmmNode (wrapRecExp)
 import CmmUtils
+import DynFlags
 import StaticFlags
 
 import UniqFM
@@ -147,46 +148,47 @@ countUses :: UserOfLocalRegs a => a -> UniqFM Int
 countUses a = foldRegsUsed (\m r -> addToUFM m r (count m r + 1)) emptyUFM a
   where count m r = lookupWithDefaultUFM m (0::Int) r
 
-cmmMiniInline :: Platform -> [CmmBasicBlock] -> [CmmBasicBlock]
-cmmMiniInline platform blocks = map do_inline blocks
+cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock]
+cmmMiniInline dflags blocks = map do_inline blocks
   where do_inline (BasicBlock id stmts)
-          = BasicBlock id (cmmMiniInlineStmts platform (countUses blocks) stmts)
+          = BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts)
 
-cmmMiniInlineStmts :: Platform -> UniqFM Int -> [CmmStmt] -> [CmmStmt]
-cmmMiniInlineStmts _        _    [] = []
-cmmMiniInlineStmts platform uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
+cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt]
+cmmMiniInlineStmts _      _    [] = []
+cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
         -- not used: just discard this assignment
   | Nothing <- lookupUFM uses u
-  = cmmMiniInlineStmts platform uses stmts
+  = cmmMiniInlineStmts dflags uses stmts
 
         -- used (literal): try to inline at all the use sites
   | Just n <- lookupUFM uses u, isLit expr
   =
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
+     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $
      case lookForInlineLit u expr stmts of
          (m, stmts')
-             | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts'
+             | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
              | otherwise ->
-                 stmt : cmmMiniInlineStmts platform (adjustUFM (\x -> x - m) uses u) stmts'
+                 stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts'
 
         -- used (foldable to literal): try to inline at all the use sites
   | Just n <- lookupUFM uses u,
     e@(CmmLit _) <- wrapRecExp foldExp expr
   =
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
+     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $
      case lookForInlineLit u e stmts of
          (m, stmts')
-             | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts'
+             | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
              | otherwise ->
-                 stmt : cmmMiniInlineStmts platform (adjustUFM (\x -> x - m) uses u) stmts'
+                 stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts'
 
         -- used once (non-literal): try to inline at the use site
   | Just 1 <- lookupUFM uses u,
     Just stmts' <- lookForInline u expr stmts
   = 
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
-     cmmMiniInlineStmts platform uses stmts'
+     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $
+     cmmMiniInlineStmts dflags uses stmts'
  where
+  platform = targetPlatform dflags
   foldExp (CmmMachOp op args) = cmmMachOpFold platform op args
   foldExp e = e
 

compiler/codeGen/StgCmmLayout.hs

@@ -58,7 +58,7 @@ import Constants
 import Util
 import Data.List
 import Outputable
-import FastString	( mkFastString, FastString, fsLit )
+import FastString
 
 ------------------------------------------------------------------------
 --		Call and return sequences
@@ -179,8 +179,8 @@ slow_call fun args reps
   = do dflags <- getDynFlags
        let platform = targetPlatform dflags
        call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
-       emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (pprPlatform platform fun) ++
-                                        " with pat " ++ showSDoc (ftext rts_fun))
+       emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc dflags (pprPlatform platform fun) ++
+                                        " with pat " ++ unpackFS rts_fun)
        emit (mkAssign nodeReg fun <*> call)
   where
     (rts_fun, arity) = slowCallPattern reps

compiler/codeGen/StgCmmProf.hs

@@ -218,7 +218,8 @@ emitCostCentreDecl cc = do
   ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS
                                         $ Module.moduleName
                                         $ cc_mod cc)
-  ; loc <- newStringCLit (showSDoc (ppr (costCentreSrcSpan cc)))
+  ; dflags <- getDynFlags
+  ; loc <- newStringCLit (showPpr dflags (costCentreSrcSpan cc))
            -- XXX should UTF-8 encode
                 -- All cost centres will be in the main package, since we
                 -- don't normally use -auto-all or add SCCs to other packages.

compiler/coreSyn/MkExternalCore.lhs

@@ -38,6 +38,7 @@ import DynFlags
 import FastString
 import Exception
 
+import Control.Monad
 import Data.Char
 import System.IO
 
@@ -45,7 +46,7 @@ emitExternalCore :: DynFlags -> CgGuts -> IO ()
 emitExternalCore dflags cg_guts
  | dopt Opt_EmitExternalCore dflags
  = (do handle <- openFile corename WriteMode
-       hPutStrLn handle (show (mkExternalCore cg_guts))
+       hPutStrLn handle (show (mkExternalCore dflags cg_guts))
        hClose handle)
    `catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
                              (text corename))
@@ -56,7 +57,10 @@ emitExternalCore _ _
 
 -- Reinventing the Reader monad; whee.
 newtype CoreM a = CoreM (CoreState -> (CoreState, a))
-type CoreState = Module
+data CoreState = CoreState {
+                     cs_dflags :: DynFlags,
+                     cs_module :: Module
+                 }
 instance Monad CoreM where
   (CoreM m) >>= f = CoreM (\ s -> case m s of
                                     (s',r) -> case f r of
@@ -67,55 +71,62 @@ runCoreM (CoreM f) s = snd $ f s
 ask :: CoreM CoreState
 ask = CoreM (\ s -> (s,s))
 
-mkExternalCore :: CgGuts -> C.Module
+instance HasDynFlags CoreM where
+    getDynFlags = liftM cs_dflags ask
+
+mkExternalCore :: DynFlags -> CgGuts -> C.Module
 -- The ModGuts has been tidied, but the implicit bindings have
 -- not been injected, so we have to add them manually here
 -- We don't include the strange data-con *workers* because they are
 -- implicit in the data type declaration itself
-mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, 
-                        cg_binds = binds})
+mkExternalCore dflags (CgGuts {cg_module=this_mod, cg_tycons = tycons,
+                               cg_binds = binds})
 {- Note that modules can be mutually recursive, but even so, we
    print out dependency information within each module. -}
-  = C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds) this_mod)
+  = C.Module (mname dflags) tdefs (runCoreM (mapM (make_vdef True) binds) initialState)
   where
-    mname  = make_mid this_mod
-    tdefs  = foldr collect_tdefs [] tycons
-
-collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
-collect_tdefs tcon tdefs 
+    initialState = CoreState {
+                       cs_dflags = dflags,
+                       cs_module = this_mod
+                   }
+    mname dflags = make_mid dflags this_mod
+    tdefs  = foldr (collect_tdefs dflags) [] tycons
+
+collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef]
+collect_tdefs dflags tcon tdefs
   | isAlgTyCon tcon = tdef: tdefs
   where
     tdef | isNewTyCon tcon = 
-                C.Newtype (qtc tcon) 
-                  (qcc (newTyConCo tcon))
+                C.Newtype (qtc dflags tcon) 
+                  (qcc dflags (newTyConCo tcon))
                   (map make_tbind tyvars) 
-                  (make_ty (snd (newTyConRhs tcon)))
+                  (make_ty dflags (snd (newTyConRhs tcon)))
          | otherwise = 
-                C.Data (qtc tcon) (map make_tbind tyvars) 
-                   (map make_cdef (tyConDataCons tcon)) 
+                C.Data (qtc dflags tcon) (map make_tbind tyvars) 
+                   (map (make_cdef dflags) (tyConDataCons tcon)) 
     tyvars = tyConTyVars tcon
 
-collect_tdefs _ tdefs = tdefs
+collect_tdefs _ _ tdefs = tdefs
 
-qtc :: TyCon -> C.Qual C.Tcon
-qtc = make_con_qid . tyConName
+qtc :: DynFlags -> TyCon -> C.Qual C.Tcon
+qtc dflags = make_con_qid dflags . tyConName
 
-qcc :: CoAxiom -> C.Qual C.Tcon
-qcc = make_con_qid . co_ax_name
+qcc :: DynFlags -> CoAxiom -> C.Qual C.Tcon
+qcc dflags = make_con_qid dflags . co_ax_name
 
-make_cdef :: DataCon -> C.Cdef
-make_cdef dcon =  C.Constr dcon_name existentials tys
+make_cdef :: DynFlags -> DataCon -> C.Cdef
+make_cdef dflags dcon =  C.Constr dcon_name existentials tys
   where 
-    dcon_name    = make_qid False False (dataConName dcon)
+    dcon_name    = make_qid dflags False False (dataConName dcon)
     existentials = map make_tbind ex_tyvars
     ex_tyvars    = dataConExTyVars dcon
-    tys 	 = map make_ty (dataConRepArgTys dcon)
+    tys 	 = map (make_ty dflags) (dataConRepArgTys dcon)
 
 make_tbind :: TyVar -> C.Tbind
 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
     
-make_vbind :: Var -> C.Vbind
-make_vbind v = (make_var_id  (Var.varName v), make_ty (varType v))
+make_vbind :: DynFlags -> Var -> C.Vbind
+make_vbind dflags v = (make_var_id  (Var.varName v), make_ty dflags (varType v))
 
 make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
 make_vdef topLevel b = 
@@ -129,29 +140,34 @@ make_vdef topLevel b =
           let local = not topLevel || localN
           rhs <- make_exp e
           -- use local flag to determine where to add the module name
-          return (local, make_qid local True vName, make_ty (varType v),rhs)
+          dflags <- getDynFlags
+          return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs)
   	where vName = Var.varName v
 
 make_exp :: CoreExpr -> CoreM C.Exp
 make_exp (Var v) = do
   let vName = Var.varName v
   isLocal <- isALocal vName
+  dflags <- getDynFlags
   return $
      case idDetails v of
        FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) 
-           -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
+           -> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v))
        FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
            panic "make_exp: FFI values not supported"
        FCallId (CCall (CCallSpec DynamicTarget     callconv _)) 
-           -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (varType v))
+           -> C.DynExternal            (showPpr dflags callconv) (make_ty dflags (varType v))
        -- Constructors are always exported, so make sure to declare them
        -- with qualified names
-       DataConWorkId _ -> C.Var (make_var_qid False vName)
-       DataConWrapId _ -> C.Var (make_var_qid False vName)
-       _ -> C.Var (make_var_qid isLocal vName)
+       DataConWorkId _ -> C.Var (make_var_qid dflags False vName)
+       DataConWrapId _ -> C.Var (make_var_qid dflags False vName)
+       _ -> C.Var (make_var_qid dflags isLocal vName)
 make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
-make_exp (Lit l) = return $ C.Lit (make_lit l)
-make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
+make_exp (Lit l) = do dflags <- getDynFlags
+                      return $ C.Lit (make_lit dflags l)
+make_exp (App e (Type t)) = do b <- make_exp e
+                               dflags <- getDynFlags
+                               return $ C.Appt b (make_ty dflags t)
 make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))"    -- TODO
 make_exp (App e1 e2) = do
    rator <- make_exp e1
@@ -159,9 +175,12 @@ make_exp (App e1 e2) = do
    return $ C.App rator rand
 make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Tb (make_tbind v)) b)
-make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> 
-                                    return $ C.Lam (C.Vb (make_vbind v)) b)
-make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
+make_exp (Lam v e) | otherwise = do b <- make_exp e
+                                    dflags <- getDynFlags
+                                    return $ C.Lam (C.Vb (make_vbind dflags v)) b
+make_exp (Cast e co) = do b <- make_exp e
+                          dflags <- getDynFlags
+                          return $ C.Cast b (make_co dflags co)
 make_exp (Let b e) = do
   vd   <- make_vdef False b
   body <- make_exp e
@@ -169,19 +188,23 @@ make_exp (Let b e) = do
 make_exp (Case e v ty alts) = do
   scrut <- make_exp e
   newAlts  <- mapM make_alt alts
-  return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
+  dflags <- getDynFlags
+  return $ C.Case scrut (make_vbind dflags v) (make_ty dflags ty) newAlts
 make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary
 make_exp _ = error "MkExternalCore died: make_exp"
 
 make_alt :: CoreAlt -> CoreM C.Alt
 make_alt (DataAlt dcon, vs, e) = do
     newE <- make_exp e
-    return $ C.Acon (make_con_qid (dataConName dcon))
+    dflags <- getDynFlags
+    return $ C.Acon (make_con_qid dflags (dataConName dcon))
            (map make_tbind tbs)
-           (map make_vbind vbs)
+           (map (make_vbind dflags) vbs)
 	   newE
 	where (tbs,vbs) = span isTyVar vs
-make_alt (LitAlt l,_,e)   = make_exp e >>= (return . (C.Alit (make_lit l)))
+make_alt (LitAlt l,_,e)   = do x <- make_exp e
+                               dflags <- getDynFlags
+                               return $ C.Alit (make_lit dflags l) x
 make_alt (DEFAULT,[],e)   = make_exp e >>= (return . C.Adefault)
 -- This should never happen, as the DEFAULT alternative binds no variables,
 -- but we might as well check for it:
@@ -189,8 +212,8 @@ make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
              ++ "alternative had a non-empty var list") (ppr a)
 
 
-make_lit :: Literal -> C.Lit
-make_lit l = 
+make_lit :: DynFlags -> Literal -> C.Lit
+make_lit dflags l = 
   case l of
     -- Note that we need to check whether the character is "big".
     -- External Core only allows character literals up to '\xff'.
@@ -208,22 +231,22 @@ make_lit l =
     MachDouble r -> C.Lrational r t
     _ -> error "MkExternalCore died: make_lit"
   where 
-    t = make_ty (literalType l)
+    t = make_ty dflags (literalType l)
 
 -- Expand type synonyms, then convert.
-make_ty :: Type -> C.Ty                 -- Be sure to expand types recursively!
+make_ty :: DynFlags -> Type -> C.Ty     -- Be sure to expand types recursively!
                                         -- example: FilePath ~> String ~> [Char]
-make_ty t | Just expanded <- tcView t = make_ty expanded
-make_ty t = make_ty' t
+make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded
+make_ty dflags t = make_ty' dflags t
  
 -- note calls to make_ty so as to expand types recursively
-make_ty' :: Type -> C.Ty
-make_ty' (TyVarTy tv)     = C.Tvar (make_var_id (tyVarName tv))
-make_ty' (AppTy t1 t2) 	  = C.Tapp (make_ty t1) (make_ty t2)
-make_ty' (FunTy t1 t2) 	  = make_ty (TyConApp funTyCon [t1,t2])
-make_ty' (ForAllTy tv t)  = C.Tforall (make_tbind tv) (make_ty t)
-make_ty' (TyConApp tc ts) = make_tyConApp tc ts
-make_ty' (LitTy {})       = panic "MkExernalCore can't do literal types yet"
+make_ty' :: DynFlags -> Type -> C.Ty
+make_ty' _      (TyVarTy tv)     = C.Tvar (make_var_id (tyVarName tv))
+make_ty' dflags (AppTy t1 t2) 	  = C.Tapp (make_ty dflags t1) (make_ty dflags t2)
+make_ty' dflags (FunTy t1 t2) 	  = make_ty dflags (TyConApp funTyCon [t1,t2])
+make_ty' dflags (ForAllTy tv t)  = C.Tforall (make_tbind tv) (make_ty dflags t)
+make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts
+make_ty' _      (LitTy {})       = panic "MkExernalCore can't do literal types yet"
 
 -- Newtypes are treated just like any other type constructor; not expanded
 -- Reason: predTypeRep does substitution and, while substitution deals
@@ -237,10 +260,10 @@ make_ty' (LitTy {})       = panic "MkExernalCore can't do literal types yet"
 -- expose the representation in interface files, which definitely isn't right.
 -- Maybe CoreTidy should know whether to expand newtypes or not?
 
-make_tyConApp :: TyCon -> [Type] -> C.Ty
-make_tyConApp tc ts =
-  foldl C.Tapp (C.Tcon (qtc tc)) 
-	    (map make_ty ts)
+make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty
+make_tyConApp dflags tc ts =
+  foldl C.Tapp (C.Tcon (qtc dflags tc)) 
+	    (map (make_ty dflags) ts)
 
 make_kind :: Kind -> C.Kind
 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
@@ -267,52 +290,53 @@ make_var_id = make_id True
 -- because that would just be ugly.)
 -- SIGH.
 -- We encode the package name as well.
-make_mid :: Module -> C.Id
+make_mid :: DynFlags -> Module -> C.Id
 -- Super ugly code, but I can't find anything else that does quite what I
 -- want (encodes the hierarchical module name without encoding the colon
 -- that separates the package name from it.)
-make_mid m = showSDoc $
+make_mid dflags m
+            = showSDoc dflags $
               (text $ zEncodeString $ packageIdString $ modulePackageId m)
               <> text ":"
               <> (pprEncoded $ pprModuleName $ moduleName m)
      where pprEncoded = pprCode CStyle
                
-make_qid :: Bool -> Bool -> Name -> C.Qual C.Id
-make_qid force_unqual is_var n = (mname,make_id is_var n)
+make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id
+make_qid dflags force_unqual is_var n = (mname,make_id is_var n)
     where mname = 
            case nameModule_maybe n of
-            Just m | not force_unqual -> make_mid m
+            Just m | not force_unqual -> make_mid dflags m
             _ -> "" 
 
-make_var_qid :: Bool -> Name -> C.Qual C.Id
-make_var_qid force_unqual = make_qid force_unqual True
-
-make_con_qid :: Name -> C.Qual C.Id
-make_con_qid = make_qid False False
-
-make_co :: Coercion -> C.Ty
-make_co (Refl ty)             = make_ty ty
-make_co (TyConAppCo tc cos)   = make_conAppCo (qtc tc) cos
-make_co (AppCo c1 c2)         = C.Tapp (make_co c1) (make_co c2)
-make_co (ForAllCo tv co)      = C.Tforall (make_tbind tv) (make_co co)
-make_co (CoVarCo cv)          = C.Tvar (make_var_id (coVarName cv))
-make_co (AxiomInstCo cc cos)  = make_conAppCo (qcc cc) cos
-make_co (UnsafeCo t1 t2)      = C.UnsafeCoercion (make_ty t1) (make_ty t2)
-make_co (SymCo co)            = C.SymCoercion (make_co co)
-make_co (TransCo c1 c2)       = C.TransCoercion (make_co c1) (make_co c2)
-make_co (NthCo d co)          = C.NthCoercion d (make_co co)
-make_co (InstCo co ty)        = C.InstCoercion (make_co co) (make_ty ty)
+make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id
+make_var_qid dflags force_unqual = make_qid dflags force_unqual True
+
+make_con_qid :: DynFlags -> Name -> C.Qual C.Id
+make_con_qid dflags = make_qid dflags False False
+
+make_co :: DynFlags -> Coercion -> C.Ty
+make_co dflags (Refl ty)             = make_ty dflags ty
+make_co dflags (TyConAppCo tc cos)   = make_conAppCo dflags (qtc dflags tc) cos
+make_co dflags (AppCo c1 c2)         = C.Tapp (make_co dflags c1) (make_co dflags c2)
+make_co dflags (ForAllCo tv co)      = C.Tforall (make_tbind tv) (make_co dflags co)
+make_co _      (CoVarCo cv)          = C.Tvar (make_var_id (coVarName cv))
+make_co dflags (AxiomInstCo cc cos)  = make_conAppCo dflags (qcc dflags cc) cos
+make_co dflags (UnsafeCo t1 t2)      = C.UnsafeCoercion (make_ty dflags t1) (make_ty dflags t2)
+make_co dflags (SymCo co)            = C.SymCoercion (make_co dflags co)
+make_co dflags (TransCo c1 c2)       = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
+make_co dflags (NthCo d co)          = C.NthCoercion d (make_co dflags co)
+make_co dflags (InstCo co ty)        = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
 
 -- Used for both tycon app coercions and axiom instantiations.
-make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
-make_conAppCo con cos =
+make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty
+make_conAppCo dflags con cos =
   foldl C.Tapp (C.Tcon con) 
-	    (map make_co cos)
+	    (map (make_co dflags) cos)
 
 -------
 isALocal :: Name -> CoreM Bool
 isALocal vName = do
-  modName <- ask
+  modName <- liftM cs_module ask
   return $ case nameModule_maybe vName of
              -- Not sure whether isInternalName corresponds to "local"ness
              -- in the External Core sense; need to re-read the spec.

compiler/deSugar/DsBinds.lhs

@@ -451,11 +451,12 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
 
        { (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id)
 
+       ; dflags <- getDynFlags
        ; let spec_id  = mkLocalId spec_name spec_ty 
          	            `setInlinePragma` inl_prag
          	 	    `setIdUnfolding`  spec_unf
              rule =  mkRule False {- Not auto -} is_local_id
-                        (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
+                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))
        			rule_act poly_name
        		        final_bndrs args
        			(mkVarApps (Var spec_id) bndrs)
@@ -463,7 +464,6 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
        ; spec_rhs <- dsHsWrapper spec_co poly_rhs
        ; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 
-       ; dflags <- getDynFlags
        ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
               (warnDs (specOnInline poly_name))
        ; return (Just (spec_pair `consOL` unf_pairs, rule))

compiler/deSugar/DsCCall.lhs

@@ -48,6 +48,7 @@ import Literal
 import PrelNames
 import VarSet
 import Constants
+import DynFlags
 import Outputable
 import Util
 \end{code}
@@ -98,13 +99,14 @@ dsCCall lbl args may_gc result_ty
   = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
        (ccall_result_ty, res_wrapper) <- boxResult result_ty
        uniq <- newUnique
+       dflags <- getDynFlags
        let
            target = StaticTarget lbl Nothing True
            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
-           the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
+           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 
-mkFCall :: Unique -> ForeignCall 
+mkFCall :: DynFlags -> Unique -> ForeignCall 
 	-> [CoreExpr] 	-- Args
 	-> Type 	-- Result type
 	-> CoreExpr
@@ -117,14 +119,14 @@ mkFCall :: Unique -> ForeignCall
 -- Here we build a ccall thus
 --	(ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
 --			a b s x c
-mkFCall uniq the_fcall val_args res_ty
+mkFCall dflags uniq the_fcall val_args res_ty
   = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
   where
     arg_tys = map exprType val_args
     body_ty = (mkFunTys arg_tys res_ty)
     tyvars  = varSetElems (tyVarsOfType body_ty)
     ty 	    = mkForAllTys tyvars body_ty
-    the_fcall_id = mkFCallId uniq the_fcall ty
+    the_fcall_id = mkFCallId dflags uniq the_fcall ty
 \end{code}
 
 \begin{code}

compiler/deSugar/DsExpr.lhs

@@ -765,14 +765,15 @@ handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
 handle_failure pat match fail_op
   | matchCanFail match
   = do { fail_op' <- dsExpr fail_op
-       ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+       ; dflags <- getDynFlags
+       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
        ; extractMatchResult match (App fail_op' fail_msg) }
   | otherwise
   = extractMatchResult match (error "It can't fail")
 
-mk_fail_msg :: Located e -> String
-mk_fail_msg pat = "Pattern match failure in do expression at " ++ 
-                  showSDoc (ppr (getLoc pat))
+mk_fail_msg :: DynFlags -> Located e -> String
+mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ 
+                         showPpr dflags (getLoc pat)
 \end{code}
 
 

compiler/deSugar/DsForeign.lhs

@@ -207,12 +207,13 @@ dsFCall fn_id co fcall mDeclHeader = do
     ccall_uniq <- newUnique
     work_uniq  <- newUnique
 
+    dflags <- getDynFlags
     (fcall', cDoc) <-
               case fcall of
               CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) ->
                do fcall_uniq <- newUnique
                   let wrapperName = mkFastString "ghc_wrapper_" `appendFS`
-                                    mkFastString (showSDoc (ppr fcall_uniq)) `appendFS`
+                                    mkFastString (showPpr dflags fcall_uniq) `appendFS`
                                     mkFastString "_" `appendFS`
                                     cName
                       fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety)
@@ -256,7 +257,7 @@ dsFCall fn_id co fcall mDeclHeader = do
     let
         -- Build the worker
         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
-        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
+        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
         work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
 
@@ -298,8 +299,9 @@ dsPrimCall fn_id co fcall = do
     args <- newSysLocalsDs arg_tys
 
     ccall_uniq <- newUnique
+    dflags <- getDynFlags
     let
-        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
+        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
         rhs      = mkLams tvs (mkLams args call_app)
         rhs'     = Cast rhs co
     return ([(fn_id, rhs')], empty, empty)
@@ -403,9 +405,10 @@ dsFExportDynamic :: Id
 dsFExportDynamic id co0 cconv = do
     fe_id <-  newSysLocalDs ty
     mod <- getModuleDs
+    dflags <- getDynFlags
     let
         -- hack: need to get at the name of the C stub we're about to generate.
-        fe_nm    = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
+        fe_nm    = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id)
 
     cback <- newSysLocalDs arg_ty
     newStablePtrId <- dsLookupGlobalId newStablePtrName
@@ -465,8 +468,8 @@ dsFExportDynamic id co0 cconv = do
   Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
         -- Must have an IO type; hence Just
 
-toCName :: Id -> String
-toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
+toCName :: DynFlags -> Id -> String
+toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
 \end{code}
 
 %*

compiler/deSugar/DsListComp.lhs

@@ -820,14 +820,16 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts
     handle_failure pat match fail_op
       | matchCanFail match
         = do { fail_op' <- dsExpr fail_op
-             ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+             ; dflags <- getDynFlags
+             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
              ; extractMatchResult match (App fail_op' fail_msg) }
       | otherwise
         = extractMatchResult match (error "It can't fail")
 
-    mk_fail_msg :: Located e -> String
-    mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++
-                      showSDoc (ppr (getLoc pat))
+    mk_fail_msg :: DynFlags -> Located e -> String
+    mk_fail_msg dflags pat
+        = "Pattern match failure in monad comprehension at " ++
+          showPpr dflags (getLoc pat)