diff options
| author | Ian Lynagh <igloo@earth.li> | 2012-06-12 18:52:05 +0100 |
|---|---|---|
| committer | Ian Lynagh <igloo@earth.li> | 2012-06-12 18:52:05 +0100 |
| commit | ab50c9c527d19f4df7ee6742b6d79c855d57c9b8 (patch) | |
| tree | ac78c3fda6f3a8ec8235345f7b02518e0d809ba0 /compiler | |
| parent | 543ec0852722318665d2f5228e29d44a5fc973f5 (diff) | |
| download | haskell-ab50c9c527d19f4df7ee6742b6d79c855d57c9b8.tar.gz | |
Pass DynFlags down to showSDoc
Diffstat (limited to 'compiler')
45 files changed, 403 insertions, 297 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index a7f4b70d61..3eaa7dceb5 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/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! diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index e4ad450069..d2f0058668 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/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 diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index c33524636b..c97c3d47cd 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/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 diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 6d16f012b3..6a53317385 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/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. diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index bc1429165a..b6c682ffc0 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/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. diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index eae9530b0e..8949387aae 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/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)) diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 76bdfb930f..a2459f5a4c 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/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} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 7fa35e30eb..a60d3c4a80 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/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} diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 93dc627f14..09afd2f06f 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/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} %* diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 74fe642f1e..efe14f2678 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/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) -- Desugar nested monad comprehensions, for example in `then..` constructs -- dsInnerMonadComp quals [a,b,c] ret_op diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 5473edf216..52944e8347 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -76,6 +76,7 @@ import Outputable import SrcLoc import Util import ListSetOps +import DynFlags import FastString import Control.Monad ( zipWithM ) @@ -439,8 +440,9 @@ mkErrorAppDs :: Id -- The error function mkErrorAppDs err_id ty msg = do src_loc <- getSrcSpanDs + dflags <- getDynFlags let - full_msg = showSDoc (hcat [ppr src_loc, text "|", msg]) + full_msg = showSDoc dflags (hcat [ppr src_loc, text "|", msg]) core_msg = Lit (mkMachString full_msg) -- mkMachString returns a result of type String# return (mkApps (Var err_id) [Type ty, core_msg]) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 0fdc7a29f6..20b7e13e7f 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -164,7 +164,7 @@ showTerm term = do -- does this still do what it is intended to do -- with the changed error handling and logging? let noop_log _ _ _ _ _ = return () - expr = "show " ++ showSDoc (ppr bname) + expr = "show " ++ showPpr dflags bname _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} txt_ <- withExtendedLinkEnv [(bname, val)] (GHC.compileExpr expr) diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index f357b97669..331c294973 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -3,6 +3,7 @@ module DebuggerUtils ( ) where import ByteCodeItbls +import DynFlags import FastString import TcRnTypes import TcRnMonad @@ -45,7 +46,8 @@ dataConInfoPtrToName x = do occFS = mkFastStringByteList occ occName = mkOccNameFS OccName.dataName occFS modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) - return (Left$ showSDoc$ ppr modName <> dot <> ppr occName ) + dflags <- getDynFlags + return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName) `recoverM` (Right `fmap` lookupOrig modName occName) where diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 3f36cfd8a0..a16832b3b3 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -442,8 +442,8 @@ linkExpr hsc_env span root_ul_bco -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith :: SrcSpan -> MsgDoc -> IO a -dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage SevFatal span msg))) +dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a +dieWith dflags span msg = ghcError (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool @@ -460,14 +460,14 @@ checkNonStdWay dflags srcspan = do -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn -- whereas we have __stginit_base_Prelude_. if (objectSuf dflags == normalObjectSuffix) - then failNonStd srcspan + then failNonStd dflags srcspan else return True normalObjectSuffix :: String normalObjectSuffix = phaseInputExt StopLn -failNonStd :: SrcSpan -> IO Bool -failNonStd srcspan = dieWith srcspan $ +failNonStd :: DynFlags -> SrcSpan -> IO Bool +failNonStd dflags srcspan = dieWith dflags srcspan $ ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$ ptext (sLit "You need to build the program twice: once the normal way, and then") $$ ptext (sLit "in the desired way using -osuf to set the object file suffix.") @@ -526,7 +526,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods mb_iface <- initIfaceCheck hsc_env $ loadInterface msg mod (ImportByUser False) iface <- case mb_iface of - Maybes.Failed err -> ghcError (ProgramError (showSDoc err)) + Maybes.Failed err -> ghcError (ProgramError (showSDoc dflags err)) Maybes.Succeeded iface -> return iface when (mi_boot iface) $ link_boot_mod_error mod @@ -554,12 +554,12 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods link_boot_mod_error mod = - ghcError (ProgramError (showSDoc ( + ghcError (ProgramError (showSDoc dflags ( text "module" <+> ppr mod <+> text "cannot be linked; it is only available as a boot module"))) no_obj :: Outputable a => a -> IO b - no_obj mod = dieWith span $ + no_obj mod = dieWith dflags span $ ptext (sLit "cannot find object file for module ") <> quotes (ppr mod) $$ while_linking_expr @@ -600,7 +600,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods <.> normalObjectSuffix ok <- doesFileExist new_file if (not ok) - then dieWith span $ + then dieWith dflags span $ ptext (sLit "cannot find normal object file ") <> quotes (text new_file) $$ while_linking_expr else return (DotO new_file) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 4be3d87f31..f06d120bc4 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -378,7 +378,7 @@ ppr_termM _ _ t = ppr_termM1 t ppr_termM1 :: Monad m => Term -> m SDoc ppr_termM1 Prim{value=words, ty=ty} = - return$ text$ repPrim (tyConAppTyCon ty) words + return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = return (char '_' <+> ifPprDebug (text "::" <> ppr ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n} @@ -493,33 +493,33 @@ cPprTermBase y = ppr_list _ _ = panic "doList" -repPrim :: TyCon -> [Word] -> String -repPrim t = rep where +repPrim :: TyCon -> [Word] -> SDoc +repPrim t = rep where rep x - | t == charPrimTyCon = show (build x :: Char) - | t == intPrimTyCon = show (build x :: Int) - | t == wordPrimTyCon = show (build x :: Word) - | t == floatPrimTyCon = show (build x :: Float) - | t == doublePrimTyCon = show (build x :: Double) - | t == int32PrimTyCon = show (build x :: Int32) - | t == word32PrimTyCon = show (build x :: Word32) - | t == int64PrimTyCon = show (build x :: Int64) - | t == word64PrimTyCon = show (build x :: Word64) - | t == addrPrimTyCon = show (nullPtr `plusPtr` build x) - | t == stablePtrPrimTyCon = "<stablePtr>" - | t == stableNamePrimTyCon = "<stableName>" - | t == statePrimTyCon = "<statethread>" - | t == realWorldTyCon = "<realworld>" - | t == threadIdPrimTyCon = "<ThreadId>" - | t == weakPrimTyCon = "<Weak>" - | t == arrayPrimTyCon = "<array>" - | t == byteArrayPrimTyCon = "<bytearray>" - | t == mutableArrayPrimTyCon = "<mutableArray>" - | t == mutableByteArrayPrimTyCon = "<mutableByteArray>" - | t == mutVarPrimTyCon= "<mutVar>" - | t == mVarPrimTyCon = "<mVar>" - | t == tVarPrimTyCon = "<tVar>" - | otherwise = showSDoc (char '<' <> ppr t <> char '>') + | t == charPrimTyCon = text $ show (build x :: Char) + | t == intPrimTyCon = text $ show (build x :: Int) + | t == wordPrimTyCon = text $ show (build x :: Word) + | t == floatPrimTyCon = text $ show (build x :: Float) + | t == doublePrimTyCon = text $ show (build x :: Double) + | t == int32PrimTyCon = text $ show (build x :: Int32) + | t == word32PrimTyCon = text $ show (build x :: Word32) + | t == int64PrimTyCon = text $ show (build x :: Int64) + | t == word64PrimTyCon = text $ show (build x :: Word64) + | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) + | t == stablePtrPrimTyCon = text "<stablePtr>" + | t == stableNamePrimTyCon = text "<stableName>" + | t == statePrimTyCon = text "<statethread>" + | t == realWorldTyCon = text "<realworld>" + | t == threadIdPrimTyCon = text "<ThreadId>" + | t == weakPrimTyCon = text "<Weak>" + | t == arrayPrimTyCon = text "<array>" + | t == byteArrayPrimTyCon = text "<bytearray>" + | t == mutableArrayPrimTyCon = text "<mutableArray>" + | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>" + | t == mutVarPrimTyCon = text "<mutVar>" + | t == mVarPrimTyCon = text "<mVar>" + | t == tVarPrimTyCon = text "<tVar>" + | otherwise = char '<' <> ppr t <> char '>' where build ww = unsafePerformIO $ withArray ww (peek . castPtr) -- This ^^^ relies on the representation of Haskell heap values being -- the same as in a C array. @@ -750,7 +750,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- ignore the unpointed args, and recover the pointeds -- This preserves laziness, and should be safe. traceTR (text "Nothing" <+> ppr dcname) - let tag = showSDoc (ppr dcname) + let dflags = hsc_dflags hsc_env + tag = showPpr dflags dcname vars <- replicateM (length$ elems$ ptrs clos) (newVar liftedTypeKind) subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index eaf8ef56f8..4430b84760 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -162,8 +162,9 @@ loadUserInterface is_boot doc mod_name loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface loadInterfaceWithException doc mod_name where_from = do { mb_iface <- loadInterface doc mod_name where_from + ; dflags <- getDynFlags ; case mb_iface of - Failed err -> ghcError (ProgramError (showSDoc err)) + Failed err -> ghcError (ProgramError (showSDoc dflags err)) Succeeded iface -> return iface } ------------------ diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index dd87cc74fa..3df54be1a7 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1118,8 +1118,9 @@ checkOldIface :: HscEnv -> IO (RecompileRequired, Maybe ModIface) checkOldIface hsc_env mod_summary source_modified maybe_iface - = do showPass (hsc_dflags hsc_env) $ - "Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary) + = do let dflags = hsc_dflags hsc_env + showPass dflags $ + "Checking old interface for " ++ (showPpr dflags $ ms_mod mod_summary) initIfaceCheck hsc_env $ check_old_iface hsc_env mod_summary source_modified maybe_iface diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 6a5e423477..8f6ea05665 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1001,7 +1001,8 @@ tcIfaceExpr (IfaceLit lit) tcIfaceExpr (IfaceFCall cc ty) = do ty' <- tcIfaceType ty u <- newUnique - return (Var (mkFCallId u cc ty')) + dflags <- getDynFlags + return (Var (mkFCallId dflags u cc ty')) tcIfaceExpr (IfaceTuple boxity args) = do args' <- mapM tcIfaceExpr args diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index b2c201cb41..8cac6b03f7 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -183,11 +183,11 @@ outputForeignStubs dflags mod location stubs ForeignStubs h_code c_code -> do let stub_c_output_d = pprCode CStyle c_code - stub_c_output_w = showSDoc stub_c_output_d + stub_c_output_w = showSDoc dflags stub_c_output_d -- Header file protos for "foreign export"ed functions. stub_h_output_d = pprCode CStyle h_code - stub_h_output_w = showSDoc stub_h_output_d + stub_h_output_w = showSDoc dflags stub_h_output_d -- in createDirectoryIfMissing True (takeDirectory stub_h) diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 5db927a952..953b2c4568 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -176,9 +176,9 @@ processDeps :: DynFlags -- -- For {-# SOURCE #-} imports the "hi" will be "hi-boot". -processDeps _ _ _ _ _ (CyclicSCC nodes) +processDeps dflags _ _ _ _ (CyclicSCC nodes) = -- There shouldn't be any cycles; report them - ghcError (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes)) + ghcError (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) = do { let extra_suffixes = depSuffixes dflags diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 201a38cdb4..be06fbc61b 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -326,7 +326,7 @@ link' dflags batch_attempt_linking hpt return Succeeded else do - compilationProgressMsg dflags $ showSDoc $ + compilationProgressMsg dflags $ showSDoc dflags $ (ptext (sLit "Linking") <+> text exe_file <+> text "...") -- Don't showPass in Batch mode; doLink will do that for us. @@ -1497,7 +1497,7 @@ mkExtraObjToLinkIntoBinary dflags = do (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ text " Call hs_init_ghc() from your main() function to set these options.") - mkExtraObj dflags "c" (showSDoc main) + mkExtraObj dflags "c" (showSDoc dflags main) where main @@ -1528,7 +1528,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do link_info <- getLinkInfo dflags dep_packages if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc (link_opts link_info)) + then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) else return [] where diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index cc382a74fe..84eb2612e0 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -70,9 +70,10 @@ forceLoadTyCon hsc_env con_name = do mb_con_thing <- lookupTypeHscEnv hsc_env con_name case mb_con_thing of - Nothing -> throwCmdLineErrorS $ missingTyThingError con_name + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name Just (ATyCon tycon) -> return tycon - Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing + Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing + where dflags = hsc_dflags hsc_env -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety -- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! @@ -91,7 +92,7 @@ getValueSafely hsc_env val_name expected_type = do -- Now look up the names for the value and type constructor in the type environment mb_val_thing <- lookupTypeHscEnv hsc_env val_name case mb_val_thing of - Nothing -> throwCmdLineErrorS $ missingTyThingError val_name + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name Just (AnId id) -> do -- Check the value type in the interface against the type recovered from the type constructor -- before finally casting the value to the type we assume corresponds to that constructor @@ -107,7 +108,8 @@ getValueSafely hsc_env val_name expected_type = do value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval return $ Just value else return Nothing - Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing + Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing + where dflags = hsc_dflags hsc_env -- | Coerce a value as usual, but: @@ -149,10 +151,9 @@ lookupRdrNameInModule hsc_env mod_name rdr_name = do [] -> return Nothing _ -> panic "lookupRdrNameInModule" - Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] - err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err - where - dflags = hsc_dflags hsc_env + Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] + err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + where dflags = hsc_dflags hsc_env wrongTyThingError :: Name -> TyThing -> SDoc @@ -161,8 +162,8 @@ wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptex missingTyThingError :: Name -> SDoc missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] -throwCmdLineErrorS :: SDoc -> IO a -throwCmdLineErrorS = throwCmdLineError . showSDoc +throwCmdLineErrorS :: DynFlags -> SDoc -> IO a +throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags throwCmdLineError :: String -> IO a throwCmdLineError = throwGhcException . CmdLineError diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 83f57c3888..301ed1b613 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -109,9 +109,9 @@ makeIntoWarning err = err { errMsgSeverity = SevWarning } -- Collecting up messages for later ordering and printing. mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg -mk_err_msg _ sev locn print_unqual msg extra +mk_err_msg dflags sev locn print_unqual msg extra = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg , errMsgShortString = showSDoc msg + , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg , errMsgExtraInfo = extra , errMsgSeverity = sev } diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index dc0730fafa..bedb30002a 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -590,8 +590,9 @@ guessTarget str Nothing if looksLikeModuleName file then return (target (TargetModule (mkModuleName file))) else do + dflags <- getDynFlags throwGhcException - (ProgramError (showSDoc $ + (ProgramError (showSDoc dflags $ text "target" <+> quotes (text file) <+> text "is not a module name or a source file")) where @@ -1291,11 +1292,11 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found loc m | modulePackageId m /= this_pkg -> return m - | otherwise -> modNotLoadedError m loc + | otherwise -> modNotLoadedError dflags m loc err -> noModError dflags noSrcSpan mod_name err -modNotLoadedError :: Module -> ModLocation -> IO a -modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $ +modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a +modNotLoadedError dflags m loc = ghcError $ CmdLineError $ showSDoc dflags $ text "module is not loaded:" <+> quotes (ppr (moduleName m)) <+> parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 0c09603ae0..3941588714 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -853,10 +853,11 @@ batchMsg hsc_env mb_mod_index recomp mod_summary = RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") RecompForcedByTH -> showMsg "Compiling " " [TH]" where + dflags = hsc_dflags hsc_env showMsg msg reason = - compilationProgressMsg (hsc_dflags hsc_env) $ + compilationProgressMsg dflags $ (showModuleIndex mb_mod_index ++ - msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) + msg ++ showModMsg dflags (hscTarget dflags) (recompileRequired recomp) mod_summary) ++ reason diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 6298192d42..aac5ba5bd3 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -182,7 +182,7 @@ srcErrorMessages :: SourceError -> ErrorMessages srcErrorMessages (SourceError msgs) = msgs mkApiErr :: DynFlags -> SDoc -> GhcApiError -mkApiErr _ msg = GhcApiError (showSDoc msg) +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) throwOneError :: MonadIO m => ErrMsg -> m ab throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err @@ -1870,9 +1870,9 @@ instance Outputable ModSummary where char '}' ] -showModMsg :: HscTarget -> Bool -> ModSummary -> String -showModMsg target recomp mod_summary - = showSDoc $ +showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String +showModMsg dflags target recomp mod_summary + = showSDoc dflags $ hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), char '(', text (normalise $ msHsFilePath mod_summary) <> comma, case target of @@ -1883,7 +1883,7 @@ showModMsg target recomp mod_summary char ')'] where mod = moduleName (ms_mod mod_summary) - mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) + mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) \end{code} %************************************************************************ diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 5fa0f6bd57..60681fc6e7 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -814,9 +814,10 @@ fromListBL bound l = BL (length l) bound l [] setContext :: GhcMonad m => [InteractiveImport] -> m () setContext imports = do { hsc_env <- getSession + ; let dflags = hsc_dflags hsc_env ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports ; case all_env_err of - Left (mod, err) -> ghcError (formatError mod err) + Left (mod, err) -> ghcError (formatError dflags mod err) Right all_env -> do { ; let old_ic = hsc_IC hsc_env final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env @@ -824,7 +825,7 @@ setContext imports hsc_env{ hsc_IC = old_ic { ic_imports = imports , ic_rn_gbl_env = final_rdr_env }}}} where - formatError mod err = ProgramError . showSDoc $ + formatError dflags mod err = ProgramError . showSDoc dflags $ text "Cannot add module" <+> ppr mod <+> text "to context:" <+> text err @@ -1009,7 +1010,8 @@ showModule :: GhcMonad m => ModSummary -> m String showModule mod_summary = withSession $ \hsc_env -> do interpreted <- isModuleInterpreted mod_summary - return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) + let dflags = hsc_dflags hsc_env + return (showModMsg dflags (hscTarget dflags) interpreted mod_summary) isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool isModuleInterpreted mod_summary = withSession $ \hsc_env -> diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 42e5cf5557..9831367fff 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -318,16 +318,17 @@ mungePackagePaths top_dir pkgroot pkg = -- (-package, -hide-package, -ignore-package). applyPackageFlag - :: UnusablePackages + :: DynFlags + -> UnusablePackages -> [PackageConfig] -- Initial database -> PackageFlag -- flag to apply -> IO [PackageConfig] -- new database -applyPackageFlag unusable pkgs flag = +applyPackageFlag dflags unusable pkgs flag = case flag of ExposePackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (p:ps,qs) -> return (p':ps') where p' = p {exposed=True} ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) @@ -335,7 +336,7 @@ applyPackageFlag unusable pkgs flag = ExposePackageId str -> case selectPackages (matchingId str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (p:ps,qs) -> return (p':ps') where p' = p {exposed=True} ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) @@ -343,7 +344,7 @@ applyPackageFlag unusable pkgs flag = HidePackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (ps,qs) -> return (map hide ps ++ qs) where hide p = p {exposed=False} @@ -351,13 +352,13 @@ applyPackageFlag unusable pkgs flag = -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (ps,qs) -> return (map trust ps ++ qs) where trust p = p {trusted=True} DistrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (ps,qs) -> return (map distrust ps ++ qs) where distrust p = p {trusted=False} @@ -402,19 +403,20 @@ sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId))) comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b -packageFlagErr :: PackageFlag +packageFlagErr :: DynFlags + -> PackageFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a -- for missing DPH package we emit a more helpful error message, because -- this may be the result of using -fdph-par or -fdph-seq. -packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg - = ghcError (CmdLineError (showSDoc $ dph_err)) +packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg + = ghcError (CmdLineError (showSDoc dflags $ dph_err)) where dph_err = text "the " <> text pkg <> text " package is not installed." $$ text "To install it: \"cabal install dph\"." is_dph_package pkg = "dph" `isPrefixOf` pkg -packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) +packageFlagErr dflags flag reasons = ghcError (CmdLineError (showSDoc dflags $ err)) where err = text "cannot satisfy " <> ppr_flag <> (if null reasons then empty else text ": ") $$ nest 4 (ppr_reasons $$ @@ -754,7 +756,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- Modify the package database according to the command-line flags -- (-package, -hide-package, -ignore-package, -hide-all-packages). -- - pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags + pkgs1 <- foldM (applyPackageFlag dflags unusable) pkgs0_unique other_flags let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1 -- Here we build up a set of the packages mentioned in -package @@ -782,7 +784,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do lookupIPID ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map = return pid - | otherwise = missingPackageErr str + | otherwise = missingPackageErr dflags str preload2 <- mapM lookupIPID preload1 @@ -799,7 +801,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do $ (basicLinkedPackages ++ preload2) -- Close the preload packages with their dependencies - dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing)) + dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let pstate = PackageState{ preloadPackages = dep_preload, @@ -964,20 +966,23 @@ getPreloadPackagesAnd dflags pkgids = preload = preloadPackages state pairs = zip pkgids (repeat Nothing) in do - all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs) + all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs) return (map (getPackageDetails state) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). -closeDeps :: PackageConfigMap +closeDeps :: DynFlags + -> PackageConfigMap -> Map InstalledPackageId PackageId -> [(PackageId, Maybe PackageId)] -> IO [PackageId] -closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) +closeDeps dflags pkg_map ipid_map ps + = throwErr dflags (closeDepsErr pkg_map ipid_map ps) -throwErr :: MaybeErr MsgDoc a -> IO a -throwErr m = case m of - Failed e -> ghcError (CmdLineError (showSDoc e)) +throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a +throwErr dflags m + = case m of + Failed e -> ghcError (CmdLineError (showSDoc dflags e)) Succeeded r -> return r closeDepsErr :: PackageConfigMap @@ -1009,8 +1014,9 @@ add_package pkg_db ipid_map ps (p, mb_parent) | otherwise = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent) -missingPackageErr :: String -> IO a -missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p))) +missingPackageErr :: DynFlags -> String -> IO a +missingPackageErr dflags p + = ghcError (CmdLineError (showSDoc dflags (missingPackageMsg p))) missingPackageMsg :: String -> SDoc missingPackageMsg p = ptext (sLit "unknown package:") <+> text p diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index d624cc1070..ddd8775ca4 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -315,7 +315,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count count' <- return $! count + 1; -- force evaulation all this stuff to avoid space leaks - {-# SCC "seqString" #-} seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return () + {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map (pprPlatform platform) imports) `seq` return () cmmNativeGens dflags ncgImpl h us' cmms @@ -818,8 +818,7 @@ Ideas for other things we could do (put these in Hoopl please!): cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do - let platform = targetPlatform dflags - blocks' <- mapM cmmBlockConFold (cmmMiniInline platform (cmmEliminateDeadBlocks blocks)) + blocks' <- mapM cmmBlockConFold (cmmMiniInline dflags (cmmEliminateDeadBlocks blocks)) return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) @@ -897,7 +896,7 @@ cmmStmtConFold stmt return $ case test' of CmmLit (CmmInt 0 _) -> CmmComment (mkFastString ("deleted: " ++ - showSDoc (pprStmt platform stmt))) + showSDoc dflags (pprStmt platform stmt))) CmmLit (CmmInt _ _) -> CmmBranch dest _other -> CmmCondBranch test' dest diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 8b8beb9376..65b34ac709 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1387,14 +1387,15 @@ unknownNameSuggestErr :: WhereLooking -> RdrName -> RnM SDoc unknownNameSuggestErr where_look tried_rdr_name = do { local_env <- getLocalRdrEnv ; global_env <- getGlobalRdrEnv + ; dflags <- getDynFlags ; let all_possibilities :: [(String, (RdrName, HowInScope))] all_possibilities - = [ (showSDoc (ppr r), (r, Left loc)) + = [ (showPpr dflags r, (r, Left loc)) | (r,loc) <- local_possibilities local_env ] - ++ [ (showSDoc (ppr r), rp) | (r,rp) <- global_possibilities global_env ] + ++ [ (showPpr dflags r, rp) | (r,rp) <- global_possibilities global_env ] - suggest = fuzzyLookup (showSDoc (ppr tried_rdr_name)) all_possibilities + suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities perhaps = ptext (sLit "Perhaps you meant") extra_err = case suggest of [] -> empty diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 48ff0eec4a..272bdfb71c 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -147,7 +147,7 @@ endPass dflags pass binds rules dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () dumpIfSet dflags dump_me pass extra_info doc - = Err.dumpIfSet dflags dump_me (showSDoc (ppr pass <+> extra_info)) doc + = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc dumpPassResult :: DynFlags -> Maybe DynFlag -- Just df => show details in a file whose @@ -158,7 +158,7 @@ dumpPassResult :: DynFlags -> IO () dumpPassResult dflags mb_flag hdr extra_info binds rules | Just dflag <- mb_flag - = Err.dumpSDoc dflags dflag (showSDoc hdr) dump_doc + = Err.dumpSDoc dflags dflag (showSDoc dflags hdr) dump_doc | otherwise = Err.debugTraceMsg dflags 2 size_doc diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index a176e6ce38..c68c900c22 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -328,9 +328,10 @@ loadPlugins hsc_env loadPlugin :: HscEnv -> ModuleName -> IO Plugin loadPlugin hsc_env mod_name = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin") + dflags = hsc_dflags hsc_env ; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name ; case mb_name of { - Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep [ ptext (sLit "The module"), ppr mod_name , ptext (sLit "did not export the plugin name") , ppr plugin_rdr_name ]) ; @@ -339,7 +340,7 @@ loadPlugin hsc_env mod_name do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) ; case mb_plugin of - Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep [ ptext (sLit "The value"), ppr name , ptext (sLit "did not have the type") , ppr pluginTyConName, ptext (sLit "as required")]) diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index a65d46e339..995d6212ce 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -627,7 +627,8 @@ specConstrProgram guts %************************************************************************ \begin{code} -data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold +data ScEnv = SCE { sc_dflags :: DynFlags, + sc_size :: Maybe Int, -- Size threshold sc_count :: Maybe Int, -- Max # of specialisations for any one fn -- See Note [Avoiding exponential blowup] sc_force :: Bool, -- Force specialisation? @@ -672,7 +673,8 @@ instance Outputable Value where --------------------- initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv initScEnv dflags anns - = SCE { sc_size = specConstrThreshold dflags, + = SCE { sc_dflags = dflags, + sc_size = specConstrThreshold dflags, sc_count = specConstrCount dflags, sc_force = False, sc_subst = emptySubst, @@ -1384,7 +1386,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) fn_name = idName fn fn_loc = nameSrcSpan fn_name spec_occ = mkSpecOcc (nameOccName fn_name) - rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number)) + dflags = sc_dflags env + rule_name = mkFastString ("SC:" ++ showSDoc dflags (ppr fn <> int rule_number)) spec_name = mkInternalName spec_uniq spec_occ fn_loc -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ -- return () diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 781918ddf9..c46d826e0a 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -162,8 +162,9 @@ deferToRuntime ev_binds_var ctxt mk_err_msg ct | Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct = do { err <- setCtLoc loc $ mk_err_msg ctxt ct + ; dflags <- getDynFlags ; let err_msg = pprLocErrMsg err - err_fs = mkFastString $ showSDoc $ + err_fs = mkFastString $ showSDoc dflags $ err_msg $$ text "(deferred type error)" -- Create the binding diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 920a702059..49c5131275 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -1060,14 +1060,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; warnMissingMethodOrAT "method" (idName sel_id) ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id + ; dflags <- getDynFlags ; return (meth_id, mkVarBind meth_id $ - mkLHsWrap lam_wrapper error_rhs) } + mkLHsWrap lam_wrapper (error_rhs dflags)) } where - error_rhs = L loc $ HsApp error_fun error_msg + error_rhs dflags = L loc $ HsApp error_fun (error_msg dflags) error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID - error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) + error_msg dflags = L loc (HsLit (HsStringPrim (mkFastString (error_string dflags)))) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) - error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) + error_string dflags = showSDoc dflags (hcat [ppr loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 9aff080efb..3f03d56408 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -359,8 +359,8 @@ mkCodeStyle = PprCode -- Can't make SDoc an instance of Show because SDoc is just a function type -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string -showSDoc :: SDoc -> String -showSDoc d = +showSDoc :: DynFlags -> SDoc -> String +showSDoc _ d = Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultUserStyle)) @@ -400,7 +400,7 @@ showSDocDebug :: SDoc -> String showSDocDebug d = show (runSDoc d (initSDocContext PprDebug)) showPpr :: Outputable a => DynFlags -> a -> String -showPpr _ = showSDoc . ppr +showPpr dflags = showSDoc dflags . ppr \end{code} \begin{code} @@ -942,7 +942,7 @@ warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x = pprDebugAndThen trace str msg x where - str = showSDoc (hsep [text "WARNING: file", text file <> comma, text "line", int line]) + str = showSDoc tracingDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line]) assertPprPanic :: String -> Int -> SDoc -> a -- ^ Panic with an assertation failure, recording the given file and line number. @@ -954,6 +954,14 @@ assertPprPanic file line msg , text "line", int line ] , msg ] +-- tracingDynFlags is a hack, necessary because we need to be able to +-- show SDocs when tracing, but we don't always have DynFlags available. +-- Do not use it if you can help it. It will not reflect options set +-- by the commandline flags, it may hav the wrong target platform, etc. +-- Currently it just panics if you try to use it. +tracingDynFlags :: DynFlags +tracingDynFlags = panic "tracingDynFlags used" + pprDebugAndThen :: (String -> a) -> String -> SDoc -> a pprDebugAndThen cont heading pretty_msg = cont (show (runSDoc doc (initSDocContext PprDebug))) diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index c92ae8073e..8b7e817826 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -210,7 +210,8 @@ vectTopBind b@(Rec bs) ; if and hasNoVectDecls then return b -- all bindings have 'NOVECTORISE' else if or hasNoVectDecls - then cantVectorise noVectoriseErr (ppr b) -- some (but not all) have 'NOVECTORISE' + then do dflags <- getDynFlags + cantVectorise dflags noVectoriseErr (ppr b) -- some (but not all) have 'NOVECTORISE' else vectorise -- no binding has a 'NOVECTORISE' decl } noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group" @@ -265,7 +266,7 @@ vectTopBinder var inline expr | eqType vty vdty -> return () | otherwise -> do dflags <- getDynFlags - cantVectorise ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $ + cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $ (text "Expected type" <+> ppr vty) $$ (text "Inferred type" <+> ppr vdty) diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index c984c10a24..8c5ef0045d 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -48,7 +48,7 @@ import Control.Applicative import Data.Maybe import Data.List import TcRnMonad (doptM) -import DynFlags (DynFlag(Opt_AvoidVect)) +import DynFlags import Util @@ -281,7 +281,8 @@ vectExpr (_, AnnLit lit) _ vectExpr e@(_, AnnLam bndr _) vt | isId bndr = (\(_, _, ve) -> ve) <$> vectFnExpr True False [] e vt - | otherwise = cantVectorise "Unexpected type lambda (vectExpr)" (ppr (deAnnotate e)) + | otherwise = do dflags <- getDynFlags + cantVectorise dflags "Unexpected type lambda (vectExpr)" (ppr (deAnnotate e)) -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty'; -- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint @@ -336,7 +337,8 @@ vectExpr (_, AnnCase scrut bndr ty alts) vt | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty , isAlgTyCon tycon = vectAlgCase tycon ty_args scrut bndr ty alts vt - | otherwise = cantVectorise "Can't vectorise expression" (ppr scrut_ty) + | otherwise = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise expression" (ppr scrut_ty) where scrut_ty = exprType (deAnnotate scrut) @@ -368,7 +370,8 @@ vectExpr (_, AnnTick tickish expr) (VITNode _ [vit]) vectExpr (_, AnnType ty) _ = liftM vType (vectType ty) -vectExpr e vit = cantVectorise "Can't vectorise expression (vectExpr)" (ppr (deAnnotate e) $$ text (" " ++ show vit)) +vectExpr e vit = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise expression (vectExpr)" (ppr (deAnnotate e) $$ text (" " ++ show vit)) -- |Vectorise an expression that *may* have an outer lambda abstraction. -- diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index ce2d947519..77793295dd 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -23,6 +23,7 @@ import OccName import Coercion import MkId +import DynFlags import FastString import MonadUtils import Control.Monad @@ -394,8 +395,10 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r = case ss of -- We can't convert data types with no data. -- See Note: [Empty PDatas]. - EmptySum -> return ([], errorEmptyPDatas el_ty) - UnarySum r -> to_con (errorEmptyPDatas el_ty) r + EmptySum -> do dflags <- getDynFlags + return ([], errorEmptyPDatas dflags el_ty) + UnarySum r -> do dflags <- getDynFlags + to_con (errorEmptyPDatas dflags el_ty) r Sum{} -> do let psums_tc = repr_psums_tc ss @@ -486,7 +489,8 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r = case ss of -- We can't convert data types with no data. -- See Note: [Empty PDatas]. - EmptySum -> return (res, errorEmptyPDatas el_ty) + EmptySum -> do dflags <- getDynFlags + return (res, errorEmptyPDatas dflags el_ty) UnarySum r -> from_con res_ty res expr r Sum {} @@ -572,9 +576,9 @@ To fix this we'd need to add an Int field to VPDs:Empty1 as well, but that's too much hassle and there's no point running a parallel computation on no data anyway. -} -errorEmptyPDatas :: Type -> a -errorEmptyPDatas tc - = cantVectorise "Vectorise.PAMethods" +errorEmptyPDatas :: DynFlags -> Type -> a +errorEmptyPDatas dflags tc + = cantVectorise dflags "Vectorise.PAMethods" $ vcat [ text "Cannot vectorise data type with no parallel data " <> quotes (ppr tc) , text "Data types to be vectorised must contain at least one constructor" , text "with at least one field." ] diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 2784868d8e..375b0af85e 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -151,7 +151,9 @@ lookupVar v = do { mb_res <- lookupVar_maybe v ; case mb_res of Just x -> return x - Nothing -> dumpVar v + Nothing -> + do dflags <- getDynFlags + dumpVar dflags v } lookupVar_maybe :: Var -> VM (Maybe (Scope Var (Var, Var))) @@ -162,12 +164,12 @@ lookupVar_maybe v Nothing -> fmap Global <$> (readGEnv $ \env -> lookupVarEnv (global_vars env) v) } -dumpVar :: Var -> a -dumpVar var +dumpVar :: DynFlags -> Var -> a +dumpVar dflags var | Just _ <- isClassOpId_maybe var - = cantVectorise "ClassOpId not vectorised:" (ppr var) + = cantVectorise dflags "ClassOpId not vectorised:" (ppr var) | otherwise - = cantVectorise "Variable not vectorised:" (ppr var) + = cantVectorise dflags "Variable not vectorised:" (ppr var) -- Global scalars -------------------------------------------------------------- diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs index e47015c548..7effd75460 100644 --- a/compiler/vectorise/Vectorise/Monad/Base.hs +++ b/compiler/vectorise/Vectorise/Monad/Base.hs @@ -84,27 +84,30 @@ liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) } -- |Throw a `pgmError` saying we can't vectorise something. -- -cantVectorise :: String -> SDoc -> a -cantVectorise s d = pgmError - . showSDoc +cantVectorise :: DynFlags -> String -> SDoc -> a +cantVectorise dflags s d = pgmError + . showSDoc dflags $ vcat [text "*** Vectorisation error ***", nest 4 $ sep [text s, nest 4 d]] -- |Like `fromJust`, but `pgmError` on Nothing. -- -maybeCantVectorise :: String -> SDoc -> Maybe a -> a -maybeCantVectorise s d Nothing = cantVectorise s d -maybeCantVectorise _ _ (Just x) = x +maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a +maybeCantVectorise dflags s d Nothing = cantVectorise dflags s d +maybeCantVectorise _ _ _ (Just x) = x -- |Like `maybeCantVectorise` but in a `Monad`. -- -maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a +maybeCantVectoriseM :: (Monad m, HasDynFlags m) + => String -> SDoc -> m (Maybe a) -> m a maybeCantVectoriseM s d p = do r <- p case r of Just x -> return x - Nothing -> cantVectorise s d + Nothing -> + do dflags <- getDynFlags + cantVectorise dflags s d -- Debugging ------------------------------------------------------------------ diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs index e728d6aa22..a5c8449fc2 100644 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -37,6 +37,7 @@ import CoreSyn import Type import TyCon import DataCon +import DynFlags import NameEnv import NameSet import Name @@ -76,7 +77,9 @@ defGlobalVar v v' -- check for duplicate vectorisation ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v ; case currentDef of - Just old_v' -> cantVectorise "Variable is already vectorised:" $ + Just old_v' -> + do dflags <- getDynFlags + cantVectorise dflags "Variable is already vectorised:" $ ppr v <+> moduleOf v old_v' Nothing -> return () @@ -147,7 +150,9 @@ defTyConName tc nameOfTc' tc' -- check for duplicate vectorisation ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) ; case currentDef of - Just old_tc' -> cantVectorise "Type constructor or class is already vectorised:" $ + Just old_tc' -> + do dflags <- getDynFlags + cantVectorise dflags "Type constructor or class is already vectorised:" $ ppr tc <+> moduleOf tc old_tc' Nothing -> return () diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index 546da3387e..34d3d75b75 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -8,6 +8,7 @@ import Vectorise.Monad.Global import Vectorise.Monad.Base import Vectorise.Env +import DynFlags import FamInstEnv import InstEnv import Class @@ -34,7 +35,9 @@ lookupInst cls tys = do { instEnv <- readGEnv global_inst_env ; case lookupUniqueInstEnv instEnv cls tys of Right (inst, inst_tys) -> return (instanceDFunId inst, inst_tys) - Left err -> cantVectorise "Vectorise.Monad.InstEnv.lookupInst:" err + Left err -> + do dflags <- getDynFlags + cantVectorise dflags "Vectorise.Monad.InstEnv.lookupInst:" err } -- Look up the representation tycon of a family instance. @@ -61,6 +64,7 @@ lookupFamInst tycon tys [(fam_inst, rep_tys)] -> return ( dataFamInstRepTyCon fam_inst , rep_tys) _other -> - cantVectorise "VectMonad.lookupFamInst: not found: " + do dflags <- getDynFlags + cantVectorise dflags "VectMonad.lookupFamInst: not found: " (ppr $ mkTyConApp tycon tys) } diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 9f682a86fd..05b78246db 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -11,6 +11,7 @@ import Type import TyCon import DataCon import BasicTypes +import DynFlags import Var import Name import Outputable @@ -35,7 +36,8 @@ vectTyConDecl tycon name' -- Type constructor representing a type class | Just cls <- tyConClass_maybe tycon = do { unless (null $ classATs cls) $ - cantVectorise "Associated types are not yet supported" (ppr cls) + do dflags <- getDynFlags + cantVectorise dflags "Associated types are not yet supported" (ppr cls) -- vectorise superclass constraint (types) ; theta' <- mapM vectType (classSCTheta cls) @@ -83,7 +85,8 @@ vectTyConDecl tycon name' -- Regular algebraic type constructor — for now, Haskell 2011-style only | isAlgTyCon tycon = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $ - cantVectorise "Currently only Haskell 2011 datatypes are supported" (ppr tycon) + do dflags <- getDynFlags + cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon) -- vectorise the data constructor of the class tycon ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon) @@ -106,7 +109,8 @@ vectTyConDecl tycon name' -- some other crazy thing that we don't handle | otherwise - = cantVectorise "Can't vectorise exotic type constructor" (ppr tycon) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon) -- |Vectorise a class method. (Don't enter it into the vectorisation map yet.) -- @@ -125,7 +129,8 @@ vectMethod id defMeth ty -- vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs vectAlgTyConRhs tc (AbstractTyCon {}) - = cantVectorise "Can't vectorise imported abstract type" (ppr tc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc) vectAlgTyConRhs _tc DataFamilyTyCon = return DataFamilyTyCon vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons @@ -138,7 +143,8 @@ vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons } } vectAlgTyConRhs tc (NewTyCon {}) - = cantVectorise noNewtypeErr (ppr tc) + = do dflags <- getDynFlags + cantVectorise dflags noNewtypeErr (ppr tc) where noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration" @@ -147,13 +153,17 @@ vectAlgTyConRhs tc (NewTyCon {}) vectDataCon :: DataCon -> VM DataCon vectDataCon dc | not . null $ ex_tvs - = cantVectorise "Can't vectorise constructor with existential type variables yet" (ppr dc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc) | not . null $ eq_spec - = cantVectorise "Can't vectorise constructor with equality context yet" (ppr dc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc) | not . null $ dataConFieldLabels dc - = cantVectorise "Can't vectorise constructor with labelled fields yet" (ppr dc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc) | not . null $ theta - = cantVectorise "Can't vectorise constructor with constraint context yet" (ppr dc) + = do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc) | otherwise = do { name' <- mkLocalisedName mkVectDataConOcc name ; tycon' <- vectTyCon tycon diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index dfc08bcf58..de80127c44 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -18,6 +18,7 @@ import TypeRep import TyCon import Var import Outputable +import DynFlags import FastString import Control.Monad @@ -82,9 +83,10 @@ paDictOfType ty where noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)" - paDictOfTyApp _ _ = failure + paDictOfTyApp _ _ = do dflags <- getDynFlags + failure dflags - failure = cantVectorise "Can't construct PA dictionary for type" (ppr ty) + failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty) -- |Produce code that refers to a method of the 'PA' class. -- @@ -160,8 +162,9 @@ prDictOfReprType ty prDictOfReprType' :: Type -> VM CoreExpr prDictOfReprType' ty = prDictOfReprType ty `orElseV` - cantVectorise "No PR dictionary for representation type" - (ppr ty) + do dflags <- getDynFlags + cantVectorise dflags "No PR dictionary for representation type" + (ppr ty) -- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding -- to the argument types. @@ -175,10 +178,12 @@ prDFunApply dfun tys = do pa <- builtin paTyCon pr <- builtin prTyCon - args <- zipWithM (dictionary pa pr) tys tycons + dflags <- getDynFlags + args <- zipWithM (dictionary dflags pa pr) tys tycons return $ Var dfun `mkTyApps` tys `mkApps` args - | otherwise = invalid + | otherwise = do dflags <- getDynFlags + invalid dflags where -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then -- ctxs is Just [PA, PR] @@ -191,10 +196,10 @@ prDFunApply dfun tys $ splitForAllTys $ varType dfun - dictionary pa pr ty tycon + dictionary dflags pa pr ty tycon | tycon == pa = paDictOfType ty | tycon == pr = prDictOfReprType ty - | otherwise = invalid + | otherwise = invalid dflags - invalid = cantVectorise "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) + invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) |