Permalink
Browse files

More DynFlags + SDoc

  • Loading branch information...
1 parent ea3a9ed commit a5f5a70c41b4bce2715bf5d478171fbaf060cddf @igfoo igfoo committed May 25, 2011
Showing with 142 additions and 122 deletions.
  1. +2 −2 compiler/HsVersions.h
  2. +11 −8 compiler/basicTypes/Name.lhs
  3. +12 −10 compiler/basicTypes/OccName.lhs
  4. +14 −13 compiler/basicTypes/RdrName.lhs
  5. +15 −14 compiler/basicTypes/SrcLoc.lhs
  6. +4 −3 compiler/basicTypes/Var.lhs
  7. +9 −8 compiler/cmm/CmmType.hs
  8. +4 −4 compiler/cmm/PprC.hs
  9. +1 −1 compiler/codeGen/CgInfoTbls.hs
  10. +1 −1 compiler/codeGen/ClosureInfo.lhs
  11. +1 −1 compiler/coreSyn/CoreArity.lhs
  12. +1 −1 compiler/coreSyn/CorePrep.lhs
  13. +3 −3 compiler/coreSyn/CoreSubst.lhs
  14. +1 −1 compiler/coreSyn/CoreSyn.lhs
  15. +3 −3 compiler/coreSyn/CoreUtils.lhs
  16. +1 −1 compiler/main/Finder.lhs
  17. +2 −2 compiler/main/TidyPgm.lhs
  18. +1 −1 compiler/prelude/PrelRules.lhs
  19. +1 −1 compiler/rename/RnNames.lhs
  20. +1 −1 compiler/rename/RnPat.lhs
  21. +2 −2 compiler/simplCore/CSE.lhs
  22. +4 −3 compiler/simplCore/SetLevels.lhs
  23. +2 −2 compiler/simplCore/SimplCore.lhs
  24. +1 −1 compiler/simplCore/SimplEnv.lhs
  25. +2 −2 compiler/simplCore/SimplUtils.lhs
  26. +2 −2 compiler/simplCore/Simplify.lhs
  27. +1 −1 compiler/specialise/SpecConstr.lhs
  28. +2 −2 compiler/specialise/Specialise.lhs
  29. +2 −2 compiler/stgSyn/CoreToStg.lhs
  30. +1 −1 compiler/stranal/DmdAnal.lhs
  31. +1 −1 compiler/stranal/WorkWrap.lhs
  32. +3 −3 compiler/stranal/WwLib.lhs
  33. +1 −1 compiler/typecheck/TcErrors.lhs
  34. +1 −1 compiler/typecheck/TcHsSyn.lhs
  35. +5 −5 compiler/typecheck/TcMType.lhs
  36. +2 −2 compiler/typecheck/TcRnTypes.lhs
  37. +1 −1 compiler/types/Coercion.lhs
  38. +4 −3 compiler/types/OptCoercion.lhs
  39. +5 −3 compiler/utils/GraphOps.hs
  40. +4 −3 compiler/utils/ListSetOps.lhs
  41. +8 −2 compiler/utils/Outputable.lhs
@@ -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}
Oops, something went wrong.

0 comments on commit a5f5a70

Please sign in to comment.