diff options
Diffstat (limited to 'compiler/GHC')
57 files changed, 573 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)) |