Commit ab50c9c5 authored by Ian Lynagh's avatar Ian Lynagh

Pass DynFlags down to showSDoc

parent 543ec085
......@@ -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!
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......
This diff is collapsed.
......@@ -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))
......
......@@ -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}
......
......@@ -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}
......
......@@ -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}
%*
......
......@@ -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
......
......@@ -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])
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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 }
------------------
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 }
......
......@@ -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)))
......
......@@ -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
......
......@@ -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,