summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2021-06-02 15:04:51 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-06-22 02:33:38 -0400
commit14956cb89d8548e531c99821ad504b4f35b5509a (patch)
tree175622c7f73df41c1e836be30a27c83914374ed6 /compiler
parent65bad0de6fd1431f0670002d68974adce3e9fc4a (diff)
downloadhaskell-14956cb89d8548e531c99821ad504b4f35b5509a.tar.gz
Put tracing functions into their own module
Now that Outputable is independent of DynFlags, we can put tracing functions using SDocs into their own module that doesn't transitively depend on any GHC.Driver.* module. A few modules needed to be moved to avoid loops in DEBUG mode.
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Builtin/Utils.hs2
-rw-r--r--compiler/GHC/Cmm/Ppr/Expr.hs3
-rw-r--r--compiler/GHC/CmmToAsm/BlockLayout.hs18
-rw-r--r--compiler/GHC/CmmToC.hs19
-rw-r--r--compiler/GHC/Core.hs3
-rw-r--r--compiler/GHC/Core/Coercion/Opt.hs11
-rw-r--r--compiler/GHC/Core/Lint.hs62
-rw-r--r--compiler/GHC/Core/Opt/Arity.hs28
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs40
-rw-r--r--compiler/GHC/Core/Opt/CprAnal.hs23
-rw-r--r--compiler/GHC/Core/Opt/OccurAnal.hs30
-rw-r--r--compiler/GHC/Core/Opt/Pipeline.hs2
-rw-r--r--compiler/GHC/Core/Opt/SetLevels.hs25
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs49
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Utils.hs27
-rw-r--r--compiler/GHC/Core/Opt/SpecConstr.hs38
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs2
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap.hs17
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap/Utils.hs34
-rw-r--r--compiler/GHC/Core/Rules.hs27
-rw-r--r--compiler/GHC/Core/Subst.hs8
-rw-r--r--compiler/GHC/Core/Unfold.hs3
-rw-r--r--compiler/GHC/Core/Utils.hs42
-rw-r--r--compiler/GHC/CoreToIface.hs39
-rw-r--r--compiler/GHC/CoreToStg.hs32
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs6
-rw-r--r--compiler/GHC/Data/Bool.hs18
-rw-r--r--compiler/GHC/Data/List/SetOps.hs37
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs4
-rw-r--r--compiler/GHC/Driver/Env.hs6
-rw-r--r--compiler/GHC/Driver/Ppr.hs90
-rw-r--r--compiler/GHC/Driver/Ppr.hs-boot9
-rw-r--r--compiler/GHC/Driver/Session.hs1
-rw-r--r--compiler/GHC/HsToCore/Binds.hs40
-rw-r--r--compiler/GHC/Iface/Load.hs2
-rw-r--r--compiler/GHC/Iface/Make.hs2
-rw-r--r--compiler/GHC/Iface/Recomp.hs1
-rw-r--r--compiler/GHC/Iface/Tidy.hs1
-rw-r--r--compiler/GHC/Parser/Lexer.x1
-rw-r--r--compiler/GHC/Rename/Names.hs1
-rw-r--r--compiler/GHC/Runtime/Eval.hs1
-rw-r--r--compiler/GHC/Stg/Pipeline.hs3
-rw-r--r--compiler/GHC/Stg/Subst.hs3
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs26
-rw-r--r--compiler/GHC/StgToCmm/Ticky.hs9
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs23
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs2
-rw-r--r--compiler/GHC/Tc/Utils/TcMType.hs40
-rw-r--r--compiler/GHC/Types/Id.hs3
-rw-r--r--compiler/GHC/Types/TyThing/Ppr.hs3
-rw-r--r--compiler/GHC/Utils/Error.hs1
-rw-r--r--compiler/GHC/Utils/Logger.hs4
-rw-r--r--compiler/GHC/Utils/Misc.hs50
-rw-r--r--compiler/GHC/Utils/Outputable.hs8
-rw-r--r--compiler/GHC/Utils/Panic.hs2
-rw-r--r--compiler/GHC/Utils/Ppr/Colour.hs7
-rw-r--r--compiler/GHC/Utils/Trace.hs77
-rw-r--r--compiler/ghc.cabal.in2
58 files changed, 575 insertions, 492 deletions
diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs
index ab46812040..16d5096605 100644
--- a/compiler/GHC/Builtin/Utils.hs
+++ b/compiler/GHC/Builtin/Utils.hs
@@ -78,6 +78,8 @@ import GHC.Utils.Constants (debugIsOn)
import GHC.Hs.Doc
import GHC.Unit.Module.ModIface (IfaceExport)
+import GHC.Data.List.SetOps
+
import Control.Applicative ((<|>))
import Data.List ( intercalate , find )
import Data.Array
diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs
index c656c98522..7828daf803 100644
--- a/compiler/GHC/Cmm/Ppr/Expr.hs
+++ b/compiler/GHC/Cmm/Ppr/Expr.hs
@@ -44,12 +44,11 @@ where
import GHC.Prelude
-import GHC.Driver.Ppr
-
import GHC.Platform
import GHC.Cmm.Expr
import GHC.Utils.Outputable
+import GHC.Utils.Trace
import Data.Maybe
import Numeric ( fromRat )
diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs
index 35dce5246d..6e2e7e2189 100644
--- a/compiler/GHC/CmmToAsm/BlockLayout.hs
+++ b/compiler/GHC/CmmToAsm/BlockLayout.hs
@@ -15,7 +15,7 @@ where
import GHC.Prelude
-import GHC.Driver.Ppr (pprTrace)
+import GHC.Platform
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Monad
@@ -23,30 +23,26 @@ import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Config
-import GHC.Cmm.BlockId
import GHC.Cmm
+import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
-import GHC.Platform
import GHC.Types.Unique.FM
import GHC.Data.Graph.Directed
+import GHC.Data.Maybe
+import GHC.Data.List.SetOps (removeDups)
+import GHC.Data.OrdList
+
+import GHC.Utils.Trace
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
-import GHC.Data.Maybe
-
--- DEBUGGING ONLY
---import GHC.Cmm.DebugBlock
---import Debug.Trace
-import GHC.Data.List.SetOps (removeDups)
-import GHC.Data.OrdList
import Data.List (sortOn, sortBy)
import Data.Foldable (toList)
-
import qualified Data.Set as Set
import Data.STRef
import Control.Monad.ST.Strict
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index ae6f4b91b6..4e828e29f4 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -25,12 +25,14 @@ module GHC.CmmToC
)
where
--- Cmm stuff
import GHC.Prelude
+import GHC.Platform
+
+import GHC.CmmToAsm.CPrim
+
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
-import GHC.Types.ForeignCall
import GHC.Cmm hiding (pprBBlock)
import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Cmm.Dataflow.Block
@@ -39,19 +41,16 @@ import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Utils
import GHC.Cmm.Switch
--- Utils
-import GHC.CmmToAsm.CPrim
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
+import GHC.Types.ForeignCall
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM
import GHC.Types.Unique
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
import GHC.Utils.Misc
+import GHC.Utils.Trace
--- The rest
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Control.Monad.ST
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index a17604300f..ecd9a6ee00 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -114,8 +114,7 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
-
-import GHC.Driver.Ppr
+import GHC.Utils.Trace
import Data.Data hiding (TyCon)
import Data.Int
diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs
index 85b6e93ec1..4be4441682 100644
--- a/compiler/GHC/Core/Coercion/Opt.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -11,27 +11,30 @@ where
import GHC.Prelude
-import GHC.Driver.Ppr
+import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType )
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Subst
import GHC.Core.Coercion
import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )
-import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType )
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
+import GHC.Core.Unify
+
import GHC.Types.Var.Set
import GHC.Types.Var.Env
+
import GHC.Data.Pair
import GHC.Data.List.SetOps ( getNth )
-import GHC.Core.Unify
-import Control.Monad ( zipWithM )
import GHC.Utils.Outputable
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+import GHC.Utils.Trace
+
+import Control.Monad ( zipWithM )
{-
%************************************************************************
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 45115bfb45..43935d1efe 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -29,33 +29,21 @@ import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Env
+import GHC.Tc.Utils.TcType ( isFloatingTy, isTyFamFree )
+import GHC.Unit.Module.ModGuts
+import GHC.Runtime.Context
+
import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils
import GHC.Core.Stats ( coreBindsStats )
import GHC.Core.Opt.Monad
-import GHC.Data.Bag
-import GHC.Types.Literal
import GHC.Core.DataCon
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Types ( multiplicityTy )
-import GHC.Tc.Utils.TcType ( isFloatingTy, isTyFamFree )
-import GHC.Types.Var as Var
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Unique.Set( nonDetEltsUniqSet )
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Id
-import GHC.Types.Id.Info
import GHC.Core.Ppr
import GHC.Core.Coercion
-import GHC.Types.SrcLoc
-import GHC.Types.Tickish
import GHC.Core.Type as Type
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
-import GHC.Types.RepType
import GHC.Core.TyCo.Rep -- checks validity of types/coercions
import GHC.Core.TyCo.Subst
import GHC.Core.TyCo.FVs
@@ -63,26 +51,44 @@ import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars )
import GHC.Core.TyCon as TyCon
import GHC.Core.Coercion.Axiom
import GHC.Core.Unify
+import GHC.Core.InstEnv ( instanceDFunId )
+import GHC.Core.Coercion.Opt ( checkAxInstCo )
+import GHC.Core.Opt.Arity ( typeArity )
+
+import GHC.Types.Literal
+import GHC.Types.Var as Var
+import GHC.Types.Var.Env
+import GHC.Types.Var.Set
+import GHC.Types.Unique.Set( nonDetEltsUniqSet )
+import GHC.Types.Name
+import GHC.Types.Name.Env
+import GHC.Types.Id
+import GHC.Types.Id.Info
+import GHC.Types.SrcLoc
+import GHC.Types.Tickish
+import GHC.Types.RepType
import GHC.Types.Basic
-import GHC.Utils.Error
-import qualified GHC.Utils.Error as Err
-import GHC.Utils.Logger
-import GHC.Data.List.SetOps
+import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv )
+import GHC.Types.TypeEnv
+
import GHC.Builtin.Names
+import GHC.Builtin.Types.Prim
+import GHC.Builtin.Types ( multiplicityTy )
+
+import GHC.Data.Bag
+import GHC.Data.List.SetOps
+
+import GHC.Utils.Monad
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
-import GHC.Core.InstEnv ( instanceDFunId )
-import GHC.Core.Coercion.Opt ( checkAxInstCo )
-import GHC.Core.Opt.Arity ( typeArity )
-import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv )
-import GHC.Types.TypeEnv
-import GHC.Unit.Module.ModGuts
-import GHC.Runtime.Context
+import GHC.Utils.Trace
+import GHC.Utils.Error
+import qualified GHC.Utils.Error as Err
+import GHC.Utils.Logger
import Control.Monad
-import GHC.Utils.Monad
import Data.Foldable ( toList )
import Data.List.NonEmpty ( NonEmpty(..), groupWith )
import Data.List ( partition )
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 021af2d503..8bdf063eb9 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -31,15 +31,16 @@ where
import GHC.Prelude
-import GHC.Driver.Ppr
+import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )
import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils
-import GHC.Types.Demand
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Types.Id
+import GHC.Core.DataCon
+import GHC.Core.TyCon ( tyConArity )
+import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc )
+import GHC.Core.Predicate ( isDictTy )
+import GHC.Core.Multiplicity
-- We have two sorts of substitution:
-- GHC.Core.Subst.Subst, and GHC.Core.TyCo.TCvSubst
@@ -48,22 +49,23 @@ import GHC.Core.Subst as Core
import GHC.Core.Type as Type
import GHC.Core.Coercion as Type
-import GHC.Core.DataCon
-import GHC.Core.TyCon ( tyConArity )
-import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc )
-import GHC.Core.Predicate ( isDictTy )
-import GHC.Core.Multiplicity
+import GHC.Types.Demand
+import GHC.Types.Var
+import GHC.Types.Var.Env
+import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Tickish
+
import GHC.Builtin.Uniques
-import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )
+import GHC.Data.FastString
+import GHC.Data.Pair
+
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
-import GHC.Data.FastString
-import GHC.Data.Pair
+import GHC.Utils.Trace
import GHC.Utils.Misc
{-
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 14d4f840b6..9917db7584 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -32,45 +32,47 @@ where
import GHC.Prelude
-import GHC.Driver.Ppr
+import GHC.Platform
import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, voidPrimId )
+import GHC.Types.Id
+import GHC.Types.Literal
+import GHC.Types.Var.Set
+import GHC.Types.Var.Env
+import GHC.Types.Name.Occurrence ( occNameFS )
+import GHC.Types.Tickish
+import GHC.Types.Name ( Name, nameOccName )
+import GHC.Types.Basic
import GHC.Core
import GHC.Core.Make
-import GHC.Types.Id
-import GHC.Types.Literal
import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe )
-import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-import GHC.Core.TyCon
- ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
- , isNewTyCon, tyConDataCons
- , tyConFamilySize )
import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType
, stripTicksTop, stripTicksTopT, mkTicks )
import GHC.Core.Multiplicity
import GHC.Core.FVs
import GHC.Core.Type
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.Name.Occurrence ( occNameFS )
-import GHC.Types.Tickish
+import GHC.Core.TyCon
+ ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
+ , isNewTyCon, tyConDataCons
+ , tyConFamilySize )
+
+import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )
+import GHC.Builtin.Types
+import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
+
+import GHC.Data.FastString
import GHC.Data.Maybe ( orElse )
-import GHC.Types.Name ( Name, nameOccName )
+
import GHC.Utils.Outputable
-import GHC.Data.FastString
-import GHC.Types.Basic
-import GHC.Platform
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+import GHC.Utils.Trace
import Control.Applicative ( Alternative(..) )
-
import Control.Monad
import Data.Functor (($>))
import qualified Data.ByteString as BS
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index 91f6abef0d..f3ae2c0b43 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -11,16 +11,16 @@ module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where
import GHC.Prelude
import GHC.Driver.Session
-import GHC.Types.Demand
-import GHC.Types.Cpr
-import GHC.Core
-import GHC.Core.Seq
-import GHC.Utils.Outputable
+
import GHC.Builtin.Names ( runRWKey )
+
import GHC.Types.Var.Env
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Demand
+import GHC.Types.Cpr
+
import GHC.Core.DataCon
import GHC.Core.FamInstEnv
import GHC.Core.Multiplicity
@@ -28,18 +28,21 @@ import GHC.Core.Opt.WorkWrap.Utils
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe )
+import GHC.Core
+import GHC.Core.Seq
+
+import GHC.Data.Graph.UnVar -- for UnVarSet
+import GHC.Data.Maybe ( isJust )
+
+import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic.Plain
import GHC.Utils.Logger ( Logger, putDumpFileMaybe, DumpFormat (..) )
-import GHC.Data.Graph.UnVar -- for UnVarSet
-import GHC.Data.Maybe ( isJust )
+--import GHC.Utils.Trace
import Control.Monad ( guard )
import Data.List ( mapAccumL )
-import GHC.Driver.Ppr
-_ = pprTrace -- Tired of commenting out the import all the time
-
{- Note [Constructed Product Result]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The goal of Constructed Product Result analysis is to identify functions that
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index 93813a1735..cc67802309 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -20,38 +20,40 @@ module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where
import GHC.Prelude
-import GHC.Driver.Ppr
-
import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp,
stripTicksTopE, mkTicks )
import GHC.Core.Opt.Arity ( joinRhsArity )
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Basic
-import GHC.Types.Tickish
-import GHC.Unit.Module( Module )
import GHC.Core.Coercion
import GHC.Core.Type
import GHC.Core.TyCo.FVs( tyCoVarsOfMCo )
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.Var
-import GHC.Types.Demand ( argOneShots, argsOneShots )
+import GHC.Data.Maybe( isJust )
import GHC.Data.Graph.Directed ( SCC(..), Node(..)
, stronglyConnCompFromEdgedVerticesUniq
, stronglyConnCompFromEdgedVerticesUniqR )
-import GHC.Builtin.Names( runRWKey )
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
-import GHC.Utils.Misc
-import GHC.Data.Maybe( isJust )
+import GHC.Types.Id
+import GHC.Types.Id.Info
+import GHC.Types.Basic
+import GHC.Types.Tickish
+import GHC.Types.Var.Set
+import GHC.Types.Var.Env
+import GHC.Types.Var
+import GHC.Types.Demand ( argOneShots, argsOneShots )
+
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+import GHC.Utils.Misc
+import GHC.Utils.Trace
+
+import GHC.Builtin.Names( runRWKey )
+import GHC.Unit.Module( Module )
+
import Data.List (mapAccumL, mapAccumR)
{-
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 23908403c7..666725f320 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -11,7 +11,6 @@ module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where
import GHC.Prelude
import GHC.Driver.Session
-import GHC.Driver.Ppr
import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
import GHC.Driver.Env
import GHC.Platform.Ways ( hasWay, Way(WayProf) )
@@ -52,6 +51,7 @@ import GHC.Utils.Logger as Logger
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
+import GHC.Utils.Trace
import GHC.Unit.External
import GHC.Unit.Module.Env
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index b1298c6b50..2d69e8eb04 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -77,8 +77,6 @@ module GHC.Core.Opt.SetLevels (
import GHC.Prelude
-import GHC.Driver.Ppr
-
import GHC.Core
import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
import GHC.Core.Utils ( exprType, exprIsHNF
@@ -92,6 +90,10 @@ import GHC.Core.Opt.Arity ( exprBotStrictness_maybe )
import GHC.Core.FVs -- all of it
import GHC.Core.Subst
import GHC.Core.Make ( sortQuantVars )
+import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType
+ , mightBeUnliftedType, closeOverKindsDSet )
+import GHC.Core.Multiplicity ( pattern Many )
+import GHC.Core.DataCon ( dataConOrigResTy )
import GHC.Types.Id
import GHC.Types.Id.Info
@@ -107,23 +109,24 @@ import GHC.Types.Name ( getOccName, mkSystemVarName )
import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Unique ( hasKey )
import GHC.Types.Tickish ( tickishIsCode )
-import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType
- , mightBeUnliftedType, closeOverKindsDSet )
-import GHC.Core.Multiplicity ( pattern Many )
+import GHC.Types.Unique.Supply
+import GHC.Types.Unique.DFM
import GHC.Types.Basic ( Arity, RecFlag(..), isRec )
-import GHC.Core.DataCon ( dataConOrigResTy )
+
import GHC.Builtin.Types
import GHC.Builtin.Names ( runRWKey )
-import GHC.Types.Unique.Supply
+
+import GHC.Data.FastString
+
+import GHC.Utils.FV
+import GHC.Utils.Monad ( mapAccumLM )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
-import GHC.Data.FastString
-import GHC.Types.Unique.DFM
-import GHC.Utils.FV
+import GHC.Utils.Trace
+
import Data.Maybe
-import GHC.Utils.Monad ( mapAccumLM )
{-
************************************************************************
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index caa18050e2..cb5264f4ba 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -13,21 +13,17 @@ module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where
import GHC.Prelude
import GHC.Platform
+
import GHC.Driver.Session
-import GHC.Driver.Ppr
+
+import GHC.Core
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Utils
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
-import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326
-import GHC.Types.SourceText
-import GHC.Types.Id
-import GHC.Types.Id.Make ( seqId )
import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )
import qualified GHC.Core.Make
-import GHC.Types.Id.Info
-import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS )
import GHC.Core.Coercion hiding ( substCo, substCoVar )
import GHC.Core.Coercion.Opt ( optCoercion )
import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe )
@@ -36,14 +32,7 @@ import GHC.Core.DataCon
, dataConRepArgTys, isUnboxedTupleDataCon
, StrictnessMark (..) )
import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
-import GHC.Core
-import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
-import GHC.Builtin.Names( runRWKey )
-import GHC.Types.Demand ( DmdSig(..), Demand, dmdTypeDepth, isStrUsedDmd
- , mkClosedDmdSig, topDmd, seqDmd, isDeadEndDiv )
-import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Core.Ppr ( pprCoreExpr )
-import GHC.Types.Unique ( hasKey )
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Utils
@@ -53,21 +42,39 @@ import GHC.Core.Opt.Arity ( ArityType(..)
import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Core.FVs ( mkRuleInfo )
import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts )
+import GHC.Core.Multiplicity
+
+import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326
+import GHC.Types.SourceText
+import GHC.Types.Id
+import GHC.Types.Id.Make ( seqId )
+import GHC.Types.Id.Info
+import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS )
+import GHC.Types.Demand ( DmdSig(..), Demand, dmdTypeDepth, isStrUsedDmd
+ , mkClosedDmdSig, topDmd, seqDmd, isDeadEndDiv )
+import GHC.Types.Cpr ( mkCprSig, botCpr )
+import GHC.Types.Unique ( hasKey )
import GHC.Types.Basic
-import GHC.Utils.Monad ( mapAccumLM, liftIO )
-import GHC.Utils.Logger
import GHC.Types.Tickish
import GHC.Types.Var ( isTyCoVar )
+
+import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
+import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
+import GHC.Builtin.Names( runRWKey )
+
import GHC.Data.Maybe ( orElse )
-import Control.Monad
+import GHC.Data.FastString
+import GHC.Unit.Module ( moduleName, pprModuleName )
+
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (debugIsOn)
-import GHC.Data.FastString
-import GHC.Unit.Module ( moduleName, pprModuleName )
-import GHC.Core.Multiplicity
-import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
+import GHC.Utils.Trace
+import GHC.Utils.Monad ( mapAccumLM, liftIO )
+import GHC.Utils.Logger
+
+import Control.Monad
{-
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 09b39cbfb2..15cccfd55b 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -39,11 +39,11 @@ module GHC.Core.Opt.Simplify.Utils (
import GHC.Prelude
-import GHC.Core.Opt.Simplify.Env
-import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) )
import GHC.Driver.Session
-import GHC.Driver.Ppr
+
import GHC.Core
+import GHC.Core.Opt.Simplify.Env
+import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) )
import qualified GHC.Core.Subst
import GHC.Core.Ppr
import GHC.Core.TyCo.Ppr ( pprParendType )
@@ -52,28 +52,31 @@ import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
+import GHC.Core.Opt.Simplify.Monad
+import GHC.Core.Type hiding( substTy )
+import GHC.Core.Coercion hiding( substCo )
+import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )
+import GHC.Core.Multiplicity
+import GHC.Core.Opt.ConstantFold
+
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Tickish
-import GHC.Types.Var
import GHC.Types.Demand
import GHC.Types.Var.Set
import GHC.Types.Basic
-import GHC.Core.Opt.Simplify.Monad
-import GHC.Core.Type hiding( substTy )
-import GHC.Core.Coercion hiding( substCo )
-import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )
-import GHC.Core.Multiplicity
-import GHC.Utils.Misc
+
import GHC.Data.OrdList ( isNilOL )
+import GHC.Data.FastString ( fsLit )
+
+import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
-import GHC.Core.Opt.ConstantFold
-import GHC.Data.FastString ( fsLit )
+import GHC.Utils.Trace
import Control.Monad ( when )
import Data.List ( sortBy )
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 3c0e6b46cf..718c840c96 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -21,14 +21,15 @@ module GHC.Core.Opt.SpecConstr(
import GHC.Prelude
+import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )
+ , gopt, hasPprDebug )
+
import GHC.Core
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.Unfold
import GHC.Core.FVs ( exprsFreeVarsList )
import GHC.Core.Opt.Monad
-import GHC.Types.Literal ( litIsLifted )
-import GHC.Unit.Module.ModGuts
import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs )
import GHC.Core.DataCon
import GHC.Core.Coercion hiding( substCo )
@@ -36,35 +37,42 @@ import GHC.Core.Rules
import GHC.Core.Type hiding ( substTy )
import GHC.Core.TyCon (TyCon, tyConUnique, tyConName )
import GHC.Core.Multiplicity
-import GHC.Types.Id
import GHC.Core.Ppr ( pprParendExpr )
import GHC.Core.Make ( mkImpossibleExpr )
+
+import GHC.Unit.Module
+import GHC.Unit.Module.ModGuts
+
+import GHC.Types.Literal ( litIsLifted )
+import GHC.Types.Id
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Tickish
import GHC.Types.Basic
-import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )
- , gopt, hasPprDebug )
-import GHC.Driver.Ppr
-import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing )
import GHC.Types.Demand
import GHC.Types.Cpr
-import GHC.Serialized ( deserializeWithData )
-import GHC.Utils.Misc
-import GHC.Data.Pair
import GHC.Types.Unique.Supply
+import GHC.Types.Unique.FM
+
+import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing )
+import GHC.Data.Pair
+import GHC.Data.FastString
+
+import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (debugIsOn)
-import GHC.Data.FastString
-import GHC.Types.Unique.FM
import GHC.Utils.Monad
-import Control.Monad ( zipWithM )
-import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
+import GHC.Utils.Trace
+
import GHC.Builtin.Names ( specTyConKey )
-import GHC.Unit.Module
+
import GHC.Exts( SpecConstrAnnotation(..) )
+import GHC.Serialized ( deserializeWithData )
+
+import Control.Monad ( zipWithM )
+import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
import Data.Ord( comparing )
{-
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 1f0b6fb2a0..88f5d408de 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -42,6 +42,7 @@ import GHC.Builtin.Types ( unboxedUnitTy )
import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust )
import GHC.Data.Bag
import GHC.Data.FastString
+import GHC.Data.List.SetOps
import GHC.Types.Basic
import GHC.Types.Unique.Supply
@@ -60,6 +61,7 @@ import GHC.Utils.Monad ( foldlM )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Trace
import GHC.Unit.Module( Module )
import GHC.Unit.Module.ModGuts
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index d7f4c1c0ee..58ac9f4c62 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -9,32 +9,35 @@ module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where
import GHC.Prelude
+import GHC.Driver.Session
+
import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Core
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Utils ( exprType, exprIsHNF )
import GHC.Core.FVs ( exprFreeVars )
+import GHC.Core.Type
+import GHC.Core.Opt.WorkWrap.Utils
+import GHC.Core.FamInstEnv
+import GHC.Core.SimpleOpt( SimpleOpts(..) )
+
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Core.Type
import GHC.Types.Unique.Supply
import GHC.Types.Basic
-import GHC.Driver.Session
-import GHC.Driver.Ppr
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.SourceText
-import GHC.Core.Opt.WorkWrap.Utils
-import GHC.Core.SimpleOpt( SimpleOpts(..) )
+import GHC.Types.Unique
+
import GHC.Utils.Misc
import GHC.Utils.Outputable
-import GHC.Types.Unique
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
-import GHC.Core.FamInstEnv
import GHC.Utils.Monad
+import GHC.Utils.Trace
{-
We take Core bindings whose binders have:
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 878bcdd068..3eb4b31c52 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -18,44 +18,48 @@ where
import GHC.Prelude
+import GHC.Driver.Session
+import GHC.Driver.Config (initSimpleOpts)
+
import GHC.Core
import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase
, bindNonRec, dataConRepFSInstPat
, normSplitTyConApp_maybe, exprIsHNF )
-import GHC.Types.Id
-import GHC.Types.Id.Info ( JoinArity )
import GHC.Core.DataCon
-import GHC.Types.Demand
-import GHC.Types.Cpr
import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup, mkCoreApp, mkCoreLet
, mkWildValBinder, mkLitRubbish )
-import GHC.Types.Id.Make ( voidArgId, voidPrimId )
-import GHC.Builtin.Types ( tupleDataCon )
-import GHC.Types.Var.Env ( mkInScopeSet )
-import GHC.Types.Var.Set ( VarSet )
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.Predicate ( isClassPred )
import GHC.Core.Coercion
import GHC.Core.FamInstEnv
-import GHC.Types.Basic ( Boxity(..) )
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Core.SimpleOpt( SimpleOpts )
+import GHC.Types.Id
+import GHC.Types.Id.Info ( JoinArity )
+import GHC.Types.Demand
+import GHC.Types.Cpr
+import GHC.Types.Id.Make ( voidArgId, voidPrimId )
+import GHC.Types.Var.Env ( mkInScopeSet )
+import GHC.Types.Var.Set ( VarSet )
+import GHC.Types.Basic ( Boxity(..) )
import GHC.Types.Unique.Supply
import GHC.Types.Unique
import GHC.Types.Name ( getOccFS )
+
+import GHC.Data.FastString
+import GHC.Data.OrdList
+import GHC.Data.List.SetOps
+
+import GHC.Builtin.Types ( tupleDataCon )
+
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Config( initSimpleOpts )
-import GHC.Data.FastString
-import GHC.Data.OrdList
-import GHC.Data.List.SetOps
+import GHC.Utils.Trace
import Control.Applicative ( (<|>) )
import Control.Monad ( zipWithM )
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 207e0b97a2..878b905929 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -27,10 +27,14 @@ module GHC.Core.Rules (
import GHC.Prelude
-import GHC.Core -- All of it
+import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ )
+import GHC.Driver.Flags
+
import GHC.Unit.Types ( primUnitId, bignumUnitId )
import GHC.Unit.Module ( Module )
import GHC.Unit.Module.Env
+
+import GHC.Core -- All of it
import GHC.Core.Subst
import GHC.Core.SimpleOpt ( exprIsLambda_maybe )
import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars
@@ -39,13 +43,16 @@ import GHC.Core.Utils ( exprType, eqExpr, mkTick, mkTicks
, stripTicksTopT, stripTicksTopE
, isJoinBind )
import GHC.Core.Ppr ( pprRules )
+import GHC.Core.Unify as Unify ( ruleMatchTyKiX )
import GHC.Core.Type as Type
( Type, TCvSubst, extendTvSubst, extendCvSubst
, mkEmptyTCvSubst, substTy )
-import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe )
-import GHC.Builtin.Types ( anyTypeOfKind )
import GHC.Core.Coercion as Coercion
import GHC.Core.Tidy ( tidyRules )
+
+import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe )
+import GHC.Builtin.Types ( anyTypeOfKind )
+
import GHC.Types.Id
import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) )
import GHC.Types.Var
@@ -56,18 +63,18 @@ import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.Unique.FM
import GHC.Types.Tickish
-import GHC.Core.Unify as Unify ( ruleMatchTyKiX )
import GHC.Types.Basic
-import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ )
-import GHC.Driver.Ppr
-import GHC.Driver.Flags
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Constants (debugIsOn)
+
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.Bag
+
import GHC.Utils.Misc as Utils
+import GHC.Utils.Trace
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Constants (debugIsOn)
+
import Data.List (sortBy, mapAccumL, isPrefixOf)
import Data.Function ( on )
import Control.Monad ( guard )
diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs
index 06aa024f16..3d93084fc4 100644
--- a/compiler/GHC/Core/Subst.hs
+++ b/compiler/GHC/Core/Subst.hs
@@ -36,8 +36,6 @@ module GHC.Core.Subst (
import GHC.Prelude
-import GHC.Driver.Ppr
-
import GHC.Core
import GHC.Core.FVs
import GHC.Core.Seq
@@ -51,7 +49,6 @@ import GHC.Core.Type hiding
, isInScope, substTyVarBndr, cloneTyVarBndr )
import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )
-import GHC.Builtin.Names
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
@@ -60,11 +57,16 @@ import GHC.Types.Var
import GHC.Types.Tickish
import GHC.Types.Id.Info
import GHC.Types.Unique.Supply
+
+import GHC.Builtin.Names
import GHC.Data.Maybe
+
+import GHC.Utils.Trace
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+
import Data.List (mapAccumL)
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 55561c9cbc..fc05566d9f 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -40,7 +40,6 @@ module GHC.Core.Unfold (
import GHC.Prelude
-import GHC.Driver.Ppr
import GHC.Driver.Flags
import GHC.Core
@@ -1295,7 +1294,7 @@ tryUnfolding logger opts !case_depth id lone_variable
, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]
ctx = log_default_dump_context (logFlags logger)
- str = "Considering inlining: " ++ showSDocDump ctx (ppr id)
+ str = "Considering inlining: " ++ renderWithContext ctx (ppr id)
n_val_args = length arg_infos
-- some_benefit is used when the RHS is small enough
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 3ec00d76be..969ede72bc 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -67,12 +67,21 @@ module GHC.Core.Utils (
import GHC.Prelude
import GHC.Platform
-import GHC.Driver.Ppr
-
import GHC.Core
-import GHC.Builtin.Names (makeStaticName, unsafeEqualityProofName)
import GHC.Core.Ppr
import GHC.Core.FVs( exprFreeVars )
+import GHC.Core.DataCon
+import GHC.Core.Type as Type
+import GHC.Core.FamInstEnv
+import GHC.Core.Predicate
+import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )
+import GHC.Core.Coercion
+import GHC.Core.TyCon
+import GHC.Core.Multiplicity
+
+import GHC.Builtin.Names (makeStaticName, unsafeEqualityProofName)
+import GHC.Builtin.PrimOps
+
import GHC.Types.Var
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
@@ -80,35 +89,30 @@ import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Literal
import GHC.Types.Tickish
-import GHC.Core.DataCon
-import GHC.Builtin.PrimOps
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Core.Type as Type
-import GHC.Core.FamInstEnv
-import GHC.Core.Predicate
-import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )
-import GHC.Core.Coercion
-import GHC.Core.TyCon
-import GHC.Core.Multiplicity
import GHC.Types.Unique
+import GHC.Types.Basic ( Arity, FullArgCount )
+import GHC.Types.Unique.Set
+
+import GHC.Data.FastString
+import GHC.Data.Maybe
+import GHC.Data.List.SetOps( minusList )
+import GHC.Data.Pair
+import GHC.Data.OrdList
+
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
-import GHC.Data.FastString
-import GHC.Data.Maybe
-import GHC.Data.List.SetOps( minusList )
-import GHC.Types.Basic ( Arity, FullArgCount )
import GHC.Utils.Misc
-import GHC.Data.Pair
+import GHC.Utils.Trace
+
import Data.ByteString ( ByteString )
import Data.Function ( on )
import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
import Data.Ord ( comparing )
-import GHC.Data.OrdList
import qualified Data.Set as Set
-import GHC.Types.Unique.Set
{-
************************************************************************
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index a1c8d0fe78..4ca3065ece 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -46,38 +46,43 @@ module GHC.CoreToIface
import GHC.Prelude
-import GHC.Driver.Ppr
-import GHC.Iface.Syntax
-import GHC.Core.DataCon
-import GHC.Types.Id
-import GHC.Types.Literal
-import GHC.Types.Id.Info
import GHC.StgToCmm.Types
+
import GHC.Core
import GHC.Core.TyCon hiding ( pprPromotionQuote )
import GHC.Core.Coercion.Axiom
+import GHC.Core.DataCon
+import GHC.Core.Type
+import GHC.Core.Multiplicity
+import GHC.Core.PatSyn
+import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Tidy ( tidyCo )
+
import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon )
import GHC.Builtin.Types ( heqTyCon )
-import GHC.Types.Id.Make ( noinlineIdName )
import GHC.Builtin.Names
+
+import GHC.Iface.Syntax
+import GHC.Data.FastString
+
+import GHC.Types.Id
+import GHC.Types.Id.Info
+import GHC.Types.Id.Make ( noinlineIdName )
+import GHC.Types.Literal
import GHC.Types.Name
import GHC.Types.Basic
-import GHC.Core.Type
-import GHC.Core.Multiplicity
-import GHC.Core.PatSyn
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Data.FastString
-import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Tickish
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Tidy ( tidyCo )
import GHC.Types.Demand ( isTopSig )
import GHC.Types.Cpr ( topCprSig )
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Misc
+import GHC.Utils.Trace
+
import Data.Maybe ( catMaybes )
{- Note [Avoiding space leaks in toIface*]
@@ -297,7 +302,7 @@ toIfaceCoercionX fr co
(toIfaceTypeX fr t2)
go (TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
- , [_,_,_,_, _] <- cos = pprPanic "toIfaceCoercion" empty
+ , [_,_,_,_, _] <- cos = panic "toIfaceCoercion"
| otherwise =
IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)
go (FunCo r w co1 co2) = IfaceFunCo r (go w) (go co1) (go co2)
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index bf20cc4286..38050e79e1 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -17,42 +17,46 @@ module GHC.CoreToStg ( coreToStg ) where
import GHC.Prelude
+import GHC.Driver.Session
+
import GHC.Core
import GHC.Core.Utils ( exprType, findDefault, isJoinBind
, exprIsTickedString_maybe )
import GHC.Core.Opt.Arity ( manifestArity )
+import GHC.Core.Type
+import GHC.Core.TyCon
+import GHC.Core.DataCon
+
import GHC.Stg.Syntax
import GHC.Stg.Debug
-import GHC.Core.Type
import GHC.Types.RepType
-import GHC.Core.TyCon
import GHC.Types.Id.Make ( coercionTokenId )
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Core.DataCon
import GHC.Types.CostCentre
import GHC.Types.Tickish
import GHC.Types.Var.Env
-import GHC.Unit.Module
import GHC.Types.Name ( isExternalName, nameModule_maybe )
import GHC.Types.Basic ( Arity )
-import GHC.Builtin.Types ( unboxedUnitDataCon )
import GHC.Types.Literal
+import GHC.Types.ForeignCall
+import GHC.Types.IPE
+import GHC.Types.Demand ( isUsedOnceDmd )
+import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
+
+import GHC.Unit.Module
+import GHC.Builtin.Types ( unboxedUnitDataCon )
+import GHC.Data.FastString
+import GHC.Platform.Ways
+import GHC.Builtin.PrimOps ( PrimCall(..) )
+
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Utils.Misc (HasDebugCallStack)
-import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
-import GHC.Driver.Session
-import GHC.Platform.Ways
-import GHC.Driver.Ppr
-import GHC.Types.ForeignCall
-import GHC.Types.IPE
-import GHC.Types.Demand ( isUsedOnceDmd )
-import GHC.Builtin.PrimOps ( PrimCall(..) )
-import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
+import GHC.Utils.Trace
import Control.Monad (ap)
import Data.Maybe (fromMaybe)
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 4529bc7d1b..30c28a6db2 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -32,7 +32,6 @@ import GHC.Builtin.Names
import GHC.Builtin.PrimOps
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
-import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )
import GHC.Core.Utils
import GHC.Core.Opt.Arity
@@ -48,10 +47,10 @@ import GHC.Core.DataCon
import GHC.Core.Opt.OccurAnal
import GHC.Core.TyCo.Rep( UnivCoProvenance(..) )
-
import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.FastString
+import GHC.Data.Pair
import GHC.Utils.Error
import GHC.Utils.Misc
@@ -60,6 +59,7 @@ import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable
import GHC.Utils.Monad ( mapAccumLM )
import GHC.Utils.Logger
+import GHC.Utils.Trace
import GHC.Types.Demand
import GHC.Types.Var
@@ -67,6 +67,7 @@ import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )
import GHC.Types.Basic
import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName )
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
@@ -75,7 +76,6 @@ import GHC.Types.Tickish
import GHC.Types.TyThing
import GHC.Types.Unique.Supply
-import GHC.Data.Pair
import Data.List ( unfoldr )
import Data.Functor.Identity
import Control.Monad
diff --git a/compiler/GHC/Data/Bool.hs b/compiler/GHC/Data/Bool.hs
new file mode 100644
index 0000000000..1428e7d2fd
--- /dev/null
+++ b/compiler/GHC/Data/Bool.hs
@@ -0,0 +1,18 @@
+module GHC.Data.Bool
+ ( OverridingBool(..)
+ , overrideWith
+ )
+where
+
+import GHC.Prelude
+
+data OverridingBool
+ = Auto
+ | Always
+ | Never
+ deriving Show
+
+overrideWith :: Bool -> OverridingBool -> Bool
+overrideWith b Auto = b
+overrideWith _ Always = True
+overrideWith _ Never = False
diff --git a/compiler/GHC/Data/List/SetOps.hs b/compiler/GHC/Data/List/SetOps.hs
index 76e421c940..fac12fadd8 100644
--- a/compiler/GHC/Data/List/SetOps.hs
+++ b/compiler/GHC/Data/List/SetOps.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -20,7 +22,10 @@ module GHC.Data.List.SetOps (
equivClasses,
-- Indexing
- getNth
+ getNth,
+
+ -- Membership
+ isIn, isn'tIn,
) where
import GHC.Prelude
@@ -28,7 +33,7 @@ import GHC.Prelude
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
-import GHC.Driver.Ppr
+import GHC.Utils.Trace
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
@@ -176,3 +181,31 @@ findDupsEq _ [] = []
findDupsEq eq (x:xs) | L.null eq_xs = findDupsEq eq xs
| otherwise = (x :| eq_xs) : findDupsEq eq neq_xs
where (eq_xs, neq_xs) = L.partition (eq x) xs
+
+-- Debugging/specialising versions of \tr{elem} and \tr{notElem}
+
+# if !defined(DEBUG)
+isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
+isIn _msg x ys = x `elem` ys
+isn'tIn _msg x ys = x `notElem` ys
+
+# else /* DEBUG */
+isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool
+isIn msg x ys
+ = elem100 0 x ys
+ where
+ elem100 :: Eq a => Int -> a -> [a] -> Bool
+ elem100 _ _ [] = False
+ elem100 i x (y:ys)
+ | i > 100 = warnPprTrace True (text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))
+ | otherwise = x == y || elem100 (i + 1) x ys
+
+isn'tIn msg x ys
+ = notElem100 0 x ys
+ where
+ notElem100 :: Eq a => Int -> a -> [a] -> Bool
+ notElem100 _ _ [] = True
+ notElem100 i x (y:ys)
+ | i > 100 = warnPprTrace True (text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))
+ | otherwise = x /= y && notElem100 (i + 1) x ys
+# endif /* DEBUG */
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 7c9c08e4c1..e0b8879fd9 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -43,6 +43,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.Utils.Exception (bracket)
+import GHC.Utils.Ppr (Mode(..))
import GHC.Unit
import GHC.Unit.State
@@ -148,7 +149,8 @@ outputC logger dflags filenm cmm_stream packages =
"C backend output"
FormatC
doc
- printForC dflags h doc
+ let ctx = initSDocContext dflags (PprCode CStyle)
+ printSDocLn ctx LeftMode h doc
Stream.consume cmm_stream id writeC
{-
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index 6606f551e5..cbddfa0ef3 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -32,15 +32,14 @@ where
import GHC.Prelude
-import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Driver.Errors ( printOrThrowDiagnostics )
import GHC.Driver.Errors.Types ( GhcMessage )
import GHC.Driver.Config.Logger (initLogFlags)
+import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
import GHC.Runtime.Context
import GHC.Runtime.Interpreter.Types (Interp)
-import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
import GHC.Unit
import GHC.Unit.Module.ModGuts
@@ -61,6 +60,7 @@ import GHC.Types.Error ( emptyMessages, Messages )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.TyThing
+import GHC.Types.Unique.FM
import GHC.Builtin.Names ( gHC_PRIM )
@@ -72,7 +72,7 @@ import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Logger
-import GHC.Types.Unique.FM
+import GHC.Utils.Trace
import Data.IORef
import qualified Data.Set as Set
diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs
index a43f9eaa1d..49188d08f0 100644
--- a/compiler/GHC/Driver/Ppr.hs
+++ b/compiler/GHC/Driver/Ppr.hs
@@ -3,39 +3,21 @@ module GHC.Driver.Ppr
( showSDoc
, showSDocUnsafe
, showSDocForUser
- , showSDocDebug
- , showSDocDump
, showPpr
, showPprUnsafe
- , pprDebugAndThen
, printForUser
- , printForC
- -- ** Trace
- , warnPprTrace
- , pprTrace
- , pprTraceM
- , pprTraceDebug
- , pprTraceIt
- , pprSTrace
- , pprTraceException
)
where
import GHC.Prelude
-import {-# SOURCE #-} GHC.Driver.Session
+import GHC.Driver.Session
import {-# SOURCE #-} GHC.Unit.State
-import GHC.Utils.Exception
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Misc
import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.GlobalVars
import GHC.Utils.Ppr ( Mode(..) )
import System.IO ( Handle )
-import Control.Monad.IO.Class
-- | Show a SDoc as a String with the default user style
showSDoc :: DynFlags -> SDoc -> String
@@ -51,77 +33,7 @@ showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContex
sty = mkUserStyle unqual AllTheWay
doc' = pprWithUnitState unit_state doc
-showSDocDump :: SDocContext -> SDoc -> String
-showSDocDump ctx d = renderWithContext ctx (withPprStyle defaultDumpStyle d)
-
-showSDocDebug :: DynFlags -> SDoc -> String
-showSDocDebug dflags d = renderWithContext ctx d
- where
- ctx = (initSDocContext dflags defaultDumpStyle)
- { sdocPprDebug = True
- }
-
printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()
printForUser dflags handle unqual depth doc
= printSDocLn ctx (PageMode False) handle doc
where ctx = initSDocContext dflags (mkUserStyle unqual depth)
-
--- | Like 'printSDocLn' but specialized with 'LeftMode' and
--- @'PprCode' 'CStyle'@. This is typically used to output C-- code.
-printForC :: DynFlags -> Handle -> SDoc -> IO ()
-printForC dflags handle doc =
- printSDocLn ctx LeftMode handle doc
- where ctx = initSDocContext dflags (PprCode CStyle)
-
-pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a
-pprDebugAndThen ctx cont heading pretty_msg
- = cont (showSDocDump ctx doc)
- where
- doc = sep [heading, nest 2 pretty_msg]
-
--- | If debug output is on, show some 'SDoc' on the screen
-pprTrace :: String -> SDoc -> a -> a
-pprTrace str doc x
- | unsafeHasNoDebugOutput = x
- | otherwise = pprDebugAndThen defaultSDocContext trace (text str) doc x
-
-pprTraceM :: Applicative f => String -> SDoc -> f ()
-pprTraceM str doc = pprTrace str doc (pure ())
-
-pprTraceDebug :: String -> SDoc -> a -> a
-pprTraceDebug str doc x
- | debugIsOn && unsafeHasPprDebug = pprTrace str doc x
- | otherwise = x
-
--- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@.
--- This allows you to print details from the returned value as well as from
--- ambient variables.
-pprTraceWith :: String -> (a -> SDoc) -> a -> a
-pprTraceWith desc f x = pprTrace desc (f x) x
-
--- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@
-pprTraceIt :: Outputable a => String -> a -> a
-pprTraceIt desc x = pprTraceWith desc ppr x
-
--- | @pprTraceException desc x action@ runs action, printing a message
--- if it throws an exception.
-pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a
-pprTraceException heading doc =
- handleGhcException $ \exc -> liftIO $ do
- putStrLn $ showSDocDump defaultSDocContext (sep [text heading, nest 2 doc])
- throwGhcExceptionIO exc
-
--- | If debug output is on, show some 'SDoc' on the screen along
--- with a call stack when available.
-pprSTrace :: HasCallStack => SDoc -> a -> a
-pprSTrace doc = pprTrace "" (doc $$ callStackDoc)
-
--- | Just warn about an assertion failure, recording the given file and line number.
-warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a
-warnPprTrace _ _ x | not debugIsOn = x
-warnPprTrace _ _msg x | unsafeHasNoDebugOutput = x
-warnPprTrace False _msg x = x
-warnPprTrace True msg x
- = pprDebugAndThen defaultSDocContext trace (text "WARNING:")
- (msg $$ callStackDoc )
- x
diff --git a/compiler/GHC/Driver/Ppr.hs-boot b/compiler/GHC/Driver/Ppr.hs-boot
deleted file mode 100644
index 58f812d6d8..0000000000
--- a/compiler/GHC/Driver/Ppr.hs-boot
+++ /dev/null
@@ -1,9 +0,0 @@
-module GHC.Driver.Ppr where
-
-import GHC.Prelude
-import GHC.Stack
-import {-# SOURCE #-} GHC.Driver.Session
-import {-# SOURCE #-} GHC.Utils.Outputable
-
-showSDoc :: DynFlags -> SDoc -> String
-warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index d51fa4d8f2..d35e0d96d4 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -241,6 +241,7 @@ import GHC.Utils.Misc
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.GlobalVars
import GHC.Data.Maybe
+import GHC.Data.Bool
import GHC.Utils.Monad
import GHC.Types.Error (DiagnosticReason(..))
import GHC.Types.SrcLoc
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 184dda1481..01a8d1d9a5 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -24,6 +24,12 @@ where
import GHC.Prelude
+import GHC.Driver.Session
+import GHC.Driver.Ppr
+import GHC.Driver.Config
+import qualified GHC.LanguageExtensions as LangExt
+import GHC.Unit.Module
+
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr )
import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper )
@@ -42,41 +48,41 @@ import GHC.Core.Utils
import GHC.Core.Opt.Arity ( etaExpand )
import GHC.Core.Unfold.Make
import GHC.Core.FVs
-import GHC.Data.Graph.Directed
import GHC.Core.Predicate
-
-import GHC.Builtin.Names
import GHC.Core.TyCon
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.Multiplicity
+import GHC.Core.Rules
+
+import GHC.Builtin.Names
import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )
+
+import GHC.Tc.Types.Evidence
+
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Var.Set
-import GHC.Core.Rules
import GHC.Types.Var.Env
import GHC.Types.Var( EvVar )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Unit.Module
import GHC.Types.SrcLoc
+import GHC.Types.Basic
+import GHC.Types.Unique.Set( nonDetEltsUniqSet )
+
import GHC.Data.Maybe
import GHC.Data.OrdList
+import GHC.Data.Graph.Directed
import GHC.Data.Bag
-import GHC.Types.Basic
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Config
import GHC.Data.FastString
+
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
-import GHC.Types.Unique.Set( nonDetEltsUniqSet )
import GHC.Utils.Monad
-import qualified GHC.LanguageExtensions as LangExt
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Trace
+
import Control.Monad
{-**********************************************************************
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index eac1ba3e9d..cc7a154b2a 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -47,7 +47,6 @@ import GHC.Driver.Env
import GHC.Driver.Errors.Types
import GHC.Driver.Session
import GHC.Driver.Backend
-import GHC.Driver.Ppr
import GHC.Driver.Hooks
import GHC.Driver.Plugins
@@ -67,6 +66,7 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
+import GHC.Utils.Trace
import GHC.Settings.Constants
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 4af7ddbf05..7421eac86d 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -51,7 +51,6 @@ import GHC.Core.Unify( RoughMatchTc(..) )
import GHC.Driver.Env
import GHC.Driver.Backend
import GHC.Driver.Session
-import GHC.Driver.Ppr
import GHC.Driver.Plugins (LoadedPlugin(..))
import GHC.Types.Id
@@ -77,6 +76,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc hiding ( eqListBy )
import GHC.Utils.Logger
+import GHC.Utils.Trace
import GHC.Data.FastString
import GHC.Data.Maybe
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 7759aea72d..9bfbe218d6 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -42,6 +42,7 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Exception
import GHC.Utils.Logger
import GHC.Utils.Constants (debugIsOn)
+import GHC.Utils.Trace
import GHC.Types.Annotations
import GHC.Types.Name
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 3285fb88e5..2a6f9ecbca 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -47,6 +47,7 @@ import GHC.Iface.Env
import GHC.Utils.Outputable
import GHC.Utils.Misc( filterOut )
import GHC.Utils.Panic
+import GHC.Utils.Trace
import GHC.Utils.Logger as Logger
import qualified GHC.Utils.Error as Err
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 1466e7da71..7c9b951eba 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -89,6 +89,7 @@ import Data.Char
import Data.List (stripPrefix, isInfixOf, partition)
import Data.Maybe
import Data.Word
+import Debug.Trace (trace)
import GHC.Data.EnumSet as EnumSet
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 05bbb71c6e..7fbbb7167e 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -55,6 +55,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc as Utils
import GHC.Utils.Panic
+import GHC.Utils.Trace
import GHC.Types.Fixity.Env
import GHC.Types.SafeHaskell
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 1c3c72d228..e28b2daeba 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -93,6 +93,7 @@ import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Logger
+import GHC.Utils.Trace
import GHC.Types.RepType
import GHC.Types.Fixity.Env
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index 5754b23baa..57996cbffa 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -28,7 +28,6 @@ import GHC.Driver.Session
import GHC.Utils.Error
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
-import GHC.Utils.Panic
import GHC.Utils.Logger
import Control.Monad
import Control.Monad.IO.Class
@@ -86,7 +85,7 @@ stg2stg logger dflags ictxt this_mod binds
return binds
StgStats ->
- trace (showStgStats binds) (return binds)
+ logTraceMsg logger "STG stats" (text (showStgStats binds)) (return binds)
StgCSE -> do
let binds' = {-# SCC "StgCse" #-} stgCse binds
diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs
index d47107bb35..487b8b8adc 100644
--- a/compiler/GHC/Stg/Subst.hs
+++ b/compiler/GHC/Stg/Subst.hs
@@ -11,8 +11,7 @@ import GHC.Utils.Monad.State.Strict
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
-
-import GHC.Driver.Ppr
+import GHC.Utils.Trace
-- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not
-- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 13b07c2dd2..7d89b71309 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -15,6 +15,14 @@ module GHC.StgToCmm.Bind (
import GHC.Prelude hiding ((<*>))
+import GHC.Driver.Session
+
+import GHC.Core ( AltCon(..) )
+import GHC.Runtime.Heap.Layout
+import GHC.Unit.Module
+
+import GHC.Stg.Syntax
+
import GHC.Platform
import GHC.Platform.Profile
@@ -32,29 +40,26 @@ import GHC.StgToCmm.Closure
import GHC.StgToCmm.Foreign (emitPrimCall)
import GHC.Cmm.Graph
-import GHC.Core ( AltCon(..) )
import GHC.Cmm.BlockId
-import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
-import GHC.Stg.Syntax
+
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Name
-import GHC.Unit.Module
-import GHC.Data.List.SetOps
-import GHC.Utils.Misc
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Tickish ( tickishIsCode )
+
+import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+
import GHC.Data.FastString
-import GHC.Driver.Session
-import GHC.Driver.Ppr
+import GHC.Data.List.SetOps
import Control.Monad
@@ -764,9 +769,10 @@ closureDescription
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.hs with a description generated from the data constructor
closureDescription dflags mod_name name
- = showSDocDump (initSDocContext dflags defaultDumpStyle) (char '<' <>
+ = let ctx = initSDocContext dflags defaultDumpStyle
+ -- defaultDumpStyle, because we want to see the unique on the Name.
+ in renderWithContext ctx (char '<' <>
(if isExternalName name
then ppr name -- ppr will include the module name prefix
else pprModule mod_name <> char '.' <> ppr name) <>
char '>')
- -- showSDocDump, because we want to see the unique on the Name.
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index e9e67f6b83..76748f2b0d 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -102,6 +102,8 @@ module GHC.StgToCmm.Ticky (
import GHC.Prelude
+import GHC.Driver.Session
+
import GHC.Platform
import GHC.Platform.Profile
@@ -126,9 +128,6 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-
-- Turgid imports for showTypeCategory
import GHC.Builtin.Names
import GHC.Tc.Utils.TcType
@@ -243,7 +242,9 @@ emitTickyCounter cloType name args
then n <+> parens (ppr mod_name) <+> ext <+> p
else n <+> ext <+> p
- ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
+ ; let ctx = (initSDocContext dflags defaultDumpStyle)
+ { sdocPprDebug = True }
+ ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name
; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
; emitDataLits ctr_lbl
-- Must match layout of includes/rts/Ticky.h's StgEntCounter
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 42d5300d1e..850b0bb48a 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -26,8 +26,11 @@ module GHC.Tc.Gen.Sig(
import GHC.Prelude
+import GHC.Driver.Session
+import GHC.Driver.Backend
+
import GHC.Hs
-import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) )
+
import GHC.Tc.Gen.HsType
import GHC.Tc.Types
import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
@@ -41,26 +44,30 @@ import GHC.Tc.Utils.Unify( tcSkolemise, unifyType )
import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs )
import GHC.Tc.Utils.Env( tcLookupId )
import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )
+import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) )
+
import GHC.Core( hasSomeUnfolding )
import GHC.Core.Type ( mkTyVarBinders )
import GHC.Core.Multiplicity
-import GHC.Driver.Session
-import GHC.Driver.Backend
-import GHC.Driver.Ppr
import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars )
import GHC.Types.Id ( Id, idName, idType, setInlinePragma
, mkLocalId, realIdUnfolding )
-import GHC.Builtin.Names( mkUnboundName )
import GHC.Types.Basic
-import GHC.Unit.Module( getModule )
import GHC.Types.Name
import GHC.Types.Name.Env
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
import GHC.Types.SrcLoc
+
+import GHC.Builtin.Names( mkUnboundName )
+import GHC.Unit.Module( getModule )
+
import GHC.Utils.Misc as Utils ( singleton )
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Trace
+
import GHC.Data.Maybe( orElse )
+
import Data.Maybe( mapMaybe )
import Control.Monad( unless )
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index cb15e962f6..371093a183 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -46,7 +46,7 @@ import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Driver.Ppr
+import GHC.Utils.Trace
{- *********************************************************************
* *
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 3172a6791a..1a8be64e29 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -96,46 +96,48 @@ module GHC.Tc.Utils.TcMType (
ensureNotLevPoly, checkForLevPoly, checkForLevPolyX,
) where
--- friends:
import GHC.Prelude
-import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} )
+import GHC.Driver.Session
+import qualified GHC.LanguageExtensions as LangExt
+
+import GHC.Tc.Types.Origin
+import GHC.Tc.Utils.Monad -- TcType, amongst others
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Types.Evidence
+import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} )
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Errors.Types
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
-import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.Coercion
import GHC.Core.Class
-import GHC.Types.Var
import GHC.Core.Predicate
-import GHC.Tc.Errors.Types
-import GHC.Tc.Types.Origin
--- others:
-import GHC.Tc.Utils.Monad -- TcType, amongst others
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Evidence
+import GHC.Types.Var
import GHC.Types.Id as Id
import GHC.Types.Name
import GHC.Types.Var.Set
-import GHC.Builtin.Types
import GHC.Types.Var.Env
import GHC.Types.Name.Env
+import GHC.Types.Unique.Set
+import GHC.Types.Basic ( TypeOrKind(..) )
+
+import GHC.Builtin.Types
+
+import GHC.Data.FastString
+import GHC.Data.Bag
+import GHC.Data.Pair
+
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (debugIsOn)
-import GHC.Data.FastString
-import GHC.Data.Bag
-import GHC.Data.Pair
-import GHC.Types.Unique.Set
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Types.Basic ( TypeOrKind(..) )
+import GHC.Utils.Trace
import Control.Monad
import GHC.Data.Maybe
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 7c78c1928b..8ac7fc214b 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -163,8 +163,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.GlobalVars
-
-import GHC.Driver.Ppr
+import GHC.Utils.Trace
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs
index 2e8476c851..efe1a748b5 100644
--- a/compiler/GHC/Types/TyThing/Ppr.hs
+++ b/compiler/GHC/Types/TyThing/Ppr.hs
@@ -18,8 +18,6 @@ module GHC.Types.TyThing.Ppr (
import GHC.Prelude
-import GHC.Driver.Ppr (warnPprTrace)
-
import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe )
import GHC.Types.Name
@@ -33,6 +31,7 @@ import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
import GHC.Iface.Make ( tyThingToIfaceDecl )
import GHC.Utils.Outputable
+import GHC.Utils.Trace
-- -----------------------------------------------------------------------------
-- Pretty-printing entities that we get from the GHC API
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 9a1ea88aa7..93ab233788 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -64,7 +64,6 @@ module GHC.Utils.Error (
import GHC.Prelude
import GHC.Driver.Session
-import GHC.Driver.Ppr
import GHC.Data.Bag
import GHC.Utils.Exception
diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs
index 77506682bd..e497b8c965 100644
--- a/compiler/GHC/Utils/Logger.hs
+++ b/compiler/GHC/Utils/Logger.hs
@@ -77,7 +77,6 @@ where
import GHC.Prelude
import GHC.Driver.Flags
-import GHC.Driver.Ppr
import GHC.Types.Error
import GHC.Types.SrcLoc
@@ -101,6 +100,7 @@ import System.IO
import Control.Monad
import Control.Concurrent.MVar
import System.IO.Unsafe
+import Debug.Trace (trace)
---------------------------------------------------------------
-- Log flags
@@ -528,7 +528,7 @@ defaultTraceAction :: TraceAction a
defaultTraceAction logflags title doc x =
if not (log_enable_debug logflags)
then x
- else trace (showSDocDump (log_default_dump_context logflags)
+ else trace (renderWithContext (log_default_dump_context logflags)
(sep [text title, nest 2 doc])) x
diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index d19d78c876..181d6c91e7 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/compiler/GHC/Utils/Misc.hs
@@ -42,8 +42,6 @@ module GHC.Utils.Misc (
isSingleton, only, expectOnly, GHC.Utils.Misc.singleton,
notNull, snocView,
- isIn, isn'tIn,
-
chunkList,
changeLast,
@@ -122,10 +120,6 @@ module GHC.Utils.Misc (
-- * Call stacks
HasCallStack,
HasDebugCallStack,
-
- -- * Utils for flags
- OverridingBool(..),
- overrideWith,
) where
import GHC.Prelude
@@ -160,11 +154,6 @@ import qualified Data.Set as Set
import Data.Time
-#if defined(DEBUG)
-import {-# SOURCE #-} GHC.Utils.Outputable ( text )
-import {-# SOURCE #-} GHC.Driver.Ppr ( warnPprTrace )
-#endif
-
infixr 9 `thenCmp`
@@ -524,34 +513,6 @@ expectOnly _ (a:_) = a
#endif
expectOnly msg _ = panic ("expectOnly: " ++ msg)
--- Debugging/specialising versions of \tr{elem} and \tr{notElem}
-
-# if !defined(DEBUG)
-isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
-isIn _msg x ys = x `elem` ys
-isn'tIn _msg x ys = x `notElem` ys
-
-# else /* DEBUG */
-isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool
-isIn msg x ys
- = elem100 0 x ys
- where
- elem100 :: Eq a => Int -> a -> [a] -> Bool
- elem100 _ _ [] = False
- elem100 i x (y:ys)
- | i > 100 = warnPprTrace True (text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))
- | otherwise = x == y || elem100 (i + 1) x ys
-
-isn'tIn msg x ys
- = notElem100 0 x ys
- where
- notElem100 :: Eq a => Int -> a -> [a] -> Bool
- notElem100 _ _ [] = True
- notElem100 i x (y:ys)
- | i > 100 = warnPprTrace True (text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))
- | otherwise = x /= y && notElem100 (i + 1) x ys
-# endif /* DEBUG */
-
-- | Split a list into chunks of /n/ elements
chunkList :: Int -> [a] -> [[a]]
@@ -1486,14 +1447,3 @@ type HasDebugCallStack = HasCallStack
#else
type HasDebugCallStack = (() :: Constraint)
#endif
-
-data OverridingBool
- = Auto
- | Always
- | Never
- deriving Show
-
-overrideWith :: Bool -> OverridingBool -> Bool
-overrideWith b Auto = b
-overrideWith _ Always = True
-overrideWith _ Never = False
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 7d33007ead..7d0436f2f2 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -57,6 +57,7 @@ module GHC.Utils.Outputable (
showSDocUnsafe,
showPprUnsafe,
renderWithContext,
+ pprDebugAndThen,
pprInfixVar, pprPrefixVar,
pprHsChar, pprHsString, pprHsBytes,
@@ -607,6 +608,13 @@ showPprUnsafe :: Outputable a => a -> String
showPprUnsafe a = renderWithContext defaultSDocContext (ppr a)
+pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a
+pprDebugAndThen ctx cont heading pretty_msg
+ = cont (renderWithContext ctx doc)
+ where
+ doc = withPprStyle defaultDumpStyle (sep [heading, nest 2 pretty_msg])
+
+
isEmpty :: SDocContext -> SDoc -> Bool
isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True})
diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs
index fb72886be7..497ea65003 100644
--- a/compiler/GHC/Utils/Panic.hs
+++ b/compiler/GHC/Utils/Panic.hs
@@ -29,7 +29,6 @@ module GHC.Utils.Panic
, assertPprM
, massertPpr
, sorry
- , trace
, panicDoc
, sorryDoc
, pgmErrorDoc
@@ -60,7 +59,6 @@ import Control.Monad.IO.Class
import qualified Control.Monad.Catch as MC
import Control.Concurrent
import Data.Typeable ( cast )
-import Debug.Trace ( trace )
import System.IO.Unsafe
#if !defined(mingw32_HOST_OS)
diff --git a/compiler/GHC/Utils/Ppr/Colour.hs b/compiler/GHC/Utils/Ppr/Colour.hs
index 7283edd182..92044d96e4 100644
--- a/compiler/GHC/Utils/Ppr/Colour.hs
+++ b/compiler/GHC/Utils/Ppr/Colour.hs
@@ -2,7 +2,7 @@ module GHC.Utils.Ppr.Colour where
import GHC.Prelude
import Data.Maybe (fromMaybe)
-import GHC.Utils.Misc (OverridingBool(..), split)
+import GHC.Data.Bool
import Data.Semigroup as Semi
-- | A colour\/style for use with 'coloured'.
@@ -93,6 +93,11 @@ parseScheme input (b, cs) =
}
)
where
+ split :: Char -> String -> [String]
+ split c s = case break (==c) s of
+ (chunk,[]) -> [chunk]
+ (chunk,_:rest) -> chunk : split c rest
+
table = do
w <- split ':' input
let (k, v') = break (== '=') w
diff --git a/compiler/GHC/Utils/Trace.hs b/compiler/GHC/Utils/Trace.hs
new file mode 100644
index 0000000000..ac29cd6fd8
--- /dev/null
+++ b/compiler/GHC/Utils/Trace.hs
@@ -0,0 +1,77 @@
+-- | Tracing utilities
+module GHC.Utils.Trace
+ ( pprTrace
+ , pprTraceM
+ , pprTraceDebug
+ , pprTraceIt
+ , pprSTrace
+ , pprTraceException
+ , warnPprTrace
+ , trace
+ )
+where
+
+import GHC.Prelude
+import GHC.Utils.Outputable
+import GHC.Utils.Exception
+import GHC.Utils.Panic
+import GHC.Utils.GlobalVars
+import GHC.Utils.Constants
+import GHC.Stack
+
+import Debug.Trace (trace)
+import Control.Monad.IO.Class
+
+-- | If debug output is on, show some 'SDoc' on the screen
+pprTrace :: String -> SDoc -> a -> a
+pprTrace str doc x
+ | unsafeHasNoDebugOutput = x
+ | otherwise = pprDebugAndThen defaultSDocContext trace (text str) doc x
+
+pprTraceM :: Applicative f => String -> SDoc -> f ()
+pprTraceM str doc = pprTrace str doc (pure ())
+
+pprTraceDebug :: String -> SDoc -> a -> a
+pprTraceDebug str doc x
+ | debugIsOn && unsafeHasPprDebug = pprTrace str doc x
+ | otherwise = x
+
+-- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@.
+-- This allows you to print details from the returned value as well as from
+-- ambient variables.
+pprTraceWith :: String -> (a -> SDoc) -> a -> a
+pprTraceWith desc f x = pprTrace desc (f x) x
+
+-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@
+pprTraceIt :: Outputable a => String -> a -> a
+pprTraceIt desc x = pprTraceWith desc ppr x
+
+-- | @pprTraceException desc x action@ runs action, printing a message
+-- if it throws an exception.
+pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a
+pprTraceException heading doc =
+ handleGhcException $ \exc -> liftIO $ do
+ putStrLn $ renderWithContext defaultSDocContext
+ $ withPprStyle defaultDumpStyle
+ $ sep [text heading, nest 2 doc]
+ throwGhcExceptionIO exc
+
+-- | If debug output is on, show some 'SDoc' on the screen along
+-- with a call stack when available.
+pprSTrace :: HasCallStack => SDoc -> a -> a
+pprSTrace doc = pprTrace "" (doc $$ traceCallStackDoc)
+
+-- | Just warn about an assertion failure, recording the given file and line number.
+warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a
+warnPprTrace _ _ x | not debugIsOn = x
+warnPprTrace _ _msg x | unsafeHasNoDebugOutput = x
+warnPprTrace False _msg x = x
+warnPprTrace True msg x
+ = pprDebugAndThen defaultSDocContext trace (text "WARNING:")
+ (msg $$ withFrozenCallStack traceCallStackDoc )
+ x
+
+traceCallStackDoc :: HasCallStack => SDoc
+traceCallStackDoc =
+ hang (text "Call stack:")
+ 4 (vcat $ map text $ lines (prettyCallStack callStack))
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index b896cbbfb8..fe1beacc8b 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -361,6 +361,7 @@ Library
GHC.Core.Utils
GHC.Data.Bag
GHC.Data.Bitmap
+ GHC.Data.Bool
GHC.Data.BooleanFormula
GHC.Data.EnumSet
GHC.Data.FastMutInt
@@ -742,6 +743,7 @@ Library
GHC.Utils.Ppr
GHC.Utils.Ppr.Colour
GHC.Utils.TmpFs
+ GHC.Utils.Trace
Language.Haskell.Syntax
Language.Haskell.Syntax.Binds