diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2021-06-02 15:04:51 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-22 02:33:38 -0400 |
commit | 14956cb89d8548e531c99821ad504b4f35b5509a (patch) | |
tree | 175622c7f73df41c1e836be30a27c83914374ed6 /compiler | |
parent | 65bad0de6fd1431f0670002d68974adce3e9fc4a (diff) | |
download | haskell-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')
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 |