Commit a5f5a70c authored by Ian Lynagh's avatar Ian Lynagh

More DynFlags + SDoc

parent ea3a9edd
......@@ -56,13 +56,13 @@ name = Util.globalMVar (value);
#ifdef DEBUG
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
#define WARN( dflags, e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
#else
-- We have to actually use all the variables we are given or we may get
-- unused variable warnings when DEBUG is off.
#define ASSERT(e) if False && (not (e)) then panic "ASSERT" else
#define ASSERT2(e,msg) if False && (const False (e,msg)) then pprPanic "ASSERT2" (msg) else
#define WARN(e,msg) if False && (e) then pprPanic "WARN" (msg) else
#define WARN(dflags,e,msg) if False && (e) then pprPanic (dflags) "WARN" (msg) else
-- Here we deliberately don't use when as Control.Monad might not be imported
#endif
......
......@@ -72,6 +72,7 @@ module Name (
#include "Typeable.h"
import {-# SOURCE #-} TypeRep( TyThing )
import {-# SOURCE #-} DynFlags (DynFlags)
import OccName
import Module
......@@ -164,7 +165,7 @@ All built-in syntax is for wired-in things.
\begin{code}
nameUnique :: Name -> Unique
nameOccName :: Name -> OccName
nameModule :: Name -> Module
nameModule :: DynFlags -> Name -> Module
nameSrcLoc :: Name -> SrcLoc
nameSrcSpan :: Name -> SrcSpan
......@@ -181,7 +182,7 @@ nameSrcSpan name = n_loc name
%************************************************************************
\begin{code}
nameIsLocalOrFrom :: Module -> Name -> Bool
nameIsLocalOrFrom :: DynFlags -> Module -> Name -> Bool
isInternalName :: Name -> Bool
isExternalName :: Name -> Bool
isSystemName :: Name -> Bool
......@@ -204,14 +205,14 @@ isExternalName _ = False
isInternalName name = not (isExternalName name)
nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name)
nameModule dflags name = nameModule_maybe name `orElse` pprPanic dflags "nameModule" (ppr name)
nameModule_maybe :: Name -> Maybe Module
nameModule_maybe (Name { n_sort = External mod}) = Just mod
nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod
nameModule_maybe _ = Nothing
nameIsLocalOrFrom from name
| isExternalName name = from == nameModule name
nameIsLocalOrFrom dflags from name
| isExternalName name = from == nameModule dflags name
| otherwise = True
isTyVarName :: Name -> Bool
......@@ -220,8 +221,8 @@ isTyVarName name = isTvOcc (nameOccName name)
isTyConName :: Name -> Bool
isTyConName name = isTcOcc (nameOccName name)
isDataConName :: Name -> Bool
isDataConName name = isDataOcc (nameOccName name)
isDataConName :: DynFlags -> Name -> Bool
isDataConName dflags name = isDataOcc dflags (nameOccName name)
isValName :: Name -> Bool
isValName name = isValOcc (nameOccName name)
......@@ -484,7 +485,9 @@ pprNameLoc name
| isGoodSrcSpan loc = pprDefnLoc loc
| isInternalName name || isSystemName name
= ptext (sLit "<no location info>")
| otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name)
| otherwise = sdocWithDynFlags $ \dflags ->
(ptext (sLit "Defined in ") <>
ppr (nameModule dflags name))
where loc = nameSrcSpan name
\end{code}
......
......@@ -101,6 +101,7 @@ import UniqFM
import UniqSet
import FastString
import Outputable
import {-# SOURCE #-} DynFlags (DynFlags)
import Binary
import StaticFlags( opt_SuppressUniques )
import Data.Char
......@@ -427,7 +428,8 @@ occNameString (OccName _ s) = unpackFS s
setOccNameSpace :: NameSpace -> OccName -> OccName
setOccNameSpace sp (OccName _ occ) = OccName sp occ
isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool
isVarOcc, isTvOcc, isTcOcc :: OccName -> Bool
isDataOcc :: DynFlags -> OccName -> Bool
isVarOcc (OccName VarName _) = True
isVarOcc _ = False
......@@ -445,20 +447,20 @@ isValOcc (OccName VarName _) = True
isValOcc (OccName DataName _) = True
isValOcc _ = False
isDataOcc (OccName DataName _) = True
isDataOcc (OccName VarName s)
| isLexCon s = pprPanic "isDataOcc: check me" (ppr s)
isDataOcc _ (OccName DataName _) = True
isDataOcc dflags (OccName VarName s)
| isLexCon s = pprPanic dflags "isDataOcc: check me" (ppr s)
-- Jan06: I don't think this should happen
isDataOcc _ = False
isDataOcc _ _ = False
-- | Test if the 'OccName' is a data constructor that starts with
-- a symbol (e.g. @:@, or @[]@)
isDataSymOcc :: OccName -> Bool
isDataSymOcc (OccName DataName s) = isLexConSym s
isDataSymOcc (OccName VarName s)
| isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s)
isDataSymOcc :: DynFlags -> OccName -> Bool
isDataSymOcc _ (OccName DataName s) = isLexConSym s
isDataSymOcc dflags (OccName VarName s)
| isLexConSym s = pprPanic dflags "isDataSymOcc: check me" (ppr s)
-- Jan06: I don't think this should happen
isDataSymOcc _ = False
isDataSymOcc _ _ = False
-- Pretty inefficient!
-- | Test if the 'OccName' is that for any operator (whether
......
......@@ -67,6 +67,7 @@ import SrcLoc
import FastString
import Outputable
import Util
import {-# SOURCE #-} DynFlags (DynFlags)
import Data.Data
\end{code}
......@@ -129,7 +130,7 @@ rdrNameOcc (Exact name) = nameOccName name
rdrNameSpace :: RdrName -> NameSpace
rdrNameSpace = occNameSpace . rdrNameOcc
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
setRdrNameSpace :: DynFlags -> RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
-- When parsing:
--
......@@ -143,12 +144,12 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- > data [] a = [] | a : [a]
--
-- For the exact-name case we return an original name.
setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n )
Orig (nameModule n)
(setOccNameSpace ns (nameOccName n))
setRdrNameSpace _ (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
setRdrNameSpace _ (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
setRdrNameSpace _ (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
setRdrNameSpace dflags (Exact n) ns = ASSERT( isExternalName n )
Orig (nameModule dflags n)
(setOccNameSpace ns (nameOccName n))
\end{code}
\begin{code}
......@@ -185,9 +186,9 @@ nameRdrName name = Exact name
-- unique is still there for debug printing, particularly
-- of Types (which are converted to IfaceTypes before printing)
nukeExact :: Name -> RdrName
nukeExact n
| isExternalName n = Orig (nameModule n) (nameOccName n)
nukeExact :: DynFlags -> Name -> RdrName
nukeExact dflags n
| isExternalName n = Orig (nameModule dflags n) (nameOccName n)
| otherwise = Unqual (nameOccName n)
\end{code}
......@@ -504,17 +505,17 @@ mkGlobalRdrEnv gres
(nameOccName (gre_name gre))
gre
findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]])
findLocalDupsRdrEnv :: DynFlags -> GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]])
-- ^ For each 'OccName', see if there are multiple local definitions
-- for it. If so, remove all but one (to suppress subsequent error messages)
-- and return a list of the duplicate bindings
findLocalDupsRdrEnv rdr_env occs
findLocalDupsRdrEnv dflags rdr_env occs
= go rdr_env [] occs
where
go rdr_env dups [] = (rdr_env, dups)
go rdr_env dups (occ:occs)
= case filter isLocalGRE gres of
[] -> WARN( True, ppr occ <+> ppr rdr_env )
[] -> WARN( dflags, True, ppr occ <+> ppr rdr_env )
go rdr_env dups occs -- Weird! No binding for occ
[_] -> go rdr_env dups occs -- The common case
dup_gres -> go (extendOccEnv rdr_env occ (head dup_gres : nonlocal_gres))
......
......@@ -74,6 +74,7 @@ module SrcLoc (
import Util
import Outputable
import FastString
import {-# SOURCE #-} DynFlags (DynFlags)
import Data.Bits
import Data.Data
......@@ -127,14 +128,14 @@ srcLocFile (SrcLoc fname _ _) = fname
srcLocFile _other = (fsLit "<unknown file")
-- | Raises an error when used on a "bad" 'SrcLoc'
srcLocLine :: SrcLoc -> Int
srcLocLine (SrcLoc _ l _) = l
srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s)
srcLocLine :: DynFlags -> SrcLoc -> Int
srcLocLine _ (SrcLoc _ l _) = l
srcLocLine dflags (UnhelpfulLoc s) = pprPanic dflags "srcLocLine" (ftext s)
-- | Raises an error when used on a "bad" 'SrcLoc'
srcLocCol :: SrcLoc -> Int
srcLocCol (SrcLoc _ _ c) = c
srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s)
srcLocCol :: DynFlags -> SrcLoc -> Int
srcLocCol _ (SrcLoc _ _ c) = c
srcLocCol dflags (UnhelpfulLoc s) = pprPanic dflags "srcLocCol" (ftext s)
-- | Move the 'SrcLoc' down by one line if the character is a newline,
-- to the next 8-char tabstop if it is a tab, and across by one
......@@ -256,19 +257,19 @@ srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
-- | Create a 'SrcSpan' between two points in a file
mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
mkSrcSpan loc1 loc2
mkSrcSpan :: DynFlags -> SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan _ (UnhelpfulLoc str) _ = UnhelpfulSpan str
mkSrcSpan _ _ (UnhelpfulLoc str) = UnhelpfulSpan str
mkSrcSpan dflags loc1 loc2
| line1 == line2 = if col1 == col2
then SrcSpanPoint file line1 col1
else SrcSpanOneLine file line1 col1 col2
| otherwise = SrcSpanMultiLine file line1 col1 line2 col2
where
line1 = srcLocLine loc1
line2 = srcLocLine loc2
col1 = srcLocCol loc1
col2 = srcLocCol loc2
line1 = srcLocLine dflags loc1
line2 = srcLocLine dflags loc2
col1 = srcLocCol dflags loc1
col2 = srcLocCol dflags loc2
file = srcLocFile loc1
-- | Combines two 'SrcSpan' into one that spans at least all the characters
......
......@@ -76,6 +76,7 @@ import Util
import FastTypes
import FastString
import Outputable
import DynFlags
import Data.Data
\end{code}
......@@ -272,9 +273,9 @@ mkTcTyVar name kind details
tc_tv_details = details
}
tcTyVarDetails :: TyVar -> TcTyVarDetails
tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details
tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
tcTyVarDetails :: DynFlags -> TyVar -> TcTyVarDetails
tcTyVarDetails _ (TcTyVar { tc_tv_details = details }) = details
tcTyVarDetails dflags var = pprPanic dflags "tcTyVarDetails" (ppr var)
setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
......
......@@ -19,6 +19,7 @@ where
import Constants
import FastString
import Outputable
import DynFlags
import Data.Word
import Data.Int
......@@ -197,14 +198,14 @@ widthInBytes W64 = 8
widthInBytes W128 = 16
widthInBytes W80 = 10
widthFromBytes :: Int -> Width
widthFromBytes 1 = W8
widthFromBytes 2 = W16
widthFromBytes 4 = W32
widthFromBytes 8 = W64
widthFromBytes 16 = W128
widthFromBytes 10 = W80
widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n)
widthFromBytes :: DynFlags -> Int -> Width
widthFromBytes _ 1 = W8
widthFromBytes _ 2 = W16
widthFromBytes _ 4 = W32
widthFromBytes _ 8 = W64
widthFromBytes _ 16 = W128
widthFromBytes _ 10 = W80
widthFromBytes dflags n = pprPanic dflags "no width for given number of bytes" (ppr n)
-- log_2 of the width in bytes, useful for generating shifts.
widthInLog :: Width -> Int
......
......@@ -775,10 +775,10 @@ pprReg r = case r of
CmmLocal local -> pprLocalReg local
CmmGlobal global -> pprGlobalReg global
pprAsPtrReg :: CmmReg -> SDoc
pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
= WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
pprAsPtrReg other_reg = pprReg other_reg
pprAsPtrReg :: DynFlags -> CmmReg -> SDoc
pprAsPtrReg dflags (CmmGlobal (VanillaReg n gcp))
= WARN( dflags, gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
pprAsPtrReg _ other_reg = pprReg other_reg
pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg gr = case gr of
......
......@@ -211,7 +211,7 @@ mkStackLayout = do
[(offset - frame_sp - retAddrSizeW, b)
| (offset, b) <- binds]
WARN( not (all (\bind -> fst bind >= 0) rel_binds),
WARN( dflags, not (all (\bind -> fst bind >= 0) rel_binds),
ppr binds $$ ppr rel_binds $$
ppr frame_size $$ ppr real_sp $$ ppr frame_sp )
return $ stack_layout rel_binds frame_size
......
......@@ -636,7 +636,7 @@ getCallMethod _ _ _ (LFUnknown True) _
getCallMethod _ name _ (LFUnknown False) n_args
| n_args > 0
= WARN( True, ppr name <+> ppr n_args )
= WARN( dflags, True, ppr name <+> ppr n_args )
SlowCall -- Note [Unsafe coerce complications]
| otherwise
......
......@@ -776,7 +776,7 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
| otherwise -- We have an expression of arity > 0,
-- but its type isn't a function.
= WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
= WARN( dflags, True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
(getTvInScope subst, reverse eis)
-- This *can* legitmately happen:
-- e.g. coerce Int (\x. x) Essentially the programmer is
......
......@@ -363,7 +363,7 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
; (floats3, rhs')
<- if manifestArity rhs1 <= arity
then return (floats2, cpeEtaExpand arity rhs2)
else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
else WARN(dflags, True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
; let float = mkFloat False False v rhs2
......
......@@ -251,7 +251,7 @@ lookupIdSubst doc (Subst in_scope ids _ _) v
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
-- Vital! See Note [Extending the Subst]
| otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope $$ doc)
| otherwise = WARN( dflags, True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope $$ doc)
Var v
-- | Find the substitution for a 'TyVar' in the 'Subst'
......@@ -645,13 +645,13 @@ substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr)
| Just wkr_expr <- lookupVarEnv ids wkr
= case wkr_expr of
Var w1 -> InlineWrapper w1
_other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr
_other -> -- WARN( dflags, True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr
-- <+> ifPprDebug (equals <+> ppr wkr_expr) )
-- Note [Worker inlining]
InlineStable -- It's not a wrapper any more, but still inline it!
| Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1
| otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
| otherwise = -- WARN( dflags, True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
-- This can legitimately happen. The worker has been inlined and
-- dropped as dead code, because we don't treat the UnfoldingSource
-- as an "occurrence".
......
......@@ -821,7 +821,7 @@ cmpAltCon (DataAlt _) DEFAULT = GT
cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
cmpAltCon (LitAlt _) DEFAULT = GT
cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
cmpAltCon con1 con2 = WARN( dflags, True, text "Comparing incomparable AltCons" <+>
ppr con1 <+> ppr con2 )
LT
\end{code}
......
......@@ -210,7 +210,7 @@ mkCoerce co expr
-- if to_ty `eqType` from_ty
-- then expr
-- else
WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
WARN(dflags, not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
(Cast expr co)
\end{code}
......@@ -1223,10 +1223,10 @@ hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_ha
hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e
hash_expr env (Case e _ _ _) = hash_expr env e
hash_expr env (Lam b e) = hash_expr (extend_env env b) e
hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1
hash_expr _ (Type _) = WARN(dflags, True, text "hash_expr: type") 1
-- Shouldn't happen. Better to use WARN than trace, because trace
-- prevents the CPR optimisation kicking in for hash_expr.
hash_expr _ (Coercion _) = WARN(True, text "hash_expr: coercion") 1
hash_expr _ (Coercion _) = WARN(dflags, True, text "hash_expr: coercion") 1
fast_hash_expr :: HashEnv -> CoreExpr -> Word32
fast_hash_expr env (Var v) = hashVar env v
......
......@@ -635,7 +635,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
from_exposed_pkg m = case lookupPackage pkg_map (modulePackageId m) of
Just pkg_config -> exposed pkg_config
Nothing -> WARN( True, ppr m ) -- Should not happen
Nothing -> WARN( dflags, True, ppr m ) -- Should not happen
False
pp_exp mod = ppr (moduleName mod)
......
......@@ -678,7 +678,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
-- unfolding in the *definition*; so look up in binder_set
refined_id = case lookupVarSet binder_set idocc of
Just id -> id
Nothing -> WARN( True, ppr idocc ) idocc
Nothing -> WARN( dflags, True, ppr idocc ) idocc
unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
referrer' | isExportedId refined_id = refined_id
......@@ -1058,7 +1058,7 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
--------- Strictness ------------
final_sig | Just sig <- strictnessInfo idinfo
= WARN( _bottom_hidden sig, ppr name ) Just sig
= WARN( dflags, _bottom_hidden sig, ppr name ) Just sig
| Just (_, sig) <- mb_bot_str = Just sig
| otherwise = Nothing
......
......@@ -508,7 +508,7 @@ tagToEnumRule _ [Type ty, Lit (MachInt i)]
(dc:rest) -> ASSERT( null rest )
Just (mkTyApps (Var (dataConWorkId dc)) tc_args)
| otherwise -- See Note [tagToEnum#]
= WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
= WARN( dflags, True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
where
correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
......
......@@ -122,7 +122,7 @@ rnImportDecl this_mod implicit_prelude
-- Compiler sanity check: if the import didn't say
-- {-# SOURCE #-} we should not get a hi-boot file
WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) (do
WARN( dflags, not want_boot && mi_boot iface, ppr imp_mod_name ) (do
-- Issue a user warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
......
......@@ -513,7 +513,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
= do { env <- getGlobalRdrEnv
; return (case lookupGRE_Name env con of
[gre] -> gre_par gre
gres -> WARN( True, ppr con <+> ppr gres ) NoParent) }
gres -> WARN( dflags, True, ppr con <+> ppr gres ) NoParent) }
| otherwise = return NoParent
dup_flds :: [[RdrName]]
......
......@@ -329,7 +329,7 @@ extendCSEnv (CS cs in_scope sub) expr expr'
where
hash = hashExpr expr
combine old new
= WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
= WARN( dflags, result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
where
result = new ++ old
short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
......@@ -348,7 +348,7 @@ addBinder :: CSEnv -> Id -> (CSEnv, Id)
addBinder (CS cs in_scope sub) v
| not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
| isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
| otherwise = WARN( True, ppr v )
| otherwise = WARN( dflags, True, ppr v )
(CS emptyUFM in_scope sub, v)
-- This last case is the unusual situation where we have shadowing of
-- a type variable; we have to discard the CSE mapping
......
......@@ -902,9 +902,10 @@ abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||
not (isEmptySpecInfo (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
zap v | isId v = WARN( dflags,
isStableUnfolding (idUnfolding v) ||
not (isEmptySpecInfo (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
| otherwise = v
......
......@@ -339,7 +339,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- iteration_no is the number of the iteration we are
-- about to begin, with '1' for the first
| iteration_no > max_iterations -- Stop if we've run out of iterations
= WARN( debugIsOn && (max_iterations > 2)
= WARN( dflags, debugIsOn && (max_iterations > 2)
, ptext (sLit "Simplifier baling out after") <+> int max_iterations
<+> ptext (sLit "iterations")
<+> (brackets $ hsep $ punctuate comma $
......@@ -618,7 +618,7 @@ shortMeOut ind_env exported_id local_id
then
if hasShortableIdInfo exported_id
then True -- See Note [Messing up the exported Id's IdInfo]
else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
else WARN( dflags, True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
False
else
False
......
......@@ -522,7 +522,7 @@ refine :: InScopeSet -> Var -> Var
refine in_scope v
| isLocalId v = case lookupInScope in_scope v of
Just v' -> v'
Nothing -> WARN( True, ppr v ) v -- This is an error!
Nothing -> WARN( dflags, True, ppr v ) v -- This is an error!
| otherwise = v
lookupRecBndr :: SimplEnv -> InId -> OutId
......
......@@ -393,7 +393,7 @@ mkArgInfo fun rules n_val_args call_cont
else
map isStrictDmd demands ++ vanilla_stricts
| otherwise
-> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
-> WARN( dflags, True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
<+> ppr n_val_args <+> ppr demands )
vanilla_stricts -- Not enough args, or no strictness
......@@ -1110,7 +1110,7 @@ tryEtaExpand env bndr rhs
= do { dflags <- getDOptsSmpl
; (new_arity, new_rhs) <- try_expand dflags
; WARN( new_arity < old_arity || new_arity < _dmd_arity,
; WARN( dflags, new_arity < old_arity || new_arity < _dmd_arity,
(ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_arity
<+> ppr new_arity <+> ppr _dmd_arity) $$ ppr new_rhs) )
-- Note [Arity decrease]
......
......@@ -2012,7 +2012,7 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp
-- it "sees" that the entire branch of an outer case is
-- inaccessible. So we simply put an error case here instead.
missingAlt env case_bndr alts cont
= WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
= WARN( dflags, True, ptext (sLit "missingAlt") <+> ppr case_bndr )
return (env, mkImpossibleExpr res_ty)
where
res_ty = contResultType env (substTy env (coreAltsType alts)) cont
......@@ -2176,7 +2176,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
++ varsToCoreExprs bndrs')
LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
LitAlt {} -> WARN( dflags, True, ptext (sLit "mkDupableAlt")
<+> ppr case_bndr <+> ppr con )
case_bndr
-- The case binder is alive but trivial, so why has
......
......@@ -1749,7 +1749,7 @@ samePat (vs1, as1) (vs2, as2)
same e1 (Note _ e2) = same e1 e2
same e1 (Cast e2 _) = same e1 e2
same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
same e1 e2 = WARN( dflags, bad e1 || bad e2, ppr e1 $$ ppr e2)
False -- Let, lambda, case should not occur
bad (Case {}) = True
bad (Let {}) = True
......
......@@ -649,7 +649,7 @@ specImport done rb fn calls_for_fn
; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) }
| otherwise
= WARN( True, ptext (sLit "specImport discard") <+> ppr fn <+> ppr calls_for_fn )
= WARN( dflags, True, ptext (sLit "specImport discard") <+> ppr fn <+> ppr calls_for_fn )
return ([], [])
\end{code}
......@@ -1024,7 +1024,7 @@ specCalls subst rules_for_me calls_for_me fn rhs
; return (spec_rules, spec_defns, plusUDList spec_uds) }
| otherwise -- No calls or RHS doesn't fit our preconceptions
= WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for")
= WARN( dflags, notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for")
<+> ppr fn $$ _trace_doc )
-- Note [Specialisation shape]
-- pprTrace "specDefn: none" (ppr fn $$ ppr calls_for_me) $
......
......@@ -218,7 +218,7 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
-- floated out a binding, in which case it will be approximate.
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
consistentCafInfo id bind
= WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
= WARN( dflags, not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
safe
where
safe = id_marked_caffy || not binding_is_caffy
......@@ -608,7 +608,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument
-- we complain.
-- We also want to check if a pointer is cast to a non-ptr etc
WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
WARN( dflags, bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
return (stg_arg : stg_args, fvs)
......
......@@ -547,7 +547,7 @@ dmdAnalRhs top_lvl rec_flag env (id, rhs)
arity = idArity id -- The idArity should be up to date
-- The simplifier was run just beforehand