diff options
Diffstat (limited to 'compiler/GHC')
506 files changed, 16128 insertions, 1942 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 1b1bfdf7fe..70a48dd350 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -159,7 +159,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Module import GHC.Types.Name.Occurrence @@ -167,7 +167,7 @@ import GHC.Types.Name.Reader import GHC.Types.Unique import GHC.Types.Name import GHC.Types.SrcLoc -import FastString +import GHC.Data.FastString {- ************************************************************************ diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs index 7f83cd7521..5123754c55 100644 --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -6,7 +6,7 @@ module GHC.Builtin.Names.TH where -import GhcPrelude () +import GHC.Prelude () import GHC.Builtin.Names( mk_known_key_name ) import GHC.Types.Module( Module, mkModuleNameFS, mkModule, thUnitId ) @@ -14,7 +14,7 @@ import GHC.Types.Name( Name ) import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) import GHC.Types.Name.Reader( RdrName, nameRdrName ) import GHC.Types.Unique -import FastString +import GHC.Data.FastString -- To add a name, do three things -- diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index b6d7f898ef..1c53df523b 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -25,7 +25,7 @@ module GHC.Builtin.PrimOps ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Builtin.Types.Prim import GHC.Builtin.Types @@ -45,8 +45,8 @@ import GHC.Types.SrcLoc ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString ) import GHC.Types.Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique ) import GHC.Types.Module ( UnitId ) -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString {- ************************************************************************ diff --git a/compiler/GHC/Builtin/PrimOps.hs-boot b/compiler/GHC/Builtin/PrimOps.hs-boot index e9f913f602..506e8bca60 100644 --- a/compiler/GHC/Builtin/PrimOps.hs-boot +++ b/compiler/GHC/Builtin/PrimOps.hs-boot @@ -1,5 +1,5 @@ module GHC.Builtin.PrimOps where -import GhcPrelude () +import GHC.Prelude () data PrimOp diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 2e4ba28b6a..c1241fa7dd 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -130,7 +130,7 @@ module GHC.Builtin.Types ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId ) @@ -159,10 +159,10 @@ import GHC.Types.ForeignCall import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Types.Unique import Data.Array -import FastString -import Outputable -import Util -import BooleanFormula ( mkAnd ) +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Data.BooleanFormula ( mkAnd ) import qualified Data.ByteString.Char8 as BS diff --git a/compiler/GHC/Builtin/Types/Literals.hs b/compiler/GHC/Builtin/Types/Literals.hs index d5c1d209c6..ef6fb962fd 100644 --- a/compiler/GHC/Builtin/Types/Literals.hs +++ b/compiler/GHC/Builtin/Types/Literals.hs @@ -21,10 +21,10 @@ module GHC.Builtin.Types.Literals , typeSymbolAppendTyCon ) where -import GhcPrelude +import GHC.Prelude import GHC.Core.Type -import Pair +import GHC.Data.Pair import GHC.Tc.Utils.TcType ( TcType, tcEqType ) import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon , Injectivity(..) ) @@ -33,7 +33,7 @@ import GHC.Tc.Types.Constraint ( Xi ) import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) import GHC.Types.Name ( Name, BuiltInSyntax(..) ) import GHC.Builtin.Types -import GHC.Builtin.Types.Prim ( mkTemplateAnonTyConBinders ) +import GHC.Builtin.Types.Prim ( mkTemplateAnonTyConBinders ) import GHC.Builtin.Names ( gHC_TYPELITS , gHC_TYPENATS @@ -49,9 +49,7 @@ import GHC.Builtin.Names , typeSymbolCmpTyFamNameKey , typeSymbolAppendFamNameKey ) -import FastString ( FastString - , fsLit, nilFS, nullFS, unpackFS, mkFastString, appendFS - ) +import GHC.Data.FastString import qualified Data.Map as Map import Data.Maybe ( isJust ) import Control.Monad ( guard ) diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 4bee18b964..e138780c44 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -90,7 +90,7 @@ module GHC.Builtin.Types.Prim( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( runtimeRepTy, unboxedTupleKind, liftedTypeKind @@ -116,8 +116,8 @@ import GHC.Core.TyCon import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Builtin.Names -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid -- import loops which show up if you import Type instead diff --git a/compiler/GHC/Builtin/Uniques.hs b/compiler/GHC/Builtin/Uniques.hs index d73544378b..5c0e29b7de 100644 --- a/compiler/GHC/Builtin/Uniques.hs +++ b/compiler/GHC/Builtin/Uniques.hs @@ -26,17 +26,17 @@ module GHC.Builtin.Uniques #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Builtin.Types import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Types.Id import GHC.Types.Basic -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Name -import Util +import GHC.Utils.Misc import Data.Bits import Data.Maybe diff --git a/compiler/GHC/Builtin/Uniques.hs-boot b/compiler/GHC/Builtin/Uniques.hs-boot index f00490b538..3e24cd5a55 100644 --- a/compiler/GHC/Builtin/Uniques.hs-boot +++ b/compiler/GHC/Builtin/Uniques.hs-boot @@ -1,6 +1,6 @@ module GHC.Builtin.Uniques where -import GhcPrelude +import GHC.Prelude import GHC.Types.Unique import GHC.Types.Name import GHC.Types.Basic diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs index 2b8b0bf698..dc03f051bb 100644 --- a/compiler/GHC/Builtin/Utils.hs +++ b/compiler/GHC/Builtin/Utils.hs @@ -47,7 +47,7 @@ module GHC.Builtin.Utils ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Builtin.Uniques import GHC.Types.Unique ( isValidKnownKeyUnique ) @@ -63,14 +63,14 @@ import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make -import Outputable +import GHC.Utils.Outputable import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Driver.Types import GHC.Core.Class import GHC.Core.TyCon import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import GHC.Builtin.Types.Literals ( typeNatTyCons ) import GHC.Hs.Doc diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index f957215d38..9ed0283394 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -15,7 +15,7 @@ module GHC.ByteCode.Asm ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable @@ -28,13 +28,13 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Literal import GHC.Core.TyCon -import FastString +import GHC.Data.FastString import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Runtime.Heap.Layout import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable import GHC.Platform -import Util +import GHC.Utils.Misc import GHC.Types.Unique import GHC.Types.Unique.DSet diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs index 93fc4970c4..73f55f63cc 100644 --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -9,7 +9,7 @@ module GHC.ByteCode.InfoTable ( mkITbls ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.ByteCode.Types import GHC.Runtime.Interpreter @@ -22,8 +22,8 @@ import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons import GHC.Types.RepType import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) -import Util -import Panic +import GHC.Utils.Misc +import GHC.Utils.Panic {- Manufacturing of info tables for DataCons diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs index b473f418e3..8aa78749aa 100644 --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -11,15 +11,15 @@ module GHC.ByteCode.Instr ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.ByteCode.Types import GHCi.RemoteTypes import GHCi.FFI (C_ffi_cif) import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Core.Ppr -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Name import GHC.Types.Unique import GHC.Types.Id diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs index 9ad218e35e..3b61d1f889 100644 --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -18,7 +18,7 @@ module GHC.ByteCode.Linker ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHCi.RemoteTypes import GHCi.ResolvedBCO @@ -32,10 +32,10 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Builtin.PrimOps import GHC.Types.Module -import FastString -import Panic -import Outputable -import Util +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Utils.Misc -- Standard libraries import Data.Array.Unboxed diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs index 7073da63c2..55ad604447 100644 --- a/compiler/GHC/ByteCode/Types.hs +++ b/compiler/GHC/ByteCode/Types.hs @@ -13,13 +13,13 @@ module GHC.ByteCode.Types , CCostCentre ) where -import GhcPrelude +import GHC.Prelude -import FastString +import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env -import Outputable +import GHC.Utils.Outputable import GHC.Builtin.PrimOps import SizedSeq import GHC.Core.Type diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index fe5109aa6f..48ffd25f1b 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -28,7 +28,7 @@ module GHC.Cmm ( module GHC.Cmm.Expr, ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Id import GHC.Types.CostCentre @@ -41,7 +41,7 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label -import Outputable +import GHC.Utils.Outputable import Data.ByteString (ByteString) ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/BlockId.hs b/compiler/GHC/Cmm/BlockId.hs index e458c29902..e6396c8e83 100644 --- a/compiler/GHC/Cmm/BlockId.hs +++ b/compiler/GHC/Cmm/BlockId.hs @@ -8,7 +8,7 @@ module GHC.Cmm.BlockId , blockLbl, infoTblLbl ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.CLabel import GHC.Types.Id.Info diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index c6969be7ca..af1d7a6e98 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -114,7 +114,7 @@ module GHC.Cmm.CLabel ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Id.Info import GHC.Types.Basic @@ -125,12 +125,12 @@ import GHC.Types.Name import GHC.Types.Unique import GHC.Builtin.PrimOps import GHC.Types.CostCentre -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Driver.Session import GHC.Platform import GHC.Types.Unique.Set -import Util +import GHC.Utils.Misc import GHC.Core.Ppr ( {- instances -} ) import GHC.CmmToAsm.Config diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs index 6cd66be30c..35f63661fa 100644 --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -5,7 +5,7 @@ module GHC.Cmm.CallConv ( realArgRegsCover ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.Expr import GHC.Runtime.Heap.Layout @@ -14,7 +14,7 @@ import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Driver.Session import GHC.Platform -import Outputable +import GHC.Utils.Outputable -- Calculate the 'GlobalReg' or stack locations for function call -- parameters as used by the Cmm calling convention. diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs index 575e041e73..cc6cb2d40b 100644 --- a/compiler/GHC/Cmm/CommonBlockElim.hs +++ b/compiler/GHC/Cmm/CommonBlockElim.hs @@ -6,7 +6,7 @@ module GHC.Cmm.CommonBlockElim where -import GhcPrelude hiding (iterate, succ, unzip, zip) +import GHC.Prelude hiding (iterate, succ, unzip, zip) import GHC.Cmm.BlockId import GHC.Cmm @@ -23,8 +23,8 @@ import Data.Maybe (mapMaybe) import qualified Data.List as List import Data.Word import qualified Data.Map as M -import Outputable -import qualified TrieMap as TM +import GHC.Utils.Outputable +import qualified GHC.Data.TrieMap as TM import GHC.Types.Unique.FM import GHC.Types.Unique import Control.Arrow (first, second) diff --git a/compiler/GHC/Cmm/ContFlowOpt.hs b/compiler/GHC/Cmm/ContFlowOpt.hs index 1e5459f460..73c13d2040 100644 --- a/compiler/GHC/Cmm/ContFlowOpt.hs +++ b/compiler/GHC/Cmm/ContFlowOpt.hs @@ -10,7 +10,7 @@ module GHC.Cmm.ContFlowOpt ) where -import GhcPrelude hiding (succ, unzip, zip) +import GHC.Prelude hiding (succ, unzip, zip) import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections @@ -20,9 +20,9 @@ import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList) -import Maybes -import Panic -import Util +import GHC.Data.Maybe +import GHC.Utils.Panic +import GHC.Utils.Misc import Control.Monad diff --git a/compiler/GHC/Cmm/Dataflow.hs b/compiler/GHC/Cmm/Dataflow.hs index d697240191..05a91fe649 100644 --- a/compiler/GHC/Cmm/Dataflow.hs +++ b/compiler/GHC/Cmm/Dataflow.hs @@ -34,7 +34,7 @@ module GHC.Cmm.Dataflow ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Types.Unique.Supply diff --git a/compiler/GHC/Cmm/Dataflow/Block.hs b/compiler/GHC/Cmm/Dataflow/Block.hs index ac567ca605..1fa8d4dfd6 100644 --- a/compiler/GHC/Cmm/Dataflow/Block.hs +++ b/compiler/GHC/Cmm/Dataflow/Block.hs @@ -38,7 +38,7 @@ module GHC.Cmm.Dataflow.Block , replaceLastNode ) where -import GhcPrelude +import GHC.Prelude -- ----------------------------------------------------------------------------- -- Shapes: Open and Closed diff --git a/compiler/GHC/Cmm/Dataflow/Collections.hs b/compiler/GHC/Cmm/Dataflow/Collections.hs index bb762bf698..1fb8f5d52c 100644 --- a/compiler/GHC/Cmm/Dataflow/Collections.hs +++ b/compiler/GHC/Cmm/Dataflow/Collections.hs @@ -12,7 +12,7 @@ module GHC.Cmm.Dataflow.Collections , UniqueMap, UniqueSet ) where -import GhcPrelude +import GHC.Prelude import qualified Data.IntMap.Strict as M import qualified Data.IntSet as S diff --git a/compiler/GHC/Cmm/Dataflow/Graph.hs b/compiler/GHC/Cmm/Dataflow/Graph.hs index de146c6a35..3fbdae85ec 100644 --- a/compiler/GHC/Cmm/Dataflow/Graph.hs +++ b/compiler/GHC/Cmm/Dataflow/Graph.hs @@ -20,8 +20,8 @@ module GHC.Cmm.Dataflow.Graph ) where -import GhcPrelude -import Util +import GHC.Prelude +import GHC.Utils.Misc import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs index 70027570d3..a63cc63ed8 100644 --- a/compiler/GHC/Cmm/Dataflow/Label.hs +++ b/compiler/GHC/Cmm/Dataflow/Label.hs @@ -13,15 +13,15 @@ module GHC.Cmm.Dataflow.Label , mkHooplLabel ) where -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable -- TODO: This should really just use GHC's Unique and Uniq{Set,FM} import GHC.Cmm.Dataflow.Collections import GHC.Types.Unique (Uniquable(..)) -import TrieMap +import GHC.Data.TrieMap ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs index 99650e01ed..a3a7566a8b 100644 --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/compiler/GHC/Cmm/DebugBlock.hs @@ -25,7 +25,7 @@ module GHC.Cmm.DebugBlock ( UnwindExpr(..), toUnwindExpr ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.BlockId @@ -33,12 +33,12 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils import GHC.Core -import FastString ( nilFS, mkFastString ) +import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Types.Module -import Outputable +import GHC.Utils.Outputable import GHC.Cmm.Ppr.Expr ( pprExpr ) import GHC.Types.SrcLoc -import Util ( seqList ) +import GHC.Utils.Misc ( seqList ) import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs index bb3fe2e202..43d6734633 100644 --- a/compiler/GHC/Cmm/Expr.hs +++ b/compiler/GHC/Cmm/Expr.hs @@ -31,7 +31,7 @@ module GHC.Cmm.Expr ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.BlockId @@ -39,7 +39,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type import GHC.Driver.Session -import Outputable (panic) +import GHC.Utils.Outputable (panic) import GHC.Types.Unique import Data.Set (Set) diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs index 01fa4dc955..edf51d8b7f 100644 --- a/compiler/GHC/Cmm/Graph.hs +++ b/compiler/GHC/Cmm/Graph.hs @@ -21,7 +21,7 @@ module GHC.Cmm.Graph ) where -import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>) +import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>) import GHC.Cmm.BlockId import GHC.Cmm @@ -32,13 +32,13 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.ForeignCall -import OrdList +import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff) import GHC.Types.Unique.Supply -import Util -import Panic +import GHC.Utils.Misc +import GHC.Utils.Panic ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index 4ccd06adac..0c0fc98eb6 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -33,26 +33,26 @@ module GHC.Cmm.Info ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout import GHC.Data.Bitmap -import Stream (Stream) -import qualified Stream +import GHC.Data.Stream (Stream) +import qualified GHC.Data.Stream as Stream import GHC.Cmm.Dataflow.Collections import GHC.Platform -import Maybes +import GHC.Data.Maybe import GHC.Driver.Session -import ErrUtils (withTimingSilent) -import Panic +import GHC.Utils.Error (withTimingSilent) +import GHC.Utils.Panic import GHC.Types.Unique.Supply -import MonadUtils -import Util -import Outputable +import GHC.Utils.Monad +import GHC.Utils.Misc +import GHC.Utils.Outputable import Data.ByteString (ByteString) import Data.Bits diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index 8ee009f638..bf936d41d9 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -8,7 +8,7 @@ module GHC.Cmm.Info.Build , SRTMap, srtMapNonCAFs ) where -import GhcPrelude hiding (succ) +import GHC.Prelude hiding (succ) import GHC.Types.Id import GHC.Types.Id.Info @@ -20,13 +20,13 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Types.Module import GHC.Platform -import Digraph +import GHC.Data.Graph.Directed import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils import GHC.Driver.Session -import Maybes -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout import GHC.Types.Unique.Supply import GHC.Types.CostCentre diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs index 4cf7fcfdc1..232ab7934d 100644 --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -3,7 +3,7 @@ module GHC.Cmm.LayoutStack ( cmmLayoutStack, setInfoTableStackMap ) where -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation @@ -25,14 +25,14 @@ import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Types.Unique.Supply -import Maybes +import GHC.Data.Maybe import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import GHC.Platform import GHC.Driver.Session -import FastString -import Outputable hiding ( isEmpty ) +import GHC.Data.FastString +import GHC.Utils.Outputable hiding ( isEmpty ) import qualified Data.Set as Set import Control.Monad.Fix import Data.Array as Array diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x index d0fca50bd3..010001cd2a 100644 --- a/compiler/GHC/Cmm/Lexer.x +++ b/compiler/GHC/Cmm/Lexer.x @@ -15,7 +15,7 @@ module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.Expr @@ -23,10 +23,10 @@ import GHC.Parser.Lexer import GHC.Cmm.Monad import GHC.Types.SrcLoc import GHC.Types.Unique.FM -import StringBuffer -import FastString +import GHC.Data.StringBuffer +import GHC.Data.FastString import GHC.Parser.CharClass -import Util +import GHC.Utils.Misc --import TRACE import Data.Word diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index 3a96e82054..aa3e3a896e 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -11,7 +11,7 @@ module GHC.Cmm.Lint ( cmmLint, cmmLintGraph ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.Dataflow.Block @@ -23,7 +23,7 @@ import GHC.Cmm.Utils import GHC.Cmm.Liveness import GHC.Cmm.Switch (switchTargetsToList) import GHC.Cmm.Ppr () -- For Outputable instances -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session import Control.Monad (ap) diff --git a/compiler/GHC/Cmm/Liveness.hs b/compiler/GHC/Cmm/Liveness.hs index 10d4ca8dfd..c229e48529 100644 --- a/compiler/GHC/Cmm/Liveness.hs +++ b/compiler/GHC/Cmm/Liveness.hs @@ -12,7 +12,7 @@ module GHC.Cmm.Liveness ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Cmm.BlockId @@ -23,8 +23,8 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Label -import Maybes -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Outputable ----------------------------------------------------------------------------- -- Calculating what variables are live on entry to a basic block diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs index f1a1e9b699..1b3dd2a531 100644 --- a/compiler/GHC/Cmm/MachOp.hs +++ b/compiler/GHC/Cmm/MachOp.hs @@ -28,11 +28,11 @@ module GHC.Cmm.MachOp ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.Type -import Outputable +import GHC.Utils.Outputable ----------------------------------------------------------------------------- -- MachOp diff --git a/compiler/GHC/Cmm/Monad.hs b/compiler/GHC/Cmm/Monad.hs index d97df7719e..27cf51af4f 100644 --- a/compiler/GHC/Cmm/Monad.hs +++ b/compiler/GHC/Cmm/Monad.hs @@ -13,7 +13,7 @@ module GHC.Cmm.Monad ( , failMsgPD ) where -import GhcPrelude +import GHC.Prelude import Control.Monad diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index d5d020ee00..5e13483fae 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -26,15 +26,15 @@ module GHC.Cmm.Node ( CmmTickScope(..), isTickSubScope, combineTickScopes, ) where -import GhcPrelude hiding (succ) +import GHC.Prelude hiding (succ) import GHC.Platform.Regs import GHC.Cmm.Expr import GHC.Cmm.Switch import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.ForeignCall -import Outputable +import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout import GHC.Core (Tickish) import qualified GHC.Types.Unique as U @@ -46,7 +46,7 @@ import GHC.Cmm.Dataflow.Label import Data.Maybe import Data.List (tails,sortBy) import GHC.Types.Unique (nonDetCmpUnique) -import Util +import GHC.Utils.Misc ------------------------ diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs index a217f71c47..4ac24523c1 100644 --- a/compiler/GHC/Cmm/Opt.hs +++ b/compiler/GHC/Cmm/Opt.hs @@ -13,13 +13,13 @@ module GHC.Cmm.Opt ( cmmMachOpFoldM ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.Utils import GHC.Cmm -import Util +import GHC.Utils.Misc -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Bits diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 9ff637de70..7da85271f6 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -202,7 +202,7 @@ necessary to the stack to accommodate it (e.g. 2). module GHC.Cmm.Parser ( parseCmmFile ) where -import GhcPrelude +import GHC.Prelude import GHC.StgToCmm.ExtCode import GHC.Cmm.CallConv @@ -243,14 +243,14 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.SrcLoc import GHC.Driver.Session -import ErrUtils -import StringBuffer -import FastString -import Panic +import GHC.Utils.Error +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Utils.Panic import GHC.Settings.Constants -import Outputable +import GHC.Utils.Outputable import GHC.Types.Basic -import Bag ( emptyBag, unitBag ) +import GHC.Data.Bag ( emptyBag, unitBag ) import GHC.Types.Var import Control.Monad diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index e730cfda40..8d8deac91d 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -9,7 +9,7 @@ module GHC.Cmm.Pipeline ( cmmPipeline ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Cmm.Lint @@ -24,10 +24,10 @@ import GHC.Cmm.Dataflow.Collections import GHC.Types.Unique.Supply import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Types import Control.Monad -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Either (partitionEithers) diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs index d37b960c80..91bdfb40aa 100644 --- a/compiler/GHC/Cmm/Ppr.hs +++ b/compiler/GHC/Cmm/Ppr.hs @@ -40,7 +40,7 @@ module GHC.Cmm.Ppr ) where -import GhcPrelude hiding (succ) +import GHC.Prelude hiding (succ) import GHC.Platform import GHC.Driver.Session (targetPlatform) @@ -48,11 +48,11 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Cmm.Ppr.Decl import GHC.Cmm.Ppr.Expr -import Util +import GHC.Utils.Misc import GHC.Types.Basic import GHC.Cmm.Dataflow.Block diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs index d6ec1882b2..43a341bf85 100644 --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ b/compiler/GHC/Cmm/Ppr/Decl.hs @@ -40,15 +40,15 @@ module GHC.Cmm.Ppr.Decl ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.Ppr.Expr import GHC.Cmm import GHC.Driver.Session -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import Data.List import System.IO diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs index 9e25ededf6..fb8e158a2d 100644 --- a/compiler/GHC/Cmm/Ppr/Expr.hs +++ b/compiler/GHC/Cmm/Ppr/Expr.hs @@ -39,13 +39,13 @@ module GHC.Cmm.Ppr.Expr ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Driver.Session (targetPlatform) import GHC.Cmm.Expr -import Outputable +import GHC.Utils.Outputable import Data.Maybe import Numeric ( fromRat ) diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs index 9017c0eb0c..f9dc3a8334 100644 --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -9,7 +9,7 @@ module GHC.Cmm.ProcPoint ) where -import GhcPrelude hiding (last, unzip, succ, zip) +import GHC.Prelude hiding (last, unzip, succ, zip) import GHC.Driver.Session import GHC.Cmm.BlockId @@ -21,9 +21,9 @@ import GHC.Cmm.Info import GHC.Cmm.Liveness import GHC.Cmm.Switch import Data.List (sortBy) -import Maybes +import GHC.Data.Maybe import Control.Monad -import Outputable +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.Supply import GHC.Cmm.Dataflow.Block diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs index 3ca4fe9c75..8c32ab01aa 100644 --- a/compiler/GHC/Cmm/Sink.hs +++ b/compiler/GHC/Cmm/Sink.hs @@ -3,7 +3,7 @@ module GHC.Cmm.Sink ( cmmSink ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Cmm.Opt diff --git a/compiler/GHC/Cmm/Switch.hs b/compiler/GHC/Cmm/Switch.hs index f297bd8b5e..b8d7456b37 100644 --- a/compiler/GHC/Cmm/Switch.hs +++ b/compiler/GHC/Cmm/Switch.hs @@ -12,9 +12,9 @@ module GHC.Cmm.Switch ( createSwitchPlan, ) where -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session import GHC.Cmm.Dataflow.Label (Label) diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs index b098917711..3279c5ab05 100644 --- a/compiler/GHC/Cmm/Switch/Implement.hs +++ b/compiler/GHC/Cmm/Switch/Implement.hs @@ -4,7 +4,7 @@ module GHC.Cmm.Switch.Implement ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.Dataflow.Block @@ -14,7 +14,7 @@ import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Types.Unique.Supply import GHC.Driver.Session -import MonadUtils (concatMapM) +import GHC.Utils.Monad (concatMapM) -- -- This module replaces Switch statements as generated by the Stg -> Cmm diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs index fced2bf076..bddc933bf1 100644 --- a/compiler/GHC/Cmm/Type.hs +++ b/compiler/GHC/Cmm/Type.hs @@ -29,12 +29,12 @@ module GHC.Cmm.Type where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Driver.Session -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import Data.Word import Data.Int diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index c23975bb44..a49557a07e 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -71,7 +71,7 @@ module GHC.Cmm.Utils( blockTicks ) where -import GhcPrelude +import GHC.Prelude import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) @@ -81,7 +81,7 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session import GHC.Types.Unique import GHC.Platform.Regs diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 56ac9ceaf5..374b6c47e8 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -30,7 +30,7 @@ module GHC.CmmToAsm ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import qualified GHC.CmmToAsm.X86.CodeGen as X86.CodeGen import qualified GHC.CmmToAsm.X86.Regs as X86.Regs @@ -53,12 +53,12 @@ import qualified GHC.CmmToAsm.PPC.Ppr as PPC.Ppr import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear as Linear -import qualified GraphColor as Color +import qualified GHC.Data.Graph.Color as Color import qualified GHC.CmmToAsm.Reg.Graph as Color import qualified GHC.CmmToAsm.Reg.Graph.Stats as Color import qualified GHC.CmmToAsm.Reg.Graph.TrivColorable as Color -import AsmUtils +import GHC.Utils.Asm import GHC.CmmToAsm.Reg.Target import GHC.Platform import GHC.CmmToAsm.BlockLayout as BlockLayout @@ -86,21 +86,21 @@ import GHC.Cmm.CLabel import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Driver.Session -import Util +import GHC.Utils.Misc import GHC.Types.Basic ( Alignment ) -import qualified Pretty -import BufWrite -import Outputable -import FastString +import qualified GHC.Utils.Ppr as Pretty +import GHC.Utils.BufHandle +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString import GHC.Types.Unique.Set -import ErrUtils +import GHC.Utils.Error import GHC.Types.Module -import Stream (Stream) -import qualified Stream +import GHC.Data.Stream (Stream) +import qualified GHC.Data.Stream as Stream -- DEBUGGING ONLY ---import OrdList +--import GHC.Data.OrdList import Data.List import Data.Maybe diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs index 7ff90e8c40..07faa91473 100644 --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -14,7 +14,7 @@ module GHC.CmmToAsm.BlockLayout where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Monad @@ -28,19 +28,19 @@ import GHC.Cmm.Dataflow.Label import GHC.Platform import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform) import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import GHC.Types.Unique -import Digraph -import Outputable -import Maybes +import GHC.Data.Graph.Directed +import GHC.Utils.Outputable +import GHC.Data.Maybe -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import Debug.Trace -import ListSetOps (removeDups) +import GHC.Data.List.SetOps (removeDups) -import OrdList +import GHC.Data.OrdList import Data.List import Data.Foldable (toList) diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs index dca02b0eb5..ad3a3cdae7 100644 --- a/compiler/GHC/CmmToAsm/CFG.hs +++ b/compiler/GHC/CmmToAsm/CFG.hs @@ -44,7 +44,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Cmm.BlockId import GHC.Cmm as Cmm @@ -56,9 +56,9 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block import qualified GHC.Cmm.Dataflow.Graph as G -import Util -import Digraph -import Maybes +import GHC.Utils.Misc +import GHC.Data.Graph.Directed +import GHC.Data.Maybe import GHC.Types.Unique import qualified GHC.CmmToAsm.CFG.Dominators as Dom @@ -72,10 +72,10 @@ import qualified Data.Set as S import Data.Tree import Data.Bifunctor -import Outputable +import GHC.Utils.Outputable -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock ---import OrdList +--import GHC.Data.OrdList --import GHC.Cmm.DebugBlock.Trace import GHC.Cmm.Ppr () -- For Outputable instances import qualified GHC.Driver.Session as D diff --git a/compiler/GHC/CmmToAsm/CFG/Dominators.hs b/compiler/GHC/CmmToAsm/CFG/Dominators.hs index b9dcacd8cb..bb28e877d7 100644 --- a/compiler/GHC/CmmToAsm/CFG/Dominators.hs +++ b/compiler/GHC/CmmToAsm/CFG/Dominators.hs @@ -38,7 +38,7 @@ module GHC.CmmToAsm.CFG.Dominators ( ,parents,ancestors
) where
-import GhcPrelude
+import GHC.Prelude
import Data.Bifunctor
import Data.Tuple (swap)
@@ -58,7 +58,7 @@ import Data.Array.Base hiding ((!)) -- ,unsafeWrite,unsafeRead
-- ,readArray,writeArray)
-import Util (debugIsOn)
+import GHC.Utils.Misc (debugIsOn)
-----------------------------------------------------------------------------
diff --git a/compiler/GHC/CmmToAsm/CPrim.hs b/compiler/GHC/CmmToAsm/CPrim.hs index 34c3a7ff6a..fc2d06262b 100644 --- a/compiler/GHC/CmmToAsm/CPrim.hs +++ b/compiler/GHC/CmmToAsm/CPrim.hs @@ -14,11 +14,11 @@ module GHC.CmmToAsm.CPrim , word2FloatLabel ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.Type import GHC.Cmm.MachOp -import Outputable +import GHC.Utils.Outputable popCntLabel :: Width -> String popCntLabel w = "hs_popcnt" ++ pprWidth w diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs index 52c0995bdf..cbd15d0580 100644 --- a/compiler/GHC/CmmToAsm/Config.hs +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -6,7 +6,7 @@ module GHC.CmmToAsm.Config ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Cmm.Type (Width(..)) import GHC.Types.Module diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index 8075bdd27e..bc5e82c316 100644 --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/compiler/GHC/CmmToAsm/Dwarf.hs @@ -2,7 +2,7 @@ module GHC.CmmToAsm.Dwarf ( dwarfGen ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.CLabel import GHC.Cmm.Expr ( GlobalReg(..) ) @@ -11,7 +11,7 @@ import GHC.Core ( Tickish(..) ) import GHC.Cmm.DebugBlock import GHC.Driver.Session import GHC.Types.Module -import Outputable +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique import GHC.Types.Unique.Supply diff --git a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs index 29592c106e..e550813be1 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs @@ -3,12 +3,12 @@ module GHC.CmmToAsm.Dwarf.Constants where -import GhcPrelude +import GHC.Prelude -import AsmUtils -import FastString +import GHC.Utils.Asm +import GHC.Data.FastString import GHC.Platform -import Outputable +import GHC.Utils.Outputable import GHC.Platform.Reg import GHC.CmmToAsm.X86.Regs diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs index eaeb570595..41c0dd518d 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -22,19 +22,19 @@ module GHC.CmmToAsm.Dwarf.Types ) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.DebugBlock import GHC.Cmm.CLabel import GHC.Cmm.Expr ( GlobalReg(..) ) -import Encoding -import FastString -import Outputable +import GHC.Utils.Encoding +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique import GHC.Platform.Reg import GHC.Types.SrcLoc -import Util +import GHC.Utils.Misc import GHC.CmmToAsm.Dwarf.Constants diff --git a/compiler/GHC/CmmToAsm/Format.hs b/compiler/GHC/CmmToAsm/Format.hs index 446c760939..0049d2c987 100644 --- a/compiler/GHC/CmmToAsm/Format.hs +++ b/compiler/GHC/CmmToAsm/Format.hs @@ -20,10 +20,10 @@ module GHC.CmmToAsm.Format ( where -import GhcPrelude +import GHC.Prelude import GHC.Cmm -import Outputable +import GHC.Utils.Outputable -- It looks very like the old MachRep, but it's now of purely local -- significance, here in the native code generator. You can change it diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs index 01f703340b..833a72a74a 100644 --- a/compiler/GHC/CmmToAsm/Instr.hs +++ b/compiler/GHC/CmmToAsm/Instr.hs @@ -14,7 +14,7 @@ module GHC.CmmToAsm.Instr ( where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Platform.Reg diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs index 07c3cc809b..9d5cf246c2 100644 --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -46,7 +46,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Platform.Reg @@ -59,7 +59,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel ( CLabel ) import GHC.Cmm.DebugBlock -import FastString ( FastString ) +import GHC.Data.FastString ( FastString ) import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Types.Unique ( Unique ) @@ -69,7 +69,7 @@ import GHC.Types.Module import Control.Monad ( ap ) import GHC.CmmToAsm.Instr -import Outputable (SDoc, pprPanic, ppr) +import GHC.Utils.Outputable (SDoc, pprPanic, ppr) import GHC.Cmm (RawCmmDecl, RawCmmStatics) import GHC.CmmToAsm.CFG diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs index d60821ee10..5b237fc7db 100644 --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -47,7 +47,7 @@ module GHC.CmmToAsm.PIC ( where -import GhcPrelude +import GHC.Prelude import qualified GHC.CmmToAsm.PPC.Instr as PPC import qualified GHC.CmmToAsm.PPC.Regs as PPC @@ -73,10 +73,10 @@ import GHC.Cmm.CLabel ( mkForeignLabel ) import GHC.Types.Basic import GHC.Types.Module -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session -import FastString +import GHC.Data.FastString diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index 16557dba71..764945c2bc 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -23,7 +23,7 @@ where #include "HsVersions.h" -- NCG stuff: -import GhcPrelude +import GHC.Prelude import GHC.Platform.Regs import GHC.CmmToAsm.PPC.Instr @@ -60,16 +60,16 @@ import GHC.Core ( Tickish(..) ) import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) -- The rest: -import OrdList -import Outputable +import GHC.Data.OrdList +import GHC.Utils.Outputable import Control.Monad ( mapAndUnzipM, when ) import Data.Bits import Data.Word import GHC.Types.Basic -import FastString -import Util +import GHC.Data.FastString +import GHC.Utils.Misc -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector diff --git a/compiler/GHC/CmmToAsm/PPC/Cond.hs b/compiler/GHC/CmmToAsm/PPC/Cond.hs index e8efa30064..a8f7aac877 100644 --- a/compiler/GHC/CmmToAsm/PPC/Cond.hs +++ b/compiler/GHC/CmmToAsm/PPC/Cond.hs @@ -8,9 +8,9 @@ module GHC.CmmToAsm.PPC.Cond ( where -import GhcPrelude +import GHC.Prelude -import Panic +import GHC.Utils.Panic data Cond = ALWAYS diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs index 674b19ef93..26c50bcdc8 100644 --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -24,7 +24,7 @@ module GHC.CmmToAsm.PPC.Instr ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.PPC.Cond @@ -41,9 +41,9 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.Info -import FastString +import GHC.Data.FastString import GHC.Cmm.CLabel -import Outputable +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM) import GHC.Types.Unique.Supply diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index 15e72bbb49..4ef5437b71 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -9,7 +9,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.CmmToAsm.PPC.Ppr (pprNatCmmDecl) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.PPC.Instr @@ -32,8 +32,8 @@ import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Driver.Session (targetPlatform) import Data.Word diff --git a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs index 58e3f44ece..0e0f1e464d 100644 --- a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs +++ b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs @@ -19,7 +19,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.PPC.Instr @@ -28,7 +28,7 @@ import GHC.Cmm import GHC.Cmm.CLabel import GHC.Types.Unique -import Outputable (ppr, text, Outputable, (<>)) +import GHC.Utils.Outputable (ppr, text, Outputable, (<>)) data JumpDest = DestBlockId BlockId diff --git a/compiler/GHC/CmmToAsm/PPC/Regs.hs b/compiler/GHC/CmmToAsm/PPC/Regs.hs index b37fb400fc..a92c7f00ef 100644 --- a/compiler/GHC/CmmToAsm/PPC/Regs.hs +++ b/compiler/GHC/CmmToAsm/PPC/Regs.hs @@ -50,7 +50,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg import GHC.Platform.Reg.Class @@ -61,7 +61,7 @@ import GHC.Cmm.CLabel ( CLabel ) import GHC.Types.Unique import GHC.Platform.Regs -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Word ( Word8, Word16, Word32, Word64 ) diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs index c0abb52ad3..405bab9fff 100644 --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -21,14 +21,14 @@ module GHC.CmmToAsm.Ppr ( where -import GhcPrelude +import GHC.Prelude -import AsmUtils +import GHC.Utils.Asm import GHC.Cmm.CLabel import GHC.Cmm import GHC.CmmToAsm.Config -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform import qualified Data.Array.Unsafe as U ( castSTUArray ) @@ -96,7 +96,7 @@ doubleToBytes d -- Printing ASCII strings. -- -- Print as a string and escape non-printable characters. --- This is similar to charToC in Utils. +-- This is similar to charToC in GHC.Utils.Misc pprASCII :: ByteString -> SDoc pprASCII str diff --git a/compiler/GHC/CmmToAsm/Reg/Graph.hs b/compiler/GHC/CmmToAsm/Reg/Graph.hs index 443072b246..022c9eed4c 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph.hs @@ -5,9 +5,9 @@ module GHC.CmmToAsm.Reg.Graph ( regAlloc ) where -import GhcPrelude +import GHC.Prelude -import qualified GraphColor as Color +import qualified GHC.Data.Graph.Color as Color import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Graph.Spill import GHC.CmmToAsm.Reg.Graph.SpillClean @@ -20,13 +20,13 @@ import GHC.CmmToAsm.Config import GHC.Platform.Reg.Class import GHC.Platform.Reg -import Bag -import Outputable +import GHC.Data.Bag +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import Util (seqList) +import GHC.Utils.Misc (seqList) import GHC.CmmToAsm.CFG import Data.Maybe diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs index ba3f825149..86c25c5a24 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs @@ -22,12 +22,12 @@ module GHC.CmmToAsm.Reg.Graph.Base ( squeese ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique -import MonadUtils (concatMapM) +import GHC.Utils.Monad (concatMapM) -- Some basic register classes. diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs index dd28981261..0bdee541ed 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs @@ -3,15 +3,15 @@ module GHC.CmmToAsm.Reg.Graph.Coalesce ( regCoalesce, slurpJoinMovs ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.Cmm -import Bag -import Digraph +import GHC.Data.Bag +import GHC.Data.Graph.Directed import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Types.Unique.Supply diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs index 5ae55334a2..4694ba6b96 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -7,7 +7,7 @@ module GHC.CmmToAsm.Reg.Graph.Spill ( SpillStats(..), accSpillSL ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr @@ -16,13 +16,13 @@ import GHC.Cmm hiding (RegSet) import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections -import MonadUtils -import State +import GHC.Utils.Monad +import GHC.Utils.Monad.State import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.List diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs index ac784582e7..c810aeeac4 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -29,7 +29,7 @@ module GHC.CmmToAsm.Reg.Graph.SpillClean ( cleanSpills ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr @@ -40,8 +40,8 @@ import GHC.Cmm import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique -import State -import Outputable +import GHC.Utils.Monad.State +import GHC.Utils.Outputable import GHC.Platform import GHC.Cmm.Dataflow.Collections diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs index 6484a38d79..995b286839 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs @@ -13,24 +13,24 @@ module GHC.CmmToAsm.Reg.Graph.SpillCost ( lifeMapFromSpillCostInfo ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.Platform.Reg.Class import GHC.Platform.Reg -import GraphBase +import GHC.Data.Graph.Base import GHC.Cmm.Dataflow.Collections (mapLookup) import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Types.Unique.FM import GHC.Types.Unique.Set -import Digraph (flattenSCCs) -import Outputable +import GHC.Data.Graph.Directed (flattenSCCs) +import GHC.Utils.Outputable import GHC.Platform -import State +import GHC.Utils.Monad.State import GHC.CmmToAsm.CFG import Data.List (nub, minimumBy) diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs index a06a22fa05..ddd353c4f2 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -16,9 +16,9 @@ module GHC.CmmToAsm.Reg.Graph.Stats ( countSRMs, addSRM ) where -import GhcPrelude +import GHC.Prelude -import qualified GraphColor as Color +import qualified GHC.Data.Graph.Color as Color import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Graph.Spill import GHC.CmmToAsm.Reg.Graph.SpillCost @@ -29,10 +29,10 @@ import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target import GHC.Platform -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique.FM import GHC.Types.Unique.Set -import State +import GHC.Utils.Monad.State -- | Holds interesting statistics from the register allocator. data RegAllocStats statics instr diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs index 4cf3d98eb1..0370670b21 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -8,16 +8,16 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg.Class import GHC.Platform.Reg -import GraphBase +import GHC.Data.Graph.Base import GHC.Types.Unique.Set import GHC.Platform -import Panic +import GHC.Utils.Panic -- trivColorable --------------------------------------------------------------- diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs b/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs index c673c69c1d..d63cc819ac 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs @@ -15,7 +15,7 @@ module GHC.CmmToAsm.Reg.Graph.X86 ( squeese, ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Graph.Base (Reg(..), RegSub(..), RegClass(..)) import GHC.Types.Unique.Set diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs index a093bad83a..00b4915d7b 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -104,7 +104,7 @@ module GHC.CmmToAsm.Reg.Linear ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.State import GHC.CmmToAsm.Reg.Linear.Base @@ -126,12 +126,12 @@ import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Cmm hiding (RegSet) -import Digraph +import GHC.Data.Graph.Directed import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Maybe diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs index 95036adb26..5784660e3f 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -17,14 +17,14 @@ module GHC.CmmToAsm.Reg.Linear.Base ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.StackMap import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Config import GHC.Platform.Reg -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Supply diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs index e340dcf5c6..b4fa0f8b76 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -9,13 +9,13 @@ module GHC.CmmToAsm.Reg.Linear.FreeRegs ( where -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg import GHC.Platform.Reg.Class import GHC.CmmToAsm.Config -import Panic +import GHC.Utils.Panic import GHC.Platform -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs index 55735913d4..4ceaf4573b 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -10,7 +10,7 @@ -- module GHC.CmmToAsm.Reg.Linear.JoinToTargets (joinToTargets) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.State import GHC.CmmToAsm.Reg.Linear.Base @@ -22,8 +22,8 @@ import GHC.Platform.Reg import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections -import Digraph -import Outputable +import GHC.Data.Graph.Directed +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs index ce0a187647..fe19164357 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs @@ -1,13 +1,13 @@ -- | Free regs map for PowerPC module GHC.CmmToAsm.Reg.Linear.PPC where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.PPC.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Word diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs index 7fa85f0913..ac7dc85366 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs @@ -3,14 +3,14 @@ -- | Free regs map for SPARC module GHC.CmmToAsm.Reg.Linear.SPARC where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.Platform.Regs -import Outputable +import GHC.Utils.Outputable import GHC.Platform import Data.Word diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs index c2477fc18f..29864f9752 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs @@ -20,7 +20,7 @@ module GHC.CmmToAsm.Reg.Linear.StackMap ( where -import GhcPrelude +import GHC.Prelude import GHC.Types.Unique.FM import GHC.Types.Unique diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs index cf8913e211..f96cc71239 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs @@ -38,7 +38,7 @@ module GHC.CmmToAsm.Reg.Linear.State ( ) where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.Stats import GHC.CmmToAsm.Reg.Linear.StackMap diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs index 84acc3a417..414128b32c 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs @@ -6,16 +6,16 @@ module GHC.CmmToAsm.Reg.Linear.Stats ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.Types.Unique.FM -import Outputable +import GHC.Utils.Outputable -import State +import GHC.Utils.Monad.State -- | Build a map of how many times each reg was alloced, clobbered, loaded etc. binSpillReasons diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs index ce103bd6b2..ae37b0f9d1 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs @@ -2,12 +2,12 @@ -- | Free regs map for i386 module GHC.CmmToAsm.Reg.Linear.X86 where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg -import Panic +import GHC.Utils.Panic import GHC.Platform import Data.Word diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs index 322ddd6bdd..325e033e85 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs @@ -2,12 +2,12 @@ -- | Free regs map for x86_64 module GHC.CmmToAsm.Reg.Linear.X86_64 where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg -import Panic +import GHC.Utils.Panic import GHC.Platform import Data.Word diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs index 5f5d4c8ff3..f650ad6186 100644 --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -37,7 +37,7 @@ module GHC.CmmToAsm.Reg.Liveness ( regLiveness, cmmTopLiveness ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg import GHC.CmmToAsm.Instr @@ -49,15 +49,15 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm hiding (RegSet, emptyRegSet) -import Digraph -import MonadUtils -import Outputable +import GHC.Data.Graph.Directed +import GHC.Utils.Monad +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import Bag -import State +import GHC.Data.Bag +import GHC.Utils.Monad.State import Data.List import Data.Maybe diff --git a/compiler/GHC/CmmToAsm/Reg/Target.hs b/compiler/GHC/CmmToAsm/Reg/Target.hs index 183d329790..d4bc561faa 100644 --- a/compiler/GHC/CmmToAsm/Reg/Target.hs +++ b/compiler/GHC/CmmToAsm/Reg/Target.hs @@ -21,13 +21,13 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform.Reg import GHC.Platform.Reg.Class import GHC.CmmToAsm.Format -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs b/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs index 6cc660bba9..b99b75f5eb 100644 --- a/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs +++ b/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs @@ -6,7 +6,7 @@ module GHC.CmmToAsm.SPARC.AddrMode ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.SPARC.Base diff --git a/compiler/GHC/CmmToAsm/SPARC/Base.hs b/compiler/GHC/CmmToAsm/SPARC/Base.hs index 85b1de9ef3..a7929081b3 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Base.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Base.hs @@ -17,9 +17,9 @@ module GHC.CmmToAsm.SPARC.Base ( where -import GhcPrelude +import GHC.Prelude -import Panic +import GHC.Utils.Panic import Data.Int diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs index f88b2140a1..2112983e73 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -20,7 +20,7 @@ where #include "HsVersions.h" -- NCG stuff: -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Base import GHC.CmmToAsm.SPARC.CodeGen.Sanity @@ -53,9 +53,9 @@ import GHC.CmmToAsm.CPrim -- The rest: import GHC.Types.Basic -import FastString -import OrdList -import Outputable +import GHC.Data.FastString +import GHC.Data.OrdList +import GHC.Utils.Outputable import GHC.Platform import Control.Monad ( mapAndUnzipM ) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs index 75eba25023..87fb09d7d6 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs @@ -4,7 +4,7 @@ module GHC.CmmToAsm.SPARC.CodeGen.Amode ( where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 import GHC.CmmToAsm.SPARC.CodeGen.Base @@ -18,7 +18,7 @@ import GHC.CmmToAsm.Format import GHC.Cmm -import OrdList +import GHC.Data.OrdList -- | Generate code to reference a memory address. diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs index f00e60ca93..34ee34295d 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs @@ -13,7 +13,7 @@ module GHC.CmmToAsm.SPARC.CodeGen.Base ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Cond @@ -27,8 +27,8 @@ import GHC.Cmm import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Platform -import Outputable -import OrdList +import GHC.Utils.Outputable +import GHC.Data.OrdList -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs index 3f8912a9c4..0a6de1a034 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs @@ -6,7 +6,7 @@ module GHC.CmmToAsm.SPARC.CodeGen.CondCode ( where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 import GHC.CmmToAsm.SPARC.CodeGen.Base @@ -20,8 +20,8 @@ import GHC.CmmToAsm.Format import GHC.Cmm -import OrdList -import Outputable +import GHC.Data.OrdList +import GHC.Utils.Outputable getCondCode :: CmmExpr -> NatM CondCode diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs index 77732cf70c..495a973c90 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs @@ -7,7 +7,7 @@ module GHC.CmmToAsm.SPARC.CodeGen.Expand ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Imm @@ -19,8 +19,8 @@ import GHC.CmmToAsm.Format import GHC.Cmm -import Outputable -import OrdList +import GHC.Utils.Outputable +import GHC.Data.OrdList -- | Expand out synthetic instructions in this top level thing expandTop :: NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs index 494e407d19..e5b5990150 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs @@ -6,7 +6,7 @@ module GHC.CmmToAsm.SPARC.CodeGen.Gen32 ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.CodeGen.CondCode import GHC.CmmToAsm.SPARC.CodeGen.Amode @@ -26,8 +26,8 @@ import GHC.Platform.Reg import GHC.Cmm import Control.Monad (liftM) -import OrdList -import Outputable +import GHC.Data.OrdList +import GHC.Utils.Outputable -- | The dual to getAnyReg: compute an expression into a register, but -- we don't mind which one it is. diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs index 18b22b2a1e..00a94ceb24 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs @@ -7,7 +7,7 @@ module GHC.CmmToAsm.SPARC.CodeGen.Gen64 ( where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 import GHC.CmmToAsm.SPARC.CodeGen.Base @@ -24,8 +24,8 @@ import GHC.Platform.Reg import GHC.Cmm -import OrdList -import Outputable +import GHC.Data.OrdList +import GHC.Utils.Outputable -- | Code to assign a 64 bit value to memory. assignMem_I64Code diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs index f8648c4549..f6ec24434c 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs @@ -6,7 +6,7 @@ module GHC.CmmToAsm.SPARC.CodeGen.Sanity ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Ppr () -- For Outputable instances @@ -14,7 +14,7 @@ import GHC.CmmToAsm.Instr import GHC.Cmm -import Outputable +import GHC.Utils.Outputable -- | Enforce intra-block invariants. diff --git a/compiler/GHC/CmmToAsm/SPARC/Cond.hs b/compiler/GHC/CmmToAsm/SPARC/Cond.hs index 89b64b7c3a..035de3dd7e 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Cond.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Cond.hs @@ -7,7 +7,7 @@ module GHC.CmmToAsm.SPARC.Cond ( where -import GhcPrelude +import GHC.Prelude -- | Branch condition codes. data Cond diff --git a/compiler/GHC/CmmToAsm/SPARC/Imm.hs b/compiler/GHC/CmmToAsm/SPARC/Imm.hs index 71b0257ac5..fd4185565c 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Imm.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Imm.hs @@ -7,12 +7,12 @@ module GHC.CmmToAsm.SPARC.Imm ( where -import GhcPrelude +import GHC.Prelude import GHC.Cmm import GHC.Cmm.CLabel -import Outputable +import GHC.Utils.Outputable -- | An immediate value. -- Not all of these are directly representable by the machine. diff --git a/compiler/GHC/CmmToAsm/SPARC/Instr.hs b/compiler/GHC/CmmToAsm/SPARC/Instr.hs index a1f890bc6d..6da02818db 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Instr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Instr.hs @@ -24,7 +24,7 @@ module GHC.CmmToAsm.SPARC.Instr ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Stack import GHC.CmmToAsm.SPARC.Imm @@ -43,8 +43,8 @@ import GHC.Cmm.CLabel import GHC.Platform.Regs import GHC.Cmm.BlockId import GHC.Cmm -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs index 661db9dfbb..3943610346 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs @@ -24,7 +24,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Instr @@ -46,9 +46,9 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections import GHC.Types.Unique ( pprUniqueAlways ) -import Outputable +import GHC.Utils.Outputable import GHC.Platform -import FastString +import GHC.Data.FastString -- ----------------------------------------------------------------------------- -- Printing this stuff out diff --git a/compiler/GHC/CmmToAsm/SPARC/Regs.hs b/compiler/GHC/CmmToAsm/SPARC/Regs.hs index d6d5d87bf6..9ee68baee2 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Regs.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Regs.hs @@ -32,7 +32,7 @@ module GHC.CmmToAsm.SPARC.Regs ( where -import GhcPrelude +import GHC.Prelude import GHC.Platform.SPARC import GHC.Platform.Reg @@ -40,7 +40,7 @@ import GHC.Platform.Reg.Class import GHC.CmmToAsm.Format import GHC.Types.Unique -import Outputable +import GHC.Utils.Outputable {- The SPARC has 64 registers of interest; 32 integer registers and 32 diff --git a/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs b/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs index 98f55d13d8..2c5b90d964 100644 --- a/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs +++ b/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs @@ -8,7 +8,7 @@ module GHC.CmmToAsm.SPARC.ShortcutJump ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Imm @@ -17,8 +17,8 @@ import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm -import Panic -import Outputable +import GHC.Utils.Panic +import GHC.Utils.Outputable data JumpDest = DestBlockId BlockId diff --git a/compiler/GHC/CmmToAsm/SPARC/Stack.hs b/compiler/GHC/CmmToAsm/SPARC/Stack.hs index 861d1ad691..4333f767f7 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Stack.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Stack.hs @@ -7,7 +7,7 @@ module GHC.CmmToAsm.SPARC.Stack ( where -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Regs @@ -15,7 +15,7 @@ import GHC.CmmToAsm.SPARC.Base import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.Config -import Outputable +import GHC.Utils.Outputable -- | Get an AddrMode relative to the address in sp. -- This gives us a stack relative addressing mode for volatile diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index 4bbf791102..2796bc32dc 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -36,7 +36,7 @@ where #include "HsVersions.h" -- NCG stuff: -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Instr import GHC.CmmToAsm.X86.Cond @@ -81,11 +81,11 @@ import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) -- The rest: import GHC.Types.ForeignCall ( CCallConv(..) ) -import OrdList -import Outputable -import FastString +import GHC.Data.OrdList +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Driver.Session -import Util +import GHC.Utils.Misc import GHC.Types.Unique.Supply ( getUniqueM ) import Control.Monad diff --git a/compiler/GHC/CmmToAsm/X86/Cond.hs b/compiler/GHC/CmmToAsm/X86/Cond.hs index bb8f61438b..424a1718b0 100644 --- a/compiler/GHC/CmmToAsm/X86/Cond.hs +++ b/compiler/GHC/CmmToAsm/X86/Cond.hs @@ -9,7 +9,7 @@ module GHC.CmmToAsm.X86.Cond ( where -import GhcPrelude +import GHC.Prelude data Cond = ALWAYS -- What's really used? ToDo diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs index 9c5888c21d..67a6ffb930 100644 --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -18,7 +18,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.X86.Regs @@ -34,8 +34,8 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Platform.Regs import GHC.Cmm -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Basic (Alignment) diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs index 0b0c406bc4..41c94f90c6 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -22,7 +22,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.X86.Regs import GHC.CmmToAsm.X86.Instr @@ -43,8 +43,8 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Types.Unique ( pprUniqueAlways ) import GHC.Platform -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import Data.Word import Data.Bits diff --git a/compiler/GHC/CmmToAsm/X86/RegInfo.hs b/compiler/GHC/CmmToAsm/X86/RegInfo.hs index 5b2464c415..de11279d54 100644 --- a/compiler/GHC/CmmToAsm/X86/RegInfo.hs +++ b/compiler/GHC/CmmToAsm/X86/RegInfo.hs @@ -8,12 +8,12 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm.Format import GHC.Platform.Reg -import Outputable +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique diff --git a/compiler/GHC/CmmToAsm/X86/Regs.hs b/compiler/GHC/CmmToAsm/X86/Regs.hs index ab8e6d3b4f..8e6f215d3c 100644 --- a/compiler/GHC/CmmToAsm/X86/Regs.hs +++ b/compiler/GHC/CmmToAsm/X86/Regs.hs @@ -49,7 +49,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform.Regs import GHC.Platform.Reg @@ -57,7 +57,7 @@ import GHC.Platform.Reg.Class import GHC.Cmm import GHC.Cmm.CLabel ( CLabel ) -import Outputable +import GHC.Utils.Outputable import GHC.Platform import qualified Data.Array as A diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index 3eddd87785..f4b8878fe2 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -26,7 +26,7 @@ module GHC.CmmToC ( #include "HsVersions.h" -- Cmm stuff -import GhcPrelude +import GHC.Prelude import GHC.Cmm.BlockId import GHC.Cmm.CLabel @@ -42,13 +42,13 @@ import GHC.Cmm.Switch -- Utils import GHC.CmmToAsm.CPrim import GHC.Driver.Session -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique -import Util +import GHC.Utils.Misc -- The rest import Data.ByteString (ByteString) diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs index ea69809c13..f91f3578e6 100644 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -13,7 +13,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -28,14 +28,14 @@ import GHC.Cmm import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Ppr -import BufWrite +import GHC.Utils.BufHandle import GHC.Driver.Session import GHC.Platform ( platformArch, Arch(..) ) -import ErrUtils -import FastString -import Outputable +import GHC.Utils.Error +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.SysTools ( figureLlvmVersion ) -import qualified Stream +import qualified GHC.Data.Stream as Stream import Control.Monad ( when, forM_ ) import Data.Maybe ( fromMaybe, catMaybes ) diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index b36b4814f1..99f5bd53a4 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -41,7 +41,7 @@ module GHC.CmmToLlvm.Base ( #include "HsVersions.h" #include "ghcautoconf.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Regs @@ -49,18 +49,18 @@ import GHC.CmmToLlvm.Regs import GHC.Cmm.CLabel import GHC.Platform.Regs ( activeStgRegs ) import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Cmm hiding ( succ ) import GHC.Cmm.Utils (regsOverlap) -import Outputable as Outp +import GHC.Utils.Outputable as Outp import GHC.Platform import GHC.Types.Unique.FM import GHC.Types.Unique -import BufWrite ( BufHandle ) +import GHC.Utils.BufHandle ( BufHandle ) import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import ErrUtils -import qualified Stream +import GHC.Utils.Error +import qualified GHC.Data.Stream as Stream import Data.Maybe (fromJust) import Control.Monad (ap) diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs index 7b3d198fa9..e106a5e111 100644 --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -8,7 +8,7 @@ module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -26,15 +26,15 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Collections import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.ForeignCall -import Outputable hiding (panic, pprPanic) -import qualified Outputable +import GHC.Utils.Outputable hiding (panic, pprPanic) +import qualified GHC.Utils.Outputable as Outputable import GHC.Platform -import OrdList +import GHC.Data.OrdList import GHC.Types.Unique.Supply import GHC.Types.Unique -import Util +import GHC.Utils.Misc import Control.Monad.Trans.Class import Control.Monad.Trans.Writer diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs index a862895b3c..b8db6ba4ed 100644 --- a/compiler/GHC/CmmToLlvm/Data.hs +++ b/compiler/GHC/CmmToLlvm/Data.hs @@ -9,7 +9,7 @@ module GHC.CmmToLlvm.Data ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -20,8 +20,8 @@ import GHC.Cmm import GHC.Driver.Session import GHC.Platform -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import qualified Data.ByteString as BS -- ---------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs index 6bf27267d7..0436dbcf07 100644 --- a/compiler/GHC/CmmToLlvm/Mangler.hs +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -11,12 +11,12 @@ module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session ( DynFlags, targetPlatform ) import GHC.Platform ( platformArch, Arch(..) ) -import ErrUtils ( withTiming ) -import Outputable ( text ) +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Outputable ( text ) import Control.Exception import qualified Data.ByteString.Char8 as B diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs index 3606ed56c0..290234d48a 100644 --- a/compiler/GHC/CmmToLlvm/Ppr.hs +++ b/compiler/GHC/CmmToLlvm/Ppr.hs @@ -9,7 +9,7 @@ module GHC.CmmToLlvm.Ppr ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -18,8 +18,8 @@ import GHC.CmmToLlvm.Data import GHC.Cmm.CLabel import GHC.Cmm -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Types.Unique -- ---------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs index 6e9be62937..0951c7e37f 100644 --- a/compiler/GHC/CmmToLlvm/Regs.hs +++ b/compiler/GHC/CmmToLlvm/Regs.hs @@ -11,14 +11,14 @@ module GHC.CmmToLlvm.Regs ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm import GHC.Cmm.Expr import GHC.Platform -import FastString -import Outputable ( panic ) +import GHC.Data.FastString +import GHC.Utils.Outputable ( panic ) import GHC.Types.Unique -- | Get the LlvmVar function variable storing the real register diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 17384f0d43..6c9bf98ca5 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -99,7 +99,7 @@ module GHC.Core ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Types.CostCentre @@ -114,11 +114,11 @@ import GHC.Types.Literal import GHC.Core.DataCon import GHC.Types.Module import GHC.Types.Basic -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Unique.Set import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) -import Binary +import GHC.Utils.Binary import Data.Data hiding (TyCon) import Data.Int diff --git a/compiler/GHC/Core/Arity.hs b/compiler/GHC/Core/Arity.hs index 9d1adab519..53e47d9746 100644 --- a/compiler/GHC/Core/Arity.hs +++ b/compiler/GHC/Core/Arity.hs @@ -21,7 +21,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.FVs @@ -38,9 +38,9 @@ import GHC.Core.Coercion as Coercion import GHC.Types.Basic import GHC.Types.Unique import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) -import Outputable -import FastString -import Util ( debugIsOn ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc ( debugIsOn ) {- ************************************************************************ diff --git a/compiler/GHC/Core/Class.hs b/compiler/GHC/Core/Class.hs index 5fb1fc9ea9..2c2f8c353b 100644 --- a/compiler/GHC/Core/Class.hs +++ b/compiler/GHC/Core/Class.hs @@ -23,7 +23,7 @@ module GHC.Core.Class ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType ) @@ -32,10 +32,10 @@ import GHC.Types.Var import GHC.Types.Name import GHC.Types.Basic import GHC.Types.Unique -import Util +import GHC.Utils.Misc import GHC.Types.SrcLoc -import Outputable -import BooleanFormula (BooleanFormula, mkTrue) +import GHC.Utils.Outputable +import GHC.Data.BooleanFormula (BooleanFormula, mkTrue) import qualified Data.Data as Data diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index ad97c4d7e9..a95c16c372 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -121,7 +121,7 @@ module GHC.Core.Coercion ( import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) -import GhcPrelude +import GHC.Prelude import GHC.Iface.Type import GHC.Core.TyCo.Rep @@ -136,16 +136,16 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name hiding ( varName ) -import Util +import GHC.Utils.Misc import GHC.Types.Basic -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique -import Pair +import GHC.Data.Pair import GHC.Types.SrcLoc import GHC.Builtin.Names import GHC.Builtin.Types.Prim -import ListSetOps -import Maybes +import GHC.Data.List.SetOps +import GHC.Data.Maybe import GHC.Types.Unique.FM import Control.Monad (foldM, zipWithM) diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot index 8a10e09268..eaf0180bef 100644 --- a/compiler/GHC/Core/Coercion.hs-boot +++ b/compiler/GHC/Core/Coercion.hs-boot @@ -2,7 +2,7 @@ module GHC.Core.Coercion where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Rep import {-# SOURCE #-} GHC.Core.TyCon @@ -10,8 +10,8 @@ import {-# SOURCE #-} GHC.Core.TyCon import GHC.Types.Basic ( LeftOrRight ) import GHC.Core.Coercion.Axiom import GHC.Types.Var -import Pair -import Util +import GHC.Data.Pair +import GHC.Utils.Misc mkReflCo :: Role -> Type -> Coercion mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs index cc4cbeff6d..4c95da97bc 100644 --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -29,19 +29,19 @@ module GHC.Core.Coercion.Axiom ( BuiltInSynFamily(..) ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Name import GHC.Types.Unique import GHC.Types.Var -import Util -import Binary -import Pair +import GHC.Utils.Misc +import GHC.Utils.Binary +import GHC.Data.Pair import GHC.Types.Basic import Data.Typeable ( Typeable ) import GHC.Types.SrcLoc diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index 6a93006791..e8a276e9ed 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -6,7 +6,7 @@ module GHC.Core.Coercion.Opt ( optCoercion, checkAxInstCo ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Core.TyCo.Rep @@ -18,11 +18,11 @@ import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Types.Var.Set import GHC.Types.Var.Env -import Outputable +import GHC.Utils.Outputable import GHC.Core.FamInstEnv ( flattenTys ) -import Pair -import ListSetOps ( getNth ) -import Util +import GHC.Data.Pair +import GHC.Data.List.SetOps ( getNth ) +import GHC.Utils.Misc import GHC.Core.Unify import GHC.Core.InstEnv import Control.Monad ( zipWithM ) diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs index e6169f7d7c..ed247c9d81 100644 --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -27,13 +27,13 @@ module GHC.Core.ConLike ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.DataCon import GHC.Core.PatSyn -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique -import Util +import GHC.Utils.Misc import GHC.Types.Name import GHC.Types.Basic import GHC.Core.TyCo.Rep (Type, ThetaType) diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index a4521d688c..0a1955eacf 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -61,7 +61,7 @@ module GHC.Core.DataCon ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) import GHC.Core.Type as Type @@ -74,12 +74,12 @@ import GHC.Types.Name import GHC.Builtin.Names import GHC.Core.Predicate import GHC.Types.Var -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Basic -import FastString +import GHC.Data.FastString import GHC.Types.Module -import Binary +import GHC.Utils.Binary import GHC.Types.Unique.Set import GHC.Types.Unique( mkAlphaTyVarUnique ) diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot index ab83a75117..aa2b266b06 100644 --- a/compiler/GHC/Core/DataCon.hs-boot +++ b/compiler/GHC/Core/DataCon.hs-boot @@ -1,12 +1,12 @@ module GHC.Core.DataCon where -import GhcPrelude +import GHC.Prelude import GHC.Types.Var( TyVar, TyCoVar, TyVarBinder ) import GHC.Types.Name( Name, NamedThing ) import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Types.Unique ( Uniquable ) -import Outputable ( Outputable, OutputableBndr ) +import GHC.Utils.Outputable ( Outputable, OutputableBndr ) import GHC.Types.Basic (Arity) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType ) diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index 6e7fa259ff..b4430f4139 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -59,7 +59,7 @@ module GHC.Core.FVs ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Types.Id @@ -77,11 +77,11 @@ import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.FamInstEnv import GHC.Builtin.Types.Prim( funTyConName ) -import Maybes( orElse ) -import Util +import GHC.Data.Maybe( orElse ) +import GHC.Utils.Misc import GHC.Types.Basic( Activation ) -import Outputable -import FV +import GHC.Utils.Outputable +import GHC.Utils.FV as FV {- ************************************************************************ @@ -105,7 +105,7 @@ exprFreeVars :: CoreExpr -> VarSet exprFreeVars = fvVarSet . exprFVs -- | Find all locally-defined free Ids or type variables in an expression --- returning a composable FV computation. See Note [FV naming conventions] in FV +-- returning a composable FV computation. See Note [FV naming conventions] in GHC.Utils.FV -- for why export it. exprFVs :: CoreExpr -> FV exprFVs = filterFV isLocalVar . expr_fvs @@ -150,7 +150,7 @@ exprsFreeVars :: [CoreExpr] -> VarSet exprsFreeVars = fvVarSet . exprsFVs -- | Find all locally-defined free Ids or type variables in several expressions --- returning a composable FV computation. See Note [FV naming conventions] in FV +-- returning a composable FV computation. See Note [FV naming conventions] in GHC.Utils.FV -- for why export it. exprsFVs :: [CoreExpr] -> FV exprsFVs exprs = mapUnionFV exprFVs exprs diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 6c737b555a..1c01f4fddd 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -41,7 +41,7 @@ module GHC.Core.FamInstEnv ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.Unify import GHC.Core.Type as Type @@ -53,14 +53,14 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name import GHC.Types.Unique.DFM -import Outputable -import Maybes +import GHC.Utils.Outputable +import GHC.Data.Maybe import GHC.Core.Map import GHC.Types.Unique -import Util +import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.SrcLoc -import FastString +import GHC.Data.FastString import Control.Monad import Data.List( mapAccumL ) import Data.Array( Array, assocs ) diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index b32d1aa150..b80b237733 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -31,7 +31,7 @@ module GHC.Core.InstEnv ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker, -- and depends on TcType in many ways @@ -43,11 +43,11 @@ import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Set import GHC.Core.Unify -import Outputable -import ErrUtils +import GHC.Utils.Outputable +import GHC.Utils.Error import GHC.Types.Basic import GHC.Types.Unique.DFM -import Util +import GHC.Utils.Misc import GHC.Types.Id import Data.Data ( Data ) import Data.Maybe ( isJust, isNothing ) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index b496b87484..bc74b7d393 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -23,14 +23,14 @@ module GHC.Core.Lint ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats ) import GHC.Core.Opt.Monad -import Bag +import GHC.Data.Bag import GHC.Types.Literal import GHC.Core.DataCon import GHC.Builtin.Types.Prim @@ -43,7 +43,7 @@ import GHC.Types.Name import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Ppr -import ErrUtils +import GHC.Utils.Error import GHC.Core.Coercion import GHC.Types.SrcLoc import GHC.Core.Type as Type @@ -55,12 +55,12 @@ import GHC.Core.TyCo.Ppr ( pprTyVar ) import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Types.Basic -import ErrUtils as Err -import ListSetOps +import GHC.Utils.Error as Err +import GHC.Data.List.SetOps import GHC.Builtin.Names -import Outputable -import FastString -import Util +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Core.InstEnv ( instanceDFunId ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Arity ( typeArity ) @@ -69,12 +69,12 @@ import GHC.Types.Demand ( splitStrictSig, isBotDiv ) import GHC.Driver.Types import GHC.Driver.Session import Control.Monad -import MonadUtils +import GHC.Utils.Monad import Data.Foldable ( toList ) import Data.List.NonEmpty ( NonEmpty ) import Data.List ( partition ) import Data.Maybe -import Pair +import GHC.Data.Pair import qualified GHC.LanguageExtensions as LangExt {- @@ -2211,7 +2211,7 @@ top-level ones. See Note [Exported LocalIds] and #9857. Note [Checking StaticPtrs] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Note [Grand plan for static forms] in StaticPtrTable for an overview. +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. Every occurrence of the function 'makeStatic' should be moved to the top level by the FloatOut pass. It's vital that we don't have nested diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index bf927ebd4d..38710f3829 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -54,7 +54,7 @@ module GHC.Core.Make ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Id import GHC.Types.Var ( EvVar, setTyVarUnique ) @@ -77,11 +77,11 @@ import GHC.Types.Id.Info import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.Name hiding ( varName ) -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Unique.Supply import GHC.Types.Basic -import Util +import GHC.Utils.Misc import Data.List import Data.Char ( ord ) diff --git a/compiler/GHC/Core/Map.hs b/compiler/GHC/Core/Map.hs index bb4eeb0fff..6fc041887d 100644 --- a/compiler/GHC/Core/Map.hs +++ b/compiler/GHC/Core/Map.hs @@ -37,23 +37,23 @@ module GHC.Core.Map ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import TrieMap +import GHC.Data.TrieMap import GHC.Core import GHC.Core.Coercion import GHC.Types.Name import GHC.Core.Type import GHC.Core.TyCo.Rep import GHC.Types.Var -import FastString(FastString) -import Util +import GHC.Data.FastString(FastString) +import GHC.Utils.Misc import qualified Data.Map as Map import qualified Data.IntMap as IntMap import GHC.Types.Var.Env import GHC.Types.Name.Env -import Outputable +import GHC.Utils.Outputable import Control.Monad( (>=>) ) {- diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index 07e243d662..39e5dd8d0a 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -13,7 +13,7 @@ module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.Subst import GHC.Types.Var ( Var ) @@ -28,10 +28,10 @@ import GHC.Core.Utils ( mkAltExpr, eqExpr import GHC.Core.FVs ( exprFreeVars ) import GHC.Core.Type ( tyConAppArgs ) import GHC.Core -import Outputable +import GHC.Utils.Outputable import GHC.Types.Basic import GHC.Core.Map -import Util ( filterOut, equalLength, debugIsOn ) +import GHC.Utils.Misc ( filterOut, equalLength, debugIsOn ) import Data.List ( mapAccumL ) {- diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index 33a0e7c31d..ef5bb94b23 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -7,7 +7,7 @@ module GHC.Core.Opt.CallArity , callArityRHS -- for testing ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -18,9 +18,9 @@ import GHC.Core import GHC.Types.Id import GHC.Core.Arity ( typeArity ) import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) -import UnVarGraph +import GHC.Data.Graph.UnVar import GHC.Types.Demand -import Util +import GHC.Utils.Misc import Control.Arrow ( first, second ) diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 91b44af996..7c18f27003 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -26,7 +26,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId ) @@ -49,13 +49,13 @@ import GHC.Core.Unfold ( exprIsConApp_maybe ) import GHC.Core.Type import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Builtin.Names -import Maybes ( orElse ) +import GHC.Data.Maybe ( orElse ) import GHC.Types.Name ( Name, nameOccName ) -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Basic import GHC.Platform -import Util +import GHC.Utils.Misc import GHC.Core.Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) import Control.Applicative ( Alternative(..) ) diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index 4bc96a81d9..f29c8e7133 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -11,14 +11,14 @@ module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Types.Demand import GHC.Types.Cpr import GHC.Core import GHC.Core.Seq -import Outputable +import GHC.Utils.Outputable import GHC.Types.Var.Env import GHC.Types.Basic import Data.List @@ -30,9 +30,9 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.FamInstEnv import GHC.Core.Opt.WorkWrap.Utils -import Util -import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) -import Maybes ( isJust, isNothing ) +import GHC.Utils.Misc +import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Data.Maybe ( isJust, isNothing ) {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 30956fd768..5d4e650564 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -13,14 +13,14 @@ module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Core.Opt.WorkWrap.Utils ( findTypeShape ) import GHC.Types.Demand -- All of it import GHC.Core import GHC.Core.Seq ( seqBinds ) -import Outputable +import GHC.Utils.Outputable import GHC.Types.Var.Env import GHC.Types.Basic import Data.List ( mapAccumL ) @@ -32,11 +32,11 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion ( Coercion, coVarsOfCo ) import GHC.Core.FamInstEnv -import Util -import Maybes ( isJust ) +import GHC.Utils.Misc +import GHC.Data.Maybe ( isJust ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) -import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) import GHC.Types.Unique.Set {- diff --git a/compiler/GHC/Core/Opt/Driver.hs b/compiler/GHC/Core/Opt/Driver.hs index 0da360e589..43470240a6 100644 --- a/compiler/GHC/Core/Opt/Driver.hs +++ b/compiler/GHC/Core/Opt/Driver.hs @@ -10,7 +10,7 @@ module GHC.Core.Opt.Driver ( core2core, simplifyExpr ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Core @@ -31,12 +31,12 @@ import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfoldin import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad -import qualified ErrUtils as Err +import qualified GHC.Utils.Error as Err import GHC.Core.Opt.FloatIn ( floatInwards ) import GHC.Core.Opt.FloatOut ( floatOutwards ) import GHC.Core.FamInstEnv import GHC.Types.Id -import ErrUtils ( withTiming, withTimingD, DumpFormat (..) ) +import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) ) import GHC.Types.Basic ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -50,14 +50,14 @@ import GHC.Core.Opt.CallArity ( callArityAnalProgram ) import GHC.Core.Opt.Exitify ( exitifyProgram ) import GHC.Core.Opt.WorkWrap ( wwTopBinds ) import GHC.Types.SrcLoc -import Util +import GHC.Utils.Misc import GHC.Types.Module import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Runtime.Loader -- ( initializePlugins ) import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import GHC.Types.Unique.FM -import Outputable +import GHC.Utils.Outputable import Control.Monad import qualified GHC.LanguageExtensions as LangExt {- @@ -186,7 +186,7 @@ getCoreToDo dflags )) -- Static forms are moved to the top level with the FloatOut pass. - -- See Note [Grand plan for static forms] in StaticPtrTable. + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. static_ptrs_float_outwards = runWhen static_ptrs $ CoreDoPasses [ simpl_gently -- Float Out can't handle type lets (sometimes created @@ -248,7 +248,7 @@ getCoreToDo dflags else -- Even with full laziness turned off, we still need to float static -- forms to the top level. See Note [Grand plan for static forms] in - -- StaticPtrTable. + -- GHC.Iface.Tidy.StaticPtrTable. static_ptrs_float_outwards, simpl_phases, diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs index 088d0cb085..d903185c1d 100644 --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -35,20 +35,20 @@ Example result: Now `t` is no longer in a recursive function, and good things happen! -} -import GhcPrelude +import GHC.Prelude import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core import GHC.Core.Utils -import State +import GHC.Utils.Monad.State import GHC.Types.Unique import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core.FVs -import FastString +import GHC.Data.FastString import GHC.Core.Type -import Util( mapSnd ) +import GHC.Utils.Misc( mapSnd ) import Data.Bifunctor import Control.Monad diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index c5b8acc7f6..4d759a47bc 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -20,7 +20,7 @@ module GHC.Core.Opt.FloatIn ( floatInwards ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Core @@ -33,9 +33,9 @@ import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) import GHC.Types.Var import GHC.Core.Type import GHC.Types.Var.Set -import Util +import GHC.Utils.Misc import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable -- import Data.List ( mapAccumL ) import GHC.Types.Basic ( RecFlag(..), isRec ) diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index d9d2d4dccf..92a747424f 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -10,7 +10,7 @@ module GHC.Core.Opt.FloatOut ( floatOutwards ) where -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.Utils @@ -19,15 +19,15 @@ import GHC.Core.Arity ( etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Driver.Session -import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) import GHC.Types.Id ( Id, idArity, idType, isBottomingId, isJoinId, isJoinId_maybe ) import GHC.Core.Opt.SetLevels import GHC.Types.Unique.Supply ( UniqSupply ) -import Bag -import Util -import Maybes -import Outputable +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Outputable import GHC.Core.Type import qualified Data.IntMap as M diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs index 2e284e3611..7a28abce20 100644 --- a/compiler/GHC/Core/Opt/LiberateCase.hs +++ b/compiler/GHC/Core/Opt/LiberateCase.hs @@ -9,7 +9,7 @@ module GHC.Core.Opt.LiberateCase ( liberateCase ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Core @@ -17,7 +17,7 @@ import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) import GHC.Builtin.Types ( unitDataConId ) import GHC.Types.Id import GHC.Types.Var.Env -import Util ( notNull ) +import GHC.Utils.Misc ( notNull ) {- The liberate-case transformation diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 81faa53e47..19d0eec4a9 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -48,7 +48,7 @@ module GHC.Core.Opt.Monad ( dumpIfSet_dyn ) where -import GhcPrelude hiding ( read ) +import GHC.Prelude hiding ( read ) import GHC.Core import GHC.Driver.Types @@ -57,18 +57,18 @@ import GHC.Driver.Session import GHC.Types.Basic ( CompilerPhase(..) ) import GHC.Types.Annotations -import IOEnv hiding ( liftIO, failM, failWithM ) -import qualified IOEnv ( liftIO ) +import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM ) +import qualified GHC.Data.IOEnv as IOEnv import GHC.Types.Var -import Outputable -import FastString -import ErrUtils( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Utils.Error( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) import GHC.Types.Unique.Supply -import MonadUtils +import GHC.Utils.Monad import GHC.Types.Name.Env import GHC.Types.SrcLoc import Data.Bifunctor ( bimap ) -import ErrUtils (dumpAction) +import GHC.Utils.Error (dumpAction) import Data.List (intersperse, groupBy, sortBy) import Data.Ord import Data.Dynamic @@ -78,7 +78,7 @@ import qualified Data.Map.Strict as MapStrict import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) ) -import Panic (throwGhcException, GhcException(..)) +import GHC.Utils.Panic (throwGhcException, GhcException(..)) {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/Monad.hs-boot b/compiler/GHC/Core/Opt/Monad.hs-boot index 6ea3a5b790..b92602dc59 100644 --- a/compiler/GHC/Core/Opt/Monad.hs-boot +++ b/compiler/GHC/Core/Opt/Monad.hs-boot @@ -9,9 +9,9 @@ module GHC.Core.Opt.Monad ( CoreToDo, CoreM ) where -import GhcPrelude +import GHC.Prelude -import IOEnv ( IOEnv ) +import GHC.Data.IOEnv ( IOEnv ) type CoreIOEnv = IOEnv CoreReader diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 4fe039cc52..21c7f86d78 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -18,7 +18,7 @@ module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.FVs @@ -36,15 +36,15 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Var import GHC.Types.Demand ( argOneShots, argsOneShots ) -import Digraph ( SCC(..), Node(..) - , stronglyConnCompFromEdgedVerticesUniq - , stronglyConnCompFromEdgedVerticesUniqR ) +import GHC.Data.Graph.Directed ( SCC(..), Node(..) + , stronglyConnCompFromEdgedVerticesUniq + , stronglyConnCompFromEdgedVerticesUniqR ) import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set -import Util -import Maybes( orElse, isJust ) -import Outputable +import GHC.Utils.Misc +import GHC.Data.Maybe( orElse, isJust ) +import GHC.Utils.Outputable import Data.List {- @@ -1240,7 +1240,7 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs) = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs) -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR -- is still deterministic with edges in nondeterministic order as - -- explained in Note [Deterministic SCC] in Digraph. + -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. where details = ND { nd_bndr = bndr' , nd_rhs = rhs' @@ -1334,7 +1334,7 @@ mkLoopBreakerNodes env lvl bndr_set body_uds details_s -- It's OK to use nonDetKeysUniqSet here as -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges -- in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. + -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. where nd' = nd { nd_bndr = new_bndr, nd_score = score } score = nodeScore env new_bndr lb_deps nd diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 710a8cf70f..8f5d9c654a 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -64,7 +64,7 @@ module GHC.Core.Opt.SetLevels ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) @@ -97,13 +97,13 @@ import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) import GHC.Core.DataCon ( dataConOrigResTy ) import GHC.Builtin.Types import GHC.Types.Unique.Supply -import Util -import Outputable -import FastString +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Unique.DFM -import FV +import GHC.Utils.FV import Data.Maybe -import MonadUtils ( mapAccumLM ) +import GHC.Utils.Monad ( mapAccumLM ) {- ************************************************************************ @@ -702,7 +702,7 @@ lvlMFE env strict_ctxt ann_expr join_arity_maybe = Nothing is_mk_static = isJust (collectMakeStaticArgs expr) - -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable + -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable -- A decision to float entails let-binding this thing, and we only do -- that if we'll escape a value lambda, or will go to the top level. @@ -1699,7 +1699,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static rhs_ty = exprType de_tagged_rhs mk_id uniq rhs_ty - -- See Note [Grand plan for static forms] in StaticPtrTable. + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. | is_mk_static = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) rhs_ty diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index d2b63ecb94..8198ba32cf 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -11,7 +11,7 @@ module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Driver.Session @@ -49,14 +49,14 @@ import GHC.Core.FVs ( mkRuleInfo ) import GHC.Core.Rules ( lookupRule, getRules ) import GHC.Types.Basic ( TopLevelFlag(..), isNotTopLevel, isTopLevel, RecFlag(..), Arity ) -import MonadUtils ( mapAccumLM, liftIO ) +import GHC.Utils.Monad ( mapAccumLM, liftIO ) import GHC.Types.Var ( isTyCoVar ) -import Maybes ( orElse ) +import GHC.Data.Maybe ( orElse ) import Control.Monad -import Outputable -import FastString -import Util -import ErrUtils +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Utils.Error import GHC.Types.Module ( moduleName, pprModuleName ) import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 2827ba037d..4a749e8951 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -45,7 +45,7 @@ module GHC.Core.Opt.Simplify.Env ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad ( SimplMode(..) ) @@ -54,7 +54,7 @@ import GHC.Core.Utils import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set -import OrdList +import GHC.Data.OrdList import GHC.Types.Id as Id import GHC.Core.Make ( mkWildValBinder ) import GHC.Driver.Session ( DynFlags ) @@ -64,9 +64,9 @@ import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvS import qualified GHC.Core.Coercion as Coercion import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) import GHC.Types.Basic -import MonadUtils -import Outputable -import Util +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Unique.FM ( pprUniqFM ) import Data.List (mapAccumL) diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index 043ced977b..b36d440402 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -20,7 +20,7 @@ module GHC.Core.Opt.Simplify.Monad ( plusSimplCount, isZeroSimplCount ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Var ( Var, isId, mkLocalVar ) import GHC.Types.Name ( mkSystemVarName ) @@ -32,12 +32,12 @@ import GHC.Core ( RuleEnv(..) ) import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Core.Opt.Monad -import Outputable -import FastString -import MonadUtils -import ErrUtils as Err -import Util ( count ) -import Panic (throwGhcExceptionIO, GhcException (..)) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Monad +import GHC.Utils.Error as Err +import GHC.Utils.Misc ( count ) +import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) import Control.Monad ( ap ) diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 1de946f724..14e1a08fe0 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -38,7 +38,7 @@ module GHC.Core.Opt.Simplify.Utils ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) ) @@ -63,12 +63,12 @@ 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 Util -import OrdList ( isNilOL ) -import MonadUtils -import Outputable +import GHC.Utils.Misc +import GHC.Data.OrdList ( isNilOL ) +import GHC.Utils.Monad +import GHC.Utils.Outputable import GHC.Core.Opt.ConstantFold -import FastString ( fsLit ) +import GHC.Data.FastString ( fsLit ) 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 f0a7821b1f..60029cb478 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -21,7 +21,7 @@ module GHC.Core.Opt.SpecConstr( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.Subst @@ -46,17 +46,17 @@ import GHC.Types.Name import GHC.Types.Basic import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) , gopt, hasPprDebug ) -import Maybes ( orElse, catMaybes, isJust, isNothing ) +import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) import GHC.Types.Demand import GHC.Types.Cpr import GHC.Serialized ( deserializeWithData ) -import Util -import Pair +import GHC.Utils.Misc +import GHC.Data.Pair import GHC.Types.Unique.Supply -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Unique.FM -import MonadUtils +import GHC.Utils.Monad import Control.Monad ( zipWithM ) import Data.List import GHC.Builtin.Names ( specTyConName ) diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index b1a85fa93f..f40e67adcd 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -13,7 +13,7 @@ module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Id import GHC.Tc.Utils.TcType hiding( substTy ) @@ -38,16 +38,16 @@ import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Builtin.Types.Prim ( voidPrimTy ) -import Maybes ( mapMaybe, maybeToList, isJust ) -import MonadUtils ( foldlM ) +import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust ) +import GHC.Utils.Monad ( foldlM ) import GHC.Types.Basic import GHC.Driver.Types -import Bag +import GHC.Data.Bag import GHC.Driver.Session -import Util -import Outputable -import FastString -import State +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Monad.State import GHC.Types.Unique.DFM import GHC.Core.TyCo.Rep (TyCoBinder (..)) diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index 0abcc06382..827a3e90a5 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -51,7 +51,7 @@ essential to make this work well! {-# LANGUAGE CPP #-} module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Var import GHC.Core @@ -62,15 +62,15 @@ import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Unique.Supply -import Util +import GHC.Utils.Misc import GHC.Types.Unique.FM import GHC.Types.Var.Set import GHC.Types.Unique import GHC.Types.Unique.Set -import Outputable +import GHC.Utils.Outputable import Data.List (mapAccumL) -import FastString +import GHC.Data.FastString #include "HsVersions.h" diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 0ba6acb731..52cdf04edf 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -7,7 +7,7 @@ {-# LANGUAGE CPP #-} module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where -import GhcPrelude +import GHC.Prelude import GHC.Core.Arity ( manifestArity ) import GHC.Core @@ -24,10 +24,10 @@ import GHC.Driver.Session import GHC.Types.Demand import GHC.Types.Cpr import GHC.Core.Opt.WorkWrap.Utils -import Util -import Outputable +import GHC.Utils.Misc +import GHC.Utils.Outputable import GHC.Core.FamInstEnv -import MonadUtils +import GHC.Utils.Monad #include "HsVersions.h" diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index cbd8788d66..4c4c3dc5e7 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -16,7 +16,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) @@ -42,12 +42,12 @@ import GHC.Types.Basic ( Boxity(..) ) import GHC.Core.TyCon import GHC.Types.Unique.Supply import GHC.Types.Unique -import Maybes -import Util -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Utils.Outputable import GHC.Driver.Session -import FastString -import ListSetOps +import GHC.Data.FastString +import GHC.Data.List.SetOps {- ************************************************************************ @@ -345,7 +345,7 @@ f x y = join j (z, w) = \(u, v) -> ... in jump j (x, y) Typically this happens with functions that are seen as computing functions, -rather than being curried. (The real-life example was GraphOps.addConflicts.) +rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.) When we create the wrapper, it *must* be in "eta-contracted" form so that the jump has the right number of arguments: diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs index 39e91795d6..6179cd600b 100644 --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -24,14 +24,14 @@ module GHC.Core.PatSyn ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.Type import GHC.Core.TyCo.Ppr import GHC.Types.Name -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique -import Util +import GHC.Utils.Misc import GHC.Types.Basic import GHC.Types.Var import GHC.Types.FieldLabel diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index df88351df2..6c3eedb77f 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -17,7 +17,7 @@ module GHC.Core.Ppr ( pprRules, pprOptCo ) where -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.Stats (exprStats) @@ -33,10 +33,10 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Ppr import GHC.Core.Coercion import GHC.Types.Basic -import Maybes -import Util -import Outputable -import FastString +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.SrcLoc ( pprUserRealSpan ) {- diff --git a/compiler/GHC/Core/Ppr/TyThing.hs b/compiler/GHC/Core/Ppr/TyThing.hs index 6782ba1518..628d13ad7f 100644 --- a/compiler/GHC/Core/Ppr/TyThing.hs +++ b/compiler/GHC/Core/Ppr/TyThing.hs @@ -19,7 +19,7 @@ module GHC.Core.Ppr.TyThing ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) @@ -31,7 +31,7 @@ import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType ) import GHC.Types.Name import GHC.Types.Var.Env( emptyTidyEnv ) -import Outputable +import GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs index dbeb099440..9f0eefef30 100644 --- a/compiler/GHC/Core/Predicate.hs +++ b/compiler/GHC/Core/Predicate.hs @@ -28,7 +28,7 @@ module GHC.Core.Predicate ( DictId, isEvVar, isDictId ) where -import GhcPrelude +import GHC.Prelude import GHC.Core.Type import GHC.Core.Class @@ -38,9 +38,9 @@ import GHC.Core.Coercion import GHC.Builtin.Names -import FastString -import Outputable -import Util +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc import Control.Monad ( guard ) diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 899ae25d1b..d4e60446bf 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -28,7 +28,7 @@ module GHC.Core.Rules ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core -- All of it import GHC.Types.Module ( Module, ModuleSet, elemModuleSet ) @@ -60,11 +60,11 @@ import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Types.Basic import GHC.Driver.Session ( DynFlags, gopt, targetPlatform ) import GHC.Driver.Flags -import Outputable -import FastString -import Maybes -import Bag -import Util +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.Bag +import GHC.Utils.Misc import Data.List import Data.Ord import Control.Monad ( guard ) diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 451a6fa4e3..25a6ab31dc 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -10,7 +10,7 @@ module GHC.Core.Seq ( megaSeqIdInfo, seqRuleInfo, seqBinds, ) where -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Types.Id.Info diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 7545209b77..2f9d86627f 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -20,7 +20,7 @@ module GHC.Core.SimpleOpt ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.Arity( etaExpandToJoinPoint ) @@ -49,13 +49,13 @@ import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic import GHC.Types.Module ( Module ) -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Session -import Outputable -import Pair -import Util -import Maybes ( orElse ) -import FastString +import GHC.Utils.Outputable +import GHC.Data.Pair +import GHC.Utils.Misc +import GHC.Data.Maybe ( orElse ) +import GHC.Data.FastString import Data.List import qualified Data.ByteString as BS diff --git a/compiler/GHC/Core/Stats.hs b/compiler/GHC/Core/Stats.hs index 29f2f44df4..cdff8283be 100644 --- a/compiler/GHC/Core/Stats.hs +++ b/compiler/GHC/Core/Stats.hs @@ -11,11 +11,11 @@ module GHC.Core.Stats ( CoreStats(..), coreBindsStats, exprStats, ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic import GHC.Core -import Outputable +import GHC.Utils.Outputable import GHC.Core.Coercion import GHC.Types.Var import GHC.Core.Type(Type, typeSize) diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 9963875bf3..ddb5b61f7b 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -37,7 +37,7 @@ module GHC.Core.Subst ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.FVs @@ -60,9 +60,9 @@ import GHC.Types.Name ( Name ) import GHC.Types.Var import GHC.Types.Id.Info import GHC.Types.Unique.Supply -import Maybes -import Util -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Utils.Outputable import Data.List diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index 0b9d91af8a..c31b58f6ed 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -15,7 +15,7 @@ module GHC.Core.Tidy ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.Seq ( seqUnfolding ) @@ -29,7 +29,7 @@ import GHC.Types.Var.Env import GHC.Types.Unique.FM import GHC.Types.Name hiding (tidyNameOcc) import GHC.Types.SrcLoc -import Maybes +import GHC.Data.Maybe import Data.List {- diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs index 3c4246750f..f54cbe71b3 100644 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -43,7 +43,7 @@ module GHC.Core.TyCo.FVs #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) @@ -51,13 +51,13 @@ import Data.Monoid as DM ( Endo(..), All(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon import GHC.Types.Var -import FV +import GHC.Utils.FV import GHC.Types.Unique.FM import GHC.Types.Var.Set import GHC.Types.Var.Env -import Util -import Panic +import GHC.Utils.Misc +import GHC.Utils.Panic {- %************************************************************************ @@ -523,14 +523,14 @@ closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems -- | `tyCoFVsOfType` that returns free variables of a type in a deterministic -- set. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. +-- Note [Deterministic FV] in GHC.Utils.FV. tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet -- See Note [Free variables of types] tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty -- | `tyCoFVsOfType` that returns free variables of a type in deterministic -- order. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. +-- Note [Deterministic FV] in GHC.Utils.FV. tyCoVarsOfTypeList :: Type -> [TyCoVar] -- See Note [Free variables of types] tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty @@ -554,10 +554,10 @@ tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys -- make the function quadratic. -- It's exported, so that it can be composed with -- other functions that compute free variables. --- See Note [FV naming conventions] in FV. +-- See Note [FV naming conventions] in GHC.Utils.FV. -- -- Eta-expanded because that makes it run faster (apparently) --- See Note [FV eta expansion] in FV for explanation. +-- See Note [FV eta expansion] in GHC.Utils.FV for explanation. tyCoFVsOfType :: Type -> FV -- See Note [Free variables of types] tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index 751aa11b75..973641bf5c 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -25,7 +25,7 @@ module GHC.Core.TyCo.Ppr pprTyThingCategory, pprShortTyThing, ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.CoreToIface ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr @@ -50,7 +50,7 @@ import GHC.Iface.Type import GHC.Types.Var.Set import GHC.Types.Var.Env -import Outputable +import GHC.Utils.Outputable import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec , funPrec, appPrec, maybeParen ) diff --git a/compiler/GHC/Core/TyCo/Ppr.hs-boot b/compiler/GHC/Core/TyCo/Ppr.hs-boot index 64562d9a28..8e89c334ea 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs-boot +++ b/compiler/GHC/Core/TyCo/Ppr.hs-boot @@ -1,7 +1,7 @@ module GHC.Core.TyCo.Ppr where import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit) -import Outputable +import GHC.Utils.Outputable pprType :: Type -> SDoc pprKind :: Kind -> SDoc diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 00d3f95c43..4ac731bc07 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -70,7 +70,7 @@ module GHC.Core.TyCo.Rep ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) @@ -88,9 +88,9 @@ import GHC.Core.Coercion.Axiom -- others import GHC.Types.Basic ( LeftOrRight(..), pickLR ) -import Outputable -import FastString -import Util +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc -- libraries import qualified Data.Data as Data hiding ( TyCon ) diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index a4d0c49b46..ed885bfdfd 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -53,7 +53,7 @@ module GHC.Core.TyCo.Subst #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type ( mkCastTy, mkAppTy, isCoercionTy ) @@ -74,13 +74,13 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env -import Pair -import Util +import GHC.Data.Pair +import GHC.Utils.Misc import GHC.Types.Unique.Supply import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set -import Outputable +import GHC.Utils.Outputable import Data.List (mapAccumL) diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs index f18ee4f132..8ec4b5818b 100644 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -18,7 +18,7 @@ module GHC.Core.TyCo.Tidy tidyTyCoVarBinder, tidyTyCoVarBinders ) where -import GhcPrelude +import GHC.Prelude import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) @@ -26,7 +26,7 @@ import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) import GHC.Types.Name hiding (varName) import GHC.Types.Var import GHC.Types.Var.Env -import Util (seqList) +import GHC.Utils.Misc (seqList) import Data.List (mapAccumL) diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index e82cb2e219..c45b744c7b 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -134,7 +134,7 @@ module GHC.Core.TyCon( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.Core.TyCo.Rep @@ -149,7 +149,7 @@ import {-# SOURCE #-} GHC.Core.DataCon , dataConTyCon, dataConFullSig , isUnboxedSumCon ) -import Binary +import GHC.Utils.Binary import GHC.Types.Var import GHC.Types.Var.Set import GHC.Core.Class @@ -159,12 +159,12 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Core.Coercion.Axiom import GHC.Builtin.Names -import Maybes -import Outputable -import FastStringEnv +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Data.FastString.Env import GHC.Types.FieldLabel import GHC.Settings.Constants -import Util +import GHC.Utils.Misc import GHC.Types.Unique( tyConRepNameUnique, dataConTyRepNameUnique ) import GHC.Types.Unique.Set import GHC.Types.Module diff --git a/compiler/GHC/Core/TyCon.hs-boot b/compiler/GHC/Core/TyCon.hs-boot index 84df99b0a9..1081249d19 100644 --- a/compiler/GHC/Core/TyCon.hs-boot +++ b/compiler/GHC/Core/TyCon.hs-boot @@ -1,6 +1,6 @@ module GHC.Core.TyCon where -import GhcPrelude +import GHC.Prelude data TyCon diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index a6521801b4..1e7af2d8cf 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -221,7 +221,7 @@ module GHC.Core.Type ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic @@ -260,15 +260,15 @@ import {-# SOURCE #-} GHC.Core.Coercion , isReflexiveCo, seqCo ) -- others -import Util -import FV -import Outputable -import FastString -import Pair -import ListSetOps +import GHC.Utils.Misc +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Data.List.SetOps import GHC.Types.Unique ( nonDetCmpUnique ) -import Maybes ( orElse ) +import GHC.Data.Maybe ( orElse ) import Data.Maybe ( isJust ) import Control.Monad ( guard ) diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot index e2d479be7d..08efbf608d 100644 --- a/compiler/GHC/Core/Type.hs-boot +++ b/compiler/GHC/Core/Type.hs-boot @@ -2,10 +2,10 @@ module GHC.Core.Type where -import GhcPrelude +import GHC.Prelude import GHC.Core.TyCon import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion ) -import Util +import GHC.Utils.Misc isPredTy :: HasDebugCallStack => Type -> Bool isCoercionTy :: Type -> Bool diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 6c88c5a24d..f619e36f8a 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -44,7 +44,7 @@ module GHC.Core.Unfold ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Core @@ -62,12 +62,12 @@ import GHC.Types.Basic ( Arity, InlineSpec(..), inlinePragmaSpec ) import GHC.Core.Type import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) -import Bag -import Util -import Outputable +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Utils.Outputable import GHC.Types.ForeignCall import GHC.Types.Name -import ErrUtils +import GHC.Utils.Error import qualified Data.ByteString as BS import Data.List diff --git a/compiler/GHC/Core/Unfold.hs-boot b/compiler/GHC/Core/Unfold.hs-boot index 54895ae8b1..4706af49e7 100644 --- a/compiler/GHC/Core/Unfold.hs-boot +++ b/compiler/GHC/Core/Unfold.hs-boot @@ -2,7 +2,7 @@ module GHC.Core.Unfold ( mkUnfolding, mkInlineUnfolding ) where -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Driver.Session diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index 2e77a9909e..3801126ba9 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -26,7 +26,7 @@ module GHC.Core.Unify ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Var import GHC.Types.Var.Env @@ -38,10 +38,10 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) import GHC.Core.TyCo.Subst ( mkTvSubst ) -import FV( FV, fvVarSet, fvVarList ) -import Util -import Pair -import Outputable +import GHC.Utils.FV( FV, fvVarSet, fvVarList ) +import GHC.Utils.Misc +import GHC.Data.Pair +import GHC.Utils.Outputable import GHC.Types.Unique.FM import GHC.Types.Unique.Set diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index d954374eef..6faf179489 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -62,7 +62,7 @@ module GHC.Core.Utils ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Core @@ -86,19 +86,19 @@ import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) import GHC.Core.Coercion import GHC.Core.TyCon import GHC.Types.Unique -import Outputable +import GHC.Utils.Outputable import GHC.Builtin.Types.Prim -import FastString -import Maybes -import ListSetOps ( minusList ) +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.List.SetOps( minusList ) import GHC.Types.Basic ( Arity ) -import Util -import Pair +import GHC.Utils.Misc +import GHC.Data.Pair import Data.ByteString ( ByteString ) import Data.Function ( on ) import Data.List import Data.Ord ( comparing ) -import OrdList +import GHC.Data.OrdList import qualified Data.Set as Set import GHC.Types.Unique.Set @@ -2099,7 +2099,7 @@ eqExpr in_scope e1 e2 env' = rnBndrs2 env bs1 bs2 go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | null a1 -- See Note [Empty case alternatives] in TrieMap + | null a1 -- See Note [Empty case alternatives] in GHC.Data.TrieMap = null a2 && go env e1 e2 && eqTypeX env t1 t2 | otherwise = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 @@ -2147,7 +2147,7 @@ diffExpr top env (Let bs1 e1) (Let bs2 e2) in ds ++ diffExpr top env' e1 e2 diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 - -- See Note [Empty case alternatives] in TrieMap + -- See Note [Empty case alternatives] in GHC.Data.TrieMap = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) where env' = rnBndr2 env b1 b2 diffAlt (c1, bs1, e1) (c2, bs2, e2) diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index b2f185498c..1f3c0dd85d 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -12,7 +12,7 @@ module GHC.CoreToByteCode ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.ByteCode.Instr import GHC.ByteCode.Asm @@ -23,7 +23,7 @@ import GHCi.FFI import GHCi.RemoteTypes import GHC.Types.Basic import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Name import GHC.Types.Id.Make @@ -41,20 +41,20 @@ import GHC.Core.Type import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon -import Util +import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Builtin.Types.Prim import GHC.Core.TyCo.Ppr ( pprType ) -import ErrUtils +import GHC.Utils.Error import GHC.Types.Unique -import FastString -import Panic +import GHC.Data.FastString +import GHC.Utils.Panic import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) import GHC.Data.Bitmap -import OrdList -import Maybes +import GHC.Data.OrdList +import GHC.Data.Maybe import GHC.Types.Var.Env import GHC.Builtin.Names ( unsafeEqualityProofName ) @@ -73,7 +73,7 @@ import Data.Map (Map) import Data.IntMap (IntMap) import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import qualified FiniteMap as Map +import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS import Data.Either ( partitionEithers ) diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index dcce320ed9..93c5ba5672 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -45,7 +45,7 @@ module GHC.CoreToIface #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Iface.Syntax import GHC.Core.DataCon @@ -62,9 +62,9 @@ import GHC.Types.Name import GHC.Types.Basic import GHC.Core.Type import GHC.Core.PatSyn -import Outputable -import FastString -import Util +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index a35c81789b..8534ff7738 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -15,7 +15,7 @@ module GHC.CoreToStg ( coreToStg ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core import GHC.Core.Utils ( exprType, findDefault, isJoinBind @@ -37,10 +37,10 @@ import GHC.Types.Name ( isExternalName, nameModule_maybe ) import GHC.Types.Basic ( Arity ) import GHC.Builtin.Types ( unboxedUnitDataCon, unitDataConId ) import GHC.Types.Literal -import Outputable -import MonadUtils -import FastString -import Util +import GHC.Utils.Outputable +import GHC.Utils.Monad +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Driver.Session import GHC.Driver.Ways import GHC.Types.ForeignCall diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 50ae474cdf..c4c2463153 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -17,7 +17,7 @@ module GHC.CoreToStg.Prep ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Core.Opt.OccurAnal @@ -48,18 +48,18 @@ import GHC.Core.DataCon import GHC.Types.Basic import GHC.Types.Module import GHC.Types.Unique.Supply -import Maybes -import OrdList -import ErrUtils +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Utils.Error import GHC.Driver.Session import GHC.Driver.Ways -import Util -import Outputable -import FastString +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits -import MonadUtils ( mapAccumLM ) +import GHC.Utils.Monad ( mapAccumLM ) import Control.Monad import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs new file mode 100644 index 0000000000..aa18bec5e1 --- /dev/null +++ b/compiler/GHC/Data/Bag.hs @@ -0,0 +1,335 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Bag: an unordered collection with duplicates +-} + +{-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor #-} + +module GHC.Data.Bag ( + Bag, -- abstract type + + emptyBag, unitBag, unionBags, unionManyBags, + mapBag, + elemBag, lengthBag, + filterBag, partitionBag, partitionBagWith, + concatBag, catBagMaybes, foldBag, + isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, + listToBag, bagToList, mapAccumBagL, + concatMapBag, concatMapBagPair, mapMaybeBag, + mapBagM, mapBagM_, + flatMapBagM, flatMapBagPairM, + mapAndUnzipBagM, mapAccumBagLM, + anyBagM, filterBagM + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import GHC.Utils.Monad +import Control.Monad +import Data.Data +import Data.Maybe( mapMaybe ) +import Data.List ( partition, mapAccumL ) +import qualified Data.Foldable as Foldable + +infixr 3 `consBag` +infixl 3 `snocBag` + +data Bag a + = EmptyBag + | UnitBag a + | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty + | ListBag [a] -- INVARIANT: the list is non-empty + deriving (Functor) + +emptyBag :: Bag a +emptyBag = EmptyBag + +unitBag :: a -> Bag a +unitBag = UnitBag + +lengthBag :: Bag a -> Int +lengthBag EmptyBag = 0 +lengthBag (UnitBag {}) = 1 +lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 +lengthBag (ListBag xs) = length xs + +elemBag :: Eq a => a -> Bag a -> Bool +elemBag _ EmptyBag = False +elemBag x (UnitBag y) = x == y +elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 +elemBag x (ListBag ys) = any (x ==) ys + +unionManyBags :: [Bag a] -> Bag a +unionManyBags xs = foldr unionBags EmptyBag xs + +-- This one is a bit stricter! The bag will get completely evaluated. + +unionBags :: Bag a -> Bag a -> Bag a +unionBags EmptyBag b = b +unionBags b EmptyBag = b +unionBags b1 b2 = TwoBags b1 b2 + +consBag :: a -> Bag a -> Bag a +snocBag :: Bag a -> a -> Bag a + +consBag elt bag = (unitBag elt) `unionBags` bag +snocBag bag elt = bag `unionBags` (unitBag elt) + +isEmptyBag :: Bag a -> Bool +isEmptyBag EmptyBag = True +isEmptyBag _ = False -- NB invariants + +isSingletonBag :: Bag a -> Bool +isSingletonBag EmptyBag = False +isSingletonBag (UnitBag _) = True +isSingletonBag (TwoBags _ _) = False -- Neither is empty +isSingletonBag (ListBag xs) = isSingleton xs + +filterBag :: (a -> Bool) -> Bag a -> Bag a +filterBag _ EmptyBag = EmptyBag +filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag +filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 + where sat1 = filterBag pred b1 + sat2 = filterBag pred b2 +filterBag pred (ListBag vs) = listToBag (filter pred vs) + +filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) +filterBagM _ EmptyBag = return EmptyBag +filterBagM pred b@(UnitBag val) = do + flag <- pred val + if flag then return b + else return EmptyBag +filterBagM pred (TwoBags b1 b2) = do + sat1 <- filterBagM pred b1 + sat2 <- filterBagM pred b2 + return (sat1 `unionBags` sat2) +filterBagM pred (ListBag vs) = do + sat <- filterM pred vs + return (listToBag sat) + +allBag :: (a -> Bool) -> Bag a -> Bool +allBag _ EmptyBag = True +allBag p (UnitBag v) = p v +allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2 +allBag p (ListBag xs) = all p xs + +anyBag :: (a -> Bool) -> Bag a -> Bool +anyBag _ EmptyBag = False +anyBag p (UnitBag v) = p v +anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 +anyBag p (ListBag xs) = any p xs + +anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool +anyBagM _ EmptyBag = return False +anyBagM p (UnitBag v) = p v +anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1 + if flag then return True + else anyBagM p b2 +anyBagM p (ListBag xs) = anyM p xs + +concatBag :: Bag (Bag a) -> Bag a +concatBag bss = foldr add emptyBag bss + where + add bs rs = bs `unionBags` rs + +catBagMaybes :: Bag (Maybe a) -> Bag a +catBagMaybes bs = foldr add emptyBag bs + where + add Nothing rs = rs + add (Just x) rs = x `consBag` rs + +partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, + Bag a {- Don't -}) +partitionBag _ EmptyBag = (EmptyBag, EmptyBag) +partitionBag pred b@(UnitBag val) + = if pred val then (b, EmptyBag) else (EmptyBag, b) +partitionBag pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBag pred b1 + (sat2, fail2) = partitionBag pred b2 +partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partition pred vs + + +partitionBagWith :: (a -> Either b c) -> Bag a + -> (Bag b {- Left -}, + Bag c {- Right -}) +partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) +partitionBagWith pred (UnitBag val) + = case pred val of + Left a -> (UnitBag a, EmptyBag) + Right b -> (EmptyBag, UnitBag b) +partitionBagWith pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBagWith pred b1 + (sat2, fail2) = partitionBagWith pred b2 +partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partitionWith pred vs + +foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative + -> (a -> r) -- Replace UnitBag with this + -> r -- Replace EmptyBag with this + -> Bag a + -> r + +{- Standard definition +foldBag t u e EmptyBag = e +foldBag t u e (UnitBag x) = u x +foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) +foldBag t u e (ListBag xs) = foldr (t.u) e xs +-} + +-- More tail-recursive definition, exploiting associativity of "t" +foldBag _ _ e EmptyBag = e +foldBag t u e (UnitBag x) = u x `t` e +foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 +foldBag t u e (ListBag xs) = foldr (t.u) e xs + +mapBag :: (a -> b) -> Bag a -> Bag b +mapBag = fmap + +concatMapBag :: (a -> Bag b) -> Bag a -> Bag b +concatMapBag _ EmptyBag = EmptyBag +concatMapBag f (UnitBag x) = f x +concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2) +concatMapBag f (ListBag xs) = foldr (unionBags . f) emptyBag xs + +concatMapBagPair :: (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c) +concatMapBagPair _ EmptyBag = (EmptyBag, EmptyBag) +concatMapBagPair f (UnitBag x) = f x +concatMapBagPair f (TwoBags b1 b2) = (unionBags r1 r2, unionBags s1 s2) + where + (r1, s1) = concatMapBagPair f b1 + (r2, s2) = concatMapBagPair f b2 +concatMapBagPair f (ListBag xs) = foldr go (emptyBag, emptyBag) xs + where + go a (s1, s2) = (unionBags r1 s1, unionBags r2 s2) + where + (r1, r2) = f a + +mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b +mapMaybeBag _ EmptyBag = EmptyBag +mapMaybeBag f (UnitBag x) = case f x of + Nothing -> EmptyBag + Just y -> UnitBag y +mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) +mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) + +mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) +mapBagM _ EmptyBag = return EmptyBag +mapBagM f (UnitBag x) = do r <- f x + return (UnitBag r) +mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 + r2 <- mapBagM f b2 + return (TwoBags r1 r2) +mapBagM f (ListBag xs) = do rs <- mapM f xs + return (ListBag rs) + +mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () +mapBagM_ _ EmptyBag = return () +mapBagM_ f (UnitBag x) = f x >> return () +mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 +mapBagM_ f (ListBag xs) = mapM_ f xs + +flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) +flatMapBagM _ EmptyBag = return EmptyBag +flatMapBagM f (UnitBag x) = f x +flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 + r2 <- flatMapBagM f b2 + return (r1 `unionBags` r2) +flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs + where + k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } + +flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) +flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) +flatMapBagPairM f (UnitBag x) = f x +flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 + (r2,s2) <- flatMapBagPairM f b2 + return (r1 `unionBags` r2, s1 `unionBags` s2) +flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs + where + k x (r2,s2) = do { (r1,s1) <- f x + ; return (r1 `unionBags` r2, s1 `unionBags` s2) } + +mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) +mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) +mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x + return (UnitBag r, UnitBag s) +mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1 + (r2,s2) <- mapAndUnzipBagM f b2 + return (TwoBags r1 r2, TwoBags s1 s2) +mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs + let (rs,ss) = unzip ts + return (ListBag rs, ListBag ss) + +mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> Bag x -- ^ inputs + -> (acc, Bag y) -- ^ final state, outputs +mapAccumBagL _ s EmptyBag = (s, EmptyBag) +mapAccumBagL f s (UnitBag x) = let (s1, x1) = f s x in (s1, UnitBag x1) +mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s b1 + (s2, b2') = mapAccumBagL f s1 b2 + in (s2, TwoBags b1' b2') +mapAccumBagL f s (ListBag xs) = let (s', xs') = mapAccumL f s xs + in (s', ListBag xs') + +mapAccumBagLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> Bag x -- ^ inputs + -> m (acc, Bag y) -- ^ final state, outputs +mapAccumBagLM _ s EmptyBag = return (s, EmptyBag) +mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) } +mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1 + ; (s2, b2') <- mapAccumBagLM f s1 b2 + ; return (s2, TwoBags b1' b2') } +mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs + ; return (s', ListBag xs') } + +listToBag :: [a] -> Bag a +listToBag [] = EmptyBag +listToBag [x] = UnitBag x +listToBag vs = ListBag vs + +bagToList :: Bag a -> [a] +bagToList b = foldr (:) [] b + +instance (Outputable a) => Outputable (Bag a) where + ppr bag = braces (pprWithCommas ppr (bagToList bag)) + +instance Data a => Data (Bag a) where + gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly + toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Bag" + dataCast1 x = gcast1 x + +instance Foldable.Foldable Bag where + foldr _ z EmptyBag = z + foldr k z (UnitBag x) = k x z + foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1 + foldr k z (ListBag xs) = foldr k z xs + + foldl _ z EmptyBag = z + foldl k z (UnitBag x) = k z x + foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2 + foldl k z (ListBag xs) = foldl k z xs + + foldl' _ z EmptyBag = z + foldl' k z (UnitBag x) = k z x + foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 + foldl' k z (ListBag xs) = foldl' k z xs + +instance Traversable Bag where + traverse _ EmptyBag = pure EmptyBag + traverse f (UnitBag x) = UnitBag <$> f x + traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2 + traverse f (ListBag xs) = ListBag <$> traverse f xs diff --git a/compiler/GHC/Data/Bitmap.hs b/compiler/GHC/Data/Bitmap.hs index 55700ddf9a..0b7158aa24 100644 --- a/compiler/GHC/Data/Bitmap.hs +++ b/compiler/GHC/Data/Bitmap.hs @@ -14,7 +14,7 @@ module GHC.Data.Bitmap ( mAX_SMALL_BITMAP_SIZE, ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Runtime.Heap.Layout diff --git a/compiler/GHC/Data/BooleanFormula.hs b/compiler/GHC/Data/BooleanFormula.hs new file mode 100644 index 0000000000..15c97558eb --- /dev/null +++ b/compiler/GHC/Data/BooleanFormula.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} + +-------------------------------------------------------------------------------- +-- | Boolean formulas without quantifiers and without negation. +-- Such a formula consists of variables, conjunctions (and), and disjunctions (or). +-- +-- This module is used to represent minimal complete definitions for classes. +-- +module GHC.Data.BooleanFormula ( + BooleanFormula(..), LBooleanFormula, + mkFalse, mkTrue, mkAnd, mkOr, mkVar, + isFalse, isTrue, + eval, simplify, isUnsatisfied, + implies, impliesAtom, + pprBooleanFormula, pprBooleanFormulaNice + ) where + +import GHC.Prelude + +import Data.List ( nub, intersperse ) +import Data.Data + +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Binary +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.Set + +---------------------------------------------------------------------- +-- Boolean formula type and smart constructors +---------------------------------------------------------------------- + +type LBooleanFormula a = Located (BooleanFormula a) + +data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a] + | Parens (LBooleanFormula a) + deriving (Eq, Data, Functor, Foldable, Traversable) + +mkVar :: a -> BooleanFormula a +mkVar = Var + +mkFalse, mkTrue :: BooleanFormula a +mkFalse = Or [] +mkTrue = And [] + +-- Convert a Bool to a BooleanFormula +mkBool :: Bool -> BooleanFormula a +mkBool False = mkFalse +mkBool True = mkTrue + +-- Make a conjunction, and try to simplify +mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a +mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd + where + -- See Note [Simplification of BooleanFormulas] + fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a] + fromAnd (L _ (And xs)) = Just xs + -- assume that xs are already simplified + -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs + fromAnd (L _ (Or [])) = Nothing + -- in case of False we bail out, And [..,mkFalse,..] == mkFalse + fromAnd x = Just [x] + mkAnd' [x] = unLoc x + mkAnd' xs = And xs + +mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a +mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr + where + -- See Note [Simplification of BooleanFormulas] + fromOr (L _ (Or xs)) = Just xs + fromOr (L _ (And [])) = Nothing + fromOr x = Just [x] + mkOr' [x] = unLoc x + mkOr' xs = Or xs + + +{- +Note [Simplification of BooleanFormulas] +~~~~~~~~~~~~~~~~~~~~~~ +The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, + 1. Collapsing nested ands and ors, so + `(mkAnd [x, And [y,z]]` + is represented as + `And [x,y,z]` + Implemented by `fromAnd`/`fromOr` + 2. Collapsing trivial ands and ors, so + `mkAnd [x]` becomes just `x`. + Implemented by mkAnd' / mkOr' + 3. Conjunction with false, disjunction with true is simplified, i.e. + `mkAnd [mkFalse,x]` becomes `mkFalse`. + 4. Common subexpression elimination: + `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. + +This simplification is not exhaustive, in the sense that it will not produce +the smallest possible equivalent expression. For example, +`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently +is not. A general simplifier would need to use something like BDDs. + +The reason behind the (crude) simplifier is to make for more user friendly +error messages. E.g. for the code + > class Foo a where + > {-# MINIMAL bar, (foo, baq | foo, quux) #-} + > instance Foo Int where + > bar = ... + > baz = ... + > quux = ... +We don't show a ridiculous error message like + Implement () and (either (`foo' and ()) or (`foo' and ())) +-} + +---------------------------------------------------------------------- +-- Evaluation and simplification +---------------------------------------------------------------------- + +isFalse :: BooleanFormula a -> Bool +isFalse (Or []) = True +isFalse _ = False + +isTrue :: BooleanFormula a -> Bool +isTrue (And []) = True +isTrue _ = False + +eval :: (a -> Bool) -> BooleanFormula a -> Bool +eval f (Var x) = f x +eval f (And xs) = all (eval f . unLoc) xs +eval f (Or xs) = any (eval f . unLoc) xs +eval f (Parens x) = eval f (unLoc x) + +-- Simplify a boolean formula. +-- The argument function should give the truth of the atoms, or Nothing if undecided. +simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a +simplify f (Var a) = case f a of + Nothing -> Var a + Just b -> mkBool b +simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs) +simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs) +simplify f (Parens x) = simplify f (unLoc x) + +-- Test if a boolean formula is satisfied when the given values are assigned to the atoms +-- if it is, returns Nothing +-- if it is not, return (Just remainder) +isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) +isUnsatisfied f bf + | isTrue bf' = Nothing + | otherwise = Just bf' + where + f' x = if f x then Just True else Nothing + bf' = simplify f' bf + +-- prop_simplify: +-- eval f x == True <==> isTrue (simplify (Just . f) x) +-- eval f x == False <==> isFalse (simplify (Just . f) x) + +-- If the boolean formula holds, does that mean that the given atom is always true? +impliesAtom :: Eq a => BooleanFormula a -> a -> Bool +Var x `impliesAtom` y = x == y +And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs + -- we have all of xs, so one of them implying y is enough +Or xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs +Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y + +implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool +implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) + where + go :: Uniquable a => Clause a -> Clause a -> Bool + go l@Clause{ clauseExprs = hyp:hyps } r = + case hyp of + Var x | memberClauseAtoms x r -> True + | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r + Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r + And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r + Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' + go l r@Clause{ clauseExprs = con:cons } = + case con of + Var x | memberClauseAtoms x l -> True + | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons } + Parens con' -> go l r { clauseExprs = unLoc con':cons } + And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' + Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } + go _ _ = False + +-- A small sequent calculus proof engine. +data Clause a = Clause { + clauseAtoms :: UniqSet a, + clauseExprs :: [BooleanFormula a] + } +extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a +extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } + +memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool +memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c + +---------------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------------- + +-- Pretty print a BooleanFormula, +-- using the arguments as pretty printers for Var, And and Or respectively +pprBooleanFormula' :: (Rational -> a -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula' pprVar pprAnd pprOr = go + where + go p (Var x) = pprVar p x + go p (And []) = cparen (p > 0) $ empty + go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) + go _ (Or []) = keyword $ text "FALSE" + go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) + go p (Parens x) = go p (unLoc x) + +-- Pretty print in source syntax, "a | b | c,d,e" +pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr + where + pprAnd p = cparen (p > 3) . fsep . punctuate comma + pprOr p = cparen (p > 2) . fsep . intersperse vbar + +-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? +pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc +pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 + where + pprVar _ = quotes . ppr + pprAnd p = cparen (p > 1) . pprAnd' + pprAnd' [] = empty + pprAnd' [x,y] = x <+> text "and" <+> y + pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs + pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) + +instance (OutputableBndr a) => Outputable (BooleanFormula a) where + ppr = pprBooleanFormulaNormal + +pprBooleanFormulaNormal :: (OutputableBndr a) + => BooleanFormula a -> SDoc +pprBooleanFormulaNormal = go + where + go (Var x) = pprPrefixOcc x + go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) + go (Or []) = keyword $ text "FALSE" + go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) + go (Parens x) = parens (go $ unLoc x) + + +---------------------------------------------------------------------- +-- Binary +---------------------------------------------------------------------- + +instance Binary a => Binary (BooleanFormula a) where + put_ bh (Var x) = putByte bh 0 >> put_ bh x + put_ bh (And xs) = putByte bh 1 >> put_ bh xs + put_ bh (Or xs) = putByte bh 2 >> put_ bh xs + put_ bh (Parens x) = putByte bh 3 >> put_ bh x + + get bh = do + h <- getByte bh + case h of + 0 -> Var <$> get bh + 1 -> And <$> get bh + 2 -> Or <$> get bh + _ -> Parens <$> get bh diff --git a/compiler/GHC/Data/EnumSet.hs b/compiler/GHC/Data/EnumSet.hs new file mode 100644 index 0000000000..61d6bf002b --- /dev/null +++ b/compiler/GHC/Data/EnumSet.hs @@ -0,0 +1,35 @@ +-- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' +-- things. +module GHC.Data.EnumSet + ( EnumSet + , member + , insert + , delete + , toList + , fromList + , empty + ) where + +import GHC.Prelude + +import qualified Data.IntSet as IntSet + +newtype EnumSet a = EnumSet IntSet.IntSet + +member :: Enum a => a -> EnumSet a -> Bool +member x (EnumSet s) = IntSet.member (fromEnum x) s + +insert :: Enum a => a -> EnumSet a -> EnumSet a +insert x (EnumSet s) = EnumSet $ IntSet.insert (fromEnum x) s + +delete :: Enum a => a -> EnumSet a -> EnumSet a +delete x (EnumSet s) = EnumSet $ IntSet.delete (fromEnum x) s + +toList :: Enum a => EnumSet a -> [a] +toList (EnumSet s) = map toEnum $ IntSet.toList s + +fromList :: Enum a => [a] -> EnumSet a +fromList = EnumSet . IntSet.fromList . map fromEnum + +empty :: EnumSet a +empty = EnumSet IntSet.empty diff --git a/compiler/GHC/Data/FastMutInt.hs b/compiler/GHC/Data/FastMutInt.hs new file mode 100644 index 0000000000..cc81b88b01 --- /dev/null +++ b/compiler/GHC/Data/FastMutInt.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Unboxed mutable Ints + +module GHC.Data.FastMutInt( + FastMutInt, newFastMutInt, + readFastMutInt, writeFastMutInt, + + FastMutPtr, newFastMutPtr, + readFastMutPtr, writeFastMutPtr + ) where + +import GHC.Prelude + +import Data.Bits +import GHC.Base +import GHC.Ptr + +newFastMutInt :: IO FastMutInt +readFastMutInt :: FastMutInt -> IO Int +writeFastMutInt :: FastMutInt -> Int -> IO () + +newFastMutPtr :: IO FastMutPtr +readFastMutPtr :: FastMutPtr -> IO (Ptr a) +writeFastMutPtr :: FastMutPtr -> Ptr a -> IO () + +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where !(I# size) = finiteBitSize (0 :: Int) + +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of { s -> + (# s, () #) } + +data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) + +newFastMutPtr = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutPtr arr #) } + -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)' + where !(I# size) = finiteBitSize (0 :: Int) + +readFastMutPtr (FastMutPtr arr) = IO $ \s -> + case readAddrArray# arr 0# s of { (# s, i #) -> + (# s, Ptr i #) } + +writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s -> + case writeAddrArray# arr 0# i s of { s -> + (# s, () #) } diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs new file mode 100644 index 0000000000..82f38601f5 --- /dev/null +++ b/compiler/GHC/Data/FastString.hs @@ -0,0 +1,693 @@ +-- (c) The University of Glasgow, 1997-2006 + +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, + GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- | +-- There are two principal string types used internally by GHC: +-- +-- ['FastString'] +-- +-- * A compact, hash-consed, representation of character strings. +-- * Comparison is O(1), and you can get a 'Unique.Unique' from them. +-- * Generated by 'fsLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. +-- +-- ['PtrString'] +-- +-- * Pointer and size of a Latin-1 encoded string. +-- * Practically no operations. +-- * Outputting them is fast. +-- * Generated by 'sLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' +-- * Requires manual memory management. +-- Improper use may lead to memory leaks or dangling pointers. +-- * It assumes Latin-1 as the encoding, therefore it cannot represent +-- arbitrary Unicode strings. +-- +-- Use 'PtrString' unless you want the facilities of 'FastString'. +module GHC.Data.FastString + ( + -- * ByteString + bytesFS, -- :: FastString -> ByteString + fastStringToByteString, -- = bytesFS (kept for haddock) + mkFastStringByteString, + fastZStringToByteString, + unsafeMkByteString, + + -- * FastZString + FastZString, + hPutFZS, + zString, + lengthFZS, + + -- * FastStrings + FastString(..), -- not abstract, for now. + + -- ** Construction + fsLit, + mkFastString, + mkFastStringBytes, + mkFastStringByteList, + mkFastStringForeignPtr, + mkFastString#, + + -- ** Deconstruction + unpackFS, -- :: FastString -> String + + -- ** Encoding + zEncodeFS, + + -- ** Operations + uniqueOfFS, + lengthFS, + nullFS, + appendFS, + headFS, + tailFS, + concatFS, + consFS, + nilFS, + isUnderscoreFS, + + -- ** Outputting + hPutFS, + + -- ** Internal + getFastStringTable, + getFastStringZEncCounter, + + -- * PtrStrings + PtrString (..), + + -- ** Construction + sLit, + mkPtrString#, + mkPtrString, + + -- ** Deconstruction + unpackPtrString, + + -- ** Operations + lengthPS + ) where + +#include "HsVersions.h" + +import GHC.Prelude as Prelude + +import GHC.Utils.Encoding +import GHC.Utils.IO.Unsafe +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +import Control.Concurrent.MVar +import Control.DeepSeq +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Foreign.C +import GHC.Exts +import System.IO +import Data.Data +import Data.IORef +import Data.Char +import Data.Semigroup as Semi + +import GHC.IO + +import Foreign + +#if GHC_STAGE >= 2 +import GHC.Conc.Sync (sharedCAF) +#endif + +import GHC.Base ( unpackCString#, unpackNBytes# ) + + +-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' +bytesFS :: FastString -> ByteString +bytesFS f = fs_bs f + +{-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-} +fastStringToByteString :: FastString -> ByteString +fastStringToByteString = bytesFS + +fastZStringToByteString :: FastZString -> ByteString +fastZStringToByteString (FastZString bs) = bs + +-- This will drop information if any character > '\xFF' +unsafeMkByteString :: String -> ByteString +unsafeMkByteString = BSC.pack + +hashFastString :: FastString -> Int +hashFastString (FastString _ _ bs _) + = inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + return $ hashStr (castPtr ptr) len + +-- ----------------------------------------------------------------------------- + +newtype FastZString = FastZString ByteString + deriving NFData + +hPutFZS :: Handle -> FastZString -> IO () +hPutFZS handle (FastZString bs) = BS.hPut handle bs + +zString :: FastZString -> String +zString (FastZString bs) = + inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen + +lengthFZS :: FastZString -> Int +lengthFZS (FastZString bs) = BS.length bs + +mkFastZStringString :: String -> FastZString +mkFastZStringString str = FastZString (BSC.pack str) + +-- ----------------------------------------------------------------------------- + +{-| A 'FastString' is a UTF-8 encoded string together with a unique ID. All +'FastString's are stored in a global hashtable to support fast O(1) +comparison. + +It is also associated with a lazy reference to the Z-encoding +of this string which is used by the compiler internally. +-} +data FastString = FastString { + uniq :: {-# UNPACK #-} !Int, -- unique id + n_chars :: {-# UNPACK #-} !Int, -- number of chars + fs_bs :: {-# UNPACK #-} !ByteString, + fs_zenc :: FastZString + -- ^ Lazily computed z-encoding of this string. + -- + -- Since 'FastString's are globally memoized this is computed at most + -- once for any given string. + } + +instance Eq FastString where + f1 == f2 = uniq f1 == uniq f2 + +instance Ord FastString where + -- Compares lexicographically, not by unique + a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } + a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } + a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } + a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + compare a b = cmpFS a b + +instance IsString FastString where + fromString = fsLit + +instance Semi.Semigroup FastString where + (<>) = appendFS + +instance Monoid FastString where + mempty = nilFS + mappend = (Semi.<>) + mconcat = concatFS + +instance Show FastString where + show fs = show (unpackFS fs) + +instance Data FastString where + -- don't traverse? + toConstr _ = abstractConstr "FastString" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "FastString" + +instance NFData FastString where + rnf fs = seq fs () + +cmpFS :: FastString -> FastString -> Ordering +cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) = + if u1 == u2 then EQ else + compare (bytesFS f1) (bytesFS f2) + +foreign import ccall unsafe "memcmp" + memcmp :: Ptr a -> Ptr b -> Int -> IO Int + +-- ----------------------------------------------------------------------------- +-- Construction + +{- +Internally, the compiler will maintain a fast string symbol table, providing +sharing and fast comparison. Creation of new @FastString@s then covertly does a +lookup, re-using the @FastString@ if there was a hit. + +The design of the FastString hash table allows for lockless concurrent reads +and updates to multiple buckets with low synchronization overhead. + +See Note [Updating the FastString table] on how it's updated. +-} +data FastStringTable = FastStringTable + {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets + {-# UNPACK #-} !(IORef Int) -- number of computed z-encodings for all buckets + (Array# (IORef FastStringTableSegment)) -- concurrent segments + +data FastStringTableSegment = FastStringTableSegment + {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment + {-# UNPACK #-} !(IORef Int) -- the number of elements + (MutableArray# RealWorld [FastString]) -- buckets in this segment + +{- +Following parameters are determined based on: + +* Benchmark based on testsuite/tests/utils/should_run/T14854.hs +* Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@: + on 2018-10-24, we have 13920 entries. +-} +segmentBits, numSegments, segmentMask, initialNumBuckets :: Int +segmentBits = 8 +numSegments = 256 -- bit segmentBits +segmentMask = 0xff -- bit segmentBits - 1 +initialNumBuckets = 64 + +hashToSegment# :: Int# -> Int# +hashToSegment# hash# = hash# `andI#` segmentMask# + where + !(I# segmentMask#) = segmentMask + +hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int# +hashToIndex# buckets# hash# = + (hash# `uncheckedIShiftRL#` segmentBits#) `remInt#` size# + where + !(I# segmentBits#) = segmentBits + size# = sizeofMutableArray# buckets# + +maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment +maybeResizeSegment segmentRef = do + segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef + let oldSize# = sizeofMutableArray# old# + newSize# = oldSize# *# 2# + (I# n#) <- readIORef counter + if isTrue# (n# <# newSize#) -- maximum load of 1 + then return segment + else do + resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \s1# -> + case newArray# newSize# [] s1# of + (# s2#, arr# #) -> (# s2#, FastStringTableSegment lock counter arr# #) + forM_ [0 .. (I# oldSize#) - 1] $ \(I# i#) -> do + fsList <- IO $ readArray# old# i# + forM_ fsList $ \fs -> do + let -- Shall we store in hash value in FastString instead? + !(I# hash#) = hashFastString fs + idx# = hashToIndex# new# hash# + IO $ \s1# -> + case readArray# new# idx# s1# of + (# s2#, bucket #) -> case writeArray# new# idx# (fs: bucket) s2# of + s3# -> (# s3#, () #) + writeIORef segmentRef resizedSegment + return resizedSegment + +{-# NOINLINE stringTable #-} +stringTable :: FastStringTable +stringTable = unsafePerformIO $ do + let !(I# numSegments#) = numSegments + !(I# initialNumBuckets#) = initialNumBuckets + loop a# i# s1# + | isTrue# (i# ==# numSegments#) = s1# + | otherwise = case newMVar () `unIO` s1# of + (# s2#, lock #) -> case newIORef 0 `unIO` s2# of + (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of + (# s4#, buckets# #) -> case newIORef + (FastStringTableSegment lock counter buckets#) `unIO` s4# of + (# s5#, segment #) -> case writeArray# a# i# segment s5# of + s6# -> loop a# (i# +# 1#) s6# + uid <- newIORef 603979776 -- ord '$' * 0x01000000 + n_zencs <- newIORef 0 + tab <- IO $ \s1# -> + case newArray# numSegments# (panic "string_table") s1# of + (# s2#, arr# #) -> case loop arr# 0# s2# of + s3# -> case unsafeFreezeArray# arr# s3# of + (# s4#, segments# #) -> + (# s4#, FastStringTable uid n_zencs segments# #) + + -- use the support wired into the RTS to share this CAF among all images of + -- libHSghc +#if GHC_STAGE < 2 + return tab +#else + sharedCAF tab getOrSetLibHSghcFastStringTable + +-- from the RTS; thus we cannot use this mechanism when GHC_STAGE<2; the previous +-- RTS might not have this symbol +foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" + getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) +#endif + +{- + +We include the FastString table in the `sharedCAF` mechanism because we'd like +FastStrings created by a Core plugin to have the same uniques as corresponding +strings created by the host compiler itself. For example, this allows plugins +to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or +even re-invoke the parser. + +In particular, the following little sanity test was failing in a plugin +prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not +be looked up /by the plugin/. + + let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" + putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts + +`mkTcOcc` involves the lookup (or creation) of a FastString. Since the +plugin's FastString.string_table is empty, constructing the RdrName also +allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These +uniques are almost certainly unequal to the ones that the host compiler +originally assigned to those FastStrings. Thus the lookup fails since the +domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's +unique. + +Maintaining synchronization of the two instances of this global is rather +difficult because of the uses of `unsafePerformIO` in this module. Not +synchronizing them risks breaking the rather major invariant that two +FastStrings with the same unique have the same string. Thus we use the +lower-level `sharedCAF` mechanism that relies on Globals.c. + +-} + +mkFastString# :: Addr# -> FastString +mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) + where ptr = Ptr a# + +{- Note [Updating the FastString table] + +We use a concurrent hashtable which contains multiple segments, each hash value +always maps to the same segment. Read is lock-free, write to the a segment +should acquire a lock for that segment to avoid race condition, writes to +different segments are independent. + +The procedure goes like this: + +1. Find out which segment to operate on based on the hash value +2. Read the relevant bucket and perform a look up of the string. +3. If it exists, return it. +4. Otherwise grab a unique ID, create a new FastString and atomically attempt + to update the relevant segment with this FastString: + + * Resize the segment by doubling the number of buckets when the number of + FastStrings in this segment grows beyond the threshold. + * Double check that the string is not in the bucket. Another thread may have + inserted it while we were creating our string. + * Return the existing FastString if it exists. The one we preemptively + created will get GCed. + * Otherwise, insert and return the string we created. +-} + +mkFastStringWith + :: (Int -> IORef Int-> IO FastString) -> Ptr Word8 -> Int -> IO FastString +mkFastStringWith mk_fs !ptr !len = do + FastStringTableSegment lock _ buckets# <- readIORef segmentRef + let idx# = hashToIndex# buckets# hash# + bucket <- IO $ readArray# buckets# idx# + res <- bucket_match bucket len ptr + case res of + Just found -> return found + Nothing -> do + -- The withMVar below is not dupable. It can lead to deadlock if it is + -- only run partially and putMVar is not called after takeMVar. + noDuplicate + n <- get_uid + new_fs <- mk_fs n n_zencs + withMVar lock $ \_ -> insert new_fs + where + !(FastStringTable uid n_zencs segments#) = stringTable + get_uid = atomicModifyIORef' uid $ \n -> (n+1,n) + + !(I# hash#) = hashStr ptr len + (# segmentRef #) = indexArray# segments# (hashToSegment# hash#) + insert fs = do + FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef + let idx# = hashToIndex# buckets# hash# + bucket <- IO $ readArray# buckets# idx# + res <- bucket_match bucket len ptr + case res of + -- The FastString was added by another thread after previous read and + -- before we acquired the write lock. + Just found -> return found + Nothing -> do + IO $ \s1# -> + case writeArray# buckets# idx# (fs: bucket) s1# of + s2# -> (# s2#, () #) + modifyIORef' counter succ + return fs + +bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString) +bucket_match [] _ _ = return Nothing +bucket_match (v@(FastString _ _ bs _):ls) len ptr + | len == BS.length bs = do + b <- BS.unsafeUseAsCString bs $ \buf -> + cmpStringPrefix ptr (castPtr buf) len + if b then return (Just v) + else bucket_match ls len ptr + | otherwise = + bucket_match ls len ptr + +mkFastStringBytes :: Ptr Word8 -> Int -> FastString +mkFastStringBytes !ptr !len = + -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- idempotent. + unsafeDupablePerformIO $ + mkFastStringWith (copyNewFastString ptr len) ptr len + +-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference +-- between this and 'mkFastStringBytes' is that we don't have to copy +-- the bytes if the string is new to the table. +mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString +mkFastStringForeignPtr ptr !fp len + = mkFastStringWith (mkNewFastString fp ptr len) ptr len + +-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference +-- between this and 'mkFastStringBytes' is that we don't have to copy +-- the bytes if the string is new to the table. +mkFastStringByteString :: ByteString -> FastString +mkFastStringByteString bs = + inlinePerformIO $ + BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do + let ptr' = castPtr ptr + mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len + +-- | Creates a UTF-8 encoded 'FastString' from a 'String' +mkFastString :: String -> FastString +mkFastString str = + inlinePerformIO $ do + let l = utf8EncodedLength str + buf <- mallocForeignPtrBytes l + withForeignPtr buf $ \ptr -> do + utf8EncodeString ptr str + mkFastStringForeignPtr ptr buf l + +-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ +mkFastStringByteList :: [Word8] -> FastString +mkFastStringByteList str = mkFastStringByteString (BS.pack str) + +-- | Creates a (lazy) Z-encoded 'FastString' from a 'String' and account +-- the number of forced z-strings into the passed 'IORef'. +mkZFastString :: IORef Int -> ByteString -> FastZString +mkZFastString n_zencs bs = unsafePerformIO $ do + atomicModifyIORef' n_zencs $ \n -> (n+1, ()) + return $ mkFastZStringString (zEncodeString (utf8DecodeByteString bs)) + +mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int + -> IORef Int -> IO FastString +mkNewFastString fp ptr len uid n_zencs = do + let bs = BS.fromForeignPtr fp 0 len + zstr = mkZFastString n_zencs bs + n_chars <- countUTF8Chars ptr len + return (FastString uid n_chars bs zstr) + +mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int + -> IORef Int -> IO FastString +mkNewFastStringByteString bs ptr len uid n_zencs = do + let zstr = mkZFastString n_zencs bs + n_chars <- countUTF8Chars ptr len + return (FastString uid n_chars bs zstr) + +copyNewFastString :: Ptr Word8 -> Int -> Int -> IORef Int -> IO FastString +copyNewFastString ptr len uid n_zencs = do + fp <- copyBytesToForeignPtr ptr len + let bs = BS.fromForeignPtr fp 0 len + zstr = mkZFastString n_zencs bs + n_chars <- countUTF8Chars ptr len + return (FastString uid n_chars bs zstr) + +copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8) +copyBytesToForeignPtr ptr len = do + fp <- mallocForeignPtrBytes len + withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len + return fp + +cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool +cmpStringPrefix ptr1 ptr2 len = + do r <- memcmp ptr1 ptr2 len + return (r == 0) + +hashStr :: Ptr Word8 -> Int -> Int + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashStr (Ptr a#) (I# len#) = loop 0# 0# + where + loop h n = + if isTrue# (n ==# len#) then + I# h + else + let + -- DO NOT move this let binding! indexCharOffAddr# reads from the + -- pointer so we need to evaluate this based on the length check + -- above. Not doing this right caused #17909. + !c = ord# (indexCharOffAddr# a# n) + !h2 = (h *# 16777619#) `xorI#` c + in + loop h2 (n +# 1#) + +-- ----------------------------------------------------------------------------- +-- Operations + +-- | Returns the length of the 'FastString' in characters +lengthFS :: FastString -> Int +lengthFS f = n_chars f + +-- | Returns @True@ if the 'FastString' is empty +nullFS :: FastString -> Bool +nullFS f = BS.null (fs_bs f) + +-- | Unpacks and decodes the FastString +unpackFS :: FastString -> String +unpackFS (FastString _ _ bs _) = utf8DecodeByteString bs + +-- | Returns a Z-encoded version of a 'FastString'. This might be the +-- original, if it was already Z-encoded. The first time this +-- function is applied to a particular 'FastString', the results are +-- memoized. +-- +zEncodeFS :: FastString -> FastZString +zEncodeFS (FastString _ _ _ ref) = ref + +appendFS :: FastString -> FastString -> FastString +appendFS fs1 fs2 = mkFastStringByteString + $ BS.append (bytesFS fs1) (bytesFS fs2) + +concatFS :: [FastString] -> FastString +concatFS = mkFastStringByteString . BS.concat . map fs_bs + +headFS :: FastString -> Char +headFS (FastString _ 0 _ _) = panic "headFS: Empty FastString" +headFS (FastString _ _ bs _) = + inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> + return (fst (utf8DecodeChar (castPtr ptr))) + +tailFS :: FastString -> FastString +tailFS (FastString _ 0 _ _) = panic "tailFS: Empty FastString" +tailFS (FastString _ _ bs _) = + inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> + do let (_, n) = utf8DecodeChar (castPtr ptr) + return $! mkFastStringByteString (BS.drop n bs) + +consFS :: Char -> FastString -> FastString +consFS c fs = mkFastString (c : unpackFS fs) + +uniqueOfFS :: FastString -> Int +uniqueOfFS (FastString u _ _ _) = u + +nilFS :: FastString +nilFS = mkFastString "" + +isUnderscoreFS :: FastString -> Bool +isUnderscoreFS fs = fs == fsLit "_" + +-- ----------------------------------------------------------------------------- +-- Stats + +getFastStringTable :: IO [[[FastString]]] +getFastStringTable = + forM [0 .. numSegments - 1] $ \(I# i#) -> do + let (# segmentRef #) = indexArray# segments# i# + FastStringTableSegment _ _ buckets# <- readIORef segmentRef + let bucketSize = I# (sizeofMutableArray# buckets#) + forM [0 .. bucketSize - 1] $ \(I# j#) -> + IO $ readArray# buckets# j# + where + !(FastStringTable _ _ segments#) = stringTable + +getFastStringZEncCounter :: IO Int +getFastStringZEncCounter = readIORef n_zencs + where + !(FastStringTable _ n_zencs _) = stringTable + +-- ----------------------------------------------------------------------------- +-- Outputting 'FastString's + +-- |Outputs a 'FastString' with /no decoding at all/, that is, you +-- get the actual bytes in the 'FastString' written to the 'Handle'. +hPutFS :: Handle -> FastString -> IO () +hPutFS handle fs = BS.hPut handle $ bytesFS fs + +-- ToDo: we'll probably want an hPutFSLocal, or something, to output +-- in the current locale's encoding (for error messages and suchlike). + +-- ----------------------------------------------------------------------------- +-- PtrStrings, here for convenience only. + +-- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars. +data PtrString = PtrString !(Ptr Word8) !Int + +-- | Wrap an unboxed address into a 'PtrString'. +mkPtrString# :: Addr# -> PtrString +mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) + +-- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 +-- encoding. The original string must not contain non-Latin-1 characters +-- (above codepoint @0xff@). +{-# INLINE mkPtrString #-} +mkPtrString :: String -> PtrString +mkPtrString s = + -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks + -- and because someone might be using `eqAddr#` to check for string equality. + unsafePerformIO (do + let len = length s + p <- mallocBytes len + let + loop :: Int -> String -> IO () + loop !_ [] = return () + loop n (c:cs) = do + pokeByteOff p n (fromIntegral (ord c) :: Word8) + loop (1+n) cs + loop 0 s + return (PtrString p len) + ) + +-- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. +-- This does not free the memory associated with 'PtrString'. +unpackPtrString :: PtrString -> String +unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# + +-- | Return the length of a 'PtrString' +lengthPS :: PtrString -> Int +lengthPS (PtrString _ n) = n + +-- ----------------------------------------------------------------------------- +-- under the carpet + +foreign import ccall unsafe "strlen" + ptrStrLength :: Ptr Word8 -> Int + +{-# NOINLINE sLit #-} +sLit :: String -> PtrString +sLit x = mkPtrString x + +{-# NOINLINE fsLit #-} +fsLit :: String -> FastString +fsLit x = mkFastString x + +{-# RULES "slit" + forall x . sLit (unpackCString# x) = mkPtrString# x #-} +{-# RULES "fslit" + forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/compiler/GHC/Data/FastString/Env.hs b/compiler/GHC/Data/FastString/Env.hs new file mode 100644 index 0000000000..36fab5727c --- /dev/null +++ b/compiler/GHC/Data/FastString/Env.hs @@ -0,0 +1,100 @@ +{- +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +-} + +-- | FastStringEnv: FastString environments +module GHC.Data.FastString.Env ( + -- * FastString environments (maps) + FastStringEnv, + + -- ** Manipulating these environments + mkFsEnv, + emptyFsEnv, unitFsEnv, + extendFsEnv_C, extendFsEnv_Acc, extendFsEnv, + extendFsEnvList, extendFsEnvList_C, + filterFsEnv, + plusFsEnv, plusFsEnv_C, alterFsEnv, + lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, + elemFsEnv, mapFsEnv, + + -- * Deterministic FastString environments (maps) + DFastStringEnv, + + -- ** Manipulating these environments + mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv + ) where + +import GHC.Prelude + +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Data.Maybe +import GHC.Data.FastString + + +-- | A non-deterministic set of FastStrings. +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why it's not +-- deterministic and why it matters. Use DFastStringEnv if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code. +type FastStringEnv a = UniqFM a -- Domain is FastString + +emptyFsEnv :: FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a +alterFsEnv :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a +extendFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a +extendFsEnv_Acc :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +plusFsEnv :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a +plusFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a +extendFsEnvList :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a +extendFsEnvList_C :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a +delFromFsEnv :: FastStringEnv a -> FastString -> FastStringEnv a +delListFromFsEnv :: FastStringEnv a -> [FastString] -> FastStringEnv a +elemFsEnv :: FastString -> FastStringEnv a -> Bool +unitFsEnv :: FastString -> a -> FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +lookupFsEnv_NF :: FastStringEnv a -> FastString -> a +filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt +mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 + +emptyFsEnv = emptyUFM +unitFsEnv x y = unitUFM x y +extendFsEnv x y z = addToUFM x y z +extendFsEnvList x l = addListToUFM x l +lookupFsEnv x y = lookupUFM x y +alterFsEnv = alterUFM +mkFsEnv l = listToUFM l +elemFsEnv x y = elemUFM x y +plusFsEnv x y = plusUFM x y +plusFsEnv_C f x y = plusUFM_C f x y +extendFsEnv_C f x y z = addToUFM_C f x y z +mapFsEnv f x = mapUFM f x +extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendFsEnvList_C x y z = addListToUFM_C x y z +delFromFsEnv x y = delFromUFM x y +delListFromFsEnv x y = delListFromUFM x y +filterFsEnv x y = filterUFM x y + +lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) + +-- Deterministic FastStringEnv +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DFastStringEnv. + +type DFastStringEnv a = UniqDFM a -- Domain is FastString + +emptyDFsEnv :: DFastStringEnv a +emptyDFsEnv = emptyUDFM + +dFsEnvElts :: DFastStringEnv a -> [a] +dFsEnvElts = eltsUDFM + +mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a +mkDFsEnv l = listToUDFM l + +lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a +lookupDFsEnv = lookupUDFM diff --git a/compiler/GHC/Data/FiniteMap.hs b/compiler/GHC/Data/FiniteMap.hs new file mode 100644 index 0000000000..055944d320 --- /dev/null +++ b/compiler/GHC/Data/FiniteMap.hs @@ -0,0 +1,31 @@ +-- Some extra functions to extend Data.Map + +module GHC.Data.FiniteMap ( + insertList, + insertListWith, + deleteList, + foldRight, foldRightWithKey + ) where + +import GHC.Prelude + +import Data.Map (Map) +import qualified Data.Map as Map + +insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt +insertList xs m = foldl' (\m (k, v) -> Map.insert k v m) m xs + +insertListWith :: Ord key + => (elt -> elt -> elt) + -> [(key,elt)] + -> Map key elt + -> Map key elt +insertListWith f xs m0 = foldl' (\m (k, v) -> Map.insertWith f k v m) m0 xs + +deleteList :: Ord key => [key] -> Map key elt -> Map key elt +deleteList ks m = foldl' (flip Map.delete) m ks + +foldRight :: (elt -> a -> a) -> a -> Map key elt -> a +foldRight = Map.foldr +foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a +foldRightWithKey = Map.foldrWithKey diff --git a/compiler/GHC/Data/Graph/Base.hs b/compiler/GHC/Data/Graph/Base.hs new file mode 100644 index 0000000000..3c40645660 --- /dev/null +++ b/compiler/GHC/Data/Graph/Base.hs @@ -0,0 +1,107 @@ + +-- | Types for the general graph colorer. +module GHC.Data.Graph.Base ( + Triv, + Graph (..), + initGraph, + graphMapModify, + + Node (..), newNode, +) + + +where + +import GHC.Prelude + +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + + +-- | A fn to check if a node is trivially colorable +-- For graphs who's color classes are disjoint then a node is 'trivially colorable' +-- when it has less neighbors and exclusions than available colors for that node. +-- +-- For graph's who's color classes overlap, ie some colors alias other colors, then +-- this can be a bit more tricky. There is a general way to calculate this, but +-- it's likely be too slow for use in the code. The coloring algorithm takes +-- a canned function which can be optimised by the user to be specific to the +-- specific graph being colored. +-- +-- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation" +-- Smith, Ramsey, Holloway - PLDI 2004. +-- +type Triv k cls color + = cls -- the class of the node we're trying to color. + -> UniqSet k -- the node's neighbors. + -> UniqSet color -- the node's exclusions. + -> Bool + + +-- | The Interference graph. +-- There used to be more fields, but they were turfed out in a previous revision. +-- maybe we'll want more later.. +-- +data Graph k cls color + = Graph { + -- | All active nodes in the graph. + graphMap :: UniqFM (Node k cls color) } + + +-- | An empty graph. +initGraph :: Graph k cls color +initGraph + = Graph + { graphMap = emptyUFM } + + +-- | Modify the finite map holding the nodes in the graph. +graphMapModify + :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color)) + -> Graph k cls color -> Graph k cls color + +graphMapModify f graph + = graph { graphMap = f (graphMap graph) } + + + +-- | Graph nodes. +-- Represents a thing that can conflict with another thing. +-- For the register allocater the nodes represent registers. +-- +data Node k cls color + = Node { + -- | A unique identifier for this node. + nodeId :: k + + -- | The class of this node, + -- determines the set of colors that can be used. + , nodeClass :: cls + + -- | The color of this node, if any. + , nodeColor :: Maybe color + + -- | Neighbors which must be colored differently to this node. + , nodeConflicts :: UniqSet k + + -- | Colors that cannot be used by this node. + , nodeExclusions :: UniqSet color + + -- | Colors that this node would prefer to be, in descending order. + , nodePreference :: [color] + + -- | Neighbors that this node would like to be colored the same as. + , nodeCoalesce :: UniqSet k } + + +-- | An empty node. +newNode :: k -> cls -> Node k cls color +newNode k cls + = Node + { nodeId = k + , nodeClass = cls + , nodeColor = Nothing + , nodeConflicts = emptyUniqSet + , nodeExclusions = emptyUniqSet + , nodePreference = [] + , nodeCoalesce = emptyUniqSet } diff --git a/compiler/GHC/Data/Graph/Color.hs b/compiler/GHC/Data/Graph/Color.hs new file mode 100644 index 0000000000..948447da58 --- /dev/null +++ b/compiler/GHC/Data/Graph/Color.hs @@ -0,0 +1,375 @@ +-- | Graph Coloring. +-- This is a generic graph coloring library, abstracted over the type of +-- the node keys, nodes and colors. +-- + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Data.Graph.Color ( + module GHC.Data.Graph.Base, + module GHC.Data.Graph.Ops, + module GHC.Data.Graph.Ppr, + colorGraph +) + +where + +import GHC.Prelude + +import GHC.Data.Graph.Base +import GHC.Data.Graph.Ops +import GHC.Data.Graph.Ppr + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Utils.Outputable + +import Data.Maybe +import Data.List + + +-- | Try to color a graph with this set of colors. +-- Uses Chaitin's algorithm to color the graph. +-- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes +-- are pushed onto a stack and removed from the graph. +-- Once this process is complete the graph can be colored by removing nodes from +-- the stack (ie in reverse order) and assigning them colors different to their neighbors. +-- +colorGraph + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq cls, Ord k + , Outputable k, Outputable cls, Outputable color) + => Bool -- ^ whether to do iterative coalescing + -> Int -- ^ how many times we've tried to color this graph so far. + -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to color. + + -> ( Graph k cls color -- the colored graph. + , UniqSet k -- the set of nodes that we couldn't find a color for. + , UniqFM k ) -- map of regs (r1 -> r2) that were coalesced + -- r1 should be replaced by r2 in the source + +colorGraph iterative spinCount colors triv spill graph0 + = let + -- If we're not doing iterative coalescing then do an aggressive coalescing first time + -- around and then conservative coalescing for subsequent passes. + -- + -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if + -- there is a lot of register pressure and we do it on every round then it can make the + -- graph less colorable and prevent the algorithm from converging in a sensible number + -- of cycles. + -- + (graph_coalesced, kksCoalesce1) + = if iterative + then (graph0, []) + else if spinCount == 0 + then coalesceGraph True triv graph0 + else coalesceGraph False triv graph0 + + -- run the scanner to slurp out all the trivially colorable nodes + -- (and do coalescing if iterative coalescing is enabled) + (ksTriv, ksProblems, kksCoalesce2) + = colorScan iterative triv spill graph_coalesced + + -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. + -- We need to apply all the coalescences found by the scanner to the original + -- graph before doing assignColors. + -- + -- Because we've got the whole, non-pruned graph here we turn on aggressive coalescing + -- to force all the (conservative) coalescences found during scanning. + -- + (graph_scan_coalesced, _) + = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 + + -- color the trivially colorable nodes + -- during scanning, keys of triv nodes were added to the front of the list as they were found + -- this colors them in the reverse order, as required by the algorithm. + (graph_triv, ksNoTriv) + = assignColors colors graph_scan_coalesced ksTriv + + -- try and color the problem nodes + -- problem nodes are the ones that were left uncolored because they weren't triv. + -- theres a change we can color them here anyway. + (graph_prob, ksNoColor) + = assignColors colors graph_triv ksProblems + + -- if the trivially colorable nodes didn't color then something is probably wrong + -- with the provided triv function. + -- + in if not $ null ksNoTriv + then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty + ( empty + $$ text "ksTriv = " <> ppr ksTriv + $$ text "ksNoTriv = " <> ppr ksNoTriv + $$ text "colors = " <> ppr colors + $$ empty + $$ dotGraph (\_ -> text "white") triv graph_triv) + + else ( graph_prob + , mkUniqSet ksNoColor -- the nodes that didn't color (spills) + , if iterative + then (listToUFM kksCoalesce2) + else (listToUFM kksCoalesce1)) + + +-- | Scan through the conflict graph separating out trivially colorable and +-- potentially uncolorable (problem) nodes. +-- +-- Checking whether a node is trivially colorable or not is a reasonably expensive operation, +-- so after a triv node is found and removed from the graph it's no good to return to the 'start' +-- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. +-- +-- To ward against this, during each pass through the graph we collect up a list of triv nodes +-- that were found, and only remove them once we've finished the pass. The more nodes we can delete +-- at once the more likely it is that nodes we've already checked will become trivially colorable +-- for the next pass. +-- +-- TODO: add work lists to finding triv nodes is easier. +-- If we've just scanned the graph, and removed triv nodes, then the only +-- nodes that we need to rescan are the ones we've removed edges from. + +colorScan + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool -- ^ whether to do iterative coalescing + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to scan + + -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce + +colorScan iterative triv spill graph + = colorScan_spin iterative triv spill graph [] [] [] + +colorScan_spin + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spin iterative triv spill graph + ksTriv ksSpill kksCoalesce + + -- if the graph is empty then we're done + | isNullUFM $ graphMap graph + = (ksTriv, ksSpill, reverse kksCoalesce) + + -- Simplify: + -- Look for trivially colorable nodes. + -- If we can find some then remove them from the graph and go back for more. + -- + | nsTrivFound@(_:_) + <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + + -- for iterative coalescing we only want non-move related + -- nodes here + && (not iterative || isEmptyUniqSet (nodeCoalesce node))) + $ graph + + , ksTrivFound <- map nodeId nsTrivFound + , graph2 <- foldr (\k g -> let Just g' = delNode k g + in g') + graph ksTrivFound + + = colorScan_spin iterative triv spill graph2 + (ksTrivFound ++ ksTriv) + ksSpill + kksCoalesce + + -- Coalesce: + -- If we're doing iterative coalescing and no triv nodes are available + -- then it's time for a coalescing pass. + | iterative + = case coalesceGraph False triv graph of + + -- we were able to coalesce something + -- go back to Simplify and see if this frees up more nodes to be trivially colorable. + (graph2, kksCoalesceFound@(_:_)) + -> colorScan_spin iterative triv spill graph2 + ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) + + -- Freeze: + -- nothing could be coalesced (or was triv), + -- time to choose a node to freeze and give up on ever coalescing it. + (graph2, []) + -> case freezeOneInGraph graph2 of + + -- we were able to freeze something + -- hopefully this will free up something for Simplify + (graph3, True) + -> colorScan_spin iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- we couldn't find something to freeze either + -- time for a spill + (graph3, False) + -> colorScan_spill iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- spill time + | otherwise + = colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + +-- Select: +-- we couldn't find any triv nodes or things to freeze or coalesce, +-- and the graph isn't empty yet.. We'll have to choose a spill +-- candidate and leave it uncolored. +-- +colorScan_spill + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + +colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce + + = let kSpill = spill graph + Just graph' = delNode kSpill graph + in colorScan_spin iterative triv spill graph' + ksTriv (kSpill : ksSpill) kksCoalesce + + +-- | Try to assign a color to all these nodes. + +assignColors + :: ( Uniquable k, Uniquable cls, Uniquable color + , Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> [k] -- ^ nodes to assign a color to. + -> ( Graph k cls color -- the colored graph + , [k]) -- the nodes that didn't color. + +assignColors colors graph ks + = assignColors' colors graph [] ks + + where assignColors' _ graph prob [] + = (graph, prob) + + assignColors' colors graph prob (k:ks) + = case assignColor colors k graph of + + -- couldn't color this node + Nothing -> assignColors' colors graph (k : prob) ks + + -- this node colored ok, so do the rest + Just graph' -> assignColors' colors graph' prob ks + + + assignColor colors u graph + | Just c <- selectColor colors graph u + = Just (setColor u c graph) + + | otherwise + = Nothing + + + +-- | Select a color for a certain node +-- taking into account preferences, neighbors and exclusions. +-- returns Nothing if no color can be assigned to this node. +-- +selectColor + :: ( Uniquable k, Uniquable cls, Uniquable color + , Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> k -- ^ key of the node to select a color for. + -> Maybe color + +selectColor colors graph u + = let -- lookup the node + Just node = lookupNode graph u + + -- lookup the available colors for the class of this node. + colors_avail + = case lookupUFM colors (nodeClass node) of + Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) + Just cs -> cs + + -- find colors we can't use because they're already being used + -- by a node that conflicts with this one. + Just nsConflicts + = sequence + $ map (lookupNode graph) + $ nonDetEltsUniqSet + $ nodeConflicts node + -- See Note [Unique Determinism and code generation] + + colors_conflict = mkUniqSet + $ catMaybes + $ map nodeColor nsConflicts + + -- the prefs of our neighbors + colors_neighbor_prefs + = mkUniqSet + $ concatMap nodePreference nsConflicts + + -- colors that are still valid for us + colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) + colors_ok = minusUniqSet colors_ok_ex colors_conflict + + -- the colors that we prefer, and are still ok + colors_ok_pref = intersectUniqSets + (mkUniqSet $ nodePreference node) colors_ok + + -- the colors that we could choose while being nice to our neighbors + colors_ok_nice = minusUniqSet + colors_ok colors_neighbor_prefs + + -- the best of all possible worlds.. + colors_ok_pref_nice + = intersectUniqSets + colors_ok_nice colors_ok_pref + + -- make the decision + chooseColor + + -- everyone is happy, yay! + | not $ isEmptyUniqSet colors_ok_pref_nice + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) + (nodePreference node) + = Just c + + -- we've got one of our preferences + | not $ isEmptyUniqSet colors_ok_pref + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) + (nodePreference node) + = Just c + + -- it wasn't a preference, but it was still ok + | not $ isEmptyUniqSet colors_ok + , c : _ <- nonDetEltsUniqSet colors_ok + -- See Note [Unique Determinism and code generation] + = Just c + + -- no colors were available for us this time. + -- looks like we're going around the loop again.. + | otherwise + = Nothing + + in chooseColor + + + diff --git a/compiler/GHC/Data/Graph/Directed.hs b/compiler/GHC/Data/Graph/Directed.hs new file mode 100644 index 0000000000..c3f397051a --- /dev/null +++ b/compiler/GHC/Data/Graph/Directed.hs @@ -0,0 +1,524 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Data.Graph.Directed ( + Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, + + SCC(..), Node(..), flattenSCC, flattenSCCs, + stronglyConnCompG, + topologicalSortG, + verticesG, edgesG, hasVertexG, + reachableG, reachablesG, transposeG, + emptyG, + + findCycle, + + -- For backwards compatibility with the simpler version of Digraph + stronglyConnCompFromEdgedVerticesOrd, + stronglyConnCompFromEdgedVerticesOrdR, + stronglyConnCompFromEdgedVerticesUniq, + stronglyConnCompFromEdgedVerticesUniqR, + + -- Simple way to classify edges + EdgeType(..), classifyEdges + ) where + +#include "HsVersions.h" + +------------------------------------------------------------------------------ +-- A version of the graph algorithms described in: +-- +-- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' +-- by David King and John Launchbury +-- +-- Also included is some additional code for printing tree structures ... +-- +-- If you ever find yourself in need of algorithms for classifying edges, +-- or finding connected/biconnected components, consult the history; Sigbjorn +-- Finne contributed some implementations in 1997, although we've since +-- removed them since they were not used anywhere in GHC. +------------------------------------------------------------------------------ + + +import GHC.Prelude + +import GHC.Utils.Misc ( minWith, count ) +import GHC.Utils.Outputable +import GHC.Data.Maybe ( expectJust ) + +-- std interfaces +import Data.Maybe +import Data.Array +import Data.List hiding (transpose) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Data.Graph as G +import Data.Graph hiding (Graph, Edge, transposeG, reachable) +import Data.Tree +import GHC.Types.Unique +import GHC.Types.Unique.FM + +{- +************************************************************************ +* * +* Graphs and Graph Construction +* * +************************************************************************ + +Note [Nodes, keys, vertices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * A 'node' is a big blob of client-stuff + + * Each 'node' has a unique (client) 'key', but the latter + is in Ord and has fast comparison + + * Digraph then maps each 'key' to a Vertex (Int) which is + arranged densely in 0.n +-} + +data Graph node = Graph { + gr_int_graph :: IntGraph, + gr_vertex_to_node :: Vertex -> node, + gr_node_to_vertex :: node -> Maybe Vertex + } + +data Edge node = Edge node node + +{-| Representation for nodes of the Graph. + + * The @payload@ is user data, just carried around in this module + + * The @key@ is the node identifier. + Key has an Ord instance for performance reasons. + + * The @[key]@ are the dependencies of the node; + it's ok to have extra keys in the dependencies that + are not the key of any Node in the graph +-} +data Node key payload = DigraphNode { + node_payload :: payload, -- ^ User data + node_key :: key, -- ^ User defined node id + node_dependencies :: [key] -- ^ Dependencies/successors of the node + } + + +instance (Outputable a, Outputable b) => Outputable (Node a b) where + ppr (DigraphNode a b c) = ppr (a, b, c) + +emptyGraph :: Graph a +emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) + +-- See Note [Deterministic SCC] +graphFromEdgedVertices + :: ReduceFn key payload + -> [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVertices _reduceFn [] = emptyGraph +graphFromEdgedVertices reduceFn edged_vertices = + Graph graph vertex_fn (key_vertex . key_extractor) + where key_extractor = node_key + (bounds, vertex_fn, key_vertex, numbered_nodes) = + reduceFn edged_vertices key_extractor + graph = array bounds [ (v, sort $ mapMaybe key_vertex ks) + | (v, (node_dependencies -> ks)) <- numbered_nodes] + -- We normalize outgoing edges by sorting on node order, so + -- that the result doesn't depend on the order of the edges + +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +graphFromEdgedVerticesOrd + :: Ord key + => [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd + +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +graphFromEdgedVerticesUniq + :: Uniquable key + => [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq + +type ReduceFn key payload = + [Node key payload] -> (Node key payload -> key) -> + (Bounds, Vertex -> Node key payload + , key -> Maybe Vertex, [(Vertex, Node key payload)]) + +{- +Note [reduceNodesIntoVertices implementations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +reduceNodesIntoVertices is parameterized by the container type. +This is to accommodate key types that don't have an Ord instance +and hence preclude the use of Data.Map. An example of such type +would be Unique, there's no way to implement Ord Unique +deterministically. + +For such types, there's a version with a Uniquable constraint. +This leaves us with two versions of every function that depends on +reduceNodesIntoVertices, one with Ord constraint and the other with +Uniquable constraint. +For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq. + +The Uniq version should be a tiny bit more efficient since it uses +Data.IntMap internally. +-} +reduceNodesIntoVertices + :: ([(key, Vertex)] -> m) + -> (key -> m -> Maybe Vertex) + -> ReduceFn key payload +reduceNodesIntoVertices fromList lookup nodes key_extractor = + (bounds, (!) vertex_map, key_vertex, numbered_nodes) + where + max_v = length nodes - 1 + bounds = (0, max_v) :: (Vertex, Vertex) + + -- Keep the order intact to make the result depend on input order + -- instead of key order + numbered_nodes = zip [0..] nodes + vertex_map = array bounds numbered_nodes + + key_map = fromList + [ (key_extractor node, v) | (v, node) <- numbered_nodes ] + key_vertex k = lookup k key_map + +-- See Note [reduceNodesIntoVertices implementations] +reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload +reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup + +-- See Note [reduceNodesIntoVertices implementations] +reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload +reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM) + +{- +************************************************************************ +* * +* SCC +* * +************************************************************************ +-} + +type WorkItem key payload + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a + +-- | Find a reasonably short cycle a->b->c->a, in a strongly +-- connected component. The input nodes are presumed to be +-- a SCC, so you can start anywhere. +findCycle :: forall payload key. Ord key + => [Node key payload] -- The nodes. The dependencies can + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next +findCycle graph + = go Set.empty (new_work root_deps []) [] + where + env :: Map.Map key (Node key payload) + env = Map.fromList [ (node_key node, node) | node <- graph ] + + -- Find the node with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + root :: Node key payload + root = fst (minWith snd [ (node, count (`Map.member` env) + (node_dependencies node)) + | node <- graph ]) + DigraphNode root_payload root_key root_deps = root + + + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((DigraphNode payload key deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) + + new_work :: [key] -> [payload] -> [WorkItem key payload] + new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] + +{- +************************************************************************ +* * +* Strongly Connected Component wrappers for Graph +* * +************************************************************************ + +Note: the components are returned topologically sorted: later components +depend on earlier ones, but not vice versa i.e. later components only have +edges going from them to earlier ones. +-} + +{- +Note [Deterministic SCC] +~~~~~~~~~~~~~~~~~~~~~~~~ +stronglyConnCompFromEdgedVerticesUniq, +stronglyConnCompFromEdgedVerticesUniqR, +stronglyConnCompFromEdgedVerticesOrd and +stronglyConnCompFromEdgedVerticesOrdR +provide a following guarantee: +Given a deterministically ordered list of nodes it returns a deterministically +ordered list of strongly connected components, where the list of vertices +in an SCC is also deterministically ordered. +Note that the order of edges doesn't need to be deterministic for this to work. +We use the order of nodes to normalize the order of edges. +-} + +stronglyConnCompG :: Graph node -> [SCC node] +stronglyConnCompG graph = decodeSccs graph forest + where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) + +decodeSccs :: Graph node -> Forest Vertex -> [SCC node] +decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest + = map decode forest + where + decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] + | otherwise = AcyclicSCC (vertex_fn v) + decode other = CyclicSCC (dec other []) + where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts + mentions_itself v = v `elem` (graph ! v) + + +-- The following two versions are provided for backwards compatibility: +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesOrd + :: Ord key + => [Node key payload] + -> [SCC payload] +stronglyConnCompFromEdgedVerticesOrd + = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR + +-- The following two versions are provided for backwards compatibility: +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesUniq + :: Uniquable key + => [Node key payload] + -> [SCC payload] +stronglyConnCompFromEdgedVerticesUniq + = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR + +-- The "R" interface is used when you expect to apply SCC to +-- (some of) the result of SCC, so you don't want to lose the dependency info +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesOrdR + :: Ord key + => [Node key payload] + -> [SCC (Node key payload)] +stronglyConnCompFromEdgedVerticesOrdR = + stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd + +-- The "R" interface is used when you expect to apply SCC to +-- (some of) the result of SCC, so you don't want to lose the dependency info +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesUniqR + :: Uniquable key + => [Node key payload] + -> [SCC (Node key payload)] +stronglyConnCompFromEdgedVerticesUniqR = + stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq + +{- +************************************************************************ +* * +* Misc wrappers for Graph +* * +************************************************************************ +-} + +topologicalSortG :: Graph node -> [node] +topologicalSortG graph = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) + +reachableG :: Graph node -> node -> [node] +reachableG graph from = map (gr_vertex_to_node graph) result + where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) + result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] + +-- | Given a list of roots return all reachable nodes. +reachablesG :: Graph node -> [node] -> [node] +reachablesG graph froms = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.reachable" #-} + reachable (gr_int_graph graph) vs + vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] + +hasVertexG :: Graph node -> node -> Bool +hasVertexG graph node = isJust $ gr_node_to_vertex graph node + +verticesG :: Graph node -> [node] +verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph) + +edgesG :: Graph node -> [Edge node] +edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph) + where v2n = gr_vertex_to_node graph + +transposeG :: Graph node -> Graph node +transposeG graph = Graph (G.transposeG (gr_int_graph graph)) + (gr_vertex_to_node graph) + (gr_node_to_vertex graph) + +emptyG :: Graph node -> Bool +emptyG g = graphEmpty (gr_int_graph g) + +{- +************************************************************************ +* * +* Showing Graphs +* * +************************************************************************ +-} + +instance Outputable node => Outputable (Graph node) where + ppr graph = vcat [ + hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), + hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) + ] + +instance Outputable node => Outputable (Edge node) where + ppr (Edge from to) = ppr from <+> text "->" <+> ppr to + +graphEmpty :: G.Graph -> Bool +graphEmpty g = lo > hi + where (lo, hi) = bounds g + +{- +************************************************************************ +* * +* IntGraphs +* * +************************************************************************ +-} + +type IntGraph = G.Graph + +{- +------------------------------------------------------------ +-- Depth first search numbering +------------------------------------------------------------ +-} + +-- Data.Tree has flatten for Tree, but nothing for Forest +preorderF :: Forest a -> [a] +preorderF ts = concatMap flatten ts + +{- +------------------------------------------------------------ +-- Finding reachable vertices +------------------------------------------------------------ +-} + +-- This generalizes reachable which was found in Data.Graph +reachable :: IntGraph -> [Vertex] -> [Vertex] +reachable g vs = preorderF (dfs g vs) + +{- +************************************************************************ +* * +* Classify Edge Types +* * +************************************************************************ +-} + +-- Remark: While we could generalize this algorithm this comes at a runtime +-- cost and with no advantages. If you find yourself using this with graphs +-- not easily represented using Int nodes please consider rewriting this +-- using the more general Graph type. + +-- | Edge direction based on DFS Classification +data EdgeType + = Forward + | Cross + | Backward -- ^ Loop back towards the root node. + -- Eg backjumps in loops + | SelfLoop -- ^ v -> v + deriving (Eq,Ord) + +instance Outputable EdgeType where + ppr Forward = text "Forward" + ppr Cross = text "Cross" + ppr Backward = text "Backward" + ppr SelfLoop = text "SelfLoop" + +newtype Time = Time Int deriving (Eq,Ord,Num,Outputable) + +--Allow for specialization +{-# INLINEABLE classifyEdges #-} + +-- | Given a start vertex, a way to get successors from a node +-- and a list of (directed) edges classify the types of edges. +classifyEdges :: forall key. Uniquable key => key -> (key -> [key]) + -> [(key,key)] -> [((key, key), EdgeType)] +classifyEdges root getSucc edges = + --let uqe (from,to) = (getUnique from, getUnique to) + --in pprTrace "Edges:" (ppr $ map uqe edges) $ + zip edges $ map classify edges + where + (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root + classify :: (key,key) -> EdgeType + classify (from,to) + | startFrom < startTo + , endFrom > endTo + = Forward + | startFrom > startTo + , endFrom < endTo + = Backward + | startFrom > startTo + , endFrom > endTo + = Cross + | getUnique from == getUnique to + = SelfLoop + | otherwise + = pprPanic "Failed to classify edge of Graph" + (ppr (getUnique from, getUnique to)) + + where + getTime event node + | Just time <- lookupUFM event node + = time + | otherwise + = pprPanic "Failed to classify edge of CFG - not not timed" + (text "edges" <> ppr (getUnique from, getUnique to) + <+> ppr starts <+> ppr ends ) + startFrom = getTime starts from + startTo = getTime starts to + endFrom = getTime ends from + endTo = getTime ends to + + addTimes :: (Time, UniqFM Time, UniqFM Time) -> key + -> (Time, UniqFM Time, UniqFM Time) + addTimes (time,starts,ends) n + --Dont reenter nodes + | elemUFM n starts + = (time,starts,ends) + | otherwise = + let + starts' = addToUFM starts n time + time' = time + 1 + succs = getSucc n :: [key] + (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs + ends'' = addToUFM ends' n time'' + in + (time'' + 1, starts'', ends'') diff --git a/compiler/GHC/Data/Graph/Ops.hs b/compiler/GHC/Data/Graph/Ops.hs new file mode 100644 index 0000000000..7d9ce669c6 --- /dev/null +++ b/compiler/GHC/Data/Graph/Ops.hs @@ -0,0 +1,698 @@ +-- | Basic operations on graphs. +-- + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Data.Graph.Ops + ( addNode + , delNode + , getNode + , lookupNode + , modNode + + , size + , union + + , addConflict + , delConflict + , addConflicts + + , addCoalesce + , delCoalesce + + , addExclusion + , addExclusions + + , addPreference + , coalesceNodes + , coalesceGraph + , freezeNode + , freezeOneInGraph + , freezeAllInGraph + , scanGraph + , setColor + , validateGraph + , slurpNodeConflictCount + ) +where + +import GHC.Prelude + +import GHC.Data.Graph.Base + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + +import Data.List hiding (union) +import Data.Maybe + +-- | Lookup a node from the graph. +lookupNode + :: Uniquable k + => Graph k cls color + -> k -> Maybe (Node k cls color) + +lookupNode graph k + = lookupUFM (graphMap graph) k + + +-- | Get a node from the graph, throwing an error if it's not there +getNode + :: Uniquable k + => Graph k cls color + -> k -> Node k cls color + +getNode graph k + = case lookupUFM (graphMap graph) k of + Just node -> node + Nothing -> panic "ColorOps.getNode: not found" + + +-- | Add a node to the graph, linking up its edges +addNode :: Uniquable k + => k -> Node k cls color + -> Graph k cls color -> Graph k cls color + +addNode k node graph + = let + -- add back conflict edges from other nodes to this one + map_conflict = + nonDetFoldUniqSet + -- It's OK to use nonDetFoldUFM here because the + -- operation is commutative + (adjustUFM_C (\n -> n { nodeConflicts = + addOneToUniqSet (nodeConflicts n) k})) + (graphMap graph) + (nodeConflicts node) + + -- add back coalesce edges from other nodes to this one + map_coalesce = + nonDetFoldUniqSet + -- It's OK to use nonDetFoldUFM here because the + -- operation is commutative + (adjustUFM_C (\n -> n { nodeCoalesce = + addOneToUniqSet (nodeCoalesce n) k})) + map_conflict + (nodeCoalesce node) + + in graph + { graphMap = addToUFM map_coalesce k node} + + +-- | Delete a node and all its edges from the graph. +delNode :: (Uniquable k) + => k -> Graph k cls color -> Maybe (Graph k cls color) + +delNode k graph + | Just node <- lookupNode graph k + = let -- delete conflict edges from other nodes to this one. + graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph + $ nonDetEltsUniqSet (nodeConflicts node) + + -- delete coalesce edge from other nodes to this one. + graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 + $ nonDetEltsUniqSet (nodeCoalesce node) + -- See Note [Unique Determinism and code generation] + + -- delete the node + graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 + + in Just graph3 + + | otherwise + = Nothing + + +-- | Modify a node in the graph. +-- returns Nothing if the node isn't present. +-- +modNode :: Uniquable k + => (Node k cls color -> Node k cls color) + -> k -> Graph k cls color -> Maybe (Graph k cls color) + +modNode f k graph + = case lookupNode graph k of + Just Node{} + -> Just + $ graphMapModify + (\fm -> let Just node = lookupUFM fm k + node' = f node + in addToUFM fm k node') + graph + + Nothing -> Nothing + + +-- | Get the size of the graph, O(n) +size :: Graph k cls color -> Int + +size graph + = sizeUFM $ graphMap graph + + +-- | Union two graphs together. +union :: Graph k cls color -> Graph k cls color -> Graph k cls color + +union graph1 graph2 + = Graph + { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } + + +-- | Add a conflict between nodes to the graph, creating the nodes required. +-- Conflicts are virtual regs which need to be colored differently. +addConflict + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addConflict (u1, c1) (u2, c2) + = let addNeighbor u c u' + = adjustWithDefaultUFM + (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) + (newNode u c) { nodeConflicts = unitUniqSet u' } + u + + in graphMapModify + ( addNeighbor u1 c1 u2 + . addNeighbor u2 c2 u1) + + +-- | Delete a conflict edge. k1 -> k2 +-- returns Nothing if the node isn't in the graph +delConflict + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delConflict k1 k2 + = modNode + (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) + k1 + + +-- | Add some conflicts to the graph, creating nodes if required. +-- All the nodes in the set are taken to conflict with each other. +addConflicts + :: Uniquable k + => UniqSet k -> (k -> cls) + -> Graph k cls color -> Graph k cls color + +addConflicts conflicts getClass + + -- just a single node, but no conflicts, create the node anyway. + | (u : []) <- nonDetEltsUniqSet conflicts + = graphMapModify + $ adjustWithDefaultUFM + id + (newNode u (getClass u)) + u + + | otherwise + = graphMapModify + $ \fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm + $ nonDetEltsUniqSet conflicts + -- See Note [Unique Determinism and code generation] + + +addConflictSet1 :: Uniquable k + => k -> (k -> cls) -> UniqSet k + -> UniqFM (Node k cls color) + -> UniqFM (Node k cls color) +addConflictSet1 u getClass set + = case delOneFromUniqSet set u of + set' -> adjustWithDefaultUFM + (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) + (newNode u (getClass u)) { nodeConflicts = set' } + u + + +-- | Add an exclusion to the graph, creating nodes if required. +-- These are extra colors that the node cannot use. +addExclusion + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> color + -> Graph k cls color -> Graph k cls color + +addExclusion u getClass color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) + (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } + u + +addExclusions + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color + +addExclusions u getClass colors graph + = foldr (addExclusion u getClass) graph colors + + +-- | Add a coalescence edge to the graph, creating nodes if required. +-- It is considered adventageous to assign the same color to nodes in a coalesence. +addCoalesce + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addCoalesce (u1, c1) (u2, c2) + = let addCoalesce u c u' + = adjustWithDefaultUFM + (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) + (newNode u c) { nodeCoalesce = unitUniqSet u' } + u + + in graphMapModify + ( addCoalesce u1 c1 u2 + . addCoalesce u2 c2 u1) + + +-- | Delete a coalescence edge (k1 -> k2) from the graph. +delCoalesce + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + +delCoalesce k1 k2 + = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) + k1 + + +-- | Add a color preference to the graph, creating nodes if required. +-- The most recently added preference is the most preferred. +-- The algorithm tries to assign a node it's preferred color if possible. +-- +addPreference + :: Uniquable k + => (k, cls) -> color + -> Graph k cls color -> Graph k cls color + +addPreference (u, c) color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodePreference = color : (nodePreference node) }) + (newNode u c) { nodePreference = [color] } + u + + +-- | Do aggressive coalescing on this graph. +-- returns the new graph and the list of pairs of nodes that got coalesced together. +-- for each pair, the resulting node will have the least key and be second in the pair. +-- +coalesceGraph + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> ( Graph k cls color + , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the + -- coalescing was applied. + +coalesceGraph aggressive triv graph + = coalesceGraph' aggressive triv graph [] + +coalesceGraph' + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> [(k, k)] + -> ( Graph k cls color + , [(k, k)]) +coalesceGraph' aggressive triv graph kkPairsAcc + = let + -- find all the nodes that have coalescence edges + cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + -- build a list of pairs of keys for node's we'll try and coalesce + -- every pair of nodes will appear twice in this list + -- ie [(k1, k2), (k2, k1) ... ] + -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for + -- build a list of what nodes get coalesced together for later on. + -- + cList = [ (nodeId node1, k2) + | node1 <- cNodes + , k2 <- nonDetEltsUniqSet $ nodeCoalesce node1 ] + -- See Note [Unique Determinism and code generation] + + -- do the coalescing, returning the new graph and a list of pairs of keys + -- that got coalesced together. + (graph', mPairs) + = mapAccumL (coalesceNodes aggressive triv) graph cList + + -- keep running until there are no more coalesces can be found + in case catMaybes mPairs of + [] -> (graph', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) + + +-- | Coalesce this pair of nodes unconditionally \/ aggressively. +-- The resulting node is the one with the least key. +-- +-- returns: Just the pair of keys if the nodes were coalesced +-- the second element of the pair being the least one +-- +-- Nothing if either of the nodes weren't in the graph + +coalesceNodes + :: (Uniquable k, Ord k, Eq cls) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> (k, k) -- ^ keys of the nodes to be coalesced + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes aggressive triv graph (k1, k2) + | (kMin, kMax) <- if k1 < k2 + then (k1, k2) + else (k2, k1) + + -- the nodes being coalesced must be in the graph + , Just nMin <- lookupNode graph kMin + , Just nMax <- lookupNode graph kMax + + -- can't coalesce conflicting modes + , not $ elementOfUniqSet kMin (nodeConflicts nMax) + , not $ elementOfUniqSet kMax (nodeConflicts nMin) + + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax + + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- don't do the coalescing after all + | otherwise + = (graph, Nothing) + +coalesceNodes_merge + :: (Uniquable k, Eq cls) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + + -- sanity checks + | nodeClass nMin /= nodeClass nMax + = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce nodes of different classes." + + | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) + = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce colored nodes." + + --- + | otherwise + = let + -- the new node gets all the edges from its two components + node = + Node { nodeId = kMin + , nodeClass = nodeClass nMin + , nodeColor = Nothing + + -- nodes don't conflict with themselves.. + , nodeConflicts + = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + + , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) + , nodePreference = nodePreference nMin ++ nodePreference nMax + + -- nodes don't coalesce with themselves.. + , nodeCoalesce + = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + } + + in coalesceNodes_check aggressive triv graph kMin kMax node + +coalesceNodes_check + :: Uniquable k + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) + +coalesceNodes_check aggressive triv graph kMin kMax node + + -- Unless we're coalescing aggressively, if the result node is not trivially + -- colorable then don't do the coalescing. + | not aggressive + , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = (graph, Nothing) + + | otherwise + = let -- delete the old nodes from the graph and add the new one + Just graph1 = delNode kMax graph + Just graph2 = delNode kMin graph1 + graph3 = addNode kMin node graph2 + + in (graph3, Just (kMax, kMin)) + + +-- | Freeze a node +-- This is for the iterative coalescer. +-- By freezing a node we give up on ever coalescing it. +-- Move all its coalesce edges into the frozen set - and update +-- back edges from other nodes. +-- +freezeNode + :: Uniquable k + => k -- ^ key of the node to freeze + -> Graph k cls color -- ^ the graph + -> Graph k cls color -- ^ graph with that node frozen + +freezeNode k + = graphMapModify + $ \fm -> + let -- freeze all the edges in the node to be frozen + Just node = lookupUFM fm k + node' = node + { nodeCoalesce = emptyUniqSet } + + fm1 = addToUFM fm k node' + + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else node -- panic "GHC.Data.Graph.Ops.freezeNode: edge to freeze wasn't in the coalesce set" + -- If the edge isn't actually in the coelesce set then just ignore it. + + fm2 = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + -- It's OK to use nonDetFoldUFM here because the operation + -- is commutative + $ nodeCoalesce node + + in fm2 + + +-- | Freeze one node in the graph +-- This if for the iterative coalescer. +-- Look for a move related node of low degree and freeze it. +-- +-- We probably don't need to scan the whole graph looking for the node of absolute +-- lowest degree. Just sample the first few and choose the one with the lowest +-- degree out of those. Also, we don't make any distinction between conflicts of different +-- classes.. this is just a heuristic, after all. +-- +-- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv +-- right here, and add it to a worklist if known triv\/non-move nodes. +-- +freezeOneInGraph + :: (Uniquable k) + => Graph k cls color + -> ( Graph k cls color -- the new graph + , Bool ) -- whether we found a node to freeze + +freezeOneInGraph graph + = let compareNodeDegree n1 n2 + = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) + + candidates + = sortBy compareNodeDegree + $ take 5 -- 5 isn't special, it's just a small number. + $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph + + in case candidates of + + -- there wasn't anything available to freeze + [] -> (graph, False) + + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) + + +-- | Freeze all the nodes in the graph +-- for debugging the iterative allocator. +-- +freezeAllInGraph + :: (Uniquable k) + => Graph k cls color + -> Graph k cls color + +freezeAllInGraph graph + = foldr freezeNode graph + $ map nodeId + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + +-- | Find all the nodes in the graph that meet some criteria +-- +scanGraph + :: (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] + +scanGraph match graph + = filter match $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + + +-- | validate the internal structure of a graph +-- all its edges should point to valid nodes +-- If they don't then throw an error +-- +validateGraph + :: (Uniquable k, Outputable k, Eq color) + => SDoc -- ^ extra debugging info to display on error + -> Bool -- ^ whether this graph is supposed to be colored. + -> Graph k cls color -- ^ graph to validate + -> Graph k cls color -- ^ validated graph + +validateGraph doc isColored graph + + -- Check that all edges point to valid nodes. + | edges <- unionManyUniqSets + ( (map nodeConflicts $ nonDetEltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ nonDetEltsUFM $ graphMap graph)) + + , nodes <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph + , badEdges <- minusUniqSet edges nodes + , not $ isEmptyUniqSet badEdges + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Graph has edges that point to non-existent nodes" + $$ text " bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr) + $$ doc ) + + -- Check that no conflicting nodes have the same color + | badNodes <- filter (not . (checkNode graph)) + $ nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + , not $ null badNodes + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Node has same color as one of it's conflicts" + $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc) + + -- If this is supposed to be a colored graph, + -- check that all nodes have a color. + | isColored + , badNodes <- filter (\n -> isNothing $ nodeColor n) + $ nonDetEltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GHC.Data.Graph.Ops.validateGraph" + ( text "Supposably colored graph has uncolored nodes." + $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc ) + + + -- graph looks ok + | otherwise + = graph + + +-- | If this node is colored, check that all the nodes which +-- conflict with it have different colors. +checkNode + :: (Uniquable k, Eq color) + => Graph k cls color + -> Node k cls color + -> Bool -- ^ True if this node is ok + +checkNode graph node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ nonDetEltsUniqSet $ nodeConflicts node + -- See Note [Unique Determinism and code generation] + + , neighbourColors <- catMaybes $ map nodeColor neighbors + , elem color neighbourColors + = False + + | otherwise + = True + + + +-- | Slurp out a map of how many nodes had a certain number of conflict neighbours + +slurpNodeConflictCount + :: Graph k cls color + -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) + +slurpNodeConflictCount graph + = addListToUFM_C + (\(c1, n1) (_, n2) -> (c1, n1 + n2)) + emptyUFM + $ map (\node + -> let count = sizeUniqSet $ nodeConflicts node + in (count, (count, 1))) + $ nonDetEltsUFM + -- See Note [Unique Determinism and code generation] + $ graphMap graph + + +-- | Set the color of a certain node +setColor + :: Uniquable k + => k -> color + -> Graph k cls color -> Graph k cls color + +setColor u color + = graphMapModify + $ adjustUFM_C + (\n -> n { nodeColor = Just color }) + u + + +{-# INLINE adjustWithDefaultUFM #-} +adjustWithDefaultUFM + :: Uniquable k + => (a -> a) -> a -> k + -> UniqFM a -> UniqFM a + +adjustWithDefaultUFM f def k map + = addToUFM_C + (\old _ -> f old) + map + k def + +-- Argument order different from UniqFM's adjustUFM +{-# INLINE adjustUFM_C #-} +adjustUFM_C + :: Uniquable k + => (a -> a) + -> k -> UniqFM a -> UniqFM a + +adjustUFM_C f k map + = case lookupUFM map k of + Nothing -> map + Just a -> addToUFM map k (f a) + diff --git a/compiler/GHC/Data/Graph/Ppr.hs b/compiler/GHC/Data/Graph/Ppr.hs new file mode 100644 index 0000000000..020284ea7e --- /dev/null +++ b/compiler/GHC/Data/Graph/Ppr.hs @@ -0,0 +1,173 @@ + +-- | Pretty printing of graphs. + +module GHC.Data.Graph.Ppr + ( dumpGraph + , dotGraph + ) +where + +import GHC.Prelude + +import GHC.Data.Graph.Base + +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + +import Data.List (mapAccumL) +import Data.Maybe + + +-- | Pretty print a graph in a somewhat human readable format. +dumpGraph + :: (Outputable k, Outputable color) + => Graph k cls color -> SDoc + +dumpGraph graph + = text "Graph" + $$ pprUFM (graphMap graph) (vcat . map dumpNode) + +dumpNode + :: (Outputable k, Outputable color) + => Node k cls color -> SDoc + +dumpNode node + = text "Node " <> ppr (nodeId node) + $$ text "conflicts " + <> parens (int (sizeUniqSet $ nodeConflicts node)) + <> text " = " + <> ppr (nodeConflicts node) + + $$ text "exclusions " + <> parens (int (sizeUniqSet $ nodeExclusions node)) + <> text " = " + <> ppr (nodeExclusions node) + + $$ text "coalesce " + <> parens (int (sizeUniqSet $ nodeCoalesce node)) + <> text " = " + <> ppr (nodeCoalesce node) + + $$ space + + + +-- | Pretty print a graph in graphviz .dot format. +-- Conflicts get solid edges. +-- Coalescences get dashed edges. +dotGraph + :: ( Uniquable k + , Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) -- ^ What graphviz color to use for each node color + -- It's usually safe to return X11 style colors here, + -- ie "red", "green" etc or a hex triplet #aaff55 etc + -> Triv k cls color + -> Graph k cls color -> SDoc + +dotGraph colorMap triv graph + = let nodes = nonDetEltsUFM $ graphMap graph + -- See Note [Unique Determinism and code generation] + in vcat + ( [ text "graph G {" ] + ++ map (dotNode colorMap triv) nodes + ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes) + ++ [ text "}" + , space ]) + + +dotNode :: ( Outputable k, Outputable cls, Outputable color) + => (color -> SDoc) + -> Triv k cls color + -> Node k cls color -> SDoc + +dotNode colorMap triv node + = let name = ppr $ nodeId node + cls = ppr $ nodeClass node + + excludes + = hcat $ punctuate space + $ map (\n -> text "-" <> ppr n) + $ nonDetEltsUniqSet $ nodeExclusions node + -- See Note [Unique Determinism and code generation] + + preferences + = hcat $ punctuate space + $ map (\n -> text "+" <> ppr n) + $ nodePreference node + + expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)] + then empty + else text "\\n" <> (excludes <+> preferences) + + -- if the node has been colored then show that, + -- otherwise indicate whether it looks trivially colorable. + color + | Just c <- nodeColor node + = text "\\n(" <> ppr c <> text ")" + + | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = text "\\n(" <> text "triv" <> text ")" + + | otherwise + = text "\\n(" <> text "spill?" <> text ")" + + label = name <> text " :: " <> cls + <> expref + <> color + + pcolorC = case nodeColor node of + Nothing -> text "style=filled fillcolor=white" + Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c) + + + pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]" + <> space <> doubleQuotes name + <> text ";" + + in pout + + +-- | Nodes in the graph are doubly linked, but we only want one edge for each +-- conflict if the graphviz graph. Traverse over the graph, but make sure +-- to only print the edges for each node once. + +dotNodeEdges + :: ( Uniquable k + , Outputable k) + => UniqSet k + -> Node k cls color + -> (UniqSet k, Maybe SDoc) + +dotNodeEdges visited node + | elementOfUniqSet (nodeId node) visited + = ( visited + , Nothing) + + | otherwise + = let dconflicts + = map (dotEdgeConflict (nodeId node)) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ minusUniqSet (nodeConflicts node) visited + + dcoalesces + = map (dotEdgeCoalesce (nodeId node)) + $ nonDetEltsUniqSet + -- See Note [Unique Determinism and code generation] + $ minusUniqSet (nodeCoalesce node) visited + + out = vcat dconflicts + $$ vcat dcoalesces + + in ( addOneToUniqSet visited (nodeId node) + , Just out) + + where dotEdgeConflict u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> text ";" + + dotEdgeCoalesce u1 u2 + = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) + <> space <> text "[ style = dashed ];" diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs new file mode 100644 index 0000000000..4d1657ce62 --- /dev/null +++ b/compiler/GHC/Data/Graph/UnVar.hs @@ -0,0 +1,145 @@ +{- + +Copyright (c) 2014 Joachim Breitner + +A data structure for undirected graphs of variables +(or in plain terms: Sets of unordered pairs of numbers) + + +This is very specifically tailored for the use in CallArity. In particular it +stores the graph as a union of complete and complete bipartite graph, which +would be very expensive to store as sets of edges or as adjanceny lists. + +It does not normalize the graphs. This means that g `unionUnVarGraph` g is +equal to g, but twice as expensive and large. + +-} +module GHC.Data.Graph.UnVar + ( UnVarSet + , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets + , delUnVarSet + , elemUnVarSet, isEmptyUnVarSet + , UnVarGraph + , emptyUnVarGraph + , unionUnVarGraph, unionUnVarGraphs + , completeGraph, completeBipartiteGraph + , neighbors + , hasLoopAt + , delNode + ) where + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import GHC.Utils.Outputable +import GHC.Data.Bag +import GHC.Types.Unique + +import qualified Data.IntSet as S + +-- We need a type for sets of variables (UnVarSet). +-- We do not use VarSet, because for that we need to have the actual variable +-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. +-- Therefore, use a IntSet directly (which is likely also a bit more efficient). + +-- Set of uniques, i.e. for adjancet nodes +newtype UnVarSet = UnVarSet (S.IntSet) + deriving Eq + +k :: Var -> Int +k v = getKey (getUnique v) + +emptyUnVarSet :: UnVarSet +emptyUnVarSet = UnVarSet S.empty + +elemUnVarSet :: Var -> UnVarSet -> Bool +elemUnVarSet v (UnVarSet s) = k v `S.member` s + + +isEmptyUnVarSet :: UnVarSet -> Bool +isEmptyUnVarSet (UnVarSet s) = S.null s + +delUnVarSet :: UnVarSet -> Var -> UnVarSet +delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s + +mkUnVarSet :: [Var] -> UnVarSet +mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs + +varEnvDom :: VarEnv a -> UnVarSet +varEnvDom ae = UnVarSet $ ufmToSet_Directly ae + +unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet +unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) + +unionUnVarSets :: [UnVarSet] -> UnVarSet +unionUnVarSets = foldr unionUnVarSet emptyUnVarSet + +instance Outputable UnVarSet where + ppr (UnVarSet s) = braces $ + hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] + + +-- The graph type. A list of complete bipartite graphs +data Gen = CBPG UnVarSet UnVarSet -- complete bipartite + | CG UnVarSet -- complete +newtype UnVarGraph = UnVarGraph (Bag Gen) + +emptyUnVarGraph :: UnVarGraph +emptyUnVarGraph = UnVarGraph emptyBag + +unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph +{- +Premature optimisation, it seems. +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s1 == s3 && s2 == s4 + = pprTrace "unionUnVarGraph fired" empty $ + completeGraph (s1 `unionUnVarSet` s2) +unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) + | s2 == s3 && s1 == s4 + = pprTrace "unionUnVarGraph fired2" empty $ + completeGraph (s1 `unionUnVarSet` s2) +-} +unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) + = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ + UnVarGraph (g1 `unionBags` g2) + +unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph +unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph + +-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } +completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph +completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 + +completeGraph :: UnVarSet -> UnVarGraph +completeGraph s = prune $ UnVarGraph $ unitBag $ CG s + +neighbors :: UnVarGraph -> Var -> UnVarSet +neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g + where go (CG s) = (if v `elemUnVarSet` s then [s] else []) + go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ + (if v `elemUnVarSet` s2 then [s1] else []) + +-- hasLoopAt G v <=> v--v ∈ G +hasLoopAt :: UnVarGraph -> Var -> Bool +hasLoopAt (UnVarGraph g) v = any go $ bagToList g + where go (CG s) = v `elemUnVarSet` s + go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 + + +delNode :: UnVarGraph -> Var -> UnVarGraph +delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g + where go (CG s) = CG (s `delUnVarSet` v) + go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) + +prune :: UnVarGraph -> UnVarGraph +prune (UnVarGraph g) = UnVarGraph $ filterBag go g + where go (CG s) = not (isEmptyUnVarSet s) + go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) + +instance Outputable Gen where + ppr (CG s) = ppr s <> char '²' + ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 +instance Outputable UnVarGraph where + ppr (UnVarGraph g) = ppr g diff --git a/compiler/GHC/Data/IOEnv.hs b/compiler/GHC/Data/IOEnv.hs new file mode 100644 index 0000000000..345482094e --- /dev/null +++ b/compiler/GHC/Data/IOEnv.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | The IO Monad with an environment +-- +-- The environment is passed around as a Reader monad but +-- as its in the IO monad, mutable references can be used +-- for updating state. +-- +module GHC.Data.IOEnv ( + IOEnv, -- Instance of Monad + + -- Monad utilities + module GHC.Utils.Monad, + + -- Errors + failM, failWithM, + IOEnvFailure(..), + + -- Getting at the environment + getEnv, setEnv, updEnv, + + runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, + tryM, tryAllM, tryMostM, fixM, + + -- I/O operations + IORef, newMutVar, readMutVar, writeMutVar, updMutVar, + atomicUpdMutVar, atomicUpdMutVar' + ) where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Utils.Exception +import GHC.Types.Module +import GHC.Utils.Panic + +import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, + atomicModifyIORef, atomicModifyIORef' ) +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO ( fixIO ) +import Control.Monad +import GHC.Utils.Monad +import Control.Applicative (Alternative(..)) + +---------------------------------------------------------------------- +-- Defining the monad type +---------------------------------------------------------------------- + + +newtype IOEnv env a = IOEnv (env -> IO a) deriving (Functor) + +unIOEnv :: IOEnv env a -> (env -> IO a) +unIOEnv (IOEnv m) = m + +instance Monad (IOEnv m) where + (>>=) = thenM + (>>) = (*>) + +instance MonadFail (IOEnv m) where + fail _ = failM -- Ignore the string + +instance Applicative (IOEnv m) where + pure = returnM + IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env ) + (*>) = thenM_ + +returnM :: a -> IOEnv env a +returnM a = IOEnv (\ _ -> return a) + +thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b +thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; + unIOEnv (f r) env }) + +thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b +thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) + +failM :: IOEnv env a +failM = IOEnv (\ _ -> throwIO IOEnvFailure) + +failWithM :: String -> IOEnv env a +failWithM s = IOEnv (\ _ -> ioError (userError s)) + +data IOEnvFailure = IOEnvFailure + +instance Show IOEnvFailure where + show IOEnvFailure = "IOEnv failure" + +instance Exception IOEnvFailure + +instance ExceptionMonad (IOEnv a) where + gcatch act handle = + IOEnv $ \s -> unIOEnv act s `gcatch` \e -> unIOEnv (handle e) s + gmask f = + IOEnv $ \s -> gmask $ \io_restore -> + let + g_restore (IOEnv m) = IOEnv $ \s -> io_restore (m s) + in + unIOEnv (f g_restore) s + +instance ContainsDynFlags env => HasDynFlags (IOEnv env) where + getDynFlags = do env <- getEnv + return $! extractDynFlags env + +instance ContainsModule env => HasModule (IOEnv env) where + getModule = do env <- getEnv + return $ extractModule env + +---------------------------------------------------------------------- +-- Fundamental combinators specific to the monad +---------------------------------------------------------------------- + + +--------------------------- +runIOEnv :: env -> IOEnv env a -> IO a +runIOEnv env (IOEnv m) = m env + + +--------------------------- +{-# NOINLINE fixM #-} + -- Aargh! Not inlining fixM alleviates a space leak problem. + -- Normally fixM is used with a lazy tuple match: if the optimiser is + -- shown the definition of fixM, it occasionally transforms the code + -- in such a way that the code generator doesn't spot the selector + -- thunks. Sigh. + +fixM :: (a -> IOEnv env a) -> IOEnv env a +fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) + + +--------------------------- +tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r) +-- Reflect UserError exceptions (only) into IOEnv monad +-- Other exceptions are not caught; they are simply propagated as exns +-- +-- The idea is that errors in the program being compiled will give rise +-- to UserErrors. But, say, pattern-match failures in GHC itself should +-- not be caught here, else they'll be reported as errors in the program +-- begin compiled! +tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env)) + +tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) +tryIOEnvFailure = try + +-- XXX We shouldn't be catching everything, e.g. timeouts +tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) +-- Catch *all* exceptions +-- This is used when running a Template-Haskell splice, when +-- even a pattern-match failure is a programmer error +tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env)) + +tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) +tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) + +--------------------------- +unsafeInterleaveM :: IOEnv env a -> IOEnv env a +unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) + +uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a +uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) + +---------------------------------------------------------------------- +-- Alternative/MonadPlus +---------------------------------------------------------------------- + +instance Alternative (IOEnv env) where + empty = IOEnv (const empty) + m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env) + +instance MonadPlus (IOEnv env) + +---------------------------------------------------------------------- +-- Accessing input/output +---------------------------------------------------------------------- + +instance MonadIO (IOEnv env) where + liftIO io = IOEnv (\ _ -> io) + +newMutVar :: a -> IOEnv env (IORef a) +newMutVar val = liftIO (newIORef val) + +writeMutVar :: IORef a -> a -> IOEnv env () +writeMutVar var val = liftIO (writeIORef var val) + +readMutVar :: IORef a -> IOEnv env a +readMutVar var = liftIO (readIORef var) + +updMutVar :: IORef a -> (a -> a) -> IOEnv env () +updMutVar var upd = liftIO (modifyIORef var upd) + +-- | Atomically update the reference. Does not force the evaluation of the +-- new variable contents. For strict update, use 'atomicUpdMutVar''. +atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd) + +-- | Strict variant of 'atomicUpdMutVar'. +atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd) + +---------------------------------------------------------------------- +-- Accessing the environment +---------------------------------------------------------------------- + +getEnv :: IOEnv env env +{-# INLINE getEnv #-} +getEnv = IOEnv (\ env -> return env) + +-- | Perform a computation with a different environment +setEnv :: env' -> IOEnv env' a -> IOEnv env a +{-# INLINE setEnv #-} +setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env) + +-- | Perform a computation with an altered environment +updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a +{-# INLINE updEnv #-} +updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) diff --git a/compiler/GHC/Data/List/SetOps.hs b/compiler/GHC/Data/List/SetOps.hs new file mode 100644 index 0000000000..2d916e9dd5 --- /dev/null +++ b/compiler/GHC/Data/List/SetOps.hs @@ -0,0 +1,182 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} + +-- | Set-like operations on lists +-- +-- Avoid using them as much as possible +module GHC.Data.List.SetOps ( + unionLists, minusList, deleteBys, + + -- Association lists + Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, + + -- Duplicate handling + hasNoDups, removeDups, findDupsEq, + equivClasses, + + -- Indexing + getNth + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Set as S + +getNth :: Outputable a => [a] -> Int -> a +getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) + xs !! n + +deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a] +-- (deleteBys eq xs ys) returns xs-ys, using the given equality function +-- Just like 'Data.List.delete' but with an equality function +deleteBys eq xs ys = foldl' (flip (L.deleteBy eq)) xs ys + +{- +************************************************************************ +* * + Treating lists as sets + Assumes the lists contain no duplicates, but are unordered +* * +************************************************************************ +-} + + +-- | Assumes that the arguments contain no duplicates +unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] +-- We special case some reasonable common patterns. +unionLists xs [] = xs +unionLists [] ys = ys +unionLists [x] ys + | isIn "unionLists" x ys = ys + | otherwise = x:ys +unionLists xs [y] + | isIn "unionLists" y xs = xs + | otherwise = y:xs +unionLists xs ys + = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys) + [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys + +-- | Calculate the set difference of two lists. This is +-- /O((m + n) log n)/, where we subtract a list of /n/ elements +-- from a list of /m/ elements. +-- +-- Extremely short cases are handled specially: +-- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1, +-- it takes /O(n)/ time. +minusList :: Ord a => [a] -> [a] -> [a] +-- There's no point building a set to perform just one lookup, so we handle +-- extremely short lists specially. It might actually be better to use +-- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5). +-- The tipping point will be somewhere in the area of where /m/ and /log n/ +-- become comparable, but we probably don't want to work too hard on this. +minusList [] _ = [] +minusList xs@[x] ys + | x `elem` ys = [] + | otherwise = xs +-- Using an empty set or a singleton would also be silly, so let's not. +minusList xs [] = xs +minusList xs [y] = filter (/= y) xs +-- When each list has at least two elements, we build a set from the +-- second argument, allowing us to filter the first argument fairly +-- efficiently. +minusList xs ys = filter (`S.notMember` yss) xs + where + yss = S.fromList ys + +{- +************************************************************************ +* * +\subsection[Utils-assoc]{Association lists} +* * +************************************************************************ + +Inefficient finite maps based on association lists and equality. +-} + +-- A finite mapping based on equality and association lists +type Assoc a b = [(a,b)] + +assoc :: (Eq a) => String -> Assoc a b -> a -> b +assocDefault :: (Eq a) => b -> Assoc a b -> a -> b +assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b +assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b +assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b + +assocDefaultUsing _ deflt [] _ = deflt +assocDefaultUsing eq deflt ((k,v) : rest) key + | k `eq` key = v + | otherwise = assocDefaultUsing eq deflt rest key + +assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key +assocDefault deflt list key = assocDefaultUsing (==) deflt list key +assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key + +assocMaybe alist key + = lookup alist + where + lookup [] = Nothing + lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest + +{- +************************************************************************ +* * +\subsection[Utils-dups]{Duplicate-handling} +* * +************************************************************************ +-} + +hasNoDups :: (Eq a) => [a] -> Bool + +hasNoDups xs = f [] xs + where + f _ [] = True + f seen_so_far (x:xs) = if x `is_elem` seen_so_far + then False + else f (x:seen_so_far) xs + + is_elem = isIn "hasNoDups" + +equivClasses :: (a -> a -> Ordering) -- Comparison + -> [a] + -> [NonEmpty a] + +equivClasses _ [] = [] +equivClasses _ [stuff] = [stuff :| []] +equivClasses cmp items = NE.groupBy eq (L.sortBy cmp items) + where + eq a b = case cmp a b of { EQ -> True; _ -> False } + +removeDups :: (a -> a -> Ordering) -- Comparison function + -> [a] + -> ([a], -- List with no duplicates + [NonEmpty a]) -- List of duplicate groups. One representative + -- from each group appears in the first result + +removeDups _ [] = ([], []) +removeDups _ [x] = ([x],[]) +removeDups cmp xs + = case L.mapAccumR collect_dups [] (equivClasses cmp xs) of { (dups, xs') -> + (xs', dups) } + where + collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a) + collect_dups dups_so_far (x :| []) = (dups_so_far, x) + collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x) + +findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a] +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 diff --git a/compiler/GHC/Data/Maybe.hs b/compiler/GHC/Data/Maybe.hs new file mode 100644 index 0000000000..230468a20e --- /dev/null +++ b/compiler/GHC/Data/Maybe.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Data.Maybe ( + module Data.Maybe, + + MaybeErr(..), -- Instance of Monad + failME, isSuccess, + + orElse, + firstJust, firstJusts, + whenIsJust, + expectJust, + rightToMaybe, + + -- * MaybeT + MaybeT(..), liftMaybeT, tryMaybeT + ) where + +import GHC.Prelude + +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Exception (catch, SomeException(..)) +import Data.Maybe +import GHC.Utils.Misc (HasCallStack) + +infixr 4 `orElse` + +{- +************************************************************************ +* * +\subsection[Maybe type]{The @Maybe@ type} +* * +************************************************************************ +-} + +firstJust :: Maybe a -> Maybe a -> Maybe a +firstJust a b = firstJusts [a, b] + +-- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or +-- @Nothing@ otherwise. +firstJusts :: [Maybe a] -> Maybe a +firstJusts = msum + +expectJust :: HasCallStack => String -> Maybe a -> a +{-# INLINE expectJust #-} +expectJust _ (Just x) = x +expectJust err Nothing = error ("expectJust " ++ err) + +whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenIsJust (Just x) f = f x +whenIsJust Nothing _ = return () + +-- | Flipped version of @fromMaybe@, useful for chaining. +orElse :: Maybe a -> a -> a +orElse = flip fromMaybe + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe (Left _) = Nothing +rightToMaybe (Right x) = Just x + +{- +************************************************************************ +* * +\subsection[MaybeT type]{The @MaybeT@ monad transformer} +* * +************************************************************************ +-} + +-- We had our own MaybeT in the past. Now we reuse transformer's MaybeT + +liftMaybeT :: Monad m => m a -> MaybeT m a +liftMaybeT act = MaybeT $ Just `liftM` act + +-- | Try performing an 'IO' action, failing on error. +tryMaybeT :: IO a -> MaybeT IO a +tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler + where + handler (SomeException _) = return Nothing + +{- +************************************************************************ +* * +\subsection[MaybeErr type]{The @MaybeErr@ type} +* * +************************************************************************ +-} + +data MaybeErr err val = Succeeded val | Failed err + deriving (Functor) + +instance Applicative (MaybeErr err) where + pure = Succeeded + (<*>) = ap + +instance Monad (MaybeErr err) where + Succeeded v >>= k = k v + Failed e >>= _ = Failed e + +isSuccess :: MaybeErr err val -> Bool +isSuccess (Succeeded {}) = True +isSuccess (Failed {}) = False + +failME :: err -> MaybeErr err val +failME e = Failed e diff --git a/compiler/GHC/Data/OrdList.hs b/compiler/GHC/Data/OrdList.hs new file mode 100644 index 0000000000..5476055f05 --- /dev/null +++ b/compiler/GHC/Data/OrdList.hs @@ -0,0 +1,192 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + + +-} +{-# LANGUAGE DeriveFunctor #-} + +{-# LANGUAGE BangPatterns #-} + +-- | Provide trees (of instructions), so that lists of instructions can be +-- appended in linear time. +module GHC.Data.OrdList ( + OrdList, + nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, + headOL, + mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse, + strictlyEqOL, strictlyOrdOL +) where + +import GHC.Prelude +import Data.Foldable + +import GHC.Utils.Outputable + +import qualified Data.Semigroup as Semigroup + +infixl 5 `appOL` +infixl 5 `snocOL` +infixr 5 `consOL` + +data OrdList a + = None + | One a + | Many [a] -- Invariant: non-empty + | Cons a (OrdList a) + | Snoc (OrdList a) a + | Two (OrdList a) -- Invariant: non-empty + (OrdList a) -- Invariant: non-empty + deriving (Functor) + +instance Outputable a => Outputable (OrdList a) where + ppr ol = ppr (fromOL ol) -- Convert to list and print that + +instance Semigroup (OrdList a) where + (<>) = appOL + +instance Monoid (OrdList a) where + mempty = nilOL + mappend = (Semigroup.<>) + mconcat = concatOL + +instance Foldable OrdList where + foldr = foldrOL + foldl' = foldlOL + toList = fromOL + null = isNilOL + length = lengthOL + +instance Traversable OrdList where + traverse f xs = toOL <$> traverse f (fromOL xs) + +nilOL :: OrdList a +isNilOL :: OrdList a -> Bool + +unitOL :: a -> OrdList a +snocOL :: OrdList a -> a -> OrdList a +consOL :: a -> OrdList a -> OrdList a +appOL :: OrdList a -> OrdList a -> OrdList a +concatOL :: [OrdList a] -> OrdList a +headOL :: OrdList a -> a +lastOL :: OrdList a -> a +lengthOL :: OrdList a -> Int + +nilOL = None +unitOL as = One as +snocOL as b = Snoc as b +consOL a bs = Cons a bs +concatOL aas = foldr appOL None aas + +headOL None = panic "headOL" +headOL (One a) = a +headOL (Many as) = head as +headOL (Cons a _) = a +headOL (Snoc as _) = headOL as +headOL (Two as _) = headOL as + +lastOL None = panic "lastOL" +lastOL (One a) = a +lastOL (Many as) = last as +lastOL (Cons _ as) = lastOL as +lastOL (Snoc _ a) = a +lastOL (Two _ as) = lastOL as + +lengthOL None = 0 +lengthOL (One _) = 1 +lengthOL (Many as) = length as +lengthOL (Cons _ as) = 1 + length as +lengthOL (Snoc as _) = 1 + length as +lengthOL (Two as bs) = length as + length bs + +isNilOL None = True +isNilOL _ = False + +None `appOL` b = b +a `appOL` None = a +One a `appOL` b = Cons a b +a `appOL` One b = Snoc a b +a `appOL` b = Two a b + +fromOL :: OrdList a -> [a] +fromOL a = go a [] + where go None acc = acc + go (One a) acc = a : acc + go (Cons a b) acc = a : go b acc + go (Snoc a b) acc = go a (b:acc) + go (Two a b) acc = go a (go b acc) + go (Many xs) acc = xs ++ acc + +fromOLReverse :: OrdList a -> [a] +fromOLReverse a = go a [] + -- acc is already in reverse order + where go :: OrdList a -> [a] -> [a] + go None acc = acc + go (One a) acc = a : acc + go (Cons a b) acc = go b (a : acc) + go (Snoc a b) acc = b : go a acc + go (Two a b) acc = go b (go a acc) + go (Many xs) acc = reverse xs ++ acc + +mapOL :: (a -> b) -> OrdList a -> OrdList b +mapOL = fmap + +foldrOL :: (a->b->b) -> b -> OrdList a -> b +foldrOL _ z None = z +foldrOL k z (One x) = k x z +foldrOL k z (Cons x xs) = k x (foldrOL k z xs) +foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs +foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 +foldrOL k z (Many xs) = foldr k z xs + +-- | Strict left fold. +foldlOL :: (b->a->b) -> b -> OrdList a -> b +foldlOL _ z None = z +foldlOL k z (One x) = k z x +foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs +foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x +foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2 +foldlOL k z (Many xs) = foldl' k z xs + +toOL :: [a] -> OrdList a +toOL [] = None +toOL [x] = One x +toOL xs = Many xs + +reverseOL :: OrdList a -> OrdList a +reverseOL None = None +reverseOL (One x) = One x +reverseOL (Cons a b) = Snoc (reverseOL b) a +reverseOL (Snoc a b) = Cons b (reverseOL a) +reverseOL (Two a b) = Two (reverseOL b) (reverseOL a) +reverseOL (Many xs) = Many (reverse xs) + +-- | Compare not only the values but also the structure of two lists +strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool +strictlyEqOL None None = True +strictlyEqOL (One x) (One y) = x == y +strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs +strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs +strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2 +strictlyEqOL (Many as) (Many bs) = as == bs +strictlyEqOL _ _ = False + +-- | Compare not only the values but also the structure of two lists +strictlyOrdOL :: Ord a => OrdList a -> OrdList a -> Ordering +strictlyOrdOL None None = EQ +strictlyOrdOL None _ = LT +strictlyOrdOL (One x) (One y) = compare x y +strictlyOrdOL (One _) _ = LT +strictlyOrdOL (Cons a as) (Cons b bs) = + compare a b `mappend` strictlyOrdOL as bs +strictlyOrdOL (Cons _ _) _ = LT +strictlyOrdOL (Snoc as a) (Snoc bs b) = + compare a b `mappend` strictlyOrdOL as bs +strictlyOrdOL (Snoc _ _) _ = LT +strictlyOrdOL (Two a1 a2) (Two b1 b2) = + (strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2) +strictlyOrdOL (Two _ _) _ = LT +strictlyOrdOL (Many as) (Many bs) = compare as bs +strictlyOrdOL (Many _ ) _ = GT + + diff --git a/compiler/GHC/Data/Pair.hs b/compiler/GHC/Data/Pair.hs new file mode 100644 index 0000000000..ae51c78edc --- /dev/null +++ b/compiler/GHC/Data/Pair.hs @@ -0,0 +1,68 @@ +{- +A simple homogeneous pair type with useful Functor, Applicative, and +Traversable instances. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Data.Pair + ( Pair(..) + , unPair + , toPair + , swap + , pLiftFst + , pLiftSnd + ) +where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Outputable +import qualified Data.Semigroup as Semi + +data Pair a = Pair { pFst :: a, pSnd :: a } + deriving (Functor) +-- Note that Pair is a *unary* type constructor +-- whereas (,) is binary + +-- The important thing about Pair is that it has a *homogeneous* +-- Functor instance, so you can easily apply the same function +-- to both components + +instance Applicative Pair where + pure x = Pair x x + (Pair f g) <*> (Pair x y) = Pair (f x) (g y) + +instance Foldable Pair where + foldMap f (Pair x y) = f x `mappend` f y + +instance Traversable Pair where + traverse f (Pair x y) = Pair <$> f x <*> f y + +instance Semi.Semigroup a => Semi.Semigroup (Pair a) where + Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) + +instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where + mempty = Pair mempty mempty + mappend = (Semi.<>) + +instance Outputable a => Outputable (Pair a) where + ppr (Pair a b) = ppr a <+> char '~' <+> ppr b + +unPair :: Pair a -> (a,a) +unPair (Pair x y) = (x,y) + +toPair :: (a,a) -> Pair a +toPair (x,y) = Pair x y + +swap :: Pair a -> Pair a +swap (Pair x y) = Pair y x + +pLiftFst :: (a -> a) -> Pair a -> Pair a +pLiftFst f (Pair a b) = Pair (f a) b + +pLiftSnd :: (a -> a) -> Pair a -> Pair a +pLiftSnd f (Pair a b) = Pair a (f b) diff --git a/compiler/GHC/Data/Stream.hs b/compiler/GHC/Data/Stream.hs new file mode 100644 index 0000000000..7996ee7343 --- /dev/null +++ b/compiler/GHC/Data/Stream.hs @@ -0,0 +1,135 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2012 +-- +-- ----------------------------------------------------------------------------- + +-- | Monadic streams +module GHC.Data.Stream ( + Stream(..), yield, liftIO, + collect, collect_, consume, fromList, + map, mapM, mapAccumL, mapAccumL_ + ) where + +import GHC.Prelude hiding (map,mapM) + +import Control.Monad hiding (mapM) + +-- | +-- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence +-- of elements of type @a@ followed by a result of type @b@. +-- +-- More concretely, a value of type @Stream m a b@ can be run using @runStream@ +-- in the Monad @m@, and it delivers either +-- +-- * the final result: @Left b@, or +-- * @Right (a,str)@, where @a@ is the next element in the stream, and @str@ +-- is a computation to get the rest of the stream. +-- +-- Stream is itself a Monad, and provides an operation 'yield' that +-- produces a new element of the stream. This makes it convenient to turn +-- existing monadic computations into streams. +-- +-- The idea is that Stream is useful for making a monadic computation +-- that produces values from time to time. This can be used for +-- knitting together two complex monadic operations, so that the +-- producer does not have to produce all its values before the +-- consumer starts consuming them. We make the producer into a +-- Stream, and the consumer pulls on the stream each time it wants a +-- new value. +-- +newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) } + +instance Monad f => Functor (Stream f a) where + fmap = liftM + +instance Monad m => Applicative (Stream m a) where + pure a = Stream (return (Left a)) + (<*>) = ap + +instance Monad m => Monad (Stream m a) where + + Stream m >>= k = Stream $ do + r <- m + case r of + Left b -> runStream (k b) + Right (a,str) -> return (Right (a, str >>= k)) + +yield :: Monad m => a -> Stream m a () +yield a = Stream (return (Right (a, return ()))) + +liftIO :: IO a -> Stream IO b a +liftIO io = Stream $ io >>= return . Left + +-- | Turn a Stream into an ordinary list, by demanding all the elements. +collect :: Monad m => Stream m a () -> m [a] +collect str = go str [] + where + go str acc = do + r <- runStream str + case r of + Left () -> return (reverse acc) + Right (a, str') -> go str' (a:acc) + +-- | Turn a Stream into an ordinary list, by demanding all the elements. +collect_ :: Monad m => Stream m a r -> m ([a], r) +collect_ str = go str [] + where + go str acc = do + r <- runStream str + case r of + Left r -> return (reverse acc, r) + Right (a, str') -> go str' (a:acc) + +consume :: Monad m => Stream m a b -> (a -> m ()) -> m b +consume str f = do + r <- runStream str + case r of + Left ret -> return ret + Right (a, str') -> do + f a + consume str' f + +-- | Turn a list into a 'Stream', by yielding each element in turn. +fromList :: Monad m => [a] -> Stream m a () +fromList = mapM_ yield + +-- | Apply a function to each element of a 'Stream', lazily +map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x +map f str = Stream $ do + r <- runStream str + case r of + Left x -> return (Left x) + Right (a, str') -> return (Right (f a, map f str')) + +-- | Apply a monadic operation to each element of a 'Stream', lazily +mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x +mapM f str = Stream $ do + r <- runStream str + case r of + Left x -> return (Left x) + Right (a, str') -> do + b <- f a + return (Right (b, mapM f str')) + +-- | analog of the list-based 'mapAccumL' on Streams. This is a simple +-- way to map over a Stream while carrying some state around. +mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a () + -> Stream m b c +mapAccumL f c str = Stream $ do + r <- runStream str + case r of + Left () -> return (Left c) + Right (a, str') -> do + (c',b) <- f c a + return (Right (b, mapAccumL f c' str')) + +mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r + -> Stream m b (c, r) +mapAccumL_ f c str = Stream $ do + r <- runStream str + case r of + Left r -> return (Left (c, r)) + Right (a, str') -> do + (c',b) <- f c a + return (Right (b, mapAccumL_ f c' str')) diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs new file mode 100644 index 0000000000..8ac5d1ae07 --- /dev/null +++ b/compiler/GHC/Data/StringBuffer.hs @@ -0,0 +1,334 @@ +{- +(c) The University of Glasgow 2006 +(c) The University of Glasgow, 1997-2006 + + +Buffers for scanning string input stored in external arrays. +-} + +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +module GHC.Data.StringBuffer + ( + StringBuffer(..), + -- non-abstract for vs\/HaskellService + + -- * Creation\/destruction + hGetStringBuffer, + hGetStringBufferBlock, + hPutStringBuffer, + appendStringBuffers, + stringToStringBuffer, + + -- * Inspection + nextChar, + currentChar, + prevChar, + atEnd, + + -- * Moving and comparison + stepOn, + offsetBytes, + byteDiff, + atLine, + + -- * Conversion + lexemeToString, + lexemeToFastString, + decodePrevNChars, + + -- * Parsing integers + parseUnsignedInteger, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Encoding +import GHC.Data.FastString +import GHC.Utils.IO.Unsafe +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +import Data.Maybe +import Control.Exception +import System.IO +import System.IO.Unsafe ( unsafePerformIO ) +import GHC.IO.Encoding.UTF8 ( mkUTF8 ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) + +import GHC.Exts + +import Foreign + +-- ----------------------------------------------------------------------------- +-- The StringBuffer type + +-- |A StringBuffer is an internal pointer to a sized chunk of bytes. +-- The bytes are intended to be *immutable*. There are pure +-- operations to read the contents of a StringBuffer. +-- +-- A StringBuffer may have a finalizer, depending on how it was +-- obtained. +-- +data StringBuffer + = StringBuffer { + buf :: {-# UNPACK #-} !(ForeignPtr Word8), + len :: {-# UNPACK #-} !Int, -- length + cur :: {-# UNPACK #-} !Int -- current pos + } + -- The buffer is assumed to be UTF-8 encoded, and furthermore + -- we add three @\'\\0\'@ bytes to the end as sentinels so that the + -- decoder doesn't have to check for overflow at every single byte + -- of a multibyte sequence. + +instance Show StringBuffer where + showsPrec _ s = showString "<stringbuffer(" + . shows (len s) . showString "," . shows (cur s) + . showString ")>" + +-- ----------------------------------------------------------------------------- +-- Creation / Destruction + +-- | Read a file into a 'StringBuffer'. The resulting buffer is automatically +-- managed by the garbage collector. +hGetStringBuffer :: FilePath -> IO StringBuffer +hGetStringBuffer fname = do + h <- openBinaryFile fname ReadMode + size_i <- hFileSize h + offset_i <- skipBOM h size_i 0 -- offset is 0 initially + let size = fromIntegral $ size_i - offset_i + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> do + r <- if size == 0 then return 0 else hGetBuf h ptr size + hClose h + if (r /= size) + then ioError (userError "short read of file") + else newUTF8StringBuffer buf ptr size + +hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer +hGetStringBufferBlock handle wanted + = do size_i <- hFileSize handle + offset_i <- hTell handle >>= skipBOM handle size_i + let size = min wanted (fromIntegral $ size_i-offset_i) + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> + do r <- if size == 0 then return 0 else hGetBuf handle ptr size + if r /= size + then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) + else newUTF8StringBuffer buf ptr size + +hPutStringBuffer :: Handle -> StringBuffer -> IO () +hPutStringBuffer hdl (StringBuffer buf len cur) + = do withForeignPtr (plusForeignPtr buf cur) $ \ptr -> + hPutBuf hdl ptr len + +-- | Skip the byte-order mark if there is one (see #1744 and #6016), +-- and return the new position of the handle in bytes. +-- +-- This is better than treating #FEFF as whitespace, +-- because that would mess up layout. We don't have a concept +-- of zero-width whitespace in Haskell: all whitespace codepoints +-- have a width of one column. +skipBOM :: Handle -> Integer -> Integer -> IO Integer +skipBOM h size offset = + -- Only skip BOM at the beginning of a file. + if size > 0 && offset == 0 + then do + -- Validate assumption that handle is in binary mode. + ASSERTM( hGetEncoding h >>= return . isNothing ) + -- Temporarily select utf8 encoding with error ignoring, + -- to make `hLookAhead` and `hGetChar` return full Unicode characters. + bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do + c <- hLookAhead h + if c == '\xfeff' + then hGetChar h >> hTell h + else return offset + else return offset + where + safeEncoding = mkUTF8 IgnoreCodingFailure + +newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer +newUTF8StringBuffer buf ptr size = do + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return $ StringBuffer buf size 0 + +appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer +appendStringBuffers sb1 sb2 + = do newBuf <- mallocForeignPtrArray (size+3) + withForeignPtr newBuf $ \ptr -> + withForeignPtr (buf sb1) $ \sb1Ptr -> + withForeignPtr (buf sb2) $ \sb2Ptr -> + do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len + copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len + pokeArray (ptr `advancePtr` size) [0,0,0] + return (StringBuffer newBuf size 0) + where sb1_len = calcLen sb1 + sb2_len = calcLen sb2 + calcLen sb = len sb - cur sb + size = sb1_len + sb2_len + +-- | Encode a 'String' into a 'StringBuffer' as UTF-8. The resulting buffer +-- is automatically managed by the garbage collector. +stringToStringBuffer :: String -> StringBuffer +stringToStringBuffer str = + unsafePerformIO $ do + let size = utf8EncodedLength str + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> do + utf8EncodeString ptr str + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return (StringBuffer buf size 0) + +-- ----------------------------------------------------------------------------- +-- Grab a character + +-- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well +-- the remaining portion (analogous to 'Data.List.uncons'). __Warning:__ The +-- behavior is undefined if the 'StringBuffer' is empty. The result shares +-- the same buffer as the original. Similar to 'utf8DecodeChar', if the +-- character cannot be decoded as UTF-8, @\'\\0\'@ is returned. +{-# INLINE nextChar #-} +nextChar :: StringBuffer -> (Char,StringBuffer) +nextChar (StringBuffer buf len (I# cur#)) = + -- Getting our fingers dirty a little here, but this is performance-critical + inlinePerformIO $ do + withForeignPtr buf $ \(Ptr a#) -> do + case utf8DecodeChar# (a# `plusAddr#` cur#) of + (# c#, nBytes# #) -> + let cur' = I# (cur# +# nBytes#) in + return (C# c#, StringBuffer buf len cur') + +-- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous +-- to 'Data.List.head'). __Warning:__ The behavior is undefined if the +-- 'StringBuffer' is empty. Similar to 'utf8DecodeChar', if the character +-- cannot be decoded as UTF-8, @\'\\0\'@ is returned. +currentChar :: StringBuffer -> Char +currentChar = fst . nextChar + +prevChar :: StringBuffer -> Char -> Char +prevChar (StringBuffer _ _ 0) deflt = deflt +prevChar (StringBuffer buf _ cur) _ = + inlinePerformIO $ do + withForeignPtr buf $ \p -> do + p' <- utf8PrevChar (p `plusPtr` cur) + return (fst (utf8DecodeChar p')) + +-- ----------------------------------------------------------------------------- +-- Moving + +-- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous +-- to 'Data.List.tail'). __Warning:__ The behavior is undefined if the +-- 'StringBuffer' is empty. The result shares the same buffer as the +-- original. +stepOn :: StringBuffer -> StringBuffer +stepOn s = snd (nextChar s) + +-- | Return a 'StringBuffer' with the first @n@ bytes removed. __Warning:__ +-- If there aren't enough characters, the returned 'StringBuffer' will be +-- invalid and any use of it may lead to undefined behavior. The result +-- shares the same buffer as the original. +offsetBytes :: Int -- ^ @n@, the number of bytes + -> StringBuffer + -> StringBuffer +offsetBytes i s = s { cur = cur s + i } + +-- | Compute the difference in offset between two 'StringBuffer's that share +-- the same buffer. __Warning:__ The behavior is undefined if the +-- 'StringBuffer's use separate buffers. +byteDiff :: StringBuffer -> StringBuffer -> Int +byteDiff s1 s2 = cur s2 - cur s1 + +-- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null'). +atEnd :: StringBuffer -> Bool +atEnd (StringBuffer _ l c) = l == c + +-- | Computes a 'StringBuffer' which points to the first character of the +-- wanted line. Lines begin at 1. +atLine :: Int -> StringBuffer -> Maybe StringBuffer +atLine line sb@(StringBuffer buf len _) = + inlinePerformIO $ + withForeignPtr buf $ \p -> do + p' <- skipToLine line len p + if p' == nullPtr + then return Nothing + else + let + delta = p' `minusPtr` p + in return $ Just (sb { cur = delta + , len = len - delta + }) + +skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8) +skipToLine !line !len !op0 = go 1 op0 + where + !opend = op0 `plusPtr` len + + go !i_line !op + | op >= opend = pure nullPtr + | i_line == line = pure op + | otherwise = do + w <- peek op :: IO Word8 + case w of + 10 -> go (i_line + 1) (plusPtr op 1) + 13 -> do + -- this is safe because a 'StringBuffer' is + -- guaranteed to have 3 bytes sentinel values. + w' <- peek (plusPtr op 1) :: IO Word8 + case w' of + 10 -> go (i_line + 1) (plusPtr op 2) + _ -> go (i_line + 1) (plusPtr op 1) + _ -> go i_line (plusPtr op 1) + +-- ----------------------------------------------------------------------------- +-- Conversion + +-- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'. +-- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8, +-- they will be replaced with @\'\\0\'@. +lexemeToString :: StringBuffer + -> Int -- ^ @n@, the number of bytes + -> String +lexemeToString _ 0 = "" +lexemeToString (StringBuffer buf _ cur) bytes = + utf8DecodeStringLazy buf cur bytes + +lexemeToFastString :: StringBuffer + -> Int -- ^ @n@, the number of bytes + -> FastString +lexemeToFastString _ 0 = nilFS +lexemeToFastString (StringBuffer buf _ cur) len = + inlinePerformIO $ + withForeignPtr buf $ \ptr -> + return $! mkFastStringBytes (ptr `plusPtr` cur) len + +-- | Return the previous @n@ characters (or fewer if we are less than @n@ +-- characters into the buffer. +decodePrevNChars :: Int -> StringBuffer -> String +decodePrevNChars n (StringBuffer buf _ cur) = + inlinePerformIO $ withForeignPtr buf $ \p0 -> + go p0 n "" (p0 `plusPtr` (cur - 1)) + where + go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String + go buf0 n acc p | n == 0 || buf0 >= p = return acc + go buf0 n acc p = do + p' <- utf8PrevChar p + let (c,_) = utf8DecodeChar p' + go buf0 (n - 1) (c:acc) p' + +-- ----------------------------------------------------------------------------- +-- Parsing integer strings in various bases +parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer +parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int + = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let + go i x | i == len = x + | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of + '_' -> go (i + 1) x -- skip "_" (#14473) + char -> go (i + 1) (x * radix + toInteger (char_to_int char)) + in go 0 0 diff --git a/compiler/GHC/Data/TrieMap.hs b/compiler/GHC/Data/TrieMap.hs new file mode 100644 index 0000000000..e2506e3d4c --- /dev/null +++ b/compiler/GHC/Data/TrieMap.hs @@ -0,0 +1,406 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module GHC.Data.TrieMap( + -- * Maps over 'Maybe' values + MaybeMap, + -- * Maps over 'List' values + ListMap, + -- * Maps over 'Literal's + LiteralMap, + -- * 'TrieMap' class + TrieMap(..), insertTM, deleteTM, + + -- * Things helpful for adding additional Instances. + (>.>), (|>), (|>>), XT, + foldMaybe, + -- * Map for leaf compression + GenMap, + lkG, xtG, mapG, fdG, + xtList, lkList + + ) where + +import GHC.Prelude + +import GHC.Types.Literal +import GHC.Types.Unique.DFM +import GHC.Types.Unique( Unique ) + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import GHC.Utils.Outputable +import Control.Monad( (>=>) ) +import Data.Kind( Type ) + +{- +This module implements TrieMaps, which are finite mappings +whose key is a structured value like a CoreExpr or Type. + +This file implements tries over general data structures. +Implementation for tries over Core Expressions/Types are +available in GHC.Core.Map. + +The regular pattern for handling TrieMaps on data structures was first +described (to my knowledge) in Connelly and Morris's 1995 paper "A +generalization of the Trie Data Structure"; there is also an accessible +description of the idea in Okasaki's book "Purely Functional Data +Structures", Section 10.3.2 + +************************************************************************ +* * + The TrieMap class +* * +************************************************************************ +-} + +type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) + -- or an existing elt (Just) + +class TrieMap m where + type Key m :: Type + emptyTM :: m a + lookupTM :: forall b. Key m -> m b -> Maybe b + alterTM :: forall b. Key m -> XT b -> m b -> m b + mapTM :: (a->b) -> m a -> m b + + foldTM :: (a -> b -> b) -> m a -> b -> b + -- The unusual argument order here makes + -- it easy to compose calls to foldTM; + -- see for example fdE below + +insertTM :: TrieMap m => Key m -> a -> m a -> m a +insertTM k v m = alterTM k (\_ -> Just v) m + +deleteTM :: TrieMap m => Key m -> m a -> m a +deleteTM k m = alterTM k (\_ -> Nothing) m + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +(>.>) :: (a -> b) -> (b -> c) -> a -> c +-- Reverse function composition (do f first, then g) +infixr 1 >.> +(f >.> g) x = g (f x) +infixr 1 |>, |>> + +(|>) :: a -> (a->b) -> b -- Reverse application +x |> f = f x + +---------------------- +(|>>) :: TrieMap m2 + => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) + -> (m2 a -> m2 a) + -> m1 (m2 a) -> m1 (m2 a) +(|>>) f g = f (Just . g . deMaybe) + +deMaybe :: TrieMap m => Maybe (m a) -> m a +deMaybe Nothing = emptyTM +deMaybe (Just m) = m + +{- +************************************************************************ +* * + IntMaps +* * +************************************************************************ +-} + +instance TrieMap IntMap.IntMap where + type Key IntMap.IntMap = Int + emptyTM = IntMap.empty + lookupTM k m = IntMap.lookup k m + alterTM = xtInt + foldTM k m z = IntMap.foldr k z m + mapTM f m = IntMap.map f m + +xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a +xtInt k f m = IntMap.alter f k m + +instance Ord k => TrieMap (Map.Map k) where + type Key (Map.Map k) = k + emptyTM = Map.empty + lookupTM = Map.lookup + alterTM k f m = Map.alter f k m + foldTM k m z = Map.foldr k z m + mapTM f m = Map.map f m + + +{- +Note [foldTM determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We want foldTM to be deterministic, which is why we have an instance of +TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that +go wrong if foldTM is nondeterministic. Consider: + + f a b = return (a <> b) + +Depending on the order that the typechecker generates constraints you +get either: + + f :: (Monad m, Monoid a) => a -> a -> m a + +or: + + f :: (Monoid a, Monad m) => a -> a -> m a + +The generated code will be different after desugaring as the dictionaries +will be bound in different orders, leading to potential ABI incompatibility. + +One way to solve this would be to notice that the typeclasses could be +sorted alphabetically. + +Unfortunately that doesn't quite work with this example: + + f a b = let x = a <> a; y = b <> b in x + +where you infer: + + f :: (Monoid m, Monoid m1) => m1 -> m -> m1 + +or: + + f :: (Monoid m1, Monoid m) => m1 -> m -> m1 + +Here you could decide to take the order of the type variables in the type +according to depth first traversal and use it to order the constraints. + +The real trouble starts when the user enables incoherent instances and +the compiler has to make an arbitrary choice. Consider: + + class T a b where + go :: a -> b -> String + + instance (Show b) => T Int b where + go a b = show a ++ show b + + instance (Show a) => T a Bool where + go a b = show a ++ show b + + f = go 10 True + +GHC is free to choose either dictionary to implement f, but for the sake of +determinism we'd like it to be consistent when compiling the same sources +with the same flags. + +inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it +gets converted to a bag of (Wanted) Cts using a fold. Then in +solve_simple_wanteds it's merged with other WantedConstraints. We want the +conversion to a bag to be deterministic. For that purpose we use UniqDFM +instead of UniqFM to implement the TrieMap. + +See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how it's made +deterministic. +-} + +instance TrieMap UniqDFM where + type Key UniqDFM = Unique + emptyTM = emptyUDFM + lookupTM k m = lookupUDFM m k + alterTM k f m = alterUDFM f m k + foldTM k m z = foldUDFM k z m + mapTM f m = mapUDFM f m + +{- +************************************************************************ +* * + Maybes +* * +************************************************************************ + +If m is a map from k -> val +then (MaybeMap m) is a map from (Maybe k) -> val +-} + +data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } + +instance TrieMap m => TrieMap (MaybeMap m) where + type Key (MaybeMap m) = Maybe (Key m) + emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } + lookupTM = lkMaybe lookupTM + alterTM = xtMaybe alterTM + foldTM = fdMaybe + mapTM = mapMb + +mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b +mapMb f (MM { mm_nothing = mn, mm_just = mj }) + = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } + +lkMaybe :: (forall b. k -> m b -> Maybe b) + -> Maybe k -> MaybeMap m a -> Maybe a +lkMaybe _ Nothing = mm_nothing +lkMaybe lk (Just x) = mm_just >.> lk x + +xtMaybe :: (forall b. k -> XT b -> m b -> m b) + -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a +xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } +xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } + +fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b +fdMaybe k m = foldMaybe k (mm_nothing m) + . foldTM k (mm_just m) + +{- +************************************************************************ +* * + Lists +* * +************************************************************************ +-} + +data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + +instance TrieMap m => TrieMap (ListMap m) where + type Key (ListMap m) = [Key m] + emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } + lookupTM = lkList lookupTM + alterTM = xtList alterTM + foldTM = fdList + mapTM = mapList + +instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where + ppr m = text "List elts" <+> ppr (foldTM (:) m []) + +mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b +mapList f (LM { lm_nil = mnil, lm_cons = mcons }) + = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } + +lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> [k] -> ListMap m a -> Maybe a +lkList _ [] = lm_nil +lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs + +xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> [k] -> XT a -> ListMap m a -> ListMap m a +xtList _ [] f m = m { lm_nil = f (lm_nil m) } +xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } + +fdList :: forall m a b. TrieMap m + => (a -> b -> b) -> ListMap m a -> b -> b +fdList k m = foldMaybe k (lm_nil m) + . foldTM (fdList k) (lm_cons m) + +foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b +foldMaybe _ Nothing b = b +foldMaybe k (Just a) b = k a b + +{- +************************************************************************ +* * + Basic maps +* * +************************************************************************ +-} + +type LiteralMap a = Map.Map Literal a + +{- +************************************************************************ +* * + GenMap +* * +************************************************************************ + +Note [Compressed TrieMap] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +The GenMap constructor augments TrieMaps with leaf compression. This helps +solve the performance problem detailed in #9960: suppose we have a handful +H of entries in a TrieMap, each with a very large key, size K. If you fold over +such a TrieMap you'd expect time O(H). That would certainly be true of an +association list! But with TrieMap we actually have to navigate down a long +singleton structure to get to the elements, so it takes time O(K*H). This +can really hurt on many type-level computation benchmarks: +see for example T9872d. + +The point of a TrieMap is that you need to navigate to the point where only one +key remains, and then things should be fast. So the point of a SingletonMap +is that, once we are down to a single (key,value) pair, we stop and +just use SingletonMap. + +'EmptyMap' provides an even more basic (but essential) optimization: if there is +nothing in the map, don't bother building out the (possibly infinite) recursive +TrieMap structure! + +Compressed triemaps are heavily used by GHC.Core.Map. So we have to mark some things +as INLINEABLE to permit specialization. +-} + +data GenMap m a + = EmptyMap + | SingletonMap (Key m) a + | MultiMap (m a) + +instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where + ppr EmptyMap = text "Empty map" + ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v + ppr (MultiMap m) = ppr m + +-- TODO undecidable instance +instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where + type Key (GenMap m) = Key m + emptyTM = EmptyMap + lookupTM = lkG + alterTM = xtG + foldTM = fdG + mapTM = mapG + +--We want to be able to specialize these functions when defining eg +--tries over (GenMap CoreExpr) which requires INLINEABLE + +{-# INLINEABLE lkG #-} +lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a +lkG _ EmptyMap = Nothing +lkG k (SingletonMap k' v') | k == k' = Just v' + | otherwise = Nothing +lkG k (MultiMap m) = lookupTM k m + +{-# INLINEABLE xtG #-} +xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a +xtG k f EmptyMap + = case f Nothing of + Just v -> SingletonMap k v + Nothing -> EmptyMap +xtG k f m@(SingletonMap k' v') + | k' == k + -- The new key matches the (single) key already in the tree. Hence, + -- apply @f@ to @Just v'@ and build a singleton or empty map depending + -- on the 'Just'/'Nothing' response respectively. + = case f (Just v') of + Just v'' -> SingletonMap k' v'' + Nothing -> EmptyMap + | otherwise + -- We've hit a singleton tree for a different key than the one we are + -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then + -- we can just return the old map. If not, we need a map with *two* + -- entries. The easiest way to do that is to insert two items into an empty + -- map of type @m a@. + = case f Nothing of + Nothing -> m + Just v -> emptyTM |> alterTM k' (const (Just v')) + >.> alterTM k (const (Just v)) + >.> MultiMap +xtG k f (MultiMap m) = MultiMap (alterTM k f m) + +{-# INLINEABLE mapG #-} +mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b +mapG _ EmptyMap = EmptyMap +mapG f (SingletonMap k v) = SingletonMap k (f v) +mapG f (MultiMap m) = MultiMap (mapTM f m) + +{-# INLINEABLE fdG #-} +fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b +fdG _ EmptyMap = \z -> z +fdG k (SingletonMap _ v) = \z -> k v z +fdG k (MultiMap m) = foldTM k m diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 4f179f4aa1..4b15a4da9d 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -18,7 +18,7 @@ module GHC.Driver.Backpack (doBackpack) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax @@ -34,15 +34,15 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Module import GHC.Types.Module import GHC.Driver.Types -import StringBuffer -import FastString -import ErrUtils +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Utils.Error import GHC.Types.SrcLoc import GHC.Driver.Main import GHC.Types.Unique.FM import GHC.Types.Unique.DFM -import Outputable -import Maybes +import GHC.Utils.Outputable +import GHC.Data.Maybe import GHC.Parser.Header import GHC.Iface.Recomp import GHC.Driver.Make @@ -50,11 +50,11 @@ import GHC.Types.Unique.DSet import GHC.Builtin.Names import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Driver.Finder -import Util +import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt -import Panic +import GHC.Utils.Panic import Data.List ( partition ) import System.Exit import Control.Monad diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs index 7a119907da..bb459d8e35 100644 --- a/compiler/GHC/Driver/Backpack/Syntax.hs +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -16,14 +16,14 @@ module GHC.Driver.Backpack.Syntax ( LRenaming, Renaming(..), ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Phases import GHC.Hs import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import GHC.Types.Module -import UnitInfo +import GHC.Unit.Info {- ************************************************************************ diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs index 243831cfc5..2becd3e952 100644 --- a/compiler/GHC/Driver/CmdLine.hs +++ b/compiler/GHC/Driver/CmdLine.hs @@ -26,14 +26,14 @@ module GHC.Driver.CmdLine #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Util -import Outputable -import Panic -import Bag +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.Bag import GHC.Types.SrcLoc -import Json +import GHC.Utils.Json import Data.Function import Data.List diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 3bce0db86d..7a768db4b9 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -15,7 +15,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) @@ -30,12 +30,12 @@ import GHC.Cmm ( RawCmmGroup ) import GHC.Cmm.CLabel import GHC.Driver.Types import GHC.Driver.Session -import Stream ( Stream ) -import qualified Stream +import GHC.Data.Stream ( Stream ) +import qualified GHC.Data.Stream as Stream import GHC.SysTools.FileCleanup -import ErrUtils -import Outputable +import GHC.Utils.Error +import GHC.Utils.Outputable import GHC.Types.Module import GHC.Types.SrcLoc import GHC.Types.CostCentre diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs index 0a4b07509f..1118e764be 100644 --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -33,17 +33,17 @@ module GHC.Driver.Finder ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Module import GHC.Driver.Types import GHC.Driver.Packages -import FastString -import Util +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Builtin.Names ( gHC_PRIM ) import GHC.Driver.Session -import Outputable -import Maybes ( expectJust ) +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe ( expectJust ) import Data.IORef ( IORef, readIORef, atomicModifyIORef' ) import System.Directory diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 2e867ac85f..b0be5f4bce 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -8,10 +8,10 @@ module GHC.Driver.Flags ) where -import GhcPrelude -import Outputable -import EnumSet -import Json +import GHC.Prelude +import GHC.Utils.Outputable +import GHC.Data.EnumSet as EnumSet +import GHC.Utils.Json -- | Debugging flags data DumpFlag diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index 35b06ca1df..b7915ed3af 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -28,7 +28,7 @@ module GHC.Driver.Hooks ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Pipeline.Monad @@ -36,9 +36,9 @@ import GHC.Driver.Types import GHC.Hs.Decls import GHC.Hs.Binds import GHC.Hs.Expr -import OrdList +import GHC.Data.OrdList import GHC.Tc.Types -import Bag +import GHC.Data.Bag import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Id @@ -52,7 +52,7 @@ import GHC.Types.Module import GHC.Core.TyCon import GHC.Types.CostCentre import GHC.Stg.Syntax -import Stream +import GHC.Data.Stream import GHC.Cmm import GHC.Hs.Extension diff --git a/compiler/GHC/Driver/Hooks.hs-boot b/compiler/GHC/Driver/Hooks.hs-boot index 40ee5560ee..48d6cdb1bc 100644 --- a/compiler/GHC/Driver/Hooks.hs-boot +++ b/compiler/GHC/Driver/Hooks.hs-boot @@ -1,6 +1,6 @@ module GHC.Driver.Hooks where -import GhcPrelude () +import GHC.Prelude () data Hooks diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 5219ac6bd7..9199130996 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -84,7 +84,7 @@ module GHC.Driver.Main , hscAddSptEntries ) where -import GhcPrelude +import GHC.Prelude import Data.Data hiding (Fixity, TyCon) import Data.Maybe ( fromJust ) @@ -97,7 +97,7 @@ import GHC.Core.Tidy ( tidyExpr ) import GHC.Core.Type ( Type, Kind ) import GHC.Core.Lint ( lintInteractiveExpr ) import GHC.Types.Var.Env ( emptyTidyEnv ) -import Panic +import GHC.Utils.Panic import GHC.Core.ConLike import GHC.Parser.Annotation @@ -107,7 +107,7 @@ import GHC.Types.Name.Reader import GHC.Hs import GHC.Hs.Dump import GHC.Core -import StringBuffer +import GHC.Data.StringBuffer import GHC.Parser import GHC.Parser.Lexer as Lexer import GHC.Types.SrcLoc @@ -134,14 +134,14 @@ import GHC.Core.TyCon import GHC.Types.Name import GHC.Types.Name.Set import GHC.Cmm -import GHC.Cmm.Parser ( parseCmmFile ) +import GHC.Cmm.Parser ( parseCmmFile ) import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline import GHC.Cmm.Info import GHC.Driver.CodeOutput import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import Fingerprint ( Fingerprint ) +import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Driver.Hooks import GHC.Tc.Utils.Env import GHC.Builtin.Names @@ -149,20 +149,20 @@ import GHC.Driver.Plugins import GHC.Runtime.Loader ( initializePlugins ) import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error -import Outputable +import GHC.Utils.Outputable import GHC.Types.Name.Env -import HscStats ( ppSourceStats ) +import GHC.Hs.Stats ( ppSourceStats ) import GHC.Driver.Types -import FastString +import GHC.Data.FastString import GHC.Types.Unique.Supply -import Bag -import Exception -import qualified Stream -import Stream (Stream) +import GHC.Data.Bag +import GHC.Utils.Exception +import qualified GHC.Data.Stream as Stream +import GHC.Data.Stream (Stream) -import Util +import GHC.Utils.Misc import Data.List ( nub, isPrefixOf, partition ) import Control.Monad @@ -1767,7 +1767,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do return (new_tythings, new_ictxt) -- | Load the given static-pointer table entries into the interpreter. --- See Note [Grand plan for static forms] in StaticPtrTable. +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () hscAddSptEntries hsc_env entries = do let add_spt_entry :: SptEntry -> IO () diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index b81b045ed6..30e313ea46 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -33,41 +33,41 @@ module GHC.Driver.Make ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import qualified GHC.Runtime.Linker as Linker import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Finder import GHC.Driver.Monad import GHC.Parser.Header import GHC.Driver.Types import GHC.Types.Module -import GHC.IfaceToCore ( typecheckIface ) -import GHC.Tc.Utils.Monad ( initIfaceCheck ) +import GHC.IfaceToCore ( typecheckIface ) +import GHC.Tc.Utils.Monad ( initIfaceCheck ) import GHC.Driver.Main -import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) +import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) import GHC.Types.Basic -import Digraph -import Exception ( tryIO, gbracket, gfinally ) -import FastString -import Maybes ( expectJust ) +import GHC.Data.Graph.Directed +import GHC.Utils.Exception ( tryIO, gbracket, gfinally ) +import GHC.Data.FastString +import GHC.Data.Maybe ( expectJust ) import GHC.Types.Name -import MonadUtils ( allM ) -import Outputable -import Panic +import GHC.Utils.Monad ( allM ) +import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Types.SrcLoc -import StringBuffer +import GHC.Data.StringBuffer import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Tc.Utils.Backpack import GHC.Driver.Packages import GHC.Types.Unique.Set -import Util +import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Name.Env import GHC.SysTools.FileCleanup @@ -76,7 +76,7 @@ import Data.Either ( rights, partitionEithers ) import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set -import qualified FiniteMap as Map ( insertListWith ) +import qualified GHC.Data.FiniteMap as Map ( insertListWith ) import Control.Concurrent ( forkIOWithUnmask, killThread ) import qualified GHC.Conc as CC @@ -1505,7 +1505,7 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do -- Add any necessary entries to the static pointer -- table. See Note [Grand plan for static forms] in - -- StaticPtrTable. + -- GHC.Iface.Tidy.StaticPtrTable. when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $ liftIO $ hscAddSptEntries hsc_env4 [ spt diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index d45b39e3b3..01af21d461 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -15,27 +15,27 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import qualified GHC import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ways -import Util +import GHC.Utils.Misc import GHC.Driver.Types import qualified GHC.SysTools as SysTools import GHC.Types.Module -import Digraph ( SCC(..) ) +import GHC.Data.Graph.Directed ( SCC(..) ) import GHC.Driver.Finder -import Outputable -import Panic +import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Types.SrcLoc import Data.List -import FastString +import GHC.Data.FastString import GHC.SysTools.FileCleanup -import Exception -import ErrUtils +import GHC.Utils.Exception +import GHC.Utils.Error import System.Directory import System.FilePath diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index 3825757ac6..d0c950baf5 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -23,13 +23,13 @@ module GHC.Driver.Monad ( WarnErrLogger, defaultWarnErrLogger ) where -import GhcPrelude +import GHC.Prelude -import MonadUtils +import GHC.Utils.Monad import GHC.Driver.Types import GHC.Driver.Session -import Exception -import ErrUtils +import GHC.Utils.Exception +import GHC.Utils.Error import Control.Monad import Data.IORef diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs index 3e85251da2..a196467497 100644 --- a/compiler/GHC/Driver/Packages.hs +++ b/compiler/GHC/Driver/Packages.hs @@ -4,7 +4,7 @@ -- | Package manipulation module GHC.Driver.Packages ( - module UnitInfo, + module GHC.Unit.Info, -- * Reading the package config, and processing cmdline args PackageState(preloadPackages, explicitPackages, moduleNameProvidersMap, requirementContext), @@ -69,10 +69,10 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.PackageDb -import UnitInfo +import GHC.Unit.Info import GHC.Driver.Session import GHC.Driver.Ways import GHC.Types.Name ( Name, nameModule_maybe ) @@ -80,17 +80,17 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Module -import Util -import Panic +import GHC.Utils.Misc +import GHC.Utils.Panic import GHC.Platform -import Outputable -import Maybes +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe import System.Environment ( getEnv ) -import FastString -import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, +import GHC.Data.FastString +import GHC.Utils.Error ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, withTiming, DumpFormat (..) ) -import Exception +import GHC.Utils.Exception import System.Directory import System.FilePath as FilePath diff --git a/compiler/GHC/Driver/Packages.hs-boot b/compiler/GHC/Driver/Packages.hs-boot index 96bb95deec..eab2ebd60f 100644 --- a/compiler/GHC/Driver/Packages.hs-boot +++ b/compiler/GHC/Driver/Packages.hs-boot @@ -1,6 +1,6 @@ module GHC.Driver.Packages where -import GhcPrelude -import FastString +import GHC.Prelude +import GHC.Data.FastString import {-# SOURCE #-} GHC.Driver.Session (DynFlags) import {-# SOURCE #-} GHC.Types.Module(ComponentId, UnitId, InstalledUnitId) data PackageState diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs index d9059f65ec..cfca2e87c1 100644 --- a/compiler/GHC/Driver/Phases.hs +++ b/compiler/GHC/Driver/Phases.hs @@ -39,13 +39,13 @@ module GHC.Driver.Phases ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable import GHC.Platform import System.FilePath -import Binary -import Util +import GHC.Utils.Binary +import GHC.Utils.Misc ----------------------------------------------------------------------------- -- Phases diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 1fc37e0662..c13f7aa0dc 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -36,7 +36,7 @@ module GHC.Driver.Pipeline ( #include <ghcplatform.h> #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Pipeline.Monad import GHC.Driver.Packages @@ -48,18 +48,18 @@ import GHC.SysTools.ExtraObj import GHC.Driver.Main import GHC.Driver.Finder import GHC.Driver.Types hiding ( Hsc ) -import Outputable +import GHC.Utils.Outputable import GHC.Types.Module -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Session -import Panic -import Util -import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) -import GHC.Types.Basic ( SuccessFlag(..) ) -import Maybes ( expectJust ) +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer ) +import GHC.Types.Basic ( SuccessFlag(..) ) +import GHC.Data.Maybe ( expectJust ) import GHC.Types.SrcLoc -import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) -import MonadUtils +import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) +import GHC.Utils.Monad import GHC.Platform import GHC.Tc.Types import GHC.Driver.Hooks @@ -67,12 +67,12 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.SysTools.FileCleanup import GHC.SysTools.Ar import GHC.Settings -import Bag ( unitBag ) -import FastString ( mkFastString ) -import GHC.Iface.Make ( mkFullIface ) -import UpdateCafInfos ( updateModDetailsCafInfos ) +import GHC.Data.Bag ( unitBag ) +import GHC.Data.FastString ( mkFastString ) +import GHC.Iface.Make ( mkFullIface ) +import GHC.Iface.UpdateCafInfos ( updateModDetailsCafInfos ) -import Exception +import GHC.Utils.Exception as Exception import System.Directory import System.FilePath import System.IO diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs index 753f829f3c..bf22ae6e9d 100644 --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -11,10 +11,10 @@ module GHC.Driver.Pipeline.Monad ( , pipeStateDynFlags, pipeStateModIface ) where -import GhcPrelude +import GHC.Prelude -import MonadUtils -import Outputable +import GHC.Utils.Monad +import GHC.Utils.Outputable import GHC.Driver.Session import GHC.Driver.Phases import GHC.Driver.Types diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs index d9e29d451b..4d4f9eab77 100644 --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -47,7 +47,7 @@ module GHC.Driver.Plugins ( , mapPlugins, withPlugins, withPlugins_ ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Core.Opt.Monad ( CoreToDo, CoreM ) import qualified GHC.Tc.Types @@ -59,9 +59,9 @@ import GHC.Driver.Types import GHC.Driver.Monad import GHC.Driver.Phases import GHC.Types.Module ( ModuleName, Module(moduleName)) -import Fingerprint +import GHC.Utils.Fingerprint import Data.List (sort) -import Outputable (Outputable(..), text, (<+>)) +import GHC.Utils.Outputable (Outputable(..), text, (<+>)) --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<> diff --git a/compiler/GHC/Driver/Plugins.hs-boot b/compiler/GHC/Driver/Plugins.hs-boot index 41a0c115d2..7b5f8ca161 100644 --- a/compiler/GHC/Driver/Plugins.hs-boot +++ b/compiler/GHC/Driver/Plugins.hs-boot @@ -2,7 +2,7 @@ -- exposed without importing all of its implementation. module GHC.Driver.Plugins where -import GhcPrelude () +import GHC.Prelude () data Plugin diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 7efba2bcea..fe35d19ee5 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -238,7 +238,7 @@ module GHC.Driver.Session ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.UniqueSubdir (uniqueSubdir) @@ -251,27 +251,28 @@ import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags import GHC.Driver.Ways import Config -import CliOption +import GHC.Utils.CliOption import GHC.Driver.CmdLine hiding (WarnReason(..)) import qualified GHC.Driver.CmdLine as Cmd import GHC.Settings.Constants -import Panic -import qualified PprColour as Col -import Util -import Maybes -import MonadUtils -import qualified Pretty +import GHC.Utils.Panic +import qualified GHC.Utils.Ppr.Colour as Col +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Monad +import qualified GHC.Utils.Ppr as Pretty import GHC.Types.SrcLoc import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) -import FastString -import Fingerprint -import Outputable +import GHC.Data.FastString +import GHC.Utils.Fingerprint +import GHC.Utils.Outputable import GHC.Settings -import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn +import {-# SOURCE #-} GHC.Utils.Error + ( Severity(..), MsgDoc, mkLocMessageAnn , getCaretDiagnostic, DumpAction, TraceAction , defaultDumpAction, defaultTraceAction ) -import Json +import GHC.Utils.Json import GHC.SysTools.Terminal ( stderrSupportsAnsiColors ) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) @@ -300,8 +301,8 @@ import System.IO.Error import Text.ParserCombinators.ReadP hiding (char) import Text.ParserCombinators.ReadP as R -import EnumSet (EnumSet) -import qualified EnumSet +import GHC.Data.EnumSet (EnumSet) +import qualified GHC.Data.EnumSet as EnumSet import GHC.Foreign (withCString, peekCString) import qualified GHC.LanguageExtensions as LangExt @@ -702,7 +703,7 @@ data DynFlags = DynFlags { ghciHistSize :: Int, - -- | MsgDoc output action: use "ErrUtils" instead of this if you can + -- | MsgDoc output action: use "GHC.Utils.Error" instead of this if you can log_action :: LogAction, dump_action :: DumpAction, trace_action :: TraceAction, diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot index 2bc44dc3c6..509535ba71 100644 --- a/compiler/GHC/Driver/Session.hs-boot +++ b/compiler/GHC/Driver/Session.hs-boot @@ -1,8 +1,8 @@ module GHC.Driver.Session where -import GhcPrelude +import GHC.Prelude import GHC.Platform -import {-# SOURCE #-} Outputable +import {-# SOURCE #-} GHC.Utils.Outputable data DynFlags diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index 581a90ea1d..b4f07618f6 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -159,7 +159,7 @@ module GHC.Driver.Types ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.ByteCode.Types import GHC.Runtime.Eval.Types ( Resume ) @@ -202,21 +202,21 @@ import GHC.Driver.Phases import qualified GHC.Driver.Phases as Phase import GHC.Types.Basic import GHC.Iface.Syntax -import Maybes -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.DFM -import FastString -import StringBuffer ( StringBuffer ) -import Fingerprint -import MonadUtils -import Bag -import Binary -import ErrUtils +import GHC.Data.FastString +import GHC.Data.StringBuffer ( StringBuffer ) +import GHC.Utils.Fingerprint +import GHC.Utils.Monad +import GHC.Data.Bag +import GHC.Utils.Binary +import GHC.Utils.Error import GHC.Types.Name.Cache import GHC.Platform -import Util +import GHC.Utils.Misc import GHC.Types.Unique.DSet import GHC.Serialized ( Serialized ) import qualified GHC.LanguageExtensions as LangExt @@ -227,7 +227,7 @@ import Data.IORef import Data.Map ( Map ) import qualified Data.Map as Map import Data.Time -import Exception +import GHC.Utils.Exception import System.FilePath import Control.DeepSeq import Control.Monad.Trans.Reader @@ -1524,7 +1524,7 @@ data CgGuts cg_spt_entries :: [SptEntry] -- ^ Static pointer table entries for static forms defined in -- the module. - -- See Note [Grand plan for static forms] in StaticPtrTable + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable } ----------------------------------- diff --git a/compiler/GHC/Driver/Ways.hs b/compiler/GHC/Driver/Ways.hs index 1b9845850f..eae86864d4 100644 --- a/compiler/GHC/Driver/Ways.hs +++ b/compiler/GHC/Driver/Ways.hs @@ -37,7 +37,7 @@ module GHC.Driver.Ways ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Driver.Flags diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index 72710c6830..59fe3e36b0 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -35,7 +35,7 @@ module GHC.Hs ( ) where -- friends: -import GhcPrelude +import GHC.Prelude import GHC.Hs.Decls import GHC.Hs.Binds @@ -51,7 +51,7 @@ import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances -- others: -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Types.Module ( ModuleName ) diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 5068f082ce..0252656203 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -23,7 +23,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. module GHC.Hs.Binds where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, LHsExpr, MatchGroup, pprFunBind, @@ -37,12 +37,12 @@ import GHC.Tc.Types.Evidence import GHC.Core.Type import GHC.Types.Name.Set import GHC.Types.Basic -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var -import Bag -import FastString -import BooleanFormula (LBooleanFormula) +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.BooleanFormula (LBooleanFormula) import Data.Data hiding ( Fixity ) import Data.List hiding ( foldr ) diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 0be89127a5..f0ffd06307 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -94,7 +94,7 @@ module GHC.Hs.Decls ( ) where -- friends: -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, HsSplice, pprExpr, pprSpliceDecl ) @@ -112,13 +112,13 @@ import GHC.Types.Name.Set -- others: import GHC.Core.Class -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.SrcLoc import GHC.Core.Type -import Bag -import Maybes +import GHC.Data.Bag +import GHC.Data.Maybe import Data.Data hiding (TyCon,Fixity, Infix) {- diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 7da56b1524..9a5035b46e 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -23,13 +23,13 @@ module GHC.Hs.Doc #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Binary -import Encoding -import FastFunctions +import GHC.Utils.Binary +import GHC.Utils.Encoding +import GHC.Utils.IO.Unsafe import GHC.Types.Name -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc import Data.ByteString (ByteString) diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index 2fe8711570..ee9df10c5d 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -15,12 +15,12 @@ module GHC.Hs.Dump ( BlankSrcSpan(..), ) where -import GhcPrelude +import GHC.Prelude import Data.Data hiding (Fixity) -import Bag +import GHC.Data.Bag import GHC.Types.Basic -import FastString +import GHC.Data.FastString import GHC.Types.Name.Set import GHC.Types.Name import GHC.Core.DataCon @@ -28,7 +28,7 @@ import GHC.Types.SrcLoc import GHC.Hs import GHC.Types.Var import GHC.Types.Module -import Outputable +import GHC.Utils.Outputable import qualified Data.ByteString as B diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 290a9716e2..a03c0aa50d 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -26,7 +26,7 @@ module GHC.Hs.Expr where #include "HsVersions.h" -- friends: -import GhcPrelude +import GHC.Prelude import GHC.Hs.Decls import GHC.Hs.Pat @@ -43,9 +43,9 @@ import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Core.ConLike import GHC.Types.SrcLoc -import Util -import Outputable -import FastString +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Core.Type import GHC.Builtin.Types (mkTupleStr) import GHC.Tc.Utils.TcType (TcType) diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot index 87a4a2b38e..ccfe2cb65d 100644 --- a/compiler/GHC/Hs/Expr.hs-boot +++ b/compiler/GHC/Hs/Expr.hs-boot @@ -11,7 +11,7 @@ module GHC.Hs.Expr where import GHC.Types.SrcLoc ( Located ) -import Outputable ( SDoc, Outputable ) +import GHC.Utils.Outputable ( SDoc, Outputable ) import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) import GHC.Types.Basic ( SpliceExplicitFlag(..)) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index b24bdf19b8..57cd67e65a 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -25,13 +25,13 @@ module GHC.Hs.Extension where -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax -import GhcPrelude +import GHC.Prelude import Data.Data hiding ( Fixity ) import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.Var -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc (Located) import Data.Kind diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index d4ed3e64a0..813d0ef9bf 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -16,7 +16,7 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces module GHC.Hs.ImpExp where -import GhcPrelude +import GHC.Prelude import GHC.Types.Module ( ModuleName ) import GHC.Hs.Doc ( HsDocString ) @@ -24,8 +24,8 @@ import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc ) import GHC.Types.Basic ( SourceText(..), StringLiteral(..), pprWithSourceText ) import GHC.Types.FieldLabel ( FieldLbl(..) ) -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.SrcLoc import GHC.Hs.Extension diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index db7a46805c..6eca193bb8 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -16,7 +16,7 @@ module GHC.Hs.Instances where import Data.Data hiding ( Fixity ) -import GhcPrelude +import GHC.Prelude import GHC.Hs.Extension import GHC.Hs.Binds import GHC.Hs.Decls diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index 964df0d356..75e5c1d315 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -19,7 +19,7 @@ module GHC.Hs.Lit where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr ) import GHC.Types.Basic @@ -27,8 +27,8 @@ import GHC.Types.Basic , negateFractionalLit, SourceText(..), pprWithSourceText , PprPrec(..), topPrec ) import GHC.Core.Type -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Hs.Extension import Data.ByteString (ByteString) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index c92967db81..4f73aa3e98 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -50,7 +50,7 @@ module GHC.Hs.Pat ( pprParendLPat, pprConArgs ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice) @@ -69,11 +69,11 @@ import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon -import Outputable +import GHC.Utils.Outputable import GHC.Core.Type import GHC.Types.SrcLoc -import Bag -- collect ev vars from pats -import Maybes +import GHC.Data.Bag -- collect ev vars from pats +import GHC.Data.Maybe import GHC.Types.Name (Name) -- libraries: import Data.Data hiding (TyCon,Fixity) diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot index c7ff0a892e..1a783e3c7e 100644 --- a/compiler/GHC/Hs/Pat.hs-boot +++ b/compiler/GHC/Hs/Pat.hs-boot @@ -9,7 +9,7 @@ module GHC.Hs.Pat where -import Outputable +import GHC.Utils.Outputable import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec ) import Data.Kind diff --git a/compiler/GHC/Hs/Stats.hs b/compiler/GHC/Hs/Stats.hs new file mode 100644 index 0000000000..5b76372f37 --- /dev/null +++ b/compiler/GHC/Hs/Stats.hs @@ -0,0 +1,187 @@ +-- | +-- Statistics for per-module compilations +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Hs.Stats ( ppSourceStats ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Hs +import GHC.Utils.Outputable +import GHC.Types.SrcLoc +import GHC.Utils.Misc + +import Data.Char + +-- | Source Statistics +ppSourceStats :: Bool -> Located HsModule -> SDoc +ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) + = (if short then hcat else vcat) + (map pp_val + [("ExportAll ", export_all), -- 1 if no export list + ("ExportDecls ", export_ds), + ("ExportModules ", export_ms), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), + ("FixityDecls ", fixity_sigs), + ("DefaultDecls ", default_ds), + ("TypeDecls ", type_ds), + ("DataDecls ", data_ds), + ("NewTypeDecls ", newt_ds), + ("TypeFamilyDecls ", type_fam_ds), + ("DataConstrs ", data_constrs), + ("DataDerivings ", data_derivs), + ("ClassDecls ", class_ds), + ("ClassMethods ", class_method_ds), + ("DefaultMethods ", default_method_ds), + ("InstDecls ", inst_ds), + ("InstMethods ", inst_method_ds), + ("InstType ", inst_type_ds), + ("InstData ", inst_data_ds), + ("TypeSigs ", bind_tys), + ("ClassOpSigs ", generic_sigs), + ("ValBinds ", val_bind_ds), + ("FunBinds ", fn_bind_ds), + ("PatSynBinds ", patsyn_ds), + ("InlineMeths ", method_inlines), + ("InlineBinds ", bind_inlines), + ("SpecialisedMeths ", method_specs), + ("SpecialisedBinds ", bind_specs) + ]) + where + decls = map unLoc ldecls + + pp_val (_, 0) = empty + pp_val (str, n) + | not short = hcat [text str, int n] + | otherwise = hcat [text (trim str), equals, int n, semi] + + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) + + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) + = count_sigs [d | SigD _ d <- decls] + -- NB: this omits fixity decls on local bindings and + -- in class decls. ToDo + + tycl_decls = [d | TyClD _ d <- decls] + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = + countTyClDecls tycl_decls + + inst_decls = [d | InstD _ d <- decls] + inst_ds = length inst_decls + default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls + val_decls = [d | ValD _ d <- decls] + + real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } + n_exports = length real_exports + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True + ; _ -> False}) + real_exports + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; _ -> 0 } + + (val_bind_ds, fn_bind_ds, patsyn_ds) + = sum3 (map count_bind val_decls) + + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = sum7 (map import_info imports) + (data_constrs, data_derivs) + = sum2 (map data_info tycl_decls) + (class_method_ds, default_method_ds) + = sum2 (map class_info tycl_decls) + (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) + = sum5 (map inst_info inst_decls) + + count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) + count_bind (PatBind {}) = (0,1,0) + count_bind (FunBind {}) = (0,1,0) + count_bind (PatSynBind {}) = (0,0,1) + count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) + + count_sigs sigs = sum5 (map sig_info sigs) + + sig_info (FixSig {}) = (1,0,0,0,0) + sig_info (TypeSig {}) = (0,1,0,0,0) + sig_info (SpecSig {}) = (0,0,1,0,0) + sig_info (InlineSig {}) = (0,0,0,1,0) + sig_info (ClassOpSig {}) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) + + import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int) + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + + safe_info False = 0 + safe_info True = 1 + qual_info NotQualified = 0 + qual_info _ = 1 + as_info Nothing = 0 + as_info (Just _) = 1 + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,0,1) + + data_info (DataDecl { tcdDataDefn = HsDataDefn + { dd_cons = cs + , dd_derivs = L _ derivs}}) + = ( length cs + , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) + 0 derivs ) + data_info _ = (0,0) + + class_info decl@(ClassDecl {}) + = (classops, addpr (sum3 (map count_bind methods))) + where + methods = map unLoc $ bagToList (tcdMeths decl) + (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) + class_info _ = (0,0) + + inst_info :: InstDecl GhcPs -> (Int, Int, Int, Int, Int) + inst_info (TyFamInstD {}) = (0,0,0,1,0) + inst_info (DataFamInstD {}) = (0,0,0,0,1) + inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths + , cid_sigs = inst_sigs + , cid_tyfam_insts = ats + , cid_datafam_insts = adts } }) + = case count_sigs (map unLoc inst_sigs) of + (_,_,ss,is,_) -> + (addpr (sum3 (map count_bind methods)), + ss, is, length ats, length adts) + where + methods = map unLoc $ bagToList inst_meths + + -- TODO: use Sum monoid + addpr :: (Int,Int,Int) -> Int + sum2 :: [(Int, Int)] -> (Int, Int) + sum3 :: [(Int, Int, Int)] -> (Int, Int, Int) + sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int) + sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int) + add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int) + -> (Int, Int, Int, Int, Int, Int, Int) + + addpr (x,y,z) = x+y+z + sum2 = foldr add2 (0,0) + where + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + sum3 = foldr add3 (0,0,0) + where + add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) + sum5 = foldr add5 (0,0,0,0,0) + where + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) + sum7 = foldr add7 (0,0,0,0,0,0,0) + + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index 38a0300a8f..fd782c6348 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -72,7 +72,7 @@ module GHC.Hs.Types ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice ) @@ -88,10 +88,10 @@ import GHC.Core.Type import GHC.Hs.Doc import GHC.Types.Basic import GHC.Types.SrcLoc -import Outputable -import FastString -import Maybes( isJust ) -import Util ( count ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Maybe( isJust ) +import GHC.Utils.Misc ( count ) import Data.Data hiding ( Fixity, Prefix, Infix ) diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 75ef5b06bf..6e89b6844a 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -104,7 +104,7 @@ module GHC.Hs.Utils( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs.Decls import GHC.Hs.Binds @@ -130,10 +130,10 @@ import GHC.Types.Name.Set hiding ( unitFV ) import GHC.Types.Name.Env import GHC.Types.Basic import GHC.Types.SrcLoc -import FastString -import Util -import Bag -import Outputable +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Utils.Outputable import GHC.Settings.Constants import Data.Either diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index ad445bf8bc..7474678e3c 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -18,7 +18,7 @@ module GHC.HsToCore ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.Usage import GHC.Driver.Session @@ -57,14 +57,14 @@ import GHC.Types.Basic import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) import GHC.Types.Var.Set -import FastString -import ErrUtils -import Outputable +import GHC.Data.FastString +import GHC.Utils.Error +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.HsToCore.Coverage -import Util -import MonadUtils -import OrdList +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Data.OrdList import GHC.HsToCore.Docs import Data.List diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index e3ac5a046b..733ae86d6e 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -16,7 +16,7 @@ module GHC.HsToCore.Arrows ( dsProcExpr ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.Match import GHC.HsToCore.Utils @@ -50,12 +50,12 @@ import GHC.Core.ConLike import GHC.Builtin.Types import GHC.Types.Basic import GHC.Builtin.Names -import Outputable +import GHC.Utils.Outputable import GHC.Types.Var.Set import GHC.Types.SrcLoc -import ListSetOps( assocMaybe ) +import GHC.Data.List.SetOps( assocMaybe ) import Data.List -import Util +import GHC.Utils.Misc import GHC.Types.Unique.DSet data DsCmdEnv = DsCmdEnv { diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index cd2a786445..7bc6fe2512 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -25,7 +25,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) @@ -44,7 +44,7 @@ import GHC.Core.Utils import GHC.Core.Arity ( etaExpand ) import GHC.Core.Unfold import GHC.Core.FVs -import Digraph +import GHC.Data.Graph.Directed import GHC.Core.Predicate import GHC.Builtin.Names @@ -61,18 +61,18 @@ import GHC.Types.Var.Set import GHC.Core.Rules import GHC.Types.Var.Env import GHC.Types.Var( EvVar ) -import Outputable +import GHC.Utils.Outputable import GHC.Types.Module import GHC.Types.SrcLoc -import Maybes -import OrdList -import Bag +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Data.Bag import GHC.Types.Basic import GHC.Driver.Session -import FastString -import Util +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Types.Unique.Set( nonDetEltsUniqSet ) -import MonadUtils +import GHC.Utils.Monad import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Data.List.NonEmpty ( nonEmpty ) @@ -1173,7 +1173,7 @@ mk_ev_binds ds_binds coVarsOfType (varType var) } -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices -- is still deterministic even if the edges are in nondeterministic order - -- as explained in Note [Deterministic SCC] in Digraph. + -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. ds_scc (AcyclicSCC (v,r)) = NonRec v r ds_scc (CyclicSCC prs) = Rec prs diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 196c4a0cf0..b2f5c4d15e 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -12,7 +12,7 @@ module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where -import GhcPrelude as Prelude +import GHC.Prelude as Prelude import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes @@ -22,29 +22,29 @@ import GHC.Stack.CCS import GHC.Core.Type import GHC.Hs import GHC.Types.Module as Module -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Driver.Session import GHC.Core.ConLike import Control.Monad import GHC.Types.SrcLoc -import ErrUtils +import GHC.Utils.Error import GHC.Types.Name.Set hiding (FreeVars) import GHC.Types.Name -import Bag +import GHC.Data.Bag import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Core import GHC.Types.Id import GHC.Types.Var.Set import Data.List -import FastString +import GHC.Data.FastString import GHC.Driver.Types import GHC.Core.TyCon import GHC.Types.Basic -import MonadUtils -import Maybes +import GHC.Utils.Monad +import GHC.Data.Maybe import GHC.Cmm.CLabel -import Util +import GHC.Utils.Misc import Data.Time import System.Directory diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 30cf626d6d..c14c2ac7e8 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -8,8 +8,8 @@ module GHC.HsToCore.Docs (extractDocs) where -import GhcPrelude -import Bag +import GHC.Prelude +import GHC.Data.Bag import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Decls diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 8e4313f80d..2ea1c17e04 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -22,7 +22,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.Match import GHC.HsToCore.Match.Literal @@ -60,12 +60,12 @@ import GHC.Core.TyCo.Ppr( pprWithTYPE ) import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic -import Maybes +import GHC.Data.Maybe import GHC.Types.Var.Env import GHC.Types.SrcLoc -import Util -import Bag -import Outputable +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Utils.Outputable as Outputable import GHC.Core.PatSyn import Control.Monad @@ -471,7 +471,7 @@ dsExpr (ArithSeq expr witness seq) Static Pointers ~~~~~~~~~~~~~~~ -See Note [Grand plan for static forms] in StaticPtrTable for an overview. +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. g = ... static f ... ==> diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index b3ecd82cf8..9589c375e8 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -22,7 +22,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Core @@ -47,8 +47,8 @@ import GHC.Types.Basic import GHC.Types.Literal import GHC.Builtin.Names import GHC.Driver.Session -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import Data.Maybe diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index dadfc40005..9eb867a098 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -16,7 +16,7 @@ Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call). module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.Monad -- temp @@ -48,14 +48,14 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Names import GHC.Types.Basic import GHC.Types.SrcLoc -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Driver.Session import GHC.Platform -import OrdList -import Util +import GHC.Data.OrdList +import GHC.Utils.Misc import GHC.Driver.Hooks -import Encoding +import GHC.Utils.Encoding import Data.Maybe import Data.List diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs index 8ee3661da6..68162187b8 100644 --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -13,7 +13,7 @@ module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar ) @@ -27,9 +27,9 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas ) import GHC.Core.Type ( Type ) -import Util +import GHC.Utils.Misc import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList ) diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 9db596fb52..9d6a9bb462 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -14,7 +14,7 @@ module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) @@ -34,10 +34,10 @@ import GHC.Builtin.Types import GHC.HsToCore.Match import GHC.Builtin.Names import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import GHC.Tc.Utils.TcType -import ListSetOps( getNth ) -import Util +import GHC.Data.List.SetOps( getNth ) +import GHC.Utils.Misc {- List comprehensions may be desugared in one of two ways: ``ordinary'' diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index b9e053c005..60b694ff9d 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -23,7 +23,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) @@ -54,12 +54,12 @@ import GHC.Core.Coercion ( eqCoercion ) import GHC.Core.TyCon ( isNewTyCon ) import GHC.Builtin.Types import GHC.Types.SrcLoc -import Maybes -import Util +import GHC.Data.Maybe +import GHC.Utils.Misc import GHC.Types.Name -import Outputable +import GHC.Utils.Outputable import GHC.Types.Basic ( isGenerated, il_value, fl_value ) -import FastString +import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot index 9466cbdb17..b42c84e10a 100644 --- a/compiler/GHC/HsToCore/Match.hs-boot +++ b/compiler/GHC/HsToCore/Match.hs-boot @@ -1,6 +1,6 @@ module GHC.HsToCore.Match where -import GhcPrelude +import GHC.Prelude import GHC.Types.Var ( Id ) import GHC.Tc.Utils.TcType ( Type ) import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs index c7022d6b1d..9c7ad46c22 100644 --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -16,7 +16,7 @@ module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Match ( match ) @@ -29,12 +29,12 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.Core ( CoreExpr ) import GHC.Core.Make ( mkCoreLets ) -import Util +import GHC.Utils.Misc import GHC.Types.Id import GHC.Types.Name.Env import GHC.Types.FieldLabel ( flSelector ) import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import Control.Monad(liftM) import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty(..)) diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 93b042e033..600af91468 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -23,7 +23,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.HsToCore.Match ( match ) @@ -49,11 +49,11 @@ import GHC.Builtin.Types.Prim import GHC.Types.Literal import GHC.Types.SrcLoc import Data.Ratio -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.Basic import GHC.Driver.Session -import Util -import FastString +import GHC.Utils.Misc +import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index f570330480..a2163209c3 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -55,7 +55,7 @@ module GHC.HsToCore.Monad ( pprRuntimeTrace ) where -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.Monad import GHC.Core.FamInstEnv @@ -68,7 +68,7 @@ import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr ) import GHC.Builtin.Names import GHC.Types.Name.Reader import GHC.Driver.Types -import Bag +import GHC.Data.Bag import GHC.Types.Basic ( Origin ) import GHC.Core.DataCon import GHC.Core.ConLike @@ -76,15 +76,15 @@ import GHC.Core.TyCon import GHC.HsToCore.PmCheck.Types import GHC.Types.Id import GHC.Types.Module -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Core.Type import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Name.Env import GHC.Driver.Session -import ErrUtils -import FastString +import GHC.Utils.Error +import GHC.Data.FastString import GHC.Types.Unique.FM ( lookupWithDefaultUFM ) import GHC.Types.Literal ( mkLitString ) import GHC.Types.CostCentre.State diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 6c8ac7f046..8b34f275b0 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -22,14 +22,14 @@ module GHC.HsToCore.PmCheck ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.PmCheck.Types import GHC.HsToCore.PmCheck.Oracle import GHC.HsToCore.PmCheck.Ppr import GHC.Types.Basic (Origin, isGenerated) import GHC.Core (CoreExpr, Expr(Var,App)) -import FastString (unpackFS, lengthFS) +import GHC.Data.FastString (unpackFS, lengthFS) import GHC.Driver.Session import GHC.Hs import GHC.Tc.Utils.Zonk (shortCutLit) @@ -39,8 +39,8 @@ import GHC.Types.Name import GHC.Tc.Instance.Family import GHC.Builtin.Types import GHC.Types.SrcLoc -import Util -import Outputable +import GHC.Utils.Misc +import GHC.Utils.Outputable import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Types.Var (EvVar) @@ -52,14 +52,14 @@ import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper) import GHC.HsToCore.Utils (selectMatchVar) import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad -import Bag -import OrdList +import GHC.Data.Bag +import GHC.Data.OrdList import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.HsToCore.Utils (isTrueLHsExpr) -import Maybes +import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import MonadUtils (concatMapM) +import GHC.Utils.Monad (concatMapM) import Control.Monad (when, forM_, zipWithM) import Data.List (elemIndex) diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index 63cc4710dd..4fd6132784 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -25,15 +25,15 @@ module GHC.HsToCore.PmCheck.Oracle ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.HsToCore.PmCheck.Types import GHC.Driver.Session -import Outputable -import ErrUtils -import Util -import Bag +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Data.Bag import GHC.Types.Unique.Set import GHC.Types.Unique.DSet import GHC.Types.Unique @@ -49,9 +49,9 @@ import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils (exprType) import GHC.Core.Make (mkListExpr, mkCharExpr) import GHC.Types.Unique.Supply -import FastString +import GHC.Data.FastString import GHC.Types.SrcLoc -import Maybes +import GHC.Data.Maybe import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn @@ -64,7 +64,7 @@ import GHC.Tc.Solver (tcNormalise, tcCheckSatisfiability) import GHC.Core.Unify (tcMatchTy) import GHC.Tc.Types (completeMatchConLikes) import GHC.Core.Coercion -import MonadUtils hiding (foldlM) +import GHC.Utils.Monad hiding (foldlM) import GHC.HsToCore.Monad hiding (foldlM) import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs index 30a5a92f2b..f8619f9a1d 100644 --- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs +++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs @@ -10,7 +10,7 @@ module GHC.HsToCore.PmCheck.Ppr ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic import GHC.Types.Id @@ -19,10 +19,10 @@ import GHC.Types.Unique.DFM import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Builtin.Types -import Outputable +import GHC.Utils.Outputable import Control.Monad.Trans.RWS.CPS -import Util -import Maybes +import GHC.Utils.Misc +import GHC.Data.Maybe import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import GHC.HsToCore.PmCheck.Types diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs index 60ed0ce356..310786b01c 100644 --- a/compiler/GHC/HsToCore/PmCheck/Types.hs +++ b/compiler/GHC/HsToCore/PmCheck/Types.hs @@ -39,11 +39,11 @@ module GHC.HsToCore.PmCheck.Types ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Util -import Bag -import FastString +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Data.FastString import GHC.Types.Var (EvVar) import GHC.Types.Id import GHC.Types.Var.Env @@ -52,9 +52,9 @@ import GHC.Types.Unique.DFM import GHC.Types.Name import GHC.Core.DataCon import GHC.Core.ConLike -import Outputable -import ListSetOps (unionLists) -import Maybes +import GHC.Utils.Outputable +import GHC.Data.List.SetOps (unionLists) +import GHC.Data.Maybe import GHC.Core.Type import GHC.Core.TyCon import GHC.Types.Literal diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs-boot b/compiler/GHC/HsToCore/PmCheck/Types.hs-boot index abbaa33cfa..a7c472faa6 100644 --- a/compiler/GHC/HsToCore/PmCheck/Types.hs-boot +++ b/compiler/GHC/HsToCore/PmCheck/Types.hs-boot @@ -1,6 +1,6 @@ module GHC.HsToCore.PmCheck.Types where -import Bag +import GHC.Data.Bag data Delta diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index b49bd9d66b..54de211b3d 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -26,7 +26,7 @@ module GHC.HsToCore.Quote( dsBracket ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) @@ -53,14 +53,14 @@ import GHC.Core.Utils import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique import GHC.Types.Basic -import Outputable -import Bag +import GHC.Utils.Outputable +import GHC.Data.Bag import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.ForeignCall -import Util -import Maybes -import MonadUtils +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Monad import GHC.Tc.Types.Evidence import Control.Monad.Trans.Reader import Control.Monad.Trans.Class diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index b0588a0a01..c15fc022f0 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -11,7 +11,7 @@ module GHC.HsToCore.Usage ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Ways @@ -20,12 +20,12 @@ import GHC.Tc.Types import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Module -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Unique.Set import GHC.Types.Unique.FM -import Fingerprint -import Maybes +import GHC.Utils.Fingerprint +import GHC.Data.Maybe import GHC.Driver.Packages import GHC.Driver.Finder diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 01f2a5c776..20ba64bbc5 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -46,7 +46,7 @@ module GHC.HsToCore.Utils ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) @@ -76,11 +76,11 @@ import GHC.Types.Unique.Supply import GHC.Types.Module import GHC.Builtin.Names import GHC.Types.Name( isInternalName ) -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc -import Util +import GHC.Utils.Misc import GHC.Driver.Session -import FastString +import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt import GHC.Tc.Types.Evidence diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index 2e1953ade7..3e00e8694d 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -33,7 +33,7 @@ module GHC.Iface.Binary ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.Monad import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName ) @@ -44,18 +44,18 @@ import GHC.Types.Name import GHC.Driver.Session import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import Panic -import Binary +import GHC.Utils.Panic +import GHC.Utils.Binary as Binary import GHC.Types.SrcLoc -import ErrUtils -import FastMutInt +import GHC.Utils.Error +import GHC.Data.FastMutInt import GHC.Types.Unique -import Outputable +import GHC.Utils.Outputable import GHC.Types.Name.Cache import GHC.Platform -import FastString +import GHC.Data.FastString import GHC.Settings.Constants -import Util +import GHC.Utils.Misc import Data.Array import Data.Array.ST diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index 72cff8b8d7..75b93605be 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -22,7 +22,7 @@ module GHC.Iface.Env ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.Monad import GHC.Driver.Types @@ -31,14 +31,14 @@ import GHC.Types.Var import GHC.Types.Name import GHC.Types.Avail import GHC.Types.Module -import FastString -import FastStringEnv +import GHC.Data.FastString +import GHC.Data.FastString.Env import GHC.Iface.Type import GHC.Types.Name.Cache import GHC.Types.Unique.Supply import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import Data.List ( partition ) {- diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 15edfd7bb6..f35cf8f2f0 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -17,12 +17,12 @@ Main functions for .hie file generation module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Avail ( Avails ) -import Bag ( Bag, bagToList ) +import GHC.Data.Bag ( Bag, bagToList ) import GHC.Types.Basic -import BooleanFormula +import GHC.Data.BooleanFormula import GHC.Core.Class ( FunDep ) import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike ( conLikeName ) @@ -31,7 +31,7 @@ import GHC.Types.FieldLabel import GHC.Hs import GHC.Driver.Types import GHC.Types.Module ( ModuleName, ml_hs_file ) -import MonadUtils ( concatMapM, liftIO ) +import GHC.Utils.Monad ( concatMapM, liftIO ) import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.SrcLoc @@ -41,8 +41,8 @@ import GHC.Builtin.Types ( mkListTy, mkSumTy ) import GHC.Types.Var ( Id, Var, setVarName, varName, varType ) import GHC.Tc.Types import GHC.Iface.Make ( mkIfaceExports ) -import Panic -import Maybes +import GHC.Utils.Panic +import GHC.Data.Maybe import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs index a90234c60f..0077c23ee4 100644 --- a/compiler/GHC/Iface/Ext/Binary.hs +++ b/compiler/GHC/Iface/Ext/Binary.hs @@ -18,21 +18,21 @@ where import GHC.Settings.Utils ( maybeRead ) import Config ( cProjectVersion ) -import GhcPrelude -import Binary +import GHC.Prelude +import GHC.Utils.Binary import GHC.Iface.Binary ( getDictFastString ) -import FastMutInt -import FastString ( FastString ) +import GHC.Data.FastMutInt +import GHC.Data.FastString ( FastString ) import GHC.Types.Module ( Module ) import GHC.Types.Name import GHC.Types.Name.Cache -import Outputable +import GHC.Utils.Outputable import GHC.Builtin.Utils import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique.Supply ( takeUniqFromSupply ) import GHC.Types.Unique import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import qualified Data.Array as A import Data.IORef diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs index 292668fe23..bb0c827627 100644 --- a/compiler/GHC/Iface/Ext/Debug.hs +++ b/compiler/GHC/Iface/Ext/Debug.hs @@ -7,12 +7,12 @@ Functions to validate and check .hie file ASTs generated by GHC. module GHC.Iface.Ext.Debug where -import GhcPrelude +import GHC.Prelude import GHC.Types.SrcLoc import GHC.Types.Module -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Iface.Ext.Types import GHC.Iface.Ext.Binary diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs index edd6540e80..88cb9c2042 100644 --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -12,18 +12,18 @@ For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files {-# LANGUAGE OverloadedStrings #-} module GHC.Iface.Ext.Types where -import GhcPrelude +import GHC.Prelude import Config -import Binary -import FastString ( FastString ) +import GHC.Utils.Binary +import GHC.Data.FastString ( FastString ) import GHC.Iface.Type import GHC.Types.Module ( ModuleName, Module ) import GHC.Types.Name ( Name ) -import Outputable hiding ( (<>) ) +import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Types.SrcLoc ( RealSrcSpan ) import GHC.Types.Avail -import qualified Outputable as O ( (<>) ) +import qualified GHC.Utils.Outputable as O ( (<>) ) import qualified Data.Array as A import qualified Data.Map as M diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index bbbe1084f1..3b9bb2b4aa 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -4,14 +4,14 @@ {-# LANGUAGE FlexibleInstances #-} module GHC.Iface.Ext.Utils where -import GhcPrelude +import GHC.Prelude import GHC.Core.Map -import GHC.Driver.Session ( DynFlags ) -import FastString ( FastString, mkFastString ) +import GHC.Driver.Session ( DynFlags ) +import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type import GHC.Types.Name hiding (varName) -import Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext ) +import GHC.Utils.Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext ) import GHC.Types.SrcLoc import GHC.CoreToIface import GHC.Core.TyCon diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 5fca78c67c..0068441ee3 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -34,7 +34,7 @@ module GHC.Iface.Load ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst @@ -48,7 +48,7 @@ import GHC.Driver.Types import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Tc.Utils.Monad -import Binary ( BinData(..) ) +import GHC.Utils.Binary ( BinData(..) ) import GHC.Settings.Constants import GHC.Builtin.Names import GHC.Builtin.Utils @@ -64,17 +64,17 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Types.Module -import Maybes -import ErrUtils +import GHC.Data.Maybe +import GHC.Utils.Error import GHC.Driver.Finder import GHC.Types.Unique.FM import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Iface.Binary -import Panic -import Util -import FastString -import Fingerprint +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Fingerprint import GHC.Driver.Hooks import GHC.Types.FieldLabel import GHC.Iface.Rename diff --git a/compiler/GHC/Iface/Load.hs-boot b/compiler/GHC/Iface/Load.hs-boot index 51270ccb33..7e7d235bb7 100644 --- a/compiler/GHC/Iface/Load.hs-boot +++ b/compiler/GHC/Iface/Load.hs-boot @@ -3,6 +3,6 @@ module GHC.Iface.Load where import GHC.Types.Module (Module) import GHC.Tc.Utils.Monad (IfM) import GHC.Driver.Types (ModIface) -import Outputable (SDoc) +import GHC.Utils.Outputable (SDoc) loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index ef9e77b44d..6ffce05405 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -21,7 +21,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Iface.Syntax import GHC.Iface.Recomp @@ -53,12 +53,12 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Module -import ErrUtils -import Outputable -import GHC.Types.Basic hiding ( SuccessFlag(..) ) -import Util hiding ( eqListBy ) -import FastString -import Maybes +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import GHC.Utils.Misc hiding ( eqListBy ) +import GHC.Data.FastString +import GHC.Data.Maybe import GHC.HsToCore.Docs import Data.Function diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 57809a6d59..430f7b4207 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -12,7 +12,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Iface.Syntax import GHC.Iface.Recomp.Binary @@ -29,16 +29,16 @@ import GHC.Driver.Session import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Module -import ErrUtils -import Digraph +import GHC.Utils.Error +import GHC.Data.Graph.Directed import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.Unique -import Util hiding ( eqListBy ) -import Maybes -import Binary -import Fingerprint -import Exception +import GHC.Utils.Misc hiding ( eqListBy ) +import GHC.Data.Maybe +import GHC.Utils.Binary +import GHC.Utils.Fingerprint +import GHC.Utils.Exception import GHC.Types.Unique.Set import GHC.Driver.Packages @@ -766,7 +766,7 @@ addFingerprints hsc_env iface0 -- used to construct the edges and -- stronglyConnCompFromEdgedVertices is deterministic -- even with non-deterministic order of edges as - -- explained in Note [Deterministic SCC] in Digraph. + -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. where getParent :: OccName -> OccName getParent occ = lookupOccEnv parent_map occ `orElse` occ diff --git a/compiler/GHC/Iface/Recomp/Binary.hs b/compiler/GHC/Iface/Recomp/Binary.hs index 55742b55eb..c07b5d7d16 100644 --- a/compiler/GHC/Iface/Recomp/Binary.hs +++ b/compiler/GHC/Iface/Recomp/Binary.hs @@ -10,13 +10,13 @@ module GHC.Iface.Recomp.Binary #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Fingerprint -import Binary +import GHC.Utils.Fingerprint +import GHC.Utils.Binary import GHC.Types.Name -import PlainPanic -import Util +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc fingerprintBinMem :: BinHandle -> IO Fingerprint fingerprintBinMem bh = withBinBuffer bh f diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs index ff5b23b709..66b6b9f15f 100644 --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -8,18 +8,18 @@ module GHC.Iface.Recomp.Flags ( , fingerprintHpcFlags ) where -import GhcPrelude +import GHC.Prelude -import Binary +import GHC.Utils.Binary import GHC.Driver.Session import GHC.Driver.Types import GHC.Types.Module import GHC.Types.Name -import Fingerprint +import GHC.Utils.Fingerprint import GHC.Iface.Recomp.Binary --- import Outputable +-- import GHC.Utils.Outputable -import qualified EnumSet +import GHC.Data.EnumSet as EnumSet import System.FilePath (normalise) -- | Produce a fingerprint of a @DynFlags@ value. We only base diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 6bceb1effb..dbe847b5f4 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -17,10 +17,10 @@ module GHC.Iface.Rename ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Types import GHC.Types.Module import GHC.Types.Unique.FM @@ -28,12 +28,12 @@ import GHC.Types.Avail import GHC.Iface.Syntax import GHC.Types.FieldLabel import GHC.Types.Var -import ErrUtils +import GHC.Utils.Error import GHC.Types.Name import GHC.Tc.Utils.Monad -import Util -import Fingerprint +import GHC.Utils.Misc +import GHC.Utils.Fingerprint import GHC.Types.Basic -- a bit vexing @@ -42,7 +42,7 @@ import GHC.Driver.Session import qualified Data.Traversable as T -import Bag +import GHC.Data.Bag import Data.IORef import GHC.Types.Name.Shape import GHC.Iface.Env diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 3c707bc348..9db82731d8 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -42,7 +42,7 @@ module GHC.Iface.Syntax ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Iface.Type import GHC.Iface.Recomp.Binary @@ -59,19 +59,19 @@ import GHC.Types.Literal import GHC.Types.ForeignCall import GHC.Types.Annotations( AnnPayload, AnnTarget ) import GHC.Types.Basic -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.Module import GHC.Types.SrcLoc -import Fingerprint -import Binary -import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) +import GHC.Utils.Fingerprint +import GHC.Utils.Binary +import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import GHC.Types.Var( VarBndr(..), binderVar ) import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) -import Util( dropList, filterByList, notNull, unzipWith, debugIsOn ) +import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Utils.Lexeme (isLexSym) import GHC.Builtin.Types ( constraintKindTyConName ) -import Util (seqList) +import GHC.Utils.Misc (seqList) import Control.Monad import System.IO.Unsafe diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 3fc645e278..e3c3c0b01c 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -14,7 +14,7 @@ module GHC.Iface.Tidy ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Types import GHC.Driver.Session @@ -30,7 +30,7 @@ import GHC.Core.Rules import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.Arity ( exprArity, exprBotStrictness_maybe ) -import StaticPtrTable +import GHC.Iface.Tidy.StaticPtrTable import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Var @@ -54,11 +54,11 @@ import GHC.Core.TyCon import GHC.Core.Class import GHC.Types.Module import GHC.Driver.Types -import Maybes +import GHC.Data.Maybe import GHC.Types.Unique.Supply -import Outputable -import Util( filterOut ) -import qualified ErrUtils as Err +import GHC.Utils.Outputable +import GHC.Utils.Misc( filterOut ) +import qualified GHC.Utils.Error as Err import Control.Monad import Data.Function @@ -378,7 +378,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env unfold_env tidy_occ_env trimmed_binds - -- See Note [Grand plan for static forms] in StaticPtrTable. + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. ; (spt_entries, tidy_binds') <- sptCreateStaticBinds hsc_env mod tidy_binds ; let { spt_init_code = sptModuleInitCode mod spt_entries diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs new file mode 100644 index 0000000000..09125a4b53 --- /dev/null +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -0,0 +1,294 @@ +-- | Code generation for the Static Pointer Table +-- +-- (c) 2014 I/O Tweag +-- +-- Each module that uses 'static' keyword declares an initialization function of +-- the form hs_spt_init_<module>() which is emitted into the _stub.c file and +-- annotated with __attribute__((constructor)) so that it gets executed at +-- startup time. +-- +-- The function's purpose is to call hs_spt_insert to insert the static +-- pointers of this module in the hashtable of the RTS, and it looks something +-- like this: +-- +-- > static void hs_hpc_init_Main(void) __attribute__((constructor)); +-- > static void hs_hpc_init_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > extern StgPtr Main_r2wb_closure; +-- > hs_spt_insert(k0, &Main_r2wb_closure); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > extern StgPtr Main_r2wc_closure; +-- > hs_spt_insert(k1, &Main_r2wc_closure); +-- > +-- > } +-- +-- where the constants are fingerprints produced from the static forms. +-- +-- The linker must find the definitions matching the @extern StgPtr <name>@ +-- declarations. For this to work, the identifiers of static pointers need to be +-- exported. This is done in GHC.Core.Opt.SetLevels.newLvlVar. +-- +-- There is also a finalization function for the time when the module is +-- unloaded. +-- +-- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); +-- > static void hs_hpc_fini_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > hs_spt_remove(k0); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > hs_spt_remove(k1); +-- > +-- > } +-- + +{-# LANGUAGE ViewPatterns, TupleSections #-} +module GHC.Iface.Tidy.StaticPtrTable + ( sptCreateStaticBinds + , sptModuleInitCode + ) where + +{- Note [Grand plan for static forms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Static forms go through the compilation phases as follows. +Here is a running example: + + f x = let k = map toUpper + in ...(static k)... + +* The renamer looks for out-of-scope names in the body of the static + form, as always. If all names are in scope, the free variables of the + body are stored in AST at the location of the static form. + +* The typechecker verifies that all free variables occurring in the + static form are floatable to top level (see Note [Meaning of + IdBindingInfo] in GHC.Tc.Types). In our example, 'k' is floatable. + Even though it is bound in a nested let, we are fine. + +* The desugarer replaces the static form with an application of the + function 'makeStatic' (defined in module GHC.StaticPtr.Internal of + base). So we get + + f x = let k = map toUpper + in ...fromStaticPtr (makeStatic location k)... + +* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic' + to the top level. Thus the FloatOut pass is always executed, even when + optimizations are disabled. So we get + + k = map toUpper + static_ptr = makeStatic location k + f x = ...fromStaticPtr static_ptr... + + The FloatOut pass is careful to produce an /exported/ Id for a floated + 'makeStatic' call, so the binding is not removed or inlined by the + simplifier. + E.g. the code for `f` above might look like + + static_ptr = makeStatic location k + f x = ...(case static_ptr of ...)... + + which might be simplified to + + f x = ...(case makeStatic location k of ...)... + + BUT the top-level binding for static_ptr must remain, so that it can be + collected to populate the Static Pointer Table. + + Making the binding exported also has a necessary effect during the + CoreTidy pass. + +* The CoreTidy pass replaces all bindings of the form + + b = /\ ... -> makeStatic location value + + with + + b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value + + where a distinct key is generated for each binding. + +* If we are compiling to object code we insert a C stub (generated by + sptModuleInitCode) into the final object which runs when the module is loaded, + inserting the static forms defined by the module into the RTS's static pointer + table. + +* If we are compiling for the byte-code interpreter, we instead explicitly add + the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter + process' SPT table using the addSptEntry interpreter message. This happens + in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep'). +-} + +import GHC.Prelude + +import GHC.Cmm.CLabel +import GHC.Core +import GHC.Core.Utils (collectMakeStaticArgs) +import GHC.Core.DataCon +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Types.Id +import GHC.Core.Make (mkStringExprFSWith) +import GHC.Types.Module +import GHC.Types.Name +import GHC.Utils.Outputable as Outputable +import GHC.Platform +import GHC.Builtin.Names +import GHC.Tc.Utils.Env (lookupGlobal) +import GHC.Core.Type + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State +import Data.List +import Data.Maybe +import GHC.Fingerprint +import qualified GHC.LanguageExtensions as LangExt + +-- | Replaces all bindings of the form +-- +-- > b = /\ ... -> makeStatic location value +-- +-- with +-- +-- > b = /\ ... -> +-- > StaticPtr key (StaticPtrInfo "pkg key" "module" location) value +-- +-- where a distinct key is generated for each binding. +-- +-- It also yields the C stub that inserts these bindings into the static +-- pointer table. +sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram + -> IO ([SptEntry], CoreProgram) +sptCreateStaticBinds hsc_env this_mod binds + | not (xopt LangExt.StaticPointers dflags) = + return ([], binds) + | otherwise = do + -- Make sure the required interface files are loaded. + _ <- lookupGlobal hsc_env unpackCStringName + (fps, binds') <- evalStateT (go [] [] binds) 0 + return (fps, binds') + where + go fps bs xs = case xs of + [] -> return (reverse fps, reverse bs) + bnd : xs' -> do + (fps', bnd') <- replaceStaticBind bnd + go (reverse fps' ++ fps) (bnd' : bs) xs' + + dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + + -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. + -- + -- The 'Int' state is used to produce a different key for each binding. + replaceStaticBind :: CoreBind + -> StateT Int IO ([SptEntry], CoreBind) + replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e + return (maybeToList mfp, NonRec b' e') + replaceStaticBind (Rec rbs) = do + (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs + return (catMaybes mfps, Rec rbs') + + replaceStatic :: Id -> CoreExpr + -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) + replaceStatic b e@(collectTyBinders -> (tvs, e0)) = + case collectMakeStaticArgs e0 of + Nothing -> return (Nothing, (b, e)) + Just (_, t, info, arg) -> do + (fp, e') <- mkStaticBind t info arg + return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) + + mkStaticBind :: Type -> CoreExpr -> CoreExpr + -> StateT Int IO (Fingerprint, CoreExpr) + mkStaticBind t srcLoc e = do + i <- get + put (i + 1) + staticPtrInfoDataCon <- + lift $ lookupDataConHscEnv staticPtrInfoDataConName + let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i + info <- mkConApp staticPtrInfoDataCon <$> + (++[srcLoc]) <$> + mapM (mkStringExprFSWith (lift . lookupIdHscEnv)) + [ unitIdFS $ moduleUnitId this_mod + , moduleNameFS $ moduleName this_mod + ] + + -- The module interface of GHC.StaticPtr should be loaded at least + -- when looking up 'fromStatic' during type-checking. + staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName + return (fp, mkConApp staticPtrDataCon + [ Type t + , mkWord64LitWordRep platform w0 + , mkWord64LitWordRep platform w1 + , info + , e ]) + + mkStaticPtrFingerprint :: Int -> Fingerprint + mkStaticPtrFingerprint n = fingerprintString $ intercalate ":" + [ unitIdString $ moduleUnitId this_mod + , moduleNameString $ moduleName this_mod + , show n + ] + + -- Choose either 'Word64#' or 'Word#' to represent the arguments of the + -- 'Fingerprint' data constructor. + mkWord64LitWordRep platform = + case platformWordSize platform of + PW4 -> mkWord64LitWord64 + PW8 -> mkWordLit platform . toInteger + + lookupIdHscEnv :: Name -> IO Id + lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>= + maybe (getError n) (return . tyThingId) + + lookupDataConHscEnv :: Name -> IO DataCon + lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>= + maybe (getError n) (return . tyThingDataCon) + + getError n = pprPanic "sptCreateStaticBinds.get: not found" $ + text "Couldn't find" <+> ppr n + +-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries +-- of @module@ into the static pointer table. +-- +-- @fps@ is a list associating each binding corresponding to a static entry with +-- its fingerprint. +sptModuleInitCode :: Module -> [SptEntry] -> SDoc +sptModuleInitCode _ [] = Outputable.empty +sptModuleInitCode this_mod entries = vcat + [ text "static void hs_spt_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "static StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "extern StgPtr " + <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi + $$ text "hs_spt_insert" <> parens + (hcat $ punctuate comma + [ char 'k' <> int i + , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n)) + ] + ) + <> semi + | (i, SptEntry n fp) <- zip [0..] entries + ] + , text "static void hs_spt_fini_" <> ppr this_mod + <> text "(void) __attribute__((destructor));" + , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi + | (i, (SptEntry _ fp)) <- zip [0..] entries + ] + ] + where + pprFingerprint :: Fingerprint -> SDoc + pprFingerprint (Fingerprint w1 w2) = + braces $ hcat $ punctuate comma + [ integer (fromIntegral w1) <> text "ULL" + , integer (fromIntegral w2) <> text "ULL" + ] diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 6aedf0fd4c..5c2172f96f 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -60,7 +60,7 @@ module GHC.Iface.Type ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( coercibleTyCon, heqTyCon @@ -73,11 +73,11 @@ import GHC.Types.Var import GHC.Builtin.Names import GHC.Types.Name import GHC.Types.Basic -import Binary -import Outputable -import FastString -import FastStringEnv -import Util +import GHC.Utils.Binary +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Utils.Misc import Data.Maybe( isJust ) import qualified Data.Semigroup as Semi diff --git a/compiler/GHC/Iface/UpdateCafInfos.hs b/compiler/GHC/Iface/UpdateCafInfos.hs new file mode 100644 index 0000000000..befb95c6ef --- /dev/null +++ b/compiler/GHC/Iface/UpdateCafInfos.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-} + +module GHC.Iface.UpdateCafInfos + ( updateModDetailsCafInfos + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Core.InstEnv +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Utils.Misc +import GHC.Types.Var +import GHC.Utils.Outputable + +#include "HsVersions.h" + +-- | Update CafInfos of all occurences (in rules, unfoldings, class instances) +updateModDetailsCafInfos + :: DynFlags + -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY. + -> ModDetails -- ^ ModDetails to update + -> ModDetails + +updateModDetailsCafInfos dflags _ mod_details + | gopt Opt_OmitInterfacePragmas dflags + = mod_details + +updateModDetailsCafInfos _ non_cafs mod_details = + {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -} + let + ModDetails{ md_types = type_env -- for unfoldings + , md_insts = insts + , md_rules = rules + } = mod_details + + -- type TypeEnv = NameEnv TyThing + ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env + -- Not strict! + + !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts + !rules' = strictMap (updateRuleCafInfos type_env') rules + in + mod_details{ md_types = type_env' + , md_insts = insts' + , md_rules = rules' + } + +-------------------------------------------------------------------------------- +-- Rules +-------------------------------------------------------------------------------- + +updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule +updateRuleCafInfos _ rule@BuiltinRule{} = rule +updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. } + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst +updateInstCafInfos type_env non_cafs = + updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs) + +-------------------------------------------------------------------------------- +-- TyThings +-------------------------------------------------------------------------------- + +updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing + +updateTyThingCafInfos type_env non_cafs (AnId id) = + AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id)) + +updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom + +-------------------------------------------------------------------------------- +-- Unfoldings +-------------------------------------------------------------------------------- + +updateIdUnfolding :: TypeEnv -> Id -> Id +updateIdUnfolding type_env id = + case idUnfolding id of + CoreUnfolding{ .. } -> + setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. } + DFunUnfolding{ .. } -> + setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. } + _ -> id + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- + +updateIdCafInfo :: NameSet -> Id -> Id +updateIdCafInfo non_cafs id + | idName id `elemNameSet` non_cafs + = -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $ + id `setIdCafInfo` NoCafRefs + | otherwise + = id + +-------------------------------------------------------------------------------- + +updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr +-- Update occurrences of GlobalIds as directed by 'env' +-- The 'env' maps a GlobalId to a version with accurate CAF info +-- (and in due course perhaps other back-end-related info) +updateGlobalIds env e = go env e + where + go_id :: NameEnv TyThing -> Id -> Id + go_id env var = + case lookupNameEnv env (varName var) of + Nothing -> var + Just (AnId id) -> id + Just other -> pprPanic "GHC.Iface.UpdateCafInfos.updateGlobalIds" $ + text "Found a non-Id for Id Name" <+> ppr (varName var) $$ + nest 4 (text "Id:" <+> ppr var $$ + text "TyThing:" <+> ppr other) + + go :: NameEnv TyThing -> CoreExpr -> CoreExpr + go env (Var v) = Var (go_id env v) + go _ e@Lit{} = e + go env (App e1 e2) = App (go env e1) (go env e2) + go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e)) + go env (Let bs e) = Let (go_binds env bs) (go env e) + go env (Case e b ty alts) = + assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts)) + where + go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e) + go env (Cast e c) = Cast (go env e) c + go env (Tick t e) = Tick t (go env e) + go _ e@Type{} = e + go _ e@Coercion{} = e + + go_binds :: NameEnv TyThing -> CoreBind -> CoreBind + go_binds env (NonRec b e) = + assertNotInNameEnv env [b] (NonRec b (go env e)) + go_binds env (Rec prs) = + assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs)) + +-- In `updateGlobaLIds` Names of local binders should not shadow Name of +-- globals. This assertion is to check that. +assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b +assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 5f3cd10cfb..d895b9228e 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -24,7 +24,7 @@ module GHC.IfaceToCore ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) import GHC.Iface.Syntax @@ -66,16 +66,16 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Types.Module import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import Outputable -import Maybes +import GHC.Utils.Outputable +import GHC.Data.Maybe import GHC.Types.SrcLoc import GHC.Driver.Session -import Util -import FastString +import GHC.Utils.Misc +import GHC.Data.FastString import GHC.Types.Basic hiding ( SuccessFlag(..) ) -import ListSetOps +import GHC.Data.List.SetOps import GHC.Fingerprint -import qualified BooleanFormula as BF +import qualified GHC.Data.BooleanFormula as BF import Control.Monad import qualified Data.Map as Map diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot index e658493d8f..91b538ef41 100644 --- a/compiler/GHC/IfaceToCore.hs-boot +++ b/compiler/GHC/IfaceToCore.hs-boot @@ -1,6 +1,6 @@ module GHC.IfaceToCore where -import GhcPrelude +import GHC.Prelude import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule , IfaceAnnotation, IfaceCompleteMatch ) import GHC.Core.TyCo.Rep ( TyThing ) diff --git a/compiler/GHC/Llvm/MetaData.hs b/compiler/GHC/Llvm/MetaData.hs index 3e319c7036..c2a1aa4a8f 100644 --- a/compiler/GHC/Llvm/MetaData.hs +++ b/compiler/GHC/Llvm/MetaData.hs @@ -2,10 +2,10 @@ module GHC.Llvm.MetaData where -import GhcPrelude +import GHC.Prelude import GHC.Llvm.Types -import Outputable +import GHC.Utils.Outputable -- The LLVM Metadata System. -- diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs index 4645c89e1a..c16f6b4136 100644 --- a/compiler/GHC/Llvm/Ppr.hs +++ b/compiler/GHC/Llvm/Ppr.hs @@ -25,7 +25,7 @@ module GHC.Llvm.Ppr ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Llvm.Syntax import GHC.Llvm.MetaData @@ -33,9 +33,9 @@ import GHC.Llvm.Types import GHC.Platform import Data.List ( intersperse ) -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique -import FastString ( sLit ) +import GHC.Data.FastString ( sLit ) -------------------------------------------------------------------------------- -- * Top Level Print functions diff --git a/compiler/GHC/Llvm/Syntax.hs b/compiler/GHC/Llvm/Syntax.hs index 51324b396d..12e0073c7a 100644 --- a/compiler/GHC/Llvm/Syntax.hs +++ b/compiler/GHC/Llvm/Syntax.hs @@ -4,7 +4,7 @@ module GHC.Llvm.Syntax where -import GhcPrelude +import GHC.Prelude import GHC.Llvm.MetaData import GHC.Llvm.Types diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs index 0452e6177c..5a59c5c8fb 100644 --- a/compiler/GHC/Llvm/Types.hs +++ b/compiler/GHC/Llvm/Types.hs @@ -9,7 +9,7 @@ module GHC.Llvm.Types where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import Data.Char import Data.Int @@ -17,8 +17,8 @@ import Numeric import GHC.Platform import GHC.Driver.Session -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Types.Unique -- from NCG diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 90b23f7ca6..81b0607a49 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -54,16 +54,16 @@ import GHC.Driver.Phases ( HscSource(..) ) import GHC.Driver.Types ( IsBootInterface, WarningTxt(..) ) import GHC.Driver.Session import GHC.Driver.Backpack.Syntax -import UnitInfo +import GHC.Unit.Info -- compiler/utils -import OrdList -import BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) -import FastString -import Maybes ( isJust, orElse ) -import Outputable -import Util ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) -import GhcPrelude +import GHC.Data.OrdList +import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) +import GHC.Data.FastString +import GHC.Data.Maybe ( isJust, orElse ) +import GHC.Utils.Outputable +import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) +import GHC.Prelude -- compiler/basicTypes import GHC.Types.Name.Reader diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index dbd1f79e23..e05ac34b75 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -13,10 +13,10 @@ module GHC.Parser.Annotation ( LRdrName -- Exists for haddocks only ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Name.Reader -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc import qualified Data.Map as Map import Data.Data diff --git a/compiler/GHC/Parser/CharClass.hs b/compiler/GHC/Parser/CharClass.hs index dc98d48f94..6d09de764c 100644 --- a/compiler/GHC/Parser/CharClass.hs +++ b/compiler/GHC/Parser/CharClass.hs @@ -16,12 +16,12 @@ module GHC.Parser.CharClass #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import Data.Bits ( Bits((.&.),(.|.)) ) import Data.Char ( ord, chr ) import Data.Word -import Panic +import GHC.Utils.Panic -- Bit masks diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index e2373827f4..12fd44dc4b 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -24,26 +24,26 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Driver.Types import GHC.Parser ( parseHeader ) import GHC.Parser.Lexer -import FastString +import GHC.Data.FastString import GHC.Hs import GHC.Types.Module import GHC.Builtin.Names -import StringBuffer +import GHC.Data.StringBuffer import GHC.Types.SrcLoc import GHC.Driver.Session -import ErrUtils -import Util -import Outputable -import Maybes -import Bag ( emptyBag, listToBag, unitBag ) -import MonadUtils -import Exception +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe +import GHC.Data.Bag ( emptyBag, listToBag, unitBag ) +import GHC.Utils.Monad +import GHC.Utils.Exception as Exception import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt @@ -345,7 +345,7 @@ optionsErrorMsgs dflags unhandled_flags flags_lines _filename , L l f' <- flags_lines , f == f' ] mkMsg (L flagSpan flag) = - ErrUtils.mkPlainErrMsg dflags flagSpan $ + GHC.Utils.Error.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053 diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 17b6674c95..3a93214cb4 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -69,7 +69,7 @@ module GHC.Parser.Lexer ( commentToAnnotation ) where -import GhcPrelude +import GHC.Prelude -- base import Control.Monad @@ -79,8 +79,7 @@ import Data.List import Data.Maybe import Data.Word -import EnumSet (EnumSet) -import qualified EnumSet +import GHC.Data.EnumSet as EnumSet -- ghc-boot import qualified GHC.LanguageExtensions as LangExt @@ -93,15 +92,15 @@ import Data.Map (Map) import qualified Data.Map as Map -- compiler/utils -import Bag -import Outputable -import StringBuffer -import FastString +import GHC.Data.Bag +import GHC.Utils.Outputable +import GHC.Data.StringBuffer +import GHC.Data.FastString import GHC.Types.Unique.FM -import Util ( readRational, readHexRational ) +import GHC.Utils.Misc ( readRational, readHexRational ) -- compiler/main -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Session as DynFlags -- compiler/basicTypes diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index b135478584..5a1817a1f6 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -103,7 +103,7 @@ module GHC.Parser.PostProcess ( PatBuilder ) where -import GhcPrelude +import GHC.Prelude import GHC.Hs -- Lots of it import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) import GHC.Core.DataCon ( DataCon, dataConTyCon ) @@ -123,16 +123,16 @@ import GHC.Types.ForeignCall import GHC.Builtin.Names ( allNameStrings ) import GHC.Types.SrcLoc import GHC.Types.Unique ( hasKey ) -import OrdList ( OrdList, fromOL ) -import Bag ( emptyBag, consBag ) -import Outputable -import FastString -import Maybes -import Util +import GHC.Data.OrdList ( OrdList, fromOL ) +import GHC.Data.Bag ( emptyBag, consBag ) +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Utils.Misc import GHC.Parser.Annotation import Data.List import GHC.Driver.Session ( WarningFlag(..), DynFlags ) -import ErrUtils ( Messages ) +import GHC.Utils.Error ( Messages ) import Control.Monad import Text.ParserCombinators.ReadP as ReadP diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index a3d5e101d7..f232113c2e 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -2,7 +2,7 @@ module GHC.Parser.PostProcess.Haddock where -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Types.SrcLoc diff --git a/compiler/GHC/Platform/ARM.hs b/compiler/GHC/Platform/ARM.hs index d0c7e5811a..d1e2d9d312 100644 --- a/compiler/GHC/Platform/ARM.hs +++ b/compiler/GHC/Platform/ARM.hs @@ -2,7 +2,7 @@ module GHC.Platform.ARM where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_arm 1 diff --git a/compiler/GHC/Platform/ARM64.hs b/compiler/GHC/Platform/ARM64.hs index ebd66b92c5..5bc1ec91e2 100644 --- a/compiler/GHC/Platform/ARM64.hs +++ b/compiler/GHC/Platform/ARM64.hs @@ -2,7 +2,7 @@ module GHC.Platform.ARM64 where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_aarch64 1 diff --git a/compiler/GHC/Platform/NoRegs.hs b/compiler/GHC/Platform/NoRegs.hs index e8abf44253..c00f4cb7ff 100644 --- a/compiler/GHC/Platform/NoRegs.hs +++ b/compiler/GHC/Platform/NoRegs.hs @@ -2,7 +2,7 @@ module GHC.Platform.NoRegs where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 1 #include "../../../includes/CodeGen.Platform.hs" diff --git a/compiler/GHC/Platform/PPC.hs b/compiler/GHC/Platform/PPC.hs index f405f95438..5b4f3bfb14 100644 --- a/compiler/GHC/Platform/PPC.hs +++ b/compiler/GHC/Platform/PPC.hs @@ -2,7 +2,7 @@ module GHC.Platform.PPC where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_powerpc 1 diff --git a/compiler/GHC/Platform/Reg.hs b/compiler/GHC/Platform/Reg.hs index 00cd254630..37fd039ef7 100644 --- a/compiler/GHC/Platform/Reg.hs +++ b/compiler/GHC/Platform/Reg.hs @@ -26,9 +26,9 @@ module GHC.Platform.Reg ( where -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Platform.Reg.Class import Data.List (intersect) diff --git a/compiler/GHC/Platform/Reg/Class.hs b/compiler/GHC/Platform/Reg/Class.hs index 8aa81c2fe9..3b967c5c55 100644 --- a/compiler/GHC/Platform/Reg/Class.hs +++ b/compiler/GHC/Platform/Reg/Class.hs @@ -4,9 +4,9 @@ module GHC.Platform.Reg.Class where -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.Unique diff --git a/compiler/GHC/Platform/Regs.hs b/compiler/GHC/Platform/Regs.hs index d214b0d89f..1b72d07979 100644 --- a/compiler/GHC/Platform/Regs.hs +++ b/compiler/GHC/Platform/Regs.hs @@ -3,7 +3,7 @@ module GHC.Platform.Regs (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg) where -import GhcPrelude +import GHC.Prelude import GHC.Cmm.Expr import GHC.Platform diff --git a/compiler/GHC/Platform/S390X.hs b/compiler/GHC/Platform/S390X.hs index 8599bb67c0..709d2db101 100644 --- a/compiler/GHC/Platform/S390X.hs +++ b/compiler/GHC/Platform/S390X.hs @@ -2,7 +2,7 @@ module GHC.Platform.S390X where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_s390x 1 diff --git a/compiler/GHC/Platform/SPARC.hs b/compiler/GHC/Platform/SPARC.hs index b0cdb27f44..b1dad08837 100644 --- a/compiler/GHC/Platform/SPARC.hs +++ b/compiler/GHC/Platform/SPARC.hs @@ -2,7 +2,7 @@ module GHC.Platform.SPARC where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_sparc 1 diff --git a/compiler/GHC/Platform/X86.hs b/compiler/GHC/Platform/X86.hs index 1570ba9fa0..e065036f61 100644 --- a/compiler/GHC/Platform/X86.hs +++ b/compiler/GHC/Platform/X86.hs @@ -2,7 +2,7 @@ module GHC.Platform.X86 where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_i386 1 diff --git a/compiler/GHC/Platform/X86_64.hs b/compiler/GHC/Platform/X86_64.hs index d2d1b15c71..27c4232975 100644 --- a/compiler/GHC/Platform/X86_64.hs +++ b/compiler/GHC/Platform/X86_64.hs @@ -2,7 +2,7 @@ module GHC.Platform.X86_64 where -import GhcPrelude +import GHC.Prelude #define MACHREGS_NO_REGS 0 #define MACHREGS_x86_64 1 diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs index 8ba1c5fb2d..c51ac4c053 100644 --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -41,13 +41,13 @@ module GHC.Plugins , module GHC.Types.Unique , module GHC.Types.Unique.Set , module GHC.Types.Unique.FM - , module FiniteMap - , module Util + , module GHC.Data.FiniteMap + , module GHC.Utils.Misc , module GHC.Serialized , module GHC.Types.SrcLoc - , module Outputable + , module GHC.Utils.Outputable , module GHC.Types.Unique.Supply - , module FastString + , module GHC.Data.FastString , -- * Getting 'Name's thNameToGhcName ) @@ -103,21 +103,21 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.FM -- Conflicts with UniqFM: --import LazyUniqFM -import FiniteMap +import GHC.Data.FiniteMap -- Common utilities -import Util +import GHC.Utils.Misc import GHC.Serialized import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique.Supply import GHC.Types.Unique ( Unique, Uniquable(..) ) -import FastString +import GHC.Data.FastString import Data.Maybe import GHC.Iface.Env ( lookupOrigIO ) -import GhcPrelude -import MonadUtils ( mapMaybeM ) +import GHC.Prelude +import GHC.Utils.Monad ( mapMaybeM ) import GHC.ThToHs ( thRdrNameGuesses ) import GHC.Tc.Utils.Env ( lookupGlobal ) diff --git a/compiler/GHC/Prelude.hs b/compiler/GHC/Prelude.hs new file mode 100644 index 0000000000..95c2d4b190 --- /dev/null +++ b/compiler/GHC/Prelude.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +-- | Custom GHC "Prelude" +-- +-- This module serves as a replacement for the "Prelude" module +-- and abstracts over differences between the bootstrapping +-- GHC version, and may also provide a common default vocabulary. + +-- Every module in GHC +-- * Is compiled with -XNoImplicitPrelude +-- * Explicitly imports GHC.Prelude + +module GHC.Prelude (module X) where + +-- We export the 'Semigroup' class but w/o the (<>) operator to avoid +-- clashing with the (Outputable.<>) operator which is heavily used +-- through GHC's code-base. + +import Prelude as X hiding ((<>)) +import Data.Foldable as X (foldl') + +{- +Note [Why do we import Prelude here?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and +ghc-heap.cabal contain the directive default-extensions: +NoImplicitPrelude. There are two motivations for this: + - Consistency with the compiler directory, which enables + NoImplicitPrelude; + - Allows loading the above dependent packages with ghc-in-ghci, + giving a smoother development experience when adding new + extensions. +-} diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index b8dbfd1e1c..5f624a3000 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -29,7 +29,7 @@ module GHC.Rename.Bind ( HsSigCtxt(..) ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr, rnStmts ) @@ -51,15 +51,15 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Reader ( RdrName, rdrNameOcc ) import GHC.Types.SrcLoc as SrcLoc -import ListSetOps ( findDupsEq ) -import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) ) -import Digraph ( SCC(..) ) -import Bag -import Util -import Outputable +import GHC.Data.List.SetOps ( findDupsEq ) +import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) ) +import GHC.Data.Graph.Directed ( SCC(..) ) +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Utils.Outputable import GHC.Types.Unique.Set -import Maybes ( orElse ) -import OrdList +import GHC.Data.Maybe ( orElse ) +import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs index bd9fd60b73..f053795073 100644 --- a/compiler/GHC/Rename/Doc.hs +++ b/compiler/GHC/Rename/Doc.hs @@ -2,7 +2,7 @@ module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where -import GhcPrelude +import GHC.Prelude import GHC.Tc.Types import GHC.Hs diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 18d922d636..1c22cf781e 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -44,7 +44,7 @@ module GHC.Rename.Env ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) import GHC.Iface.Env @@ -63,18 +63,18 @@ import GHC.Types.Module import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon -import ErrUtils ( MsgDoc ) +import GHC.Utils.Error ( MsgDoc ) import GHC.Builtin.Names( rOOT_MAIN ) import GHC.Types.Basic ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) ) import GHC.Types.SrcLoc as SrcLoc -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.Unique.Set ( uniqSetAny ) -import Util -import Maybes +import GHC.Utils.Misc +import GHC.Data.Maybe import GHC.Driver.Session -import FastString +import GHC.Data.FastString import Control.Monad -import ListSetOps ( minusList ) +import GHC.Data.List.SetOps ( minusList ) import qualified GHC.LanguageExtensions as LangExt import GHC.Rename.Unbound import GHC.Rename.Utils diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 9c52087448..62afe116df 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -26,7 +26,7 @@ module GHC.Rename.Expr ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS , rnMatchGroup, rnGRHS, makeMiniFixityEnv) @@ -54,12 +54,12 @@ import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Unique.Set import Data.List -import Util -import ListSetOps ( removeDups ) -import ErrUtils -import Outputable +import GHC.Utils.Misc +import GHC.Data.List.SetOps ( removeDups ) +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc -import FastString +import GHC.Data.FastString import Control.Monad import GHC.Builtin.Types ( nilDataConName ) import qualified GHC.LanguageExtensions as LangExt @@ -353,7 +353,7 @@ rnExpr (ArithSeq x _ seq) For the static form we check that it is not used in splices. We also collect the free variables of the term which come from -this module. See Note [Grand plan for static forms] in StaticPtrTable. +this module. See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. -} rnExpr e@(HsStatic _ expr) = do diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot index 012b7731b3..cc52d45e82 100644 --- a/compiler/GHC/Rename/Expr.hs-boot +++ b/compiler/GHC/Rename/Expr.hs-boot @@ -4,7 +4,7 @@ import GHC.Hs import GHC.Types.Name.Set ( FreeVars ) import GHC.Tc.Types import GHC.Types.SrcLoc ( Located ) -import Outputable ( Outputable ) +import GHC.Utils.Outputable ( Outputable ) rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs index b86be35160..5920a1ee9a 100644 --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -16,7 +16,7 @@ module GHC.Rename.Fixity ) where -import GhcPrelude +import GHC.Prelude import GHC.Iface.Load import GHC.Hs @@ -29,8 +29,8 @@ import GHC.Types.Module import GHC.Types.Basic ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity, SourceText(..) ) import GHC.Types.SrcLoc -import Outputable -import Maybes +import GHC.Utils.Outputable +import GHC.Data.Maybe import Data.List import Data.Function ( on ) import GHC.Rename.Unbound diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 822f6f9cb9..99b928af3f 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -32,7 +32,7 @@ module GHC.Rename.HsType ( nubL, elemRdr ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) @@ -54,14 +54,14 @@ import GHC.Types.SrcLoc import GHC.Types.Name.Set import GHC.Types.FieldLabel -import Util -import ListSetOps ( deleteBys ) +import GHC.Utils.Misc +import GHC.Data.List.SetOps ( deleteBys ) import GHC.Types.Basic ( compareFixity, funTyFixity, negateFixity , Fixity(..), FixityDirection(..), LexicalFixity(..) , TypeOrKind(..) ) -import Outputable -import FastString -import Maybes +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt import Data.List ( nubBy, partition, (\\) ) diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index bc2c7d3d5d..88ad0fee94 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -19,7 +19,7 @@ module GHC.Rename.Module ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) @@ -53,19 +53,19 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Avail -import Outputable -import Bag +import GHC.Utils.Outputable +import GHC.Data.Bag import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) ) -import FastString +import GHC.Data.FastString import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session -import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith ) +import GHC.Utils.Misc ( debugIsOn, filterOut, lengthExceeds, partitionWith ) import GHC.Driver.Types ( HscEnv, hsc_dflags ) -import ListSetOps ( findDupsEq, removeDups, equivClasses ) -import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..) - , stronglyConnCompFromEdgedVerticesUniq ) +import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) +import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) + , stronglyConnCompFromEdgedVerticesUniq ) import GHC.Types.Unique.Set -import OrdList +import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -1397,7 +1397,7 @@ depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs -- It's OK to use nonDetEltsUFM here as -- stronglyConnCompFromEdgedVertices is still deterministic -- even if the edges are in nondeterministic order as explained - -- in Note [Deterministic SCC] in Digraph. + -- in Note [Deterministic SCC] in GHC.Data.Graph.Directed. toParents :: GlobalRdrEnv -> NameSet -> NameSet toParents rdr_env ns diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index ed08087899..c0832b5e35 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -32,7 +32,7 @@ module GHC.Rename.Names ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Core.TyCo.Ppr @@ -53,13 +53,13 @@ import GHC.Types.FieldLabel import GHC.Driver.Types import GHC.Types.Name.Reader import GHC.Parser.PostProcess ( setRdrNameSpace ) -import Outputable -import Maybes +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Basic ( TopLevelFlag(..), StringLiteral(..) ) -import Util -import FastString -import FastStringEnv +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Data.FastString.Env import GHC.Types.Id import GHC.Core.Type import GHC.Core.PatSyn diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 8e6747550e..1e2bf09f45 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -44,7 +44,7 @@ module GHC.Rename.Pat (-- main entry points -- ENH: thin imports to only what is necessary for patterns -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) @@ -67,9 +67,9 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Basic -import Util -import ListSetOps ( removeDups ) -import Outputable +import GHC.Utils.Misc +import GHC.Data.List.SetOps( removeDups ) +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Types.Literal ( inCharRange ) import GHC.Builtin.Types ( nilDataCon ) diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index c8aa73554f..1842cd0c44 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -14,7 +14,7 @@ module GHC.Rename.Splice ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Name import GHC.Types.Name.Set @@ -28,7 +28,7 @@ import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) import GHC.Types.Basic ( TopLevelFlag, isTopLevel, SourceText(..) ) -import Outputable +import GHC.Utils.Outputable import GHC.Types.Module import GHC.Types.SrcLoc import GHC.Rename.HsType ( rnLHsType ) @@ -41,8 +41,8 @@ import GHC.Tc.Utils.Env ( checkWellStaged ) import GHC.Builtin.Names.TH ( liftName ) import GHC.Driver.Session -import FastString -import ErrUtils ( dumpIfSet_dyn_printer, DumpFormat (..) ) +import GHC.Data.FastString +import GHC.Utils.Error ( dumpIfSet_dyn_printer, DumpFormat (..) ) import GHC.Tc.Utils.Env ( tcMetaTy ) import GHC.Driver.Hooks import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName diff --git a/compiler/GHC/Rename/Splice.hs-boot b/compiler/GHC/Rename/Splice.hs-boot index a885ea4387..06b8dc6c92 100644 --- a/compiler/GHC/Rename/Splice.hs-boot +++ b/compiler/GHC/Rename/Splice.hs-boot @@ -1,6 +1,6 @@ module GHC.Rename.Splice where -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Tc.Utils.Monad import GHC.Types.Name.Set diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index aa4e05941f..c0cc6eeb64 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -17,7 +17,7 @@ module GHC.Rename.Unbound ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Name.Reader import GHC.Driver.Types @@ -25,12 +25,12 @@ import GHC.Tc.Utils.Monad import GHC.Types.Name import GHC.Types.Module import GHC.Types.SrcLoc as SrcLoc -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique) -import Util -import Maybes +import GHC.Utils.Misc +import GHC.Data.Maybe import GHC.Driver.Session -import FastString +import GHC.Data.FastString import Data.List import Data.Function ( on ) import GHC.Types.Unique.DFM (udfmToList) diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 3c4f5d065f..19a7c57cfb 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -33,7 +33,7 @@ module GHC.Rename.Utils ( where -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Types.Name.Reader @@ -45,12 +45,12 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Core.DataCon import GHC.Types.SrcLoc as SrcLoc -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Basic ( TopLevelFlag(..) ) -import ListSetOps ( removeDups ) +import GHC.Data.List.SetOps ( removeDups ) import GHC.Driver.Session -import FastString +import GHC.Data.FastString import Control.Monad import Data.List import GHC.Settings.Constants ( mAX_TUPLE_SIZE ) diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 50622d8fa9..511293ba5c 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -14,7 +14,7 @@ module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where -import GhcPrelude +import GHC.Prelude import GHC.Runtime.Linker import GHC.Runtime.Heap.Inspect @@ -32,12 +32,12 @@ import GHC.Types.Var.Set import GHC.Types.Unique.Set import GHC.Core.Type import GHC -import Outputable +import GHC.Utils.Outputable import GHC.Core.Ppr.TyThing -import ErrUtils -import MonadUtils +import GHC.Utils.Error +import GHC.Utils.Monad import GHC.Driver.Session -import Exception +import GHC.Utils.Exception import Control.Monad import Data.List ( (\\) ) diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 8e6d5e3ed5..cf3329fb8b 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -46,7 +46,7 @@ module GHC.Runtime.Eval ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Runtime.Eval.Types @@ -82,19 +82,19 @@ import GHC.Driver.Session import GHC.LanguageExtensions import GHC.Types.Unique import GHC.Types.Unique.Supply -import MonadUtils +import GHC.Utils.Monad import GHC.Types.Module import GHC.Builtin.Names ( toDynName, pretendNameIsInScope ) import GHC.Builtin.Types ( isCTupleTyConName ) -import Panic -import Maybes -import ErrUtils +import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Utils.Error import GHC.Types.SrcLoc import GHC.Runtime.Heap.Inspect -import Outputable -import FastString -import Bag -import Util +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Utils.Misc import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, mkPStatePure) import GHC.Parser.Lexer (ParserFlags) import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport) @@ -106,10 +106,10 @@ import qualified Data.IntMap as IntMap import Data.List (find,intercalate) import Data.Map (Map) import qualified Data.Map as Map -import StringBuffer (stringToStringBuffer) +import GHC.Data.StringBuffer (stringToStringBuffer) import Control.Monad import Data.Array -import Exception +import GHC.Utils.Exception import Unsafe.Coerce ( unsafeCoerce ) import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces ) diff --git a/compiler/GHC/Runtime/Eval/Types.hs b/compiler/GHC/Runtime/Eval/Types.hs index 753f776f20..0f2cd80c34 100644 --- a/compiler/GHC/Runtime/Eval/Types.hs +++ b/compiler/GHC/Runtime/Eval/Types.hs @@ -12,7 +12,7 @@ module GHC.Runtime.Eval.Types ( BreakInfo(..) ) where -import GhcPrelude +import GHC.Prelude import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) @@ -22,7 +22,7 @@ import GHC.Types.Module import GHC.Types.Name.Reader import GHC.Core.Type import GHC.Types.SrcLoc -import Exception +import GHC.Utils.Exception import Data.Word import GHC.Stack.CCS diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 0c856aa7a5..748020fa21 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -25,7 +25,7 @@ module GHC.Runtime.Heap.Inspect( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Runtime.Interpreter as GHCi @@ -50,14 +50,14 @@ import GHC.Types.Name import GHC.Types.Name.Occurrence as OccName import GHC.Types.Module import GHC.Iface.Env -import Util +import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Types.Basic ( Boxity(..) ) import GHC.Builtin.Types.Prim import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Driver.Session -import Outputable as Ppr +import GHC.Utils.Outputable as Ppr import GHC.Char import GHC.Exts.Heap import GHC.Runtime.Heap.Layout ( roundUpTo ) diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index c469f00cb4..7436cbefd8 100644 --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -44,13 +44,13 @@ module GHC.Runtime.Heap.Layout ( card, cardRoundUp, cardTableSizeB, cardTableSizeW ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic( ConTagZ ) import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable import GHC.Platform -import FastString +import GHC.Data.FastString import Data.Word import Data.Bits diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index 61e5297184..081c71d388 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -53,26 +53,26 @@ module GHC.Runtime.Interpreter , fromEvalResult ) where -import GhcPrelude +import GHC.Prelude import GHC.Runtime.Interpreter.Types import GHCi.Message import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) -import Fingerprint +import GHC.Utils.Fingerprint import GHC.Driver.Types import GHC.Types.Unique.FM -import Panic +import GHC.Utils.Panic import GHC.Driver.Session -import Exception +import GHC.Utils.Exception import GHC.Types.Basic -import FastString -import Util +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Runtime.Eval.Types(BreakInfo(..)) -import Outputable(brackets, ppr, showSDocUnqual) +import GHC.Utils.Outputable(brackets, ppr, showSDocUnqual) import GHC.Types.SrcLoc -import Maybes +import GHC.Data.Maybe import GHC.Types.Module import GHC.ByteCode.Types import GHC.Types.Unique diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs index 9decf8abb2..11f405815c 100644 --- a/compiler/GHC/Runtime/Interpreter/Types.hs +++ b/compiler/GHC/Runtime/Interpreter/Types.hs @@ -10,7 +10,7 @@ module GHC.Runtime.Interpreter.Types ) where -import GhcPrelude +import GHC.Prelude import GHCi.RemoteTypes import GHCi.Message ( Pipe ) diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index c103feb3fc..30be5eca55 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -29,7 +29,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Runtime.Interpreter import GHC.Runtime.Interpreter.Types @@ -47,18 +47,18 @@ import GHC.Driver.Ways import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Module -import ListSetOps +import GHC.Data.List.SetOps import GHC.Runtime.Linker.Types (DynLinker(..), LinkerUnitId, PersistentLinkerState(..)) import GHC.Driver.Session import GHC.Types.Basic -import Outputable -import Panic -import Util -import ErrUtils +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Error import GHC.Types.SrcLoc -import qualified Maybes +import qualified GHC.Data.Maybe as Maybes import GHC.Types.Unique.DSet -import FastString +import GHC.Data.FastString import GHC.Platform import GHC.SysTools import GHC.SysTools.FileCleanup @@ -82,7 +82,7 @@ import System.Environment (lookupEnv) import System.Win32.Info (getSystemDirectory) #endif -import Exception +import GHC.Utils.Exception {- ********************************************************************** diff --git a/compiler/GHC/Runtime/Linker/Types.hs b/compiler/GHC/Runtime/Linker/Types.hs index d8530a1460..fce4e80e60 100644 --- a/compiler/GHC/Runtime/Linker/Types.hs +++ b/compiler/GHC/Runtime/Linker/Types.hs @@ -15,13 +15,13 @@ module GHC.Runtime.Linker.Types ( SptEntry(..) ) where -import GhcPrelude ( FilePath, String, show ) +import GHC.Prelude ( FilePath, String, show ) import Data.Time ( UTCTime ) import Data.Maybe ( Maybe ) import Control.Concurrent.MVar ( MVar ) import GHC.Types.Module ( InstalledUnitId, Module ) import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) -import Outputable +import GHC.Utils.Outputable import GHC.Types.Var ( Id ) import GHC.Fingerprint.Type ( Fingerprint ) import GHC.Types.Name.Env ( NameEnv ) @@ -95,7 +95,7 @@ data Unlinked -- carries some static pointer table entries which -- should be loaded along with the BCOs. -- See Note [Grant plan for static forms] in - -- StaticPtrTable. + -- GHC.Iface.Tidy.StaticPtrTable. instance Outputable Unlinked where ppr (DotO path) = text "DotO" <+> text path @@ -104,7 +104,7 @@ instance Outputable Unlinked where ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt -- | An entry to be inserted into a module's static pointer table. --- See Note [Grand plan for static forms] in StaticPtrTable. +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. data SptEntry = SptEntry Id Fingerprint instance Outputable SptEntry where diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index be8395896c..81168f7c28 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -20,7 +20,7 @@ module GHC.Runtime.Loader ( lessUnsafeCoerce ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Runtime.Linker ( linkModule, getHValue ) @@ -46,11 +46,11 @@ import GHC.Core.TyCon ( TyCon ) import GHC.Types.Name ( Name, nameModule_maybe ) import GHC.Types.Id ( idType ) import GHC.Types.Module ( Module, ModuleName ) -import Panic -import FastString -import ErrUtils -import Outputable -import Exception +import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Exception import GHC.Driver.Hooks import Control.Monad ( unless ) diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs index e0466a1cf2..08b108a291 100644 --- a/compiler/GHC/Settings.hs +++ b/compiler/GHC/Settings.hs @@ -69,10 +69,10 @@ module GHC.Settings , sGhcRtsWithLibdw ) where -import GhcPrelude +import GHC.Prelude -import CliOption -import Fingerprint +import GHC.Utils.CliOption +import GHC.Utils.Fingerprint import GHC.Platform data Settings = Settings diff --git a/compiler/GHC/Settings/Constants.hs b/compiler/GHC/Settings/Constants.hs index 92a917e430..a852a5845d 100644 --- a/compiler/GHC/Settings/Constants.hs +++ b/compiler/GHC/Settings/Constants.hs @@ -1,7 +1,7 @@ -- | Compile-time settings module GHC.Settings.Constants where -import GhcPrelude +import GHC.Prelude import Config diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs index bc15564543..225d5a6ec8 100644 --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -9,16 +9,16 @@ module GHC.Settings.IO #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Settings.Platform import GHC.Settings.Utils import Config -import CliOption -import Fingerprint +import GHC.Utils.CliOption +import GHC.Utils.Fingerprint import GHC.Platform -import Outputable +import GHC.Utils.Outputable import GHC.Settings import GHC.SysTools.BaseDir diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index 4fbcf47a02..404b7faffd 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -86,12 +86,12 @@ Solution: do unarise first. module GHC.Stg.CSE (stgCse) where -import GhcPrelude +import GHC.Prelude import GHC.Core.DataCon import GHC.Types.Id import GHC.Stg.Syntax -import Outputable +import GHC.Utils.Outputable import GHC.Types.Basic (isWeakLoopBreaker) import GHC.Types.Var.Env import GHC.Core (AltCon(..)) @@ -106,7 +106,7 @@ import Control.Monad( (>=>) ) -------------- -- A lookup trie for data constructor applications, i.e. --- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap. +-- keys of type `(DataCon, [StgArg])`, following the patterns in GHC.Data.TrieMap. data StgArgMap a = SAM { sam_var :: DVarEnv a diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs index 90eec24f74..3f35acbb16 100644 --- a/compiler/GHC/Stg/DepAnal.hs +++ b/compiler/GHC/Stg/DepAnal.hs @@ -2,13 +2,13 @@ module GHC.Stg.DepAnal (depSortStgPgm) where -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Types.Id import GHC.Types.Name (Name, nameIsLocalOrFrom) import GHC.Types.Name.Env -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique.Set (nonDetEltsUniqSet) import GHC.Types.Var.Set import GHC.Types.Module (Module) diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs index e323775c5f..7fd7a3cae6 100644 --- a/compiler/GHC/Stg/FVs.hs +++ b/compiler/GHC/Stg/FVs.hs @@ -42,14 +42,14 @@ module GHC.Stg.FVs ( annBindingFreeVars ) where -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Types.Id import GHC.Types.Var.Set import GHC.Core ( Tickish(Breakpoint) ) -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import Data.Maybe ( mapMaybe ) diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs index f90ef519fe..8044584321 100644 --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -17,7 +17,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic import GHC.Driver.Session @@ -26,9 +26,9 @@ import GHC.Stg.FVs ( annBindingFreeVars ) import GHC.Stg.Lift.Analysis import GHC.Stg.Lift.Monad import GHC.Stg.Syntax -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique.Supply -import Util +import GHC.Utils.Misc import GHC.Types.Var.Set import Control.Monad ( when ) import Data.Maybe ( isNothing ) diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 13778237ea..f6a955adb3 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -20,7 +20,7 @@ module GHC.Stg.Lift.Analysis ( closureGrowth -- Exported just for the docs ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Types.Basic @@ -32,8 +32,8 @@ import GHC.Stg.Syntax import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure import qualified GHC.StgToCmm.Layout as StgToCmm.Layout -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Var.Set import Data.Maybe ( mapMaybe ) diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index 28ec3e1e69..b693730eca 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -22,21 +22,21 @@ module GHC.Stg.Lift.Monad ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS ) import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Name -import Outputable -import OrdList +import GHC.Utils.Outputable +import GHC.Data.OrdList import GHC.Stg.Subst import GHC.Stg.Syntax import GHC.Core.Type import GHC.Types.Unique.Supply -import Util +import GHC.Utils.Misc import GHC.Types.Var.Env import GHC.Types.Var.Set diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index bf4cfce443..69c961a081 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -37,12 +37,12 @@ basic properties listed above. module GHC.Stg.Lint ( lintStgTopBindings ) where -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Driver.Session -import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) +import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel ) import GHC.Types.CostCentre ( isCurrentCCS ) import GHC.Types.Id ( Id, idType, isJoinId, idName ) @@ -50,13 +50,13 @@ import GHC.Types.Var.Set import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) -import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) +import GHC.Utils.Error ( MsgDoc, Severity(..), mkLocMessage ) import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import GHC.Types.Module ( Module ) -import qualified ErrUtils as Err +import qualified GHC.Utils.Error as Err import Control.Applicative ((<|>)) import Control.Monad diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index 4b463cb95e..59b592fbc1 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -13,7 +13,7 @@ module GHC.Stg.Pipeline ( stg2stg ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax @@ -26,9 +26,9 @@ import GHC.Stg.Lift ( stgLiftLams ) import GHC.Types.Module ( Module ) import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error import GHC.Types.Unique.Supply -import Outputable +import GHC.Utils.Outputable import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.State.Strict diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs index c2d546d587..329f319a47 100644 --- a/compiler/GHC/Stg/Stats.hs +++ b/compiler/GHC/Stg/Stats.hs @@ -27,12 +27,12 @@ module GHC.Stg.Stats ( showStgStats ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Types.Id (Id) -import Panic +import GHC.Utils.Panic import Data.Map (Map) import qualified Data.Map as Map diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs index abbbfb0fd7..ba3550b330 100644 --- a/compiler/GHC/Stg/Subst.hs +++ b/compiler/GHC/Stg/Subst.hs @@ -4,13 +4,13 @@ module GHC.Stg.Subst where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Id import GHC.Types.Var.Env import Control.Monad.Trans.State.Strict -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc -- | 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/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index aefb49d988..71f1b5fbc1 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -61,7 +61,7 @@ module GHC.Stg.Syntax ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core ( AltCon, Tickish ) import GHC.Types.CostCentre ( CostCentreStack ) @@ -75,7 +75,7 @@ import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Literal ( Literal, literalType ) import GHC.Types.Module ( Module ) -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Packages ( isDynLinkName ) import GHC.Platform import GHC.Core.Ppr( {- instances -} ) @@ -83,7 +83,7 @@ import GHC.Builtin.PrimOps ( PrimOp, PrimCall ) import GHC.Core.TyCon ( PrimRep(..), TyCon ) import GHC.Core.Type ( Type ) import GHC.Types.RepType ( typePrimRep1 ) -import Util +import GHC.Utils.Misc import Data.List.NonEmpty ( NonEmpty, toList ) diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index de74b0b0ab..e0b96d0249 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -200,25 +200,25 @@ module GHC.Stg.Unarise (unarise) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic import GHC.Core import GHC.Core.DataCon -import FastString (FastString, mkFastString) +import GHC.Data.FastString (FastString, mkFastString) import GHC.Types.Id import GHC.Types.Literal import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) import GHC.Types.Id.Make (voidPrimId, voidArgId) -import MonadUtils (mapAccumLM) -import Outputable +import GHC.Utils.Monad (mapAccumLM) +import GHC.Utils.Outputable import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Core.Type import GHC.Builtin.Types.Prim (intPrimTy,wordPrimTy,word64PrimTy) import GHC.Builtin.Types import GHC.Types.Unique.Supply -import Util +import GHC.Utils.Misc import GHC.Types.Var.Env import Data.Bifunctor (second) diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 231144965e..4a2c379b36 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -13,7 +13,7 @@ module GHC.StgToCmm ( codeGen ) where #include "HsVersions.h" -import GhcPrelude as Prelude +import GHC.Prelude as Prelude import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad @@ -32,7 +32,7 @@ import GHC.Cmm.CLabel import GHC.Stg.Syntax import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Types import GHC.Types.CostCentre @@ -42,18 +42,18 @@ import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Types.Module -import Outputable -import Stream +import GHC.Utils.Outputable +import GHC.Data.Stream import GHC.Types.Basic import GHC.Types.Var.Set ( isEmptyDVarSet ) import GHC.SysTools.FileCleanup -import OrdList +import GHC.Data.OrdList import GHC.Cmm.Graph import Data.IORef import Control.Monad (when,void) -import Util +import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs index a3df5a881f..4d85d23d17 100644 --- a/compiler/GHC/StgToCmm/ArgRep.hs +++ b/compiler/GHC/StgToCmm/ArgRep.hs @@ -17,7 +17,7 @@ module GHC.StgToCmm.ArgRep ( ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.StgToCmm.Closure ( idPrimRep ) @@ -27,8 +27,8 @@ import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString -- I extricated this code as this new module in order to avoid a -- cyclic dependency between GHC.StgToCmm.Layout and GHC.StgToCmm.Ticky. diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 8db97d8083..851da5ed21 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -13,7 +13,7 @@ module GHC.StgToCmm.Bind ( pushUpdateFrame, emitUpdateFrame ) where -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.Platform import GHC.StgToCmm.Expr @@ -43,12 +43,12 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Module -import ListSetOps -import Util +import GHC.Data.List.SetOps +import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Types.Basic -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Driver.Session import Control.Monad diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs index 7775cdf033..1ed7f2384f 100644 --- a/compiler/GHC/StgToCmm/CgUtils.hs +++ b/compiler/GHC/StgToCmm/CgUtils.hs @@ -16,7 +16,7 @@ module GHC.StgToCmm.CgUtils ( get_GlobalReg_addr, ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform.Regs import GHC.Cmm @@ -25,7 +25,7 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- Information about global registers diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index b7e7c48fa0..431a46ef48 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -64,7 +64,7 @@ module GHC.StgToCmm.Closure ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Runtime.Heap.Layout @@ -84,9 +84,9 @@ import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Types.RepType import GHC.Types.Basic -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session -import Util +import GHC.Utils.Misc import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index a0645305fa..6d2ca60944 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -17,7 +17,7 @@ module GHC.StgToCmm.DataCon ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Stg.Syntax import GHC.Core ( AltCon(..) ) @@ -38,17 +38,17 @@ import GHC.Types.CostCentre import GHC.Types.Module import GHC.Core.DataCon import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Id.Info( CafInfo( NoCafRefs ) ) import GHC.Types.Name (isInternalName) import GHC.Types.RepType (countConRepArgs) import GHC.Types.Literal import GHC.Builtin.Utils -import Outputable +import GHC.Utils.Outputable import GHC.Platform -import Util -import MonadUtils (mapMaybeM) +import GHC.Utils.Misc +import GHC.Utils.Monad (mapMaybeM) import Control.Monad import Data.Char diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index da2158c7e9..03c53db979 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -24,7 +24,7 @@ module GHC.StgToCmm.Env ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core.TyCon import GHC.Platform @@ -41,12 +41,12 @@ import GHC.Driver.Session import GHC.Types.Id import GHC.Cmm.Graph import GHC.Types.Name -import Outputable +import GHC.Utils.Outputable import GHC.Stg.Syntax import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import GHC.Types.Var.Env ------------------------------------- diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 94cd97ca23..b05da01d1b 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -14,7 +14,7 @@ module GHC.StgToCmm.Expr ( cgExpr ) where #include "HsVersions.h" -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind ) @@ -46,10 +46,10 @@ import GHC.Core.TyCon import GHC.Core.Type ( isUnliftedType ) import GHC.Types.RepType ( isVoidTy, countConRepArgs ) import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) -import Maybes -import Util -import FastString -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable import Control.Monad ( unless, void ) import Control.Arrow ( first ) diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs index 84195a67d2..e26d971c7f 100644 --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -37,7 +37,7 @@ module GHC.StgToCmm.ExtCode ( where -import GhcPrelude +import GHC.Prelude import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Monad (FCode, newUnique) @@ -48,7 +48,7 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.Module import GHC.Types.Unique.FM import GHC.Types.Unique diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index 51fee717c4..72dae672ba 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -18,7 +18,7 @@ module GHC.StgToCmm.Foreign ( emitCloseNursery, ) where -import GhcPrelude hiding( succ, (<*>) ) +import GHC.Prelude hiding( succ, (<*>) ) import GHC.Stg.Syntax import GHC.StgToCmm.Prof (storeCurCCS, ccsType) @@ -39,14 +39,14 @@ import GHC.Runtime.Heap.Layout import GHC.Types.ForeignCall import GHC.Driver.Session import GHC.Platform -import Maybes -import Outputable +import GHC.Data.Maybe +import GHC.Utils.Outputable import GHC.Types.Unique.Supply import GHC.Types.Basic import GHC.Core.TyCo.Rep import GHC.Builtin.Types.Prim -import Util (zipEqual) +import GHC.Utils.Misc (zipEqual) import Control.Monad diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 9a66d77c7f..65c2e7beff 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -22,7 +22,7 @@ module GHC.StgToCmm.Heap ( emitSetDynHdr ) where -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.Stg.Syntax import GHC.Cmm.CLabel @@ -47,8 +47,8 @@ import GHC.Types.Id ( Id ) import GHC.Types.Module import GHC.Driver.Session import GHC.Platform -import FastString( mkFastString, fsLit ) -import Panic( sorry ) +import GHC.Data.FastString( mkFastString, fsLit ) +import GHC.Utils.Panic( sorry ) import Control.Monad (when) import Data.Maybe (isJust) diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs index 4feb81217b..e418d03fde 100644 --- a/compiler/GHC/StgToCmm/Hpc.hs +++ b/compiler/GHC/StgToCmm/Hpc.hs @@ -8,7 +8,7 @@ module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where -import GhcPrelude +import GHC.Prelude import GHC.StgToCmm.Monad diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 14ec8445c5..a02d66906f 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -32,7 +32,7 @@ module GHC.StgToCmm.Layout ( #include "HsVersions.h" -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.StgToCmm.Closure import GHC.StgToCmm.Env @@ -56,10 +56,10 @@ import GHC.Driver.Session import GHC.Platform import GHC.Types.Module -import Util +import GHC.Utils.Misc import Data.List -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import Control.Monad ------------------------------------------------------------------------ diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index a23d942c60..5516c2e7bc 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -59,7 +59,7 @@ module GHC.StgToCmm.Monad ( CgInfoDownwards(..), CgState(..) -- non-abstract ) where -import GhcPrelude hiding( sequence, succ ) +import GHC.Prelude hiding( sequence, succ ) import GHC.Platform import GHC.Cmm @@ -73,13 +73,13 @@ import GHC.Runtime.Heap.Layout import GHC.Types.Module import GHC.Types.Id import GHC.Types.Var.Env -import OrdList +import GHC.Data.OrdList import GHC.Types.Basic( ConTagZ ) import GHC.Types.Unique import GHC.Types.Unique.Supply -import FastString -import Outputable -import Util +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc import Control.Monad import Data.List diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index b315c6a196..18acc11304 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -24,7 +24,7 @@ module GHC.StgToCmm.Prim ( #include "HsVersions.h" -import GhcPrelude hiding ((<*>)) +import GHC.Prelude hiding ((<*>)) import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign @@ -49,9 +49,9 @@ import GHC.Cmm.CLabel import GHC.Cmm.Utils import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout -import FastString -import Outputable -import Util +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc import Data.Maybe import Data.Bits ((.&.), bit) diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 578dbc1318..ae123fd9c7 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -23,7 +23,7 @@ module GHC.StgToCmm.Prof ( ldvEnter, ldvEnterClosure, ldvRecordCreate ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.StgToCmm.Closure @@ -38,9 +38,9 @@ import GHC.Cmm.CLabel import GHC.Types.CostCentre import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Types.Module as Module -import Outputable +import GHC.Utils.Outputable import Control.Monad import Data.Char (ord) diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 179dc2d2d8..8eff2f608c 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -105,7 +105,7 @@ module GHC.StgToCmm.Ticky ( tickySlowCall, tickySlowCallPat, ) where -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) @@ -124,9 +124,9 @@ import GHC.Types.Module import GHC.Types.Name import GHC.Types.Id import GHC.Types.Basic -import FastString -import Outputable -import Util +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Driver.Session diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index de59cf3be9..d60de74267 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -48,7 +48,7 @@ module GHC.StgToCmm.Utils ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.StgToCmm.Monad @@ -69,13 +69,13 @@ import GHC.Core.TyCon import GHC.Runtime.Heap.Layout import GHC.Types.Module import GHC.Types.Literal -import Digraph -import Util +import GHC.Data.Graph.Directed +import GHC.Utils.Misc import GHC.Types.Unique import GHC.Types.Unique.Supply (MonadUnique(..)) import GHC.Driver.Session -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Types.RepType import GHC.Types.CostCentre diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs index f3f1b4b1ca..0ec9912c8d 100644 --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -38,14 +38,14 @@ module GHC.SysTools ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Settings.Utils import GHC.Types.Module import GHC.Driver.Packages -import Outputable -import ErrUtils +import GHC.Utils.Outputable +import GHC.Utils.Error import GHC.Platform import GHC.Driver.Session import GHC.Driver.Ways diff --git a/compiler/GHC/SysTools/Ar.hs b/compiler/GHC/SysTools/Ar.hs index 200b652049..198ad6596f 100644 --- a/compiler/GHC/SysTools/Ar.hs +++ b/compiler/GHC/SysTools/Ar.hs @@ -32,7 +32,7 @@ module GHC.SysTools.Ar ) where -import GhcPrelude +import GHC.Prelude import Data.List (mapAccumL, isPrefixOf) import Data.Monoid ((<>)) diff --git a/compiler/GHC/SysTools/BaseDir.hs b/compiler/GHC/SysTools/BaseDir.hs index fe749b5cdc..e5b0c7ca61 100644 --- a/compiler/GHC/SysTools/BaseDir.hs +++ b/compiler/GHC/SysTools/BaseDir.hs @@ -19,12 +19,12 @@ module GHC.SysTools.BaseDir #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -- See note [Base Dir] for why some of this logic is shared with ghc-pkg. import GHC.BaseDir -import Panic +import GHC.Utils.Panic import System.Environment (lookupEnv) import System.FilePath diff --git a/compiler/GHC/SysTools/Elf.hs b/compiler/GHC/SysTools/Elf.hs index 5d4d87af45..ca563dfb52 100644 --- a/compiler/GHC/SysTools/Elf.hs +++ b/compiler/GHC/SysTools/Elf.hs @@ -14,16 +14,16 @@ module GHC.SysTools.Elf ( makeElfNote ) where -import GhcPrelude +import GHC.Prelude -import AsmUtils -import Exception +import GHC.Utils.Asm +import GHC.Utils.Exception import GHC.Driver.Session import GHC.Platform -import ErrUtils -import Maybes (MaybeT(..),runMaybeT) -import Util (charToC) -import Outputable (text,hcat,SDoc) +import GHC.Utils.Error +import GHC.Data.Maybe (MaybeT(..),runMaybeT) +import GHC.Utils.Misc (charToC) +import GHC.Utils.Outputable (text,hcat,SDoc) import Control.Monad (when) import Data.Binary.Get diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs index f20f815107..0a04860185 100644 --- a/compiler/GHC/SysTools/ExtraObj.hs +++ b/compiler/GHC/SysTools/ExtraObj.hs @@ -13,17 +13,17 @@ module GHC.SysTools.ExtraObj ( haveRtsOptsFlags ) where -import AsmUtils -import ErrUtils +import GHC.Utils.Asm +import GHC.Utils.Error import GHC.Driver.Session import GHC.Driver.Packages import GHC.Platform -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Types.Module import GHC.SysTools.Elf -import Util -import GhcPrelude +import GHC.Utils.Misc +import GHC.Prelude import Control.Monad import Data.Maybe diff --git a/compiler/GHC/SysTools/FileCleanup.hs b/compiler/GHC/SysTools/FileCleanup.hs index ef41185cdd..f72480d65f 100644 --- a/compiler/GHC/SysTools/FileCleanup.hs +++ b/compiler/GHC/SysTools/FileCleanup.hs @@ -7,13 +7,13 @@ module GHC.SysTools.FileCleanup , withSystemTempDirectory, withTempDirectory ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session -import ErrUtils -import Outputable -import Util -import Exception +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Exception as Exception import GHC.Driver.Phases import Control.Monad diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs index 8051570755..039c1d12aa 100644 --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -8,11 +8,11 @@ ----------------------------------------------------------------------------- module GHC.SysTools.Info where -import Exception -import ErrUtils +import GHC.Utils.Exception +import GHC.Utils.Error import GHC.Driver.Session -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import Data.List import Data.IORef @@ -20,7 +20,7 @@ import Data.IORef import System.IO import GHC.Platform -import GhcPrelude +import GHC.Prelude import GHC.SysTools.Process diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs index 82f7a6d2f0..83547ab06c 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -10,14 +10,14 @@ module GHC.SysTools.Process where #include "HsVersions.h" -import Exception -import ErrUtils +import GHC.Utils.Exception +import GHC.Utils.Error import GHC.Driver.Session -import FastString -import Outputable -import Panic -import GhcPrelude -import Util +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Prelude +import GHC.Utils.Misc import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) import Control.Concurrent diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index 9d7b736fee..ee2f664571 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -8,19 +8,19 @@ ----------------------------------------------------------------------------- module GHC.SysTools.Tasks where -import Exception -import ErrUtils +import GHC.Utils.Exception as Exception +import GHC.Utils.Error import GHC.Driver.Types import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable import GHC.Platform -import Util +import GHC.Utils.Misc import Data.List import System.IO import System.Process -import GhcPrelude +import GHC.Prelude import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion) diff --git a/compiler/GHC/SysTools/Terminal.hs b/compiler/GHC/SysTools/Terminal.hs index 69c605bc73..c7951e0b43 100644 --- a/compiler/GHC/SysTools/Terminal.hs +++ b/compiler/GHC/SysTools/Terminal.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module GHC.SysTools.Terminal (stderrSupportsAnsiColors) where -import GhcPrelude +import GHC.Prelude #if defined(MIN_VERSION_terminfo) import Control.Exception (catch) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 6f5d72a51a..eca079ed23 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -15,7 +15,7 @@ module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Driver.Session @@ -47,9 +47,9 @@ import GHC.Types.Avail import GHC.Core.Unify( tcUnifyTy ) import GHC.Core.Class import GHC.Core.Type -import ErrUtils +import GHC.Utils.Error import GHC.Core.DataCon -import Maybes +import GHC.Data.Maybe import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Set as NameSet @@ -60,11 +60,11 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Builtin.Names import GHC.Types.SrcLoc -import Util -import Outputable -import FastString -import Bag -import FV (fvVarList, unionFV, mkFVs) +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs index 41aa86080d..6a13cfaccd 100644 --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -24,23 +24,23 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Bag +import GHC.Data.Bag import GHC.Core.DataCon -import FastString +import GHC.Data.FastString import GHC.Hs -import Outputable +import GHC.Utils.Outputable import GHC.Builtin.Names import GHC.Types.Name.Reader import GHC.Types.SrcLoc -import State +import GHC.Utils.Monad.State import GHC.Tc.Deriv.Generate import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.Type -import Util +import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Id.Make (coerceId) diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index ad103ca7c8..8177416c4b 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -38,7 +38,7 @@ module GHC.Tc.Deriv.Generate ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.Monad import GHC.Hs @@ -46,8 +46,8 @@ import GHC.Types.Name.Reader import GHC.Types.Basic import GHC.Core.DataCon import GHC.Types.Name -import Fingerprint -import Encoding +import GHC.Utils.Fingerprint +import GHC.Utils.Encoding import GHC.Driver.Session import GHC.Builtin.Utils @@ -69,13 +69,13 @@ import GHC.Core.Type import GHC.Core.Class import GHC.Types.Var.Set import GHC.Types.Var.Env -import Util +import GHC.Utils.Misc import GHC.Types.Var -import Outputable +import GHC.Utils.Outputable import GHC.Utils.Lexeme -import FastString -import Pair -import Bag +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Data.Bag import Data.List ( find, partition, intersperse ) @@ -2400,7 +2400,7 @@ mkAuxBinderName dflags parent occ_fun parent_stable_hash = let Fingerprint high low = fingerprintString parent_stable in toBase62 high ++ toBase62Padded low - -- See Note [Base 62 encoding 128-bit integers] in Encoding + -- See Note [Base 62 encoding 128-bit integers] in GHC.Utils.Encoding parent_occ = nameOccName parent diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index d4af39d83c..31dc85d7e9 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -19,7 +19,7 @@ module GHC.Tc.Deriv.Generics ) where -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Core.Type @@ -42,14 +42,14 @@ import GHC.Builtin.Names import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Driver.Types -import ErrUtils( Validity(..), andValid ) +import GHC.Utils.Error( Validity(..), andValid ) import GHC.Types.SrcLoc -import Bag +import GHC.Data.Bag import GHC.Types.Var.Env import GHC.Types.Var.Set (elemVarSet) -import Outputable -import FastString -import Util +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Misc import Control.Monad (mplus) import Data.List (zip4, partition) diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index 849f0bf2a9..56dafd2097 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -16,16 +16,16 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Bag +import GHC.Data.Bag import GHC.Types.Basic import GHC.Core.Class import GHC.Core.DataCon -import ErrUtils +import GHC.Utils.Error import GHC.Tc.Utils.Instantiate -import Outputable -import Pair +import GHC.Utils.Outputable +import GHC.Data.Pair import GHC.Builtin.Names import GHC.Tc.Deriv.Utils import GHC.Tc.Utils.Env @@ -46,7 +46,7 @@ import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints) import GHC.Builtin.Types (typeToTypeKind) import GHC.Core.Unify (tcUnifyTy) -import Util +import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.Var.Set diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index 63c0e3002c..72ee0e6af3 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -22,14 +22,14 @@ module GHC.Tc.Deriv.Utils ( newDerivClsInst, extendLocalInstEnv ) where -import GhcPrelude +import GHC.Prelude -import Bag +import GHC.Data.Bag import GHC.Types.Basic import GHC.Core.Class import GHC.Core.DataCon import GHC.Driver.Session -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Types (lookupFixity, mi_fix) import GHC.Hs import GHC.Tc.Utils.Instantiate @@ -37,7 +37,7 @@ import GHC.Core.InstEnv import GHC.Iface.Load (loadInterfaceForName) import GHC.Types.Module (getModule) import GHC.Types.Name -import Outputable +import GHC.Utils.Outputable import GHC.Builtin.Names import GHC.Types.SrcLoc import GHC.Tc.Deriv.Generate @@ -50,13 +50,13 @@ import GHC.Builtin.Names.TH (liftClassKey) import GHC.Core.TyCon import GHC.Core.TyCo.Ppr (pprSourceTyCon) import GHC.Core.Type -import Util +import GHC.Utils.Misc import GHC.Types.Var.Set import Control.Monad.Trans.Reader import Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import ListSetOps (assocMaybe) +import GHC.Data.List.SetOps (assocMaybe) -- | To avoid having to manually plumb everything in 'DerivEnv' throughout -- various functions in @GHC.Tc.Deriv@ and @GHC.Tc.Deriv.Infer@, we use 'DerivM', which diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index ae08f78443..e4746032d3 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -15,7 +15,7 @@ module GHC.Tc.Errors( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Types import GHC.Tc.Utils.Monad @@ -51,19 +51,19 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name.Set -import Bag -import ErrUtils ( ErrMsg, errDoc, pprLocErrMsg ) +import GHC.Data.Bag +import GHC.Utils.Error ( ErrMsg, errDoc, pprLocErrMsg ) import GHC.Types.Basic import GHC.Core.ConLike ( ConLike(..)) -import Util -import FastString -import Outputable +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Driver.Session -import ListSetOps ( equivClasses ) -import Maybes +import GHC.Data.List.SetOps ( equivClasses ) +import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import FV ( fvVarList, unionFV ) +import GHC.Utils.FV ( fvVarList, unionFV ) import Control.Monad ( when ) import Data.Foldable ( toList ) diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 771765901c..543fa0fca0 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -17,7 +17,7 @@ module GHC.Tc.Errors.Hole ) where -import GhcPrelude +import GHC.Prelude import GHC.Tc.Types import GHC.Tc.Utils.Monad @@ -34,14 +34,14 @@ import GHC.Builtin.Names ( gHC_ERR ) import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Var.Env -import Bag +import GHC.Data.Bag import GHC.Core.ConLike ( ConLike(..) ) -import Util +import GHC.Utils.Misc import GHC.Tc.Utils.Env (tcLookup) -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session -import Maybes -import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) +import GHC.Data.Maybe +import GHC.Utils.FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) import Control.Arrow ( (&&&) ) diff --git a/compiler/GHC/Tc/Errors/Hole.hs-boot b/compiler/GHC/Tc/Errors/Hole.hs-boot index bc79c3eed4..fa3299c5d3 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole.hs-boot @@ -6,7 +6,7 @@ module GHC.Tc.Errors.Hole where import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Constraint ( Ct, Implication ) -import Outputable ( SDoc ) +import GHC.Utils.Outputable ( SDoc ) import GHC.Types.Var.Env ( TidyEnv ) findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs index 8aabc615ce..92bbe00115 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -5,7 +5,7 @@ module GHC.Tc.Errors.Hole.FitTypes ( hfIsLcl, pprHoleFitCand ) where -import GhcPrelude +import GHC.Prelude import GHC.Tc.Types import GHC.Tc.Types.Constraint @@ -16,7 +16,7 @@ import GHC.Types.Name.Reader import GHC.Hs.Doc import GHC.Types.Id -import Outputable +import GHC.Utils.Outputable import GHC.Types.Name import Data.Function ( on ) diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs index ef7168076f..47bca17766 100644 --- a/compiler/GHC/Tc/Gen/Annotation.hs +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -10,7 +10,7 @@ -- | Typechecking annotations module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation ) import GHC.Types.Module @@ -22,7 +22,7 @@ import GHC.Types.Name import GHC.Types.Annotations import GHC.Tc.Utils.Monad import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Types -- Some platforms don't support the interpreter, and compilation on those diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index 69c5e67197..5d26927ed4 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -12,7 +12,7 @@ -- | Typecheck arrow notation module GHC.Tc.Gen.Arrow ( tcProc ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcLExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcCheckExpr ) @@ -35,8 +35,8 @@ import GHC.Types.Var.Set import GHC.Builtin.Types.Prim import GHC.Types.Basic( Arity ) import GHC.Types.SrcLoc -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import Control.Monad diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 44fd594849..929e02cc07 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -20,7 +20,7 @@ module GHC.Tc.Gen.Bind ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcLExpr ) @@ -28,7 +28,7 @@ import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) import GHC.Core (Tickish (..)) import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) import GHC.Driver.Session -import FastString +import GHC.Data.FastString import GHC.Hs import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Monad @@ -56,13 +56,13 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.SrcLoc -import Bag -import ErrUtils -import Digraph -import Maybes -import Util +import GHC.Data.Bag +import GHC.Utils.Error +import GHC.Data.Graph.Directed +import GHC.Data.Maybe +import GHC.Utils.Misc import GHC.Types.Basic -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Builtin.Names( ipClassName ) import GHC.Tc.Validity (checkValidType) import GHC.Types.Unique.FM @@ -552,7 +552,7 @@ mkEdges sig_fn binds ] -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices -- is still deterministic even if the edges are in nondeterministic order - -- as explained in Note [Deterministic SCC] in Digraph. + -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. where bind_fvs (FunBind { fun_ext = fvs }) = fvs bind_fvs (PatBind { pat_ext = fvs }) = fvs diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs index bf1132aa3e..ab5e021653 100644 --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -8,7 +8,7 @@ -- | Typechecking @default@ declarations module GHC.Tc.Gen.Default ( tcDefaults ) where -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Core.Class @@ -21,8 +21,8 @@ import GHC.Tc.Validity import GHC.Tc.Utils.TcType import GHC.Builtin.Names import GHC.Types.SrcLoc -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt tcDefaults :: [LDefaultDecl GhcRn] diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index b384b494e4..d4235ba171 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -7,7 +7,7 @@ module GHC.Tc.Gen.Export (tcRnExports, exports_from_avail) where -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Builtin.Names @@ -18,7 +18,7 @@ import GHC.Tc.Utils.TcType import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) -import ErrUtils +import GHC.Utils.Error import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Module @@ -29,14 +29,14 @@ import GHC.Types.Avail import GHC.Core.TyCon import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Types -import Outputable +import GHC.Utils.Outputable import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn -import Maybes +import GHC.Data.Maybe import GHC.Types.Unique.Set -import Util (capitalise) -import FastString (fsLit) +import GHC.Utils.Misc (capitalise) +import GHC.Data.FastString (fsLit) import Control.Monad import GHC.Driver.Session diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 70201773b9..94341c62c2 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -30,7 +30,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) import GHC.Builtin.Names.TH( liftStringName, liftName ) @@ -79,12 +79,12 @@ import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names import GHC.Driver.Session import GHC.Types.SrcLoc -import Util +import GHC.Utils.Misc import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) -import ListSetOps -import Maybes -import Outputable -import FastString +import GHC.Data.List.SetOps +import GHC.Data.Maybe +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString import Control.Monad import GHC.Core.Class(classTyCon) import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) @@ -578,7 +578,7 @@ tcExpr (HsProc x pat cmd) res_ty ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. --- See Note [Grand plan for static forms] in StaticPtrTable for an overview. +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. -- To type check -- (static e) :: p a -- we want to check (e :: a), diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 858d865026..8163e6820d 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -33,7 +33,7 @@ module GHC.Tc.Gen.Foreign #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs @@ -47,7 +47,7 @@ import GHC.Core.FamInstEnv import GHC.Core.Coercion import GHC.Core.Type import GHC.Types.ForeignCall -import ErrUtils +import GHC.Utils.Error import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader @@ -56,10 +56,10 @@ import GHC.Core.TyCon import GHC.Tc.Utils.TcType import GHC.Builtin.Names import GHC.Driver.Session -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Platform import GHC.Types.SrcLoc -import Bag +import GHC.Data.Bag import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index a25a7320e4..0614bfcc95 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -68,7 +68,7 @@ module GHC.Tc.Gen.HsType ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Tc.Utils.Monad @@ -103,18 +103,18 @@ import GHC.Builtin.Types import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Settings.Constants ( mAX_CTUPLE_SIZE ) -import ErrUtils( MsgDoc ) +import GHC.Utils.Error( MsgDoc ) import GHC.Types.Unique import GHC.Types.Unique.Set -import Util +import GHC.Utils.Misc import GHC.Types.Unique.Supply -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Builtin.Names hiding ( wildCardName ) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt -import Maybes +import GHC.Data.Maybe import Data.List ( find ) import Control.Monad diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 45fece68c0..857470b155 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -34,7 +34,7 @@ module GHC.Tc.Gen.Match ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRhoNC, tcInferRho , tcCheckId, tcLExpr, tcLExprNC, tcExpr @@ -56,8 +56,8 @@ import GHC.Types.Id import GHC.Core.TyCon import GHC.Builtin.Types.Prim import GHC.Tc.Types.Evidence -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.SrcLoc -- Create chunkified tuple tybes for monad comprehensions diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 0456677cc7..2f7d2e7721 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -26,7 +26,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) @@ -58,12 +58,12 @@ import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Types.Var.Set -import Util -import Outputable +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable import qualified GHC.LanguageExtensions as LangExt import Control.Arrow ( second ) import Control.Monad ( when ) -import ListSetOps ( getNth ) +import GHC.Data.List.SetOps ( getNth ) {- ************************************************************************ diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index 35b20acaa8..20620d2c36 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -10,7 +10,7 @@ -- | Typechecking transformation rules module GHC.Tc.Gen.Rule ( tcRules ) where -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Tc.Types @@ -33,9 +33,9 @@ import GHC.Types.Var( EvVar ) import GHC.Types.Var.Set import GHC.Types.Basic ( RuleName ) import GHC.Types.SrcLoc -import Outputable -import FastString -import Bag +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Bag {- Note [Typechecking rules] diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 83fab20ca5..a8cdd08bce 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -25,7 +25,7 @@ module GHC.Tc.Gen.Sig( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Tc.Gen.HsType @@ -49,10 +49,10 @@ import GHC.Types.Basic import GHC.Types.Module( getModule ) import GHC.Types.Name import GHC.Types.Name.Env -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc -import Util( singleton ) -import Maybes( orElse ) +import GHC.Utils.Misc( singleton ) +import GHC.Data.Maybe( orElse ) import Data.Maybe( mapMaybe ) import Control.Monad( unless ) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 830e17abd4..67ef5a3e6c 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -34,7 +34,7 @@ module GHC.Tc.Gen.Splice( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Types.Annotations @@ -43,7 +43,7 @@ import GHC.Types.Name import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType -import Outputable +import GHC.Utils.Outputable import GHC.Tc.Gen.Expr import GHC.Types.SrcLoc import GHC.Builtin.Names.TH @@ -103,21 +103,21 @@ import GHC.Types.Id.Info import GHC.HsToCore.Expr import GHC.HsToCore.Monad import GHC.Serialized -import ErrUtils -import Util +import GHC.Utils.Error +import GHC.Utils.Misc import GHC.Types.Unique import GHC.Types.Var.Set import Data.List ( find ) import Data.Maybe -import FastString +import GHC.Data.FastString import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) ) -import Maybes( MaybeErr(..) ) +import GHC.Data.Maybe( MaybeErr(..) ) import GHC.Driver.Session -import Panic +import GHC.Utils.Panic as Panic import GHC.Utils.Lexeme -import qualified EnumSet +import qualified GHC.Data.EnumSet as EnumSet import GHC.Driver.Plugins -import Bag +import GHC.Data.Bag import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types diff --git a/compiler/GHC/Tc/Gen/Splice.hs-boot b/compiler/GHC/Tc/Gen/Splice.hs-boot index d74edf3f3a..fe57d4a124 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs-boot +++ b/compiler/GHC/Tc/Gen/Splice.hs-boot @@ -3,7 +3,7 @@ module GHC.Tc.Gen.Splice where -import GhcPrelude +import GHC.Prelude import GHC.Types.Name import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) import GHC.Tc.Types( TcM , SpliceType ) diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index 53054de7f8..43c2092c70 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -11,7 +11,7 @@ module GHC.Tc.Instance.Class ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad @@ -40,8 +40,8 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class import GHC.Driver.Session -import Outputable -import Util( splitAtList, fstOf3 ) +import GHC.Utils.Outputable +import GHC.Utils.Misc( splitAtList, fstOf3 ) import Data.Maybe {- ******************************************************************* diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 68c894f2e4..6f1ac07f74 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -12,7 +12,7 @@ module GHC.Tc.Instance.Family ( reportInjectivityErrors, reportConflictingInjectivityErrs ) where -import GhcPrelude +import GHC.Prelude import GHC.Driver.Types import GHC.Core.FamInstEnv @@ -28,20 +28,20 @@ import GHC.Tc.Utils.TcType import GHC.Core.Coercion.Axiom import GHC.Driver.Session import GHC.Types.Module -import Outputable -import Util +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Name.Reader import GHC.Core.DataCon ( dataConName ) -import Maybes +import GHC.Data.Maybe import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen ) import GHC.Tc.Utils.TcMType import GHC.Types.Name -import Panic +import GHC.Utils.Panic import GHC.Types.Var.Set -import FV -import Bag( Bag, unionBags, unitBag ) +import GHC.Utils.FV +import GHC.Data.Bag( Bag, unionBags, unitBag ) import Control.Monad import Data.List ( sortBy ) import Data.List.NonEmpty ( NonEmpty(..) ) diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs index 40344af9ed..aba9031be6 100644 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -23,7 +23,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Name import GHC.Types.Var @@ -38,13 +38,13 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) -import FV -import Outputable -import ErrUtils( Validity(..), allValid ) +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Utils.Error( Validity(..), allValid ) import GHC.Types.SrcLoc -import Util +import GHC.Utils.Misc -import Pair ( Pair(..) ) +import GHC.Data.Pair ( Pair(..) ) import Data.List ( nubBy ) import Data.Maybe import Data.Foldable ( fold ) diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index c3e59b2f4c..2c7656a20c 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -12,7 +12,7 @@ module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) ) @@ -37,13 +37,13 @@ import GHC.Core.DataCon import GHC.Types.Module import GHC.Hs import GHC.Driver.Session -import Bag +import GHC.Data.Bag import GHC.Types.Var ( VarBndr(..) ) import GHC.Core.Map import GHC.Settings.Constants -import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) -import Outputable -import FastString ( FastString, mkFastString, fsLit ) +import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) +import GHC.Utils.Outputable +import GHC.Data.FastString ( FastString, mkFastString, fsLit ) import Control.Monad.Trans.State import Control.Monad.Trans.Class (lift) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index cc3bf4a2cc..e202fdcec7 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -48,7 +48,7 @@ module GHC.Tc.Module ( getRenamedStuff, RenamedStuff ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) @@ -78,7 +78,7 @@ import GHC.Tc.Gen.Export import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin -import qualified BooleanFormula as BF +import qualified GHC.Data.BooleanFormula as BF import GHC.Core.Ppr.TyThing ( pprTyThingInContext ) import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Tc.Instance.Family @@ -106,7 +106,7 @@ import GHC.Iface.Load import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Module -import ErrUtils +import GHC.Utils.Error import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env @@ -119,8 +119,8 @@ import GHC.Types.Avail import GHC.Core.TyCon import GHC.Types.SrcLoc import GHC.Driver.Types -import ListSetOps -import Outputable +import GHC.Data.List.SetOps +import GHC.Utils.Outputable as Outputable import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Type @@ -130,10 +130,10 @@ import GHC.Core.Coercion.Axiom import GHC.Types.Annotations import Data.List ( find, sortBy, sort ) import Data.Ord -import FastString -import Maybes -import Util -import Bag +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Data.Bag import GHC.Tc.Utils.Instantiate (tcGetInsts) import qualified GHC.LanguageExtensions as LangExt import Data.Data ( Data ) diff --git a/compiler/GHC/Tc/Module.hs-boot b/compiler/GHC/Tc/Module.hs-boot index f1f5e31e8a..90d775a4e2 100644 --- a/compiler/GHC/Tc/Module.hs-boot +++ b/compiler/GHC/Tc/Module.hs-boot @@ -1,9 +1,9 @@ module GHC.Tc.Module where -import GhcPrelude +import GHC.Prelude import GHC.Core.Type(TyThing) import GHC.Tc.Types (TcM) -import Outputable (SDoc) +import GHC.Utils.Outputable (SDoc) import GHC.Types.Name (Name) checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs index cde159815f..228647767d 100644 --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -50,7 +50,7 @@ module GHC.Tc.Plugin ( getEvBindsTcPluginM ) where -import GhcPrelude +import GHC.Prelude import qualified GHC.Tc.Utils.Monad as TcM import qualified GHC.Tc.Solver.Monad as TcS @@ -77,12 +77,12 @@ import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Class import GHC.Driver.Types -import Outputable +import GHC.Utils.Outputable import GHC.Core.Type import GHC.Core.Coercion ( BlockSubstFlag(..) ) import GHC.Types.Id import GHC.Core.InstEnv -import FastString +import GHC.Data.FastString import GHC.Types.Unique diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index c060eac638..92b739f00b 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -26,16 +26,16 @@ module GHC.Tc.Solver( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Bag +import GHC.Data.Bag import GHC.Core.Class ( Class, classKey, classTyCon ) import GHC.Driver.Session import GHC.Types.Id ( idType, mkLocalId ) import GHC.Tc.Utils.Instantiate -import ListSetOps +import GHC.Data.List.SetOps import GHC.Types.Name -import Outputable +import GHC.Utils.Outputable import GHC.Builtin.Utils import GHC.Builtin.Names import GHC.Tc.Errors @@ -52,19 +52,19 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Builtin.Types ( liftedRepTy ) import GHC.Core.Unify ( tcMatchTyKi ) -import Util +import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Unique.Set import GHC.Types.Basic ( IntWithInf, intGtLimit ) -import ErrUtils ( emptyMessages ) +import GHC.Utils.Error ( emptyMessages ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Data.Foldable ( toList ) import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty(..) ) -import Maybes ( isJust ) +import GHC.Data.Maybe ( isJust ) {- ********************************************************************************* diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index c9d93b063e..5a231f2e44 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -11,7 +11,7 @@ module GHC.Tc.Solver.Canonical( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Types.Constraint import GHC.Core.Predicate @@ -35,16 +35,16 @@ import GHC.Types.Var import GHC.Types.Var.Env( mkInScopeSet ) import GHC.Types.Var.Set( delVarSetList ) import GHC.Types.Name.Occurrence ( OccName ) -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Session( DynFlags ) import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs.Types( HsIPName(..) ) -import Pair -import Util -import Bag -import MonadUtils +import GHC.Data.Pair +import GHC.Utils.Misc +import GHC.Data.Bag +import GHC.Utils.Monad import Control.Monad import Data.Maybe ( isJust ) import Data.List ( zip4 ) diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs index e1a290fdf9..551e1de395 100644 --- a/compiler/GHC/Tc/Solver/Flatten.hs +++ b/compiler/GHC/Tc/Solver/Flatten.hs @@ -12,7 +12,7 @@ module GHC.Tc.Solver.Flatten( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Types import GHC.Core.TyCo.Ppr ( pprTyVar ) @@ -27,14 +27,14 @@ import GHC.Core.Coercion import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env -import Outputable +import GHC.Utils.Outputable import GHC.Tc.Solver.Monad as TcS import GHC.Types.Basic( SwapFlag(..) ) -import Util -import Bag +import GHC.Utils.Misc +import GHC.Data.Bag import Control.Monad -import MonadUtils ( zipWith3M ) +import GHC.Utils.Monad ( zipWith3M ) import Data.Foldable ( foldrM ) import Control.Arrow ( first ) diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index acb9ca5543..6a391d4406 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -10,7 +10,7 @@ module GHC.Tc.Solver.Interact ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic ( SwapFlag(..), isSwapped, infinity, IntWithInf, intGtLimit ) import GHC.Tc.Solver.Canonical @@ -36,15 +36,15 @@ import GHC.Core.FamInstEnv import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) import GHC.Tc.Types.Evidence -import Outputable +import GHC.Utils.Outputable import GHC.Tc.Types import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Solver.Monad -import Bag -import MonadUtils ( concatMapM, foldlM ) +import GHC.Data.Bag +import GHC.Utils.Monad ( concatMapM, foldlM ) import GHC.Core import Data.List( partition, deleteFirstsBy ) @@ -52,11 +52,11 @@ import GHC.Types.SrcLoc import GHC.Types.Var.Env import Control.Monad -import Maybes( isJust ) -import Pair (Pair(..)) +import GHC.Data.Maybe( isJust ) +import GHC.Data.Pair (Pair(..)) import GHC.Types.Unique( hasKey ) import GHC.Driver.Session -import Util +import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import Control.Monad.Trans.Class diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 822ccb2248..0baad1ff4b 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -127,7 +127,7 @@ module GHC.Tc.Solver.Monad ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Types @@ -148,7 +148,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Unify -import ErrUtils +import GHC.Utils.Error import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Core.TyCon @@ -161,10 +161,10 @@ import qualified GHC.Rename.Env as TcM import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set -import Outputable -import Bag +import GHC.Utils.Outputable +import GHC.Data.Bag as Bag import GHC.Types.Unique.Supply -import Util +import GHC.Utils.Misc import GHC.Tc.Types import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint @@ -173,16 +173,16 @@ import GHC.Core.Predicate import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.DFM -import Maybes +import GHC.Data.Maybe import GHC.Core.Map import Control.Monad -import MonadUtils +import GHC.Utils.Monad import Data.IORef import Data.List ( partition, mapAccumL ) #if defined(DEBUG) -import Digraph +import GHC.Data.Graph.Directed import GHC.Types.Unique.Set #endif @@ -2860,7 +2860,7 @@ checkForCyclicBinds ev_binds_map -- It's OK to use nonDetEltsUFM here as -- stronglyConnCompFromEdgedVertices is still deterministic even -- if the edges are in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. + -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. #endif ---------------------------- diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index e69990cb63..1f44338a4c 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -25,7 +25,7 @@ module GHC.Tc.TyCl ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Driver.Types @@ -64,12 +64,12 @@ import GHC.Types.Module import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import Outputable -import Maybes +import GHC.Utils.Outputable +import GHC.Data.Maybe import GHC.Core.Unify -import Util +import GHC.Utils.Misc import GHC.Types.SrcLoc -import ListSetOps +import GHC.Data.List.SetOps import GHC.Driver.Session import GHC.Types.Unique import GHC.Core.ConLike( ConLike(..) ) diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index 908f1398d7..fa0c196504 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -17,7 +17,7 @@ module GHC.Tc.TyCl.Build ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Iface.Env import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) @@ -41,8 +41,8 @@ import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) import GHC.Driver.Session import GHC.Tc.Utils.Monad import GHC.Types.Unique.Supply -import Util -import Outputable +import GHC.Utils.Misc +import GHC.Utils.Outputable mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index 55105f84ff..cedd42916b 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -28,7 +28,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Tc.Utils.Env @@ -56,15 +56,15 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var import GHC.Types.Var.Env -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Core.TyCon -import Maybes +import GHC.Data.Maybe import GHC.Types.Basic -import Bag -import FastString -import BooleanFormula -import Util +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.BooleanFormula +import GHC.Utils.Misc import Control.Monad import Data.List ( mapAccumL, partition ) diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index a716c9671f..22849451bf 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -21,7 +21,7 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Tc.Gen.Bind @@ -61,24 +61,24 @@ import GHC.Core.Class import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set -import Bag +import GHC.Data.Bag import GHC.Types.Basic import GHC.Driver.Session -import ErrUtils -import FastString +import GHC.Utils.Error +import GHC.Data.FastString import GHC.Types.Id -import ListSetOps +import GHC.Data.List.SetOps import GHC.Types.Name import GHC.Types.Name.Set -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc -import Util -import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) +import GHC.Utils.Misc +import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Data.Tuple -import Maybes +import GHC.Data.Maybe import Data.List( mapAccumL ) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 37ba4e3329..00e0beb5e1 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -20,7 +20,7 @@ module GHC.Tc.TyCl.PatSyn ) where -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Tc.Gen.Pat @@ -35,9 +35,9 @@ import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Core.PatSyn import GHC.Types.Name.Set -import Panic -import Outputable -import FastString +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Var import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet ) import GHC.Types.Id @@ -57,9 +57,9 @@ import GHC.Types.Id.Make import GHC.Tc.TyCl.Utils import GHC.Core.ConLike import GHC.Types.FieldLabel -import Bag -import Util -import ErrUtils +import GHC.Data.Bag +import GHC.Utils.Misc +import GHC.Utils.Error import Data.Maybe( mapMaybe ) import Control.Monad ( zipWithM ) import Data.List( partition ) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot index 44be72781d..fb4ac51013 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot @@ -3,7 +3,7 @@ module GHC.Tc.TyCl.PatSyn where import GHC.Hs ( PatSynBind, LHsBinds ) import GHC.Tc.Types ( TcM, TcSigInfo ) import GHC.Tc.Utils.Monad ( TcGblEnv) -import Outputable ( Outputable ) +import GHC.Utils.Outputable ( Outputable ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import Data.Maybe ( Maybe ) diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 5ee3620db1..890222b8aa 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -30,7 +30,7 @@ module GHC.Tc.TyCl.Utils( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env @@ -59,12 +59,12 @@ import GHC.Core.Coercion ( ltRole ) import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Types.Unique ( mkBuiltinUnique ) -import Outputable -import Util -import Maybes -import Bag -import FastString -import FV +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Utils.FV as FV import GHC.Types.Module import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 8c4086a2ca..be345c4f30 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -84,7 +84,7 @@ module GHC.Tc.Types( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Platform import GHC.Hs @@ -102,7 +102,7 @@ import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Deltas) -import IOEnv +import GHC.Data.IOEnv import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Env @@ -113,15 +113,15 @@ import GHC.Types.Var.Env import GHC.Types.Module import GHC.Types.SrcLoc import GHC.Types.Var.Set -import ErrUtils +import GHC.Utils.Error import GHC.Types.Unique.FM import GHC.Types.Basic -import Bag +import GHC.Data.Bag import GHC.Driver.Session -import Outputable -import ListSetOps -import Fingerprint -import Util +import GHC.Utils.Outputable +import GHC.Data.List.SetOps +import GHC.Utils.Fingerprint +import GHC.Utils.Misc import GHC.Builtin.Names ( isUnboundName ) import GHC.Types.CostCentre.State @@ -1167,7 +1167,7 @@ For (static e) to be valid, we need for every 'x' free in 'e', that x's binding is floatable to the top level. Specifically: * x's RhsNames must be empty * x's type has no free variables -See Note [Grand plan for static forms] in StaticPtrTable.hs. +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.hs. This test is made in GHC.Tc.Gen.Expr.checkClosedInStaticForm. Actually knowing x's RhsNames (rather than just its emptiness or otherwise) is just so we can produce better error messages diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs index 3f85594c97..fdfd13e339 100644 --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -70,7 +70,7 @@ module GHC.Tc.Types.Constraint ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Types ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel , setLclEnvLoc, getLclEnvLoc ) @@ -90,15 +90,15 @@ import GHC.Core import GHC.Core.TyCo.Ppr import GHC.Types.Name.Occurrence -import FV +import GHC.Utils.FV import GHC.Types.Var.Set import GHC.Driver.Session import GHC.Types.Basic -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc -import Bag -import Util +import GHC.Data.Bag +import GHC.Utils.Misc import Control.Monad ( msum ) @@ -439,12 +439,12 @@ tyCoVarsOfCt :: Ct -> TcTyCoVarSet tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt -- | Returns free variables of constraints as a deterministically ordered. --- list. See Note [Deterministic FV] in FV. +-- list. See Note [Deterministic FV] in GHC.Utils.FV. tyCoVarsOfCtList :: Ct -> [TcTyCoVar] tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt -- | Returns free variables of constraints as a composable FV computation. --- See Note [Deterministic FV] in FV. +-- See Note [Deterministic FV] in GHC.Utils.FV. tyCoFVsOfCt :: Ct -> FV tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) -- This must consult only the ctPred, so that it gets *tidied* fvs if the @@ -452,34 +452,34 @@ tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) -- fields of the Ct, only the predicate in the CtEvidence. -- | Returns free variables of a bag of constraints as a non-deterministic --- set. See Note [Deterministic FV] in FV. +-- set. See Note [Deterministic FV] in GHC.Utils.FV. tyCoVarsOfCts :: Cts -> TcTyCoVarSet tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts -- | Returns free variables of a bag of constraints as a deterministically --- ordered list. See Note [Deterministic FV] in FV. +-- ordered list. See Note [Deterministic FV] in GHC.Utils.FV. tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts -- | Returns free variables of a bag of constraints as a composable FV --- computation. See Note [Deterministic FV] in FV. +-- computation. See Note [Deterministic FV] in GHC.Utils.FV. tyCoFVsOfCts :: Cts -> FV tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV -- | Returns free variables of WantedConstraints as a non-deterministic --- set. See Note [Deterministic FV] in FV. +-- set. See Note [Deterministic FV] in GHC.Utils.FV. tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet -- Only called on *zonked* things, hence no need to worry about flatten-skolems tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC -- | Returns free variables of WantedConstraints as a deterministically --- ordered list. See Note [Deterministic FV] in FV. +-- ordered list. See Note [Deterministic FV] in GHC.Utils.FV. tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] -- Only called on *zonked* things, hence no need to worry about flatten-skolems tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC -- | Returns free variables of WantedConstraints as a composable FV --- computation. See Note [Deterministic FV] in FV. +-- computation. See Note [Deterministic FV] in GHC.Utils.FV. tyCoFVsOfWC :: WantedConstraints -> FV -- Only called on *zonked* things, hence no need to worry about flatten-skolems tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic }) @@ -487,7 +487,7 @@ tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic }) tyCoFVsOfBag tyCoFVsOfImplic implic -- | Returns free variables of Implication as a composable FV computation. --- See Note [Deterministic FV] in FV. +-- See Note [Deterministic FV] in GHC.Utils.FV. tyCoFVsOfImplic :: Implication -> FV -- Only called on *zonked* things, hence no need to worry about flatten-skolems tyCoFVsOfImplic (Implic { ic_skols = skols diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs index 09f016ca71..1352ceca90 100644 --- a/compiler/GHC/Tc/Types/EvTerm.hs +++ b/compiler/GHC/Tc/Types/EvTerm.hs @@ -4,9 +4,9 @@ module GHC.Tc.Types.EvTerm ( evDelayedError, evCallStack ) where -import GhcPrelude +import GHC.Prelude -import FastString +import GHC.Data.FastString import GHC.Core.Type import GHC.Core import GHC.Core.Make diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs index 922055ebf5..9c7e237ffe 100644 --- a/compiler/GHC/Tc/Types/Evidence.hs +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -53,7 +53,7 @@ module GHC.Tc.Types.Evidence ( ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Var import GHC.Core.Coercion.Axiom @@ -69,16 +69,16 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Predicate import GHC.Types.Name -import Pair +import GHC.Data.Pair import GHC.Core import GHC.Core.Class ( classSCSelId ) import GHC.Core.FVs ( exprSomeFreeVars ) -import Util -import Bag +import GHC.Utils.Misc +import GHC.Data.Bag import qualified Data.Data as Data -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc import Data.IORef( IORef ) import GHC.Types.Unique.Set diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 86427853de..d21f594aef 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -22,7 +22,7 @@ module GHC.Tc.Types.Origin ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.TcType @@ -40,8 +40,8 @@ import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SrcLoc -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Types.Basic {- ********************************************************************* diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index fc134817be..98999e57c8 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -18,7 +18,7 @@ module GHC.Tc.Utils.Backpack ( instantiateSignature, ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) import GHC.Driver.Packages @@ -39,7 +39,7 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin import GHC.Iface.Load import GHC.Rename.Names -import ErrUtils +import GHC.Utils.Error import GHC.Types.Id import GHC.Types.Module import GHC.Types.Name @@ -48,11 +48,11 @@ import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.SrcLoc import GHC.Driver.Types -import Outputable +import GHC.Utils.Outputable import GHC.Core.Type -import FastString +import GHC.Data.FastString import GHC.Rename.Fixity ( lookupFixityRn ) -import Maybes +import GHC.Data.Maybe import GHC.Tc.Utils.Env import GHC.Types.Var import GHC.Iface.Syntax @@ -65,7 +65,7 @@ import GHC.Types.Name.Shape import GHC.Tc.Errors import GHC.Tc.Utils.Unify import GHC.Iface.Rename -import Util +import GHC.Utils.Misc import Control.Monad import Data.List (find) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index cf55316b22..d1a92298db 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -71,7 +71,7 @@ module GHC.Tc.Utils.Env( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Iface.Env @@ -101,15 +101,15 @@ import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Types.Module -import Outputable -import Encoding -import FastString -import Bag -import ListSetOps -import ErrUtils -import Maybes( MaybeErr(..), orElse ) +import GHC.Utils.Outputable +import GHC.Utils.Encoding +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Data.List.SetOps +import GHC.Utils.Error +import GHC.Data.Maybe( MaybeErr(..), orElse ) import qualified GHC.LanguageExtensions as LangExt -import Util ( HasDebugCallStack ) +import GHC.Utils.Misc ( HasDebugCallStack ) import Data.IORef import Data.List (intercalate) diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 7e45b5d947..ea8ffd912b 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -34,13 +34,13 @@ module GHC.Tc.Utils.Instantiate ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckExpr, tcSyntaxOp ) import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind ) import GHC.Types.Basic ( IntegralLit(..), SourceText(..) ) -import FastString +import GHC.Data.FastString import GHC.Hs import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad @@ -70,8 +70,8 @@ import GHC.Types.Var.Env import GHC.Builtin.Names import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session -import Util -import Outputable +import GHC.Utils.Misc +import GHC.Utils.Outputable import GHC.Types.Basic ( TypeOrKind(..) ) import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 918a71594d..60714e4cc1 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -138,15 +138,15 @@ module GHC.Tc.Utils.Monad( -- * Types etc. module GHC.Tc.Types, - module IOEnv + module GHC.Data.IOEnv ) where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Tc.Types -- Re-export all -import IOEnv -- Re-export all +import GHC.Data.IOEnv -- Re-export all import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin @@ -166,20 +166,20 @@ import GHC.Builtin.Names import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Var.Env -import ErrUtils +import GHC.Utils.Error import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set -import Bag -import Outputable +import GHC.Data.Bag +import GHC.Utils.Outputable as Outputable import GHC.Types.Unique.Supply import GHC.Driver.Session -import FastString -import Panic -import Util +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Utils.Misc import GHC.Types.Annotations import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) -import Maybes +import GHC.Data.Maybe import GHC.Types.CostCentre.State import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index d37b37efe3..1189a57cd7 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -94,7 +94,7 @@ module GHC.Tc.Utils.TcMType ( #include "HsVersions.h" -- friends: -import GhcPrelude +import GHC.Prelude import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr @@ -119,18 +119,18 @@ import GHC.Builtin.Types.Prim import GHC.Types.Var.Env import GHC.Types.Name.Env import GHC.Builtin.Names -import Util -import Outputable -import FastString -import Bag -import Pair +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Data.Pair import GHC.Types.Unique.Set import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Basic ( TypeOrKind(..) ) import Control.Monad -import Maybes +import GHC.Data.Maybe import Data.List ( mapAccumL ) import Control.Arrow ( second ) import qualified Data.Semigroup as Semi diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index dc1ef3a69e..693fd1f132 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -189,7 +189,7 @@ module GHC.Tc.Utils.TcType ( #include "HsVersions.h" -- friends: -import GhcPrelude +import GHC.Prelude import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) @@ -217,12 +217,12 @@ import GHC.Builtin.Names import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey , listTyCon, constraintKind ) import GHC.Types.Basic -import Util -import Maybes -import ListSetOps ( getNth, findDupsEq ) -import Outputable -import FastString -import ErrUtils( Validity(..), MsgDoc, isValid ) +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Data.List.SetOps ( getNth, findDupsEq ) +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Utils.Error( Validity(..), MsgDoc, isValid ) import qualified GHC.LanguageExtensions as LangExt import Data.List ( mapAccumL ) diff --git a/compiler/GHC/Tc/Utils/TcType.hs-boot b/compiler/GHC/Tc/Utils/TcType.hs-boot index 481d261f79..dc5f4cf73f 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs-boot +++ b/compiler/GHC/Tc/Utils/TcType.hs-boot @@ -1,5 +1,5 @@ module GHC.Tc.Utils.TcType where -import Outputable( SDoc ) +import GHC.Utils.Outputable( SDoc ) data MetaDetails diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 6a4d61627b..7c14e56319 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -40,7 +40,7 @@ module GHC.Tc.Utils.Unify ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Core.TyCo.Rep @@ -62,13 +62,13 @@ import GHC.Builtin.Types.Prim( tYPE ) import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Var.Env -import ErrUtils +import GHC.Utils.Error import GHC.Driver.Session import GHC.Types.Basic -import Bag -import Util +import GHC.Data.Bag +import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt -import Outputable +import GHC.Utils.Outputable as Outputable import Data.Maybe( isNothing ) import Control.Monad diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot index a281bf136b..36f3367634 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs-boot +++ b/compiler/GHC/Tc/Utils/Unify.hs-boot @@ -1,6 +1,6 @@ module GHC.Tc.Utils.Unify where -import GhcPrelude +import GHC.Prelude import GHC.Tc.Utils.TcType ( TcTauType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Evidence ( TcCoercion ) diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 09caf5fefa..8fbbba22b1 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -46,7 +46,7 @@ module GHC.Tc.Utils.Zonk ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Hs import GHC.Types.Id @@ -74,11 +74,11 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Platform import GHC.Types.Basic -import Maybes +import GHC.Data.Maybe import GHC.Types.SrcLoc -import Bag -import Outputable -import Util +import GHC.Data.Bag +import GHC.Utils.Outputable +import GHC.Utils.Misc import GHC.Types.Unique.FM import GHC.Core diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index c72d4cd357..7b9d1192bd 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -22,9 +22,9 @@ module GHC.Tc.Validity ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Maybes +import GHC.Data.Maybe -- friends: import GHC.Tc.Utils.Unify ( tcSubType_NC ) @@ -59,15 +59,15 @@ import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Var ( VarBndr(..), mkTyVar ) -import FV -import ErrUtils +import GHC.Utils.FV +import GHC.Utils.Error import GHC.Driver.Session -import Util -import ListSetOps +import GHC.Utils.Misc +import GHC.Data.List.SetOps import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable as Outputable import GHC.Types.Unique ( mkAlphaTyVarUnique ) -import Bag ( emptyBag ) +import GHC.Data.Bag ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 622ab13403..aad08d862e 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -24,7 +24,7 @@ module GHC.ThToHs ) where -import GhcPrelude +import GHC.Prelude import GHC.Hs as Hs import GHC.Builtin.Names @@ -40,13 +40,13 @@ import GHC.Builtin.Types import GHC.Types.Basic as Hs import GHC.Types.ForeignCall import GHC.Types.Unique -import ErrUtils -import Bag +import GHC.Utils.Error +import GHC.Data.Bag import GHC.Utils.Lexeme -import Util -import FastString -import Outputable -import MonadUtils ( foldrM ) +import GHC.Utils.Misc +import GHC.Data.FastString +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Monad ( foldrM ) import qualified Data.ByteString as BS import Control.Monad( unless, ap ) diff --git a/compiler/GHC/Types/Annotations.hs b/compiler/GHC/Types/Annotations.hs index 4dde431ab5..c096558651 100644 --- a/compiler/GHC/Types/Annotations.hs +++ b/compiler/GHC/Types/Annotations.hs @@ -17,16 +17,16 @@ module GHC.Types.Annotations ( deserializeAnns ) where -import GhcPrelude +import GHC.Prelude -import Binary +import GHC.Utils.Binary import GHC.Types.Module ( Module , ModuleEnv, emptyModuleEnv, extendModuleEnvWith , plusModuleEnv_C, lookupWithDefaultModuleEnv , mapModuleEnv ) import GHC.Types.Name.Env import GHC.Types.Name -import Outputable +import GHC.Utils.Outputable import GHC.Serialized import Control.Monad diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs index 8730ce2e88..bee35d9395 100644 --- a/compiler/GHC/Types/Avail.hs +++ b/compiler/GHC/Types/Avail.hs @@ -28,17 +28,17 @@ module GHC.Types.Avail ( ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.FieldLabel -import Binary -import ListSetOps -import Outputable -import Util +import GHC.Utils.Binary +import GHC.Data.List.SetOps +import GHC.Utils.Outputable +import GHC.Utils.Misc import Data.Data ( Data ) import Data.List ( find ) diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 103b1940a0..bbffb143cc 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -113,10 +113,10 @@ module GHC.Types.Basic ( TypeOrKind(..), isTypeLevel, isKindLevel ) where -import GhcPrelude +import GHC.Prelude -import FastString -import Outputable +import GHC.Data.FastString +import GHC.Utils.Outputable import GHC.Types.SrcLoc ( Located,unLoc ) import Data.Data hiding (Fixity, Prefix, Infix) import Data.Function (on) diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs index 5280d90d31..a8fb03cef7 100644 --- a/compiler/GHC/Types/CostCentre.hs +++ b/compiler/GHC/Types/CostCentre.hs @@ -20,17 +20,17 @@ module GHC.Types.CostCentre ( cmpCostCentre -- used for removing dups in a list ) where -import GhcPrelude +import GHC.Prelude -import Binary +import GHC.Utils.Binary import GHC.Types.Var import GHC.Types.Name import GHC.Types.Module import GHC.Types.Unique -import Outputable +import GHC.Utils.Outputable import GHC.Types.SrcLoc -import FastString -import Util +import GHC.Data.FastString +import GHC.Utils.Misc import GHC.Types.CostCentre.State import Data.Data diff --git a/compiler/GHC/Types/CostCentre/State.hs b/compiler/GHC/Types/CostCentre/State.hs index 51c364f776..f53034d700 100644 --- a/compiler/GHC/Types/CostCentre/State.hs +++ b/compiler/GHC/Types/CostCentre/State.hs @@ -9,12 +9,12 @@ module GHC.Types.CostCentre.State ) where -import GhcPrelude -import FastString -import FastStringEnv +import GHC.Prelude +import GHC.Data.FastString +import GHC.Data.FastString.Env import Data.Data -import Binary +import GHC.Utils.Binary -- | Per-module state for tracking cost centre indices. -- diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs index e19c86142e..403104b8ad 100644 --- a/compiler/GHC/Types/Cpr.hs +++ b/compiler/GHC/Types/Cpr.hs @@ -8,11 +8,11 @@ module GHC.Types.Cpr ( CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic -import Outputable -import Binary +import GHC.Utils.Outputable +import GHC.Utils.Binary -- -- * CprResult diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 0ecb1b0b72..a382bda18d 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -58,16 +58,16 @@ module GHC.Types.Demand ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable import GHC.Types.Var ( Var ) import GHC.Types.Var.Env import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import GHC.Types.Basic -import Binary -import Maybes ( orElse ) +import GHC.Utils.Binary +import GHC.Data.Maybe ( orElse ) import GHC.Core.Type ( Type ) import GHC.Core.TyCon ( isNewTyCon, isClassTyCon ) diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs index e73877b292..a392af845e 100644 --- a/compiler/GHC/Types/FieldLabel.hs +++ b/compiler/GHC/Types/FieldLabel.hs @@ -71,15 +71,15 @@ module GHC.Types.FieldLabel ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Name.Occurrence import GHC.Types.Name -import FastString -import FastStringEnv -import Outputable -import Binary +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Utils.Outputable +import GHC.Utils.Binary import Data.Data diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs index 46cdfd2af3..0ab67c7b35 100644 --- a/compiler/GHC/Types/ForeignCall.hs +++ b/compiler/GHC/Types/ForeignCall.hs @@ -18,11 +18,11 @@ module GHC.Types.ForeignCall ( Header(..), CType(..), ) where -import GhcPrelude +import GHC.Prelude -import FastString -import Binary -import Outputable +import GHC.Data.FastString +import GHC.Utils.Binary +import GHC.Utils.Outputable import GHC.Types.Module import GHC.Types.Basic ( SourceText, pprWithSourceText ) diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 713f1c6258..ebb762dacd 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -118,7 +118,7 @@ module GHC.Types.Id ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Driver.Session import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, @@ -146,13 +146,13 @@ import GHC.Types.Module import GHC.Core.Class import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) import GHC.Types.ForeignCall -import Maybes +import GHC.Data.Maybe import GHC.Types.SrcLoc -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.Supply -import FastString -import Util +import GHC.Data.FastString +import GHC.Utils.Misc -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index a0a3b94ca9..0e7d2d1b5f 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -84,7 +84,7 @@ module GHC.Types.Id.Info ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Core hiding( hasCoreUnfolding ) import GHC.Core( hasCoreUnfolding ) @@ -99,11 +99,11 @@ import GHC.Core.TyCon import GHC.Core.PatSyn import GHC.Core.Type import GHC.Types.ForeignCall -import Outputable +import GHC.Utils.Outputable import GHC.Types.Module import GHC.Types.Demand import GHC.Types.Cpr -import Util +import GHC.Utils.Misc -- infixl so you can say (id `set` a `set` b) infixl 1 `setRuleInfo`, diff --git a/compiler/GHC/Types/Id/Info.hs-boot b/compiler/GHC/Types/Id/Info.hs-boot index c6912344aa..1b0e130de3 100644 --- a/compiler/GHC/Types/Id/Info.hs-boot +++ b/compiler/GHC/Types/Id/Info.hs-boot @@ -1,6 +1,6 @@ module GHC.Types.Id.Info where -import GhcPrelude -import Outputable +import GHC.Prelude +import GHC.Utils.Outputable data IdInfo data IdDetails diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index d9d137a13b..df62ad5469 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -40,7 +40,7 @@ module GHC.Types.Id.Make ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Builtin.Types.Prim import GHC.Builtin.Types @@ -71,11 +71,11 @@ import GHC.Types.Unique import GHC.Types.Unique.Supply import GHC.Builtin.Names import GHC.Types.Basic hiding ( SuccessFlag(..) ) -import Util +import GHC.Utils.Misc import GHC.Driver.Session -import Outputable -import FastString -import ListSetOps +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Data.List.SetOps import GHC.Types.Var (VarBndr(Bndr)) import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index 9c1d08822d..c31f6349db 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -50,20 +50,20 @@ module GHC.Types.Literal #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Builtin.Types.Prim import GHC.Builtin.Names import GHC.Core.Type import GHC.Core.TyCon -import Outputable -import FastString +import GHC.Utils.Outputable +import GHC.Data.FastString import GHC.Types.Basic -import Binary +import GHC.Utils.Binary import GHC.Settings.Constants import GHC.Platform import GHC.Types.Unique.FM -import Util +import GHC.Utils.Misc import Data.ByteString (ByteString) import Data.Int diff --git a/compiler/GHC/Types/Module.hs b/compiler/GHC/Types/Module.hs index 80ae18684f..76bc026ea3 100644 --- a/compiler/GHC/Types/Module.hs +++ b/compiler/GHC/Types/Module.hs @@ -137,25 +137,25 @@ module GHC.Types.Module unitModuleSet ) where -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique.DSet -import FastString -import Binary -import Util +import GHC.Data.FastString +import GHC.Utils.Binary +import GHC.Utils.Misc import Data.List (sortBy, sort) import Data.Ord import Data.Version import GHC.PackageDb -import Fingerprint +import GHC.Utils.Fingerprint import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 -import Encoding +import GHC.Utils.Encoding import qualified Text.ParserCombinators.ReadP as Parse import Text.ParserCombinators.ReadP (ReadP, (<++)) @@ -168,7 +168,7 @@ import Data.Map (Map) import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified FiniteMap as Map +import qualified GHC.Data.FiniteMap as Map import System.FilePath import {-# SOURCE #-} GHC.Driver.Session (DynFlags) diff --git a/compiler/GHC/Types/Module.hs-boot b/compiler/GHC/Types/Module.hs-boot index 77df64280f..5d30a94f32 100644 --- a/compiler/GHC/Types/Module.hs-boot +++ b/compiler/GHC/Types/Module.hs-boot @@ -1,6 +1,6 @@ module GHC.Types.Module where -import GhcPrelude +import GHC.Prelude data Module data ModuleName diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index 60aee23af8..691a198167 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -79,7 +79,7 @@ module GHC.Types.Name ( module GHC.Types.Name.Occurrence ) where -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing ) @@ -87,11 +87,11 @@ import GHC.Types.Name.Occurrence import GHC.Types.Module import GHC.Types.SrcLoc import GHC.Types.Unique -import Util -import Maybes -import Binary -import FastString -import Outputable +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Binary +import GHC.Data.FastString +import GHC.Utils.Outputable import Control.DeepSeq import Data.Data diff --git a/compiler/GHC/Types/Name.hs-boot b/compiler/GHC/Types/Name.hs-boot index fdd2f62b8d..331dbda5ed 100644 --- a/compiler/GHC/Types/Name.hs-boot +++ b/compiler/GHC/Types/Name.hs-boot @@ -1,5 +1,5 @@ module GHC.Types.Name where -import GhcPrelude () +import GHC.Prelude () data Name diff --git a/compiler/GHC/Types/Name/Cache.hs b/compiler/GHC/Types/Name/Cache.hs index 9cac5eadf1..2d81e048ad 100644 --- a/compiler/GHC/Types/Name/Cache.hs +++ b/compiler/GHC/Types/Name/Cache.hs @@ -10,14 +10,14 @@ module GHC.Types.Name.Cache , NameCache(..), OrigNameCache ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Module import GHC.Types.Name import GHC.Types.Unique.Supply import GHC.Builtin.Types -import Util -import Outputable +import GHC.Utils.Misc +import GHC.Utils.Outputable import GHC.Builtin.Names #include "HsVersions.h" diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs index 25842ab3f1..500c58043d 100644 --- a/compiler/GHC/Types/Name/Env.hs +++ b/compiler/GHC/Types/Name/Env.hs @@ -37,13 +37,13 @@ module GHC.Types.Name.Env ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Digraph +import GHC.Data.Graph.Directed import GHC.Types.Name import GHC.Types.Unique.FM import GHC.Types.Unique.DFM -import Maybes +import GHC.Data.Maybe {- ************************************************************************ @@ -60,7 +60,7 @@ depAnal is deterministic provided it gets the nodes in a deterministic order. The order of lists that get_defs and get_uses return doesn't matter, as these are only used to construct the edges, and stronglyConnCompFromEdgedVertices is deterministic even when the edges are not in deterministic order as explained -in Note [Deterministic SCC] in Digraph. +in Note [Deterministic SCC] in GHC.Data.Graph.Directed. -} depAnal :: forall node. diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index c54770be13..4c5ac689f2 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -101,17 +101,17 @@ module GHC.Types.Name.Occurrence ( FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv ) where -import GhcPrelude +import GHC.Prelude -import Util +import GHC.Utils.Misc import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set -import FastString -import FastStringEnv -import Outputable +import GHC.Data.FastString +import GHC.Data.FastString.Env +import GHC.Utils.Outputable import GHC.Utils.Lexeme -import Binary +import GHC.Utils.Binary import Control.DeepSeq import Data.Char import Data.Data diff --git a/compiler/GHC/Types/Name/Occurrence.hs-boot b/compiler/GHC/Types/Name/Occurrence.hs-boot index 212b58b8e6..ef23bb13fb 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs-boot +++ b/compiler/GHC/Types/Name/Occurrence.hs-boot @@ -1,5 +1,5 @@ module GHC.Types.Name.Occurrence where -import GhcPrelude () +import GHC.Prelude () data OccName diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index 29c427d5f9..274e3a90ce 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -70,21 +70,21 @@ module GHC.Types.Name.Reader ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Module import GHC.Types.Name import GHC.Types.Avail import GHC.Types.Name.Set -import Maybes +import GHC.Data.Maybe import GHC.Types.SrcLoc as SrcLoc -import FastString +import GHC.Data.FastString import GHC.Types.FieldLabel -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set -import Util +import GHC.Utils.Misc import GHC.Types.Name.Env import Data.Data diff --git a/compiler/GHC/Types/Name/Set.hs b/compiler/GHC/Types/Name/Set.hs index 04a8f1effa..c011bcbf23 100644 --- a/compiler/GHC/Types/Name/Set.hs +++ b/compiler/GHC/Types/Name/Set.hs @@ -33,10 +33,10 @@ module GHC.Types.Name.Set ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Name -import OrdList +import GHC.Data.OrdList import GHC.Types.Unique.Set import Data.List (sortBy) diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs index be89bf349c..c7bfd98152 100644 --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -13,9 +13,9 @@ where #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable import GHC.Driver.Types import GHC.Types.Module import GHC.Types.Unique.FM @@ -25,7 +25,7 @@ import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env import GHC.Tc.Utils.Monad -import Util +import GHC.Utils.Misc import GHC.Iface.Env import Control.Monad diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index c1bcb314d3..b883fbb05a 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -23,17 +23,17 @@ module GHC.Types.RepType #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic (Arity, RepArity) import GHC.Core.DataCon -import Outputable +import GHC.Utils.Outputable import GHC.Builtin.Names import GHC.Core.Coercion import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.Type -import Util +import GHC.Utils.Misc import GHC.Builtin.Types.Prim import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind ) diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index 9211104cb3..d61c942397 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -106,12 +106,12 @@ module GHC.Types.SrcLoc ( ) where -import GhcPrelude +import GHC.Prelude -import Util -import Json -import Outputable -import FastString +import GHC.Utils.Misc +import GHC.Utils.Json +import GHC.Utils.Outputable +import GHC.Data.FastString import Control.DeepSeq import Control.Applicative (liftA2) diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs index 574d630ca1..fba286da3f 100644 --- a/compiler/GHC/Types/Unique.hs +++ b/compiler/GHC/Types/Unique.hs @@ -75,12 +75,12 @@ module GHC.Types.Unique ( #include "HsVersions.h" #include "Unique.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Basic -import FastString -import Outputable -import Util +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Utils.Misc -- just for implementing a fast [0,61) -> Char function import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs index 21e2f8249b..8d79626c19 100644 --- a/compiler/GHC/Types/Unique/DFM.hs +++ b/compiler/GHC/Types/Unique/DFM.hs @@ -61,10 +61,10 @@ module GHC.Types.Unique.DFM ( alwaysUnsafeUfmToUdfm, ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) -import Outputable +import GHC.Utils.Outputable import qualified Data.IntMap as M import Data.Data diff --git a/compiler/GHC/Types/Unique/DSet.hs b/compiler/GHC/Types/Unique/DSet.hs index 32d32536df..149f40e06f 100644 --- a/compiler/GHC/Types/Unique/DSet.hs +++ b/compiler/GHC/Types/Unique/DSet.hs @@ -37,9 +37,9 @@ module GHC.Types.Unique.DSet ( mapUniqDSet ) where -import GhcPrelude +import GHC.Prelude -import Outputable +import GHC.Utils.Outputable import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 01ab645783..4dedf468da 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/compiler/GHC/Types/Unique/FM.hs @@ -71,10 +71,10 @@ module GHC.Types.Unique.FM ( pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) -import Outputable +import GHC.Utils.Outputable import qualified Data.IntMap as M import qualified Data.IntSet as S diff --git a/compiler/GHC/Types/Unique/Set.hs b/compiler/GHC/Types/Unique/Set.hs index 1c52a66732..24f8a40e9b 100644 --- a/compiler/GHC/Types/Unique/Set.hs +++ b/compiler/GHC/Types/Unique/Set.hs @@ -46,12 +46,12 @@ module GHC.Types.Unique.Set ( nonDetFoldUniqSet_Directly ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Unique.FM import GHC.Types.Unique import Data.Coerce -import Outputable +import GHC.Utils.Outputable import Data.Data import qualified Data.Semigroup as Semi diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs index 403b88917e..bf4e6dd933 100644 --- a/compiler/GHC/Types/Unique/Supply.hs +++ b/compiler/GHC/Types/Unique/Supply.hs @@ -33,14 +33,14 @@ module GHC.Types.Unique.Supply ( initUniqSupply ) where -import GhcPrelude +import GHC.Prelude import GHC.Types.Unique -import PlainPanic (panic) +import GHC.Utils.Panic.Plain (panic) import GHC.IO -import MonadUtils +import GHC.Utils.Monad import Control.Monad import Data.Bits import Data.Char diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs index 0f91cfd08c..1479856fb4 100644 --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -89,7 +89,7 @@ module GHC.Types.Var ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) @@ -100,9 +100,9 @@ import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCo import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique , mkUniqueGrimily, nonDetCmpUnique ) -import Util -import Binary -import Outputable +import GHC.Utils.Misc +import GHC.Utils.Binary +import GHC.Utils.Outputable import Data.Data diff --git a/compiler/GHC/Types/Var.hs-boot b/compiler/GHC/Types/Var.hs-boot index bf83f8cda6..6ea03efd91 100644 --- a/compiler/GHC/Types/Var.hs-boot +++ b/compiler/GHC/Types/Var.hs-boot @@ -1,12 +1,12 @@ module GHC.Types.Var where -import GhcPrelude () +import GHC.Prelude () -- We compile this module with -XNoImplicitPrelude (for some -- reason), so if there are no imports it does not seem to -- depend on anything. But it does! We must, for example, -- compile GHC.Types in the ghc-prim library first. -- So this otherwise-unnecessary import tells the build system - -- that this module depends on GhcPrelude, which ensures + -- that this module depends on GHC.Prelude, which ensures -- that GHC.Type is built first. data ArgFlag diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index fff3dc897d..883d5bbeca 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -74,7 +74,7 @@ module GHC.Types.Var.Env ( emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList ) where -import GhcPrelude +import GHC.Prelude import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM import GHC.Types.Name.Occurrence @@ -85,9 +85,9 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique -import Util -import Maybes -import Outputable +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Outputable {- ************************************************************************ diff --git a/compiler/GHC/Types/Var/Set.hs b/compiler/GHC/Types/Var/Set.hs index 5126988a2c..5f1ea2e6c4 100644 --- a/compiler/GHC/Types/Var/Set.hs +++ b/compiler/GHC/Types/Var/Set.hs @@ -46,7 +46,7 @@ module GHC.Types.Var.Set ( #include "HsVersions.h" -import GhcPrelude +import GHC.Prelude import GHC.Types.Var ( Var, TyVar, CoVar, TyCoVar, Id ) import GHC.Types.Unique @@ -55,7 +55,7 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.DSet import GHC.Types.Unique.FM( disjointUFM, pluralUFM, pprUFM ) import GHC.Types.Unique.DFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) -import Outputable (SDoc) +import GHC.Utils.Outputable (SDoc) -- | A non-deterministic Variable Set -- diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs new file mode 100644 index 0000000000..7248d84620 --- /dev/null +++ b/compiler/GHC/Unit/Info.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} + +-- | +-- Package configuration information: essentially the interface to Cabal, with +-- some utilities +-- +-- (c) The University of Glasgow, 2004 +-- +module GHC.Unit.Info ( + -- $package_naming + + -- * UnitId + packageConfigId, + expandedUnitInfoId, + definiteUnitInfoId, + installedUnitInfoId, + + -- * The UnitInfo type: information about a unit + UnitInfo, + InstalledPackageInfo(..), + ComponentId(..), + SourcePackageId(..), + PackageName(..), + Version(..), + defaultUnitInfo, + sourcePackageIdString, + packageNameString, + pprUnitInfo, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.PackageDb +import Data.Version + +import GHC.Data.FastString +import GHC.Utils.Outputable +import GHC.Types.Module as Module +import GHC.Types.Unique + +-- ----------------------------------------------------------------------------- +-- Our UnitInfo type is the InstalledPackageInfo from ghc-boot, +-- which is similar to a subset of the InstalledPackageInfo type from Cabal. + +type UnitInfo = InstalledPackageInfo + ComponentId + SourcePackageId + PackageName + Module.InstalledUnitId + Module.UnitId + Module.ModuleName + Module.Module + +-- TODO: there's no need for these to be FastString, as we don't need the uniq +-- feature, but ghc doesn't currently have convenient support for any +-- other compact string types, e.g. plain ByteString or Text. + +newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) +newtype PackageName = PackageName + { unPackageName :: FastString + } + deriving (Eq, Ord) + +instance BinaryStringRep SourcePackageId where + fromStringRep = SourcePackageId . mkFastStringByteString + toStringRep (SourcePackageId s) = bytesFS s + +instance BinaryStringRep PackageName where + fromStringRep = PackageName . mkFastStringByteString + toStringRep (PackageName s) = bytesFS s + +instance Uniquable SourcePackageId where + getUnique (SourcePackageId n) = getUnique n + +instance Uniquable PackageName where + getUnique (PackageName n) = getUnique n + +instance Outputable SourcePackageId where + ppr (SourcePackageId str) = ftext str + +instance Outputable PackageName where + ppr (PackageName str) = ftext str + +defaultUnitInfo :: UnitInfo +defaultUnitInfo = emptyInstalledPackageInfo + +sourcePackageIdString :: UnitInfo -> String +sourcePackageIdString pkg = unpackFS str + where + SourcePackageId str = sourcePackageId pkg + +packageNameString :: UnitInfo -> String +packageNameString pkg = unpackFS str + where + PackageName str = packageName pkg + +pprUnitInfo :: UnitInfo -> SDoc +pprUnitInfo InstalledPackageInfo {..} = + vcat [ + field "name" (ppr packageName), + field "version" (text (showVersion packageVersion)), + field "id" (ppr unitId), + field "exposed" (ppr exposed), + field "exposed-modules" (ppr exposedModules), + field "hidden-modules" (fsep (map ppr hiddenModules)), + field "trusted" (ppr trusted), + field "import-dirs" (fsep (map text importDirs)), + field "library-dirs" (fsep (map text libraryDirs)), + field "dynamic-library-dirs" (fsep (map text libraryDynDirs)), + field "hs-libraries" (fsep (map text hsLibraries)), + field "extra-libraries" (fsep (map text extraLibraries)), + field "extra-ghci-libraries" (fsep (map text extraGHCiLibraries)), + field "include-dirs" (fsep (map text includeDirs)), + field "includes" (fsep (map text includes)), + field "depends" (fsep (map ppr depends)), + field "cc-options" (fsep (map text ccOptions)), + field "ld-options" (fsep (map text ldOptions)), + field "framework-dirs" (fsep (map text frameworkDirs)), + field "frameworks" (fsep (map text frameworks)), + field "haddock-interfaces" (fsep (map text haddockInterfaces)), + field "haddock-html" (fsep (map text haddockHTMLs)) + ] + where + field name body = text name <> colon <+> nest 4 body + +-- ----------------------------------------------------------------------------- +-- UnitId (package names, versions and dep hash) + +-- $package_naming +-- #package_naming# +-- Mostly the compiler deals in terms of 'UnitId's, which are md5 hashes +-- of a package ID, keys of its dependencies, and Cabal flags. You're expected +-- to pass in the unit id in the @-this-unit-id@ flag. However, for +-- wired-in packages like @base@ & @rts@, we don't necessarily know what the +-- version is, so these are handled specially; see #wired_in_packages#. + +-- | Get the GHC 'UnitId' right out of a Cabalish 'UnitInfo' +installedUnitInfoId :: UnitInfo -> InstalledUnitId +installedUnitInfoId = unitId + +packageConfigId :: UnitInfo -> UnitId +packageConfigId p = + if indefinite p + then newUnitId (componentId p) (instantiatedWith p) + else DefiniteUnitId (DefUnitId (unitId p)) + +expandedUnitInfoId :: UnitInfo -> UnitId +expandedUnitInfoId p = + newUnitId (componentId p) (instantiatedWith p) + +definiteUnitInfoId :: UnitInfo -> Maybe DefUnitId +definiteUnitInfoId p = + case packageConfigId p of + DefiniteUnitId def_uid -> Just def_uid + _ -> Nothing diff --git a/compiler/GHC/Utils/Asm.hs b/compiler/GHC/Utils/Asm.hs new file mode 100644 index 0000000000..5b8b209f5e --- /dev/null +++ b/compiler/GHC/Utils/Asm.hs @@ -0,0 +1,21 @@ +-- | Various utilities used in generating assembler. +-- +-- These are used not only by the native code generator, but also by the +-- GHC.Driver.Pipeline +module GHC.Utils.Asm + ( sectionType + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Utils.Outputable + +-- | Generate a section type (e.g. @\@progbits@). See #13937. +sectionType :: Platform -- ^ Target platform + -> String -- ^ section type + -> SDoc -- ^ pretty assembler fragment +sectionType platform ty = + case platformArch platform of + ArchARM{} -> char '%' <> text ty + _ -> char '@' <> text ty diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs new file mode 100644 index 0000000000..1283dd5ffb --- /dev/null +++ b/compiler/GHC/Utils/Binary.hs @@ -0,0 +1,1457 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BangPatterns #-} + +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +module GHC.Utils.Binary + ( {-type-} Bin, + {-class-} Binary(..), + {-type-} BinHandle, + SymbolTable, Dictionary, + + BinData(..), dataHandle, handleData, + + openBinMem, +-- closeBin, + + seekBin, + tellBin, + castBin, + withBinBuffer, + + writeBinMem, + readBinMem, + + putAt, getAt, + + -- * For writing instances + putByte, + getByte, + + -- * Variable length encodings + putULEB128, + getULEB128, + putSLEB128, + getSLEB128, + + -- * Lazy Binary I/O + lazyGet, + lazyPut, + + -- * User data + UserData(..), getUserData, setUserData, + newReadState, newWriteState, + putDictionary, getDictionary, putFS, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Types.Name (Name) +import GHC.Data.FastString +import GHC.Utils.Panic.Plain +import GHC.Types.Unique.FM +import GHC.Data.FastMutInt +import GHC.Utils.Fingerprint +import GHC.Types.Basic +import GHC.Types.SrcLoc + +import Control.DeepSeq +import Foreign +import Data.Array +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Data.IORef +import Data.Char ( ord, chr ) +import Data.Time +import Data.List (unfoldr) +import Type.Reflection +import Type.Reflection.Unsafe +import Data.Kind (Type) +import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) +import Control.Monad ( when, (<$!>), unless ) +import System.IO as IO +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +import GHC.Real ( Ratio(..) ) +import GHC.Serialized + +type BinArray = ForeignPtr Word8 + + + +--------------------------------------------------------------- +-- BinData +--------------------------------------------------------------- + +data BinData = BinData Int BinArray + +instance NFData BinData where + rnf (BinData sz _) = rnf sz + +instance Binary BinData where + put_ bh (BinData sz dat) = do + put_ bh sz + putPrim bh sz $ \dest -> + withForeignPtr dat $ \orig -> + copyBytes dest orig sz + -- + get bh = do + sz <- get bh + dat <- mallocForeignPtrBytes sz + getPrim bh sz $ \orig -> + withForeignPtr dat $ \dest -> + copyBytes dest orig sz + return (BinData sz dat) + +dataHandle :: BinData -> IO BinHandle +dataHandle (BinData size bin) = do + ixr <- newFastMutInt + szr <- newFastMutInt + writeFastMutInt ixr 0 + writeFastMutInt szr size + binr <- newIORef bin + return (BinMem noUserData ixr szr binr) + +handleData :: BinHandle -> IO BinData +handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +data BinHandle + = BinMem { -- binary data stored in an unboxed array + bh_usr :: UserData, -- sigh, need parameterized modules :-) + _off_r :: !FastMutInt, -- the current offset + _sz_r :: !FastMutInt, -- size of the array (cached) + _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) + } + -- XXX: should really store a "high water mark" for dumping out + -- the binary data to a file. + +getUserData :: BinHandle -> UserData +getUserData bh = bh_usr bh + +setUserData :: BinHandle -> UserData -> BinHandle +setUserData bh us = bh { bh_usr = us } + +-- | Get access to the underlying buffer. +-- +-- It is quite important that no references to the 'ByteString' leak out of the +-- continuation lest terrible things happen. +withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a +withBinBuffer (BinMem _ ix_r _ arr_r) action = do + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + withForeignPtr arr $ \ptr -> + BS.unsafePackCStringLen (castPtr ptr, ix) >>= action + + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i) = BinPtr i + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +-- | Do not rely on instance sizes for general types, +-- we use variable length encoding for many of them. +class Binary a where + put_ :: BinHandle -> a -> IO () + put :: BinHandle -> a -> IO (Bin a) + get :: BinHandle -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do _ <- put bh a; return () + put bh a = do p <- tellBin bh; put_ bh a; return p + +putAt :: Binary a => BinHandle -> Bin a -> a -> IO () +putAt bh p x = do seekBin bh p; put_ bh x; return () + +getAt :: Binary a => BinHandle -> Bin a -> IO a +getAt bh p = do seekBin bh p; get bh + +openBinMem :: Int -> IO BinHandle +openBinMem size + | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" + | otherwise = do + arr <- mallocForeignPtrBytes size + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + return (BinMem noUserData ix_r sz_r arr_r) + +tellBin :: BinHandle -> IO (Bin a) +tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +seekBin :: BinHandle -> Bin a -> IO () +seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +writeBinMem :: BinHandle -> FilePath -> IO () +writeBinMem (BinMem _ ix_r _ arr_r) fn = do + h <- openBinaryFile fn WriteMode + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + withForeignPtr arr $ \p -> hPutBuf h p ix + hClose h + +readBinMem :: FilePath -> IO BinHandle +-- Return a BinHandle with a totally undefined State +readBinMem filename = do + h <- openBinaryFile filename ReadMode + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + arr <- mallocForeignPtrBytes filesize + count <- withForeignPtr arr $ \p -> hGetBuf h p filesize + when (count /= filesize) $ + error ("Binary.readBinMem: only read " ++ show count ++ " bytes") + hClose h + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r filesize + return (BinMem noUserData ix_r sz_r arr_r) + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem _ _ sz_r arr_r) !off = do + !sz <- readFastMutInt sz_r + let !sz' = getSize sz + arr <- readIORef arr_r + arr' <- mallocForeignPtrBytes sz' + withForeignPtr arr $ \old -> + withForeignPtr arr' $ \new -> + copyBytes new old sz + writeFastMutInt sz_r sz' + writeIORef arr_r arr' + where + getSize :: Int -> Int + getSize !sz + | sz > off + = sz + | otherwise + = getSize (sz * 2) + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +-- | Takes a size and action writing up to @size@ bytes. +-- After the action has run advance the index to the buffer +-- by size bytes. +putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () +putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix + size > sz) $ + expandBin h (ix + size) + arr <- readIORef arr_r + withForeignPtr arr $ \op -> f (op `plusPtr` ix) + writeFastMutInt ix_r (ix + size) + +-- -- | Similar to putPrim but advances the index by the actual number of +-- -- bytes written. +-- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () +-- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do +-- ix <- readFastMutInt ix_r +-- sz <- readFastMutInt sz_r +-- when (ix + size > sz) $ +-- expandBin h (ix + size) +-- arr <- readIORef arr_r +-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) +-- writeFastMutInt ix_r (ix + written) + +getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a +getPrim (BinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix + size > sz) $ + ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) + arr <- readIORef arr_r + w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) + writeFastMutInt ix_r (ix + size) + return w + +putWord8 :: BinHandle -> Word8 -> IO () +putWord8 h !w = putPrim h 1 (\op -> poke op w) + +getWord8 :: BinHandle -> IO Word8 +getWord8 h = getPrim h 1 peek + +-- putWord16 :: BinHandle -> Word16 -> IO () +-- putWord16 h w = putPrim h 2 (\op -> do +-- pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) +-- pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) +-- ) + +-- getWord16 :: BinHandle -> IO Word16 +-- getWord16 h = getPrim h 2 (\op -> do +-- w0 <- fromIntegral <$> peekElemOff op 0 +-- w1 <- fromIntegral <$> peekElemOff op 1 +-- return $! w0 `shiftL` 8 .|. w1 +-- ) + +putWord32 :: BinHandle -> Word32 -> IO () +putWord32 h w = putPrim h 4 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) + ) + +getWord32 :: BinHandle -> IO Word32 +getWord32 h = getPrim h 4 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + + return $! (w0 `shiftL` 24) .|. + (w1 `shiftL` 16) .|. + (w2 `shiftL` 8) .|. + w3 + ) + +-- putWord64 :: BinHandle -> Word64 -> IO () +-- putWord64 h w = putPrim h 8 (\op -> do +-- pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) +-- pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) +-- pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) +-- pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) +-- pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) +-- pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) +-- pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) +-- pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) +-- ) + +-- getWord64 :: BinHandle -> IO Word64 +-- getWord64 h = getPrim h 8 (\op -> do +-- w0 <- fromIntegral <$> peekElemOff op 0 +-- w1 <- fromIntegral <$> peekElemOff op 1 +-- w2 <- fromIntegral <$> peekElemOff op 2 +-- w3 <- fromIntegral <$> peekElemOff op 3 +-- w4 <- fromIntegral <$> peekElemOff op 4 +-- w5 <- fromIntegral <$> peekElemOff op 5 +-- w6 <- fromIntegral <$> peekElemOff op 6 +-- w7 <- fromIntegral <$> peekElemOff op 7 + +-- return $! (w0 `shiftL` 56) .|. +-- (w1 `shiftL` 48) .|. +-- (w2 `shiftL` 40) .|. +-- (w3 `shiftL` 32) .|. +-- (w4 `shiftL` 24) .|. +-- (w5 `shiftL` 16) .|. +-- (w6 `shiftL` 8) .|. +-- w7 +-- ) + +putByte :: BinHandle -> Word8 -> IO () +putByte bh !w = putWord8 bh w + +getByte :: BinHandle -> IO Word8 +getByte h = getWord8 h + +-- ----------------------------------------------------------------------------- +-- Encode numbers in LEB128 encoding. +-- Requires one byte of space per 7 bits of data. +-- +-- There are signed and unsigned variants. +-- Do NOT use the unsigned one for signed values, at worst it will +-- result in wrong results, at best it will lead to bad performance +-- when coercing negative values to an unsigned type. +-- +-- We mark them as SPECIALIZE as it's extremely critical that they get specialized +-- to their specific types. +-- +-- TODO: Each use of putByte performs a bounds check, +-- we should use putPrimMax here. However it's quite hard to return +-- the number of bytes written into putPrimMax without allocating an +-- Int for it, while the code below does not allocate at all. +-- So we eat the cost of the bounds check instead of increasing allocations +-- for now. + +-- Unsigned numbers +{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-} +putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO () +putULEB128 bh w = +#if defined(DEBUG) + (if w < 0 then panic "putULEB128: Signed number" else id) $ +#endif + go w + where + go :: a -> IO () + go w + | w <= (127 :: a) + = putByte bh (fromIntegral w :: Word8) + | otherwise = do + -- bit 7 (8th bit) indicates more to come. + let !byte = setBit (fromIntegral w) 7 :: Word8 + putByte bh byte + go (w `unsafeShiftR` 7) + +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-} +{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-} +getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a +getULEB128 bh = + go 0 0 + where + go :: Int -> a -> IO a + go shift w = do + b <- getByte bh + let !hasMore = testBit b 7 + let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a + if hasMore + then do + go (shift+7) val + else + return $! val + +-- Signed numbers +{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-} +putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO () +putSLEB128 bh initial = go initial + where + go :: a -> IO () + go val = do + let !byte = fromIntegral (clearBit val 7) :: Word8 + let !val' = val `unsafeShiftR` 7 + let !signBit = testBit byte 6 + let !done = + -- Unsigned value, val' == 0 and last value can + -- be discriminated from a negative number. + ((val' == 0 && not signBit) || + -- Signed value, + (val' == -1 && signBit)) + + let !byte' = if done then byte else setBit byte 7 + putByte bh byte' + + unless done $ go val' + +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-} +{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-} +getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a +getSLEB128 bh = do + (val,shift,signed) <- go 0 0 + if signed && (shift < finiteBitSize val ) + then return $! ((complement 0 `unsafeShiftL` shift) .|. val) + else return val + where + go :: Int -> a -> IO (a,Int,Bool) + go shift val = do + byte <- getByte bh + let !byteVal = fromIntegral (clearBit byte 7) :: a + let !val' = val .|. (byteVal `unsafeShiftL` shift) + let !more = testBit byte 7 + let !shift' = shift+7 + if more + then go (shift') val' + else do + let !signed = testBit byte 6 + return (val',shift',signed) + +-- ----------------------------------------------------------------------------- +-- Primitive Word writes + +instance Binary Word8 where + put_ bh !w = putWord8 bh w + get = getWord8 + +instance Binary Word16 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word32 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word64 where + put_ = putULEB128 + get = getULEB128 + +-- ----------------------------------------------------------------------------- +-- Primitive Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int32 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int64 where + put_ h w = putSLEB128 h w + get h = getSLEB128 h + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ _ () = return () + get _ = return () + +instance Binary Bool where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) + +instance Binary Int where + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) + +instance Binary a => Binary [a] where + put_ bh l = do + let len = length l + put_ bh len + mapM_ (put_ bh) l + get bh = do + len <- get bh :: IO Int -- Int is variable length encoded so only + -- one byte for small lists. + let loop 0 = return [] + loop n = do a <- get bh; as <- loop (n-1); return (a:as) + loop len + +instance (Ix a, Binary a, Binary b) => Binary (Array a b) where + put_ bh arr = do + put_ bh $ bounds arr + put_ bh $ elems arr + get bh = do + bounds <- get bh + xs <- get bh + return $ listArray bounds xs + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where + put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where + put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where + put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + g <- get bh + return (a,b,c,d,e,f,g) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = putByte bh 0 + put_ bh (Just a) = do putByte bh 1; put_ bh a + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do putByte bh 0; put_ bh a + put_ bh (Right b) = do putByte bh 1; put_ bh b + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance Binary UTCTime where + put_ bh u = do put_ bh (utctDay u) + put_ bh (utctDayTime u) + get bh = do day <- get bh + dayTime <- get bh + return $ UTCTime { utctDay = day, utctDayTime = dayTime } + +instance Binary Day where + put_ bh d = put_ bh (toModifiedJulianDay d) + get bh = do i <- get bh + return $ ModifiedJulianDay { toModifiedJulianDay = i } + +instance Binary DiffTime where + put_ bh dt = put_ bh (toRational dt) + get bh = do r <- get bh + return $ fromRational r + +{- +Finally - a reasonable portable Integer instance. + +We used to encode values in the Int32 range as such, +falling back to a string of all things. In either case +we stored a tag byte to discriminate between the two cases. + +This made some sense as it's highly portable but also not very +efficient. + +However GHC stores a surprisingly large number off large Integer +values. In the examples looked at between 25% and 50% of Integers +serialized were outside of the Int32 range. + +Consider a valie like `2724268014499746065`, some sort of hash +actually generated by GHC. +In the old scheme this was encoded as a list of 19 chars. This +gave a size of 77 Bytes, one for the length of the list and 76 +since we encode chars as Word32 as well. + +We can easily do better. The new plan is: + +* Start with a tag byte + * 0 => Int64 (LEB128 encoded) + * 1 => Negative large interger + * 2 => Positive large integer +* Followed by the value: + * Int64 is encoded as usual + * Large integers are encoded as a list of bytes (Word8). + We use Data.Bits which defines a bit order independent of the representation. + Values are stored LSB first. + +This means our example value `2724268014499746065` is now only 10 bytes large. +* One byte tag +* One byte for the length of the [Word8] list. +* 8 bytes for the actual date. + +The new scheme also does not depend in any way on +architecture specific details. + +We still use this scheme even with LEB128 available, +as it has less overhead for truly large numbers. (> maxBound :: Int64) + +The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal +-} + +instance Binary Integer where + put_ bh i + | i >= lo64 && i <= hi64 = do + putWord8 bh 0 + put_ bh (fromIntegral i :: Int64) + | otherwise = do + if i < 0 + then putWord8 bh 1 + else putWord8 bh 2 + put_ bh (unroll $ abs i) + where + lo64 = fromIntegral (minBound :: Int64) + hi64 = fromIntegral (maxBound :: Int64) + get bh = do + int_kind <- getWord8 bh + case int_kind of + 0 -> fromIntegral <$!> (get bh :: IO Int64) + -- Large integer + 1 -> negate <$!> getInt + 2 -> getInt + _ -> panic "Binary Integer - Invalid byte" + where + getInt :: IO Integer + getInt = roll <$!> (get bh :: IO [Word8]) + +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldl' unstep 0 . reverse + where + unstep a b = a `shiftL` 8 .|. fromIntegral b + + + {- + -- This code is currently commented out. + -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for + -- discussion. + + put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) + put_ bh (J# s# a#) = do + putByte bh 1 + put_ bh (I# s#) + let sz# = sizeofByteArray# a# -- in *bytes* + put_ bh (I# sz#) -- in *bytes* + putByteArray bh a# sz# + + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () +putByteArray bh a s# = loop 0# + where loop n# + | n# ==# s# = return () + | otherwise = do + putByte bh (indexByteArray a n#) + loop (n# +# 1#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + -} + +{- +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () +writeByteArray arr i (W8# w) = IO $ \s -> + case writeWord8Array# arr i w s of { s -> + (# s, () #) } + +indexByteArray :: ByteArray# -> Int# -> Word8 +indexByteArray a# n# = W8# (indexWord8Array# a# n#) + +-} +instance (Binary a) => Binary (Ratio a) where + put_ bh (a :% b) = do put_ bh a; put_ bh b + get bh = do a <- get bh; b <- get bh; return (a :% b) + +-- Instance uses fixed-width encoding to allow inserting +-- Bin placeholders in the stream. +instance Binary (Bin a) where + put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) + get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) + +-- ----------------------------------------------------------------------------- +-- Instances for Data.Typeable stuff + +instance Binary TyCon where + put_ bh tc = do + put_ bh (tyConPackage tc) + put_ bh (tyConModule tc) + put_ bh (tyConName tc) + put_ bh (tyConKindArgs tc) + put_ bh (tyConKindRep tc) + get bh = + mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh + +instance Binary VecCount where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary VecElem where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary RuntimeRep where + put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b + put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps + put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps + put_ bh LiftedRep = putByte bh 3 + put_ bh UnliftedRep = putByte bh 4 + put_ bh IntRep = putByte bh 5 + put_ bh WordRep = putByte bh 6 + put_ bh Int64Rep = putByte bh 7 + put_ bh Word64Rep = putByte bh 8 + put_ bh AddrRep = putByte bh 9 + put_ bh FloatRep = putByte bh 10 + put_ bh DoubleRep = putByte bh 11 + put_ bh Int8Rep = putByte bh 12 + put_ bh Word8Rep = putByte bh 13 + put_ bh Int16Rep = putByte bh 14 + put_ bh Word16Rep = putByte bh 15 +#if __GLASGOW_HASKELL__ >= 809 + put_ bh Int32Rep = putByte bh 16 + put_ bh Word32Rep = putByte bh 17 +#endif + + get bh = do + tag <- getByte bh + case tag of + 0 -> VecRep <$> get bh <*> get bh + 1 -> TupleRep <$> get bh + 2 -> SumRep <$> get bh + 3 -> pure LiftedRep + 4 -> pure UnliftedRep + 5 -> pure IntRep + 6 -> pure WordRep + 7 -> pure Int64Rep + 8 -> pure Word64Rep + 9 -> pure AddrRep + 10 -> pure FloatRep + 11 -> pure DoubleRep + 12 -> pure Int8Rep + 13 -> pure Word8Rep + 14 -> pure Int16Rep + 15 -> pure Word16Rep +#if __GLASGOW_HASKELL__ >= 809 + 16 -> pure Int32Rep + 17 -> pure Word32Rep +#endif + _ -> fail "Binary.putRuntimeRep: invalid tag" + +instance Binary KindRep where + put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k + put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr + put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b + put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b + put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r + put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r + + get bh = do + tag <- getByte bh + case tag of + 0 -> KindRepTyConApp <$> get bh <*> get bh + 1 -> KindRepVar <$> get bh + 2 -> KindRepApp <$> get bh <*> get bh + 3 -> KindRepFun <$> get bh <*> get bh + 4 -> KindRepTYPE <$> get bh + 5 -> KindRepTypeLit <$> get bh <*> get bh + _ -> fail "Binary.putKindRep: invalid tag" + +instance Binary TypeLitSort where + put_ bh TypeLitSymbol = putByte bh 0 + put_ bh TypeLitNat = putByte bh 1 + get bh = do + tag <- getByte bh + case tag of + 0 -> pure TypeLitSymbol + 1 -> pure TypeLitNat + _ -> fail "Binary.putTypeLitSort: invalid tag" + +putTypeRep :: BinHandle -> TypeRep a -> IO () +-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind +-- relations. +-- See Note [Mutually recursive representations of primitive types] +putTypeRep bh rep + | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) + = put_ bh (0 :: Word8) +putTypeRep bh (Con' con ks) = do + put_ bh (1 :: Word8) + put_ bh con + put_ bh ks +putTypeRep bh (App f x) = do + put_ bh (2 :: Word8) + putTypeRep bh f + putTypeRep bh x +putTypeRep bh (Fun arg res) = do + put_ bh (3 :: Word8) + putTypeRep bh arg + putTypeRep bh res + +getSomeTypeRep :: BinHandle -> IO SomeTypeRep +getSomeTypeRep bh = do + tag <- get bh :: IO Word8 + case tag of + 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) + 1 -> do con <- get bh :: IO TyCon + ks <- get bh :: IO [SomeTypeRep] + return $ SomeTypeRep $ mkTrCon con ks + + 2 -> do SomeTypeRep f <- getSomeTypeRep bh + SomeTypeRep x <- getSomeTypeRep bh + case typeRepKind f of + Fun arg res -> + case arg `eqTypeRep` typeRepKind x of + Just HRefl -> + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $ SomeTypeRep $ mkTrApp f x + _ -> failure "Kind mismatch in type application" [] + _ -> failure "Kind mismatch in type application" + [ " Found argument of kind: " ++ show (typeRepKind x) + , " Where the constructor: " ++ show f + , " Expects kind: " ++ show arg + ] + _ -> failure "Applied non-arrow" + [ " Applied type: " ++ show f + , " To argument: " ++ show x + ] + 3 -> do SomeTypeRep arg <- getSomeTypeRep bh + SomeTypeRep res <- getSomeTypeRep bh + if + | App argkcon _ <- typeRepKind arg + , App reskcon _ <- typeRepKind res + , Just HRefl <- argkcon `eqTypeRep` tYPErep + , Just HRefl <- reskcon `eqTypeRep` tYPErep + -> return $ SomeTypeRep $ Fun arg res + | otherwise -> failure "Kind mismatch" [] + _ -> failure "Invalid SomeTypeRep" [] + where + tYPErep :: TypeRep TYPE + tYPErep = typeRep + + failure description info = + fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ] + ++ map (" "++) info + +instance Typeable a => Binary (TypeRep (a :: k)) where + put_ = putTypeRep + get bh = do + SomeTypeRep rep <- getSomeTypeRep bh + case rep `eqTypeRep` expected of + Just HRefl -> pure rep + Nothing -> fail $ unlines + [ "Binary: Type mismatch" + , " Deserialized type: " ++ show rep + , " Expected type: " ++ show expected + ] + where expected = typeRep :: TypeRep a + +instance Binary SomeTypeRep where + put_ bh (SomeTypeRep rep) = putTypeRep bh rep + get = getSomeTypeRep + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyPut :: Binary a => BinHandle -> a -> IO () +lazyPut bh a = do + -- output the obj with a ptr to skip over it: + pre_a <- tellBin bh + put_ bh pre_a -- save a slot for the ptr + put_ bh a -- dump the object + q <- tellBin bh -- q = ptr to after object + putAt bh pre_a q -- fill in slot before a with ptr to q + seekBin bh q -- finally carry on writing at q + +lazyGet :: Binary a => BinHandle -> IO a +lazyGet bh = do + p <- get bh -- a BinPtr + p_a <- tellBin bh + a <- unsafeInterleaveIO $ do + -- NB: Use a fresh off_r variable in the child thread, for thread + -- safety. + off_r <- newFastMutInt + getAt bh { _off_r = off_r } p_a + seekBin bh p -- skip over the object for now + return a + +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +-- | Information we keep around during interface file +-- serialization/deserialization. Namely we keep the functions for serializing +-- and deserializing 'Name's and 'FastString's. We do this because we actually +-- use serialization in two distinct settings, +-- +-- * When serializing interface files themselves +-- +-- * When computing the fingerprint of an IfaceDecl (which we computing by +-- hashing its Binary serialization) +-- +-- These two settings have different needs while serializing Names: +-- +-- * Names in interface files are serialized via a symbol table (see Note +-- [Symbol table representation of names] in GHC.Iface.Binary). +-- +-- * During fingerprinting a binding Name is serialized as the OccName and a +-- non-binding Name is serialized as the fingerprint of the thing they +-- represent. See Note [Fingerprinting IfaceDecls] for further discussion. +-- +data UserData = + UserData { + -- for *deserialising* only: + ud_get_name :: BinHandle -> IO Name, + ud_get_fs :: BinHandle -> IO FastString, + + -- for *serialising* only: + ud_put_nonbinding_name :: BinHandle -> Name -> IO (), + -- ^ serialize a non-binding 'Name' (e.g. a reference to another + -- binding). + ud_put_binding_name :: BinHandle -> Name -> IO (), + -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) + ud_put_fs :: BinHandle -> FastString -> IO () + } + +newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's + -> (BinHandle -> IO FastString) + -> UserData +newReadState get_name get_fs + = UserData { ud_get_name = get_name, + ud_get_fs = get_fs, + ud_put_nonbinding_name = undef "put_nonbinding_name", + ud_put_binding_name = undef "put_binding_name", + ud_put_fs = undef "put_fs" + } + +newWriteState :: (BinHandle -> Name -> IO ()) + -- ^ how to serialize non-binding 'Name's + -> (BinHandle -> Name -> IO ()) + -- ^ how to serialize binding 'Name's + -> (BinHandle -> FastString -> IO ()) + -> UserData +newWriteState put_nonbinding_name put_binding_name put_fs + = UserData { ud_get_name = undef "get_name", + ud_get_fs = undef "get_fs", + ud_put_nonbinding_name = put_nonbinding_name, + ud_put_binding_name = put_binding_name, + ud_put_fs = put_fs + } + +noUserData :: a +noUserData = undef "UserData" + +undef :: String -> a +undef s = panic ("Binary.UserData: no " ++ s) + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +type Dictionary = Array Int FastString -- The dictionary + -- Should be 0-indexed + +putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO () +putDictionary bh sz dict = do + put_ bh sz + mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) + -- It's OK to use nonDetEltsUFM here because the elements have indices + -- that array uses to create order + +getDictionary :: BinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh + elems <- sequence (take sz (repeat (getFS bh))) + return (listArray (0,sz-1) elems) + +--------------------------------------------------------- +-- The Symbol Table +--------------------------------------------------------- + +-- On disk, the symbol table is an array of IfExtName, when +-- reading it in we turn it into a SymbolTable. + +type SymbolTable = Array Int Name + +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + +putFS :: BinHandle -> FastString -> IO () +putFS bh fs = putBS bh $ bytesFS fs + +getFS :: BinHandle -> IO FastString +getFS bh = do + l <- get bh :: IO Int + getPrim bh l (\src -> pure $! mkFastStringBytes src l ) + +putBS :: BinHandle -> ByteString -> IO () +putBS bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + put_ bh l + putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) + +getBS :: BinHandle -> IO ByteString +getBS bh = do + l <- get bh :: IO Int + BS.create l $ \dest -> do + getPrim bh l (\src -> BS.memcpy dest src l) + +instance Binary ByteString where + put_ bh f = putBS bh f + get bh = getBS bh + +instance Binary FastString where + put_ bh f = + case getUserData bh of + UserData { ud_put_fs = put_fs } -> put_fs bh f + + get bh = + case getUserData bh of + UserData { ud_get_fs = get_fs } -> get_fs bh + +-- Here to avoid loop +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + +instance Binary PromotionFlag where + put_ bh NotPromoted = putByte bh 0 + put_ bh IsPromoted = putByte bh 1 + + get bh = do + n <- getByte bh + case n of + 0 -> return NotPromoted + 1 -> return IsPromoted + _ -> fail "Binary(IsPromoted): fail)" + +instance Binary Fingerprint where + put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 + get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) + +instance Binary FunctionOrData where + put_ bh IsFunction = putByte bh 0 + put_ bh IsData = putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> return IsFunction + 1 -> return IsData + _ -> panic "Binary FunctionOrData" + +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh ConstraintTuple = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return BoxedTuple + 1 -> do return UnboxedTuple + _ -> do return ConstraintTuple + +instance Binary Activation where + put_ bh NeverActive = do + putByte bh 0 + put_ bh AlwaysActive = do + putByte bh 1 + put_ bh (ActiveBefore src aa) = do + putByte bh 2 + put_ bh src + put_ bh aa + put_ bh (ActiveAfter src ab) = do + putByte bh 3 + put_ bh src + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do return NeverActive + 1 -> do return AlwaysActive + 2 -> do src <- get bh + aa <- get bh + return (ActiveBefore src aa) + _ -> do src <- get bh + ab <- get bh + return (ActiveAfter src ab) + +instance Binary InlinePragma where + put_ bh (InlinePragma s a b c d) = do + put_ bh s + put_ bh a + put_ bh b + put_ bh c + put_ bh d + + get bh = do + s <- get bh + a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (InlinePragma s a b c d) + +instance Binary RuleMatchInfo where + put_ bh FunLike = putByte bh 0 + put_ bh ConLike = putByte bh 1 + get bh = do + h <- getByte bh + if h == 1 then return ConLike + else return FunLike + +instance Binary InlineSpec where + put_ bh NoUserInline = putByte bh 0 + put_ bh Inline = putByte bh 1 + put_ bh Inlinable = putByte bh 2 + put_ bh NoInline = putByte bh 3 + + get bh = do h <- getByte bh + case h of + 0 -> return NoUserInline + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline + +instance Binary RecFlag where + put_ bh Recursive = do + putByte bh 0 + put_ bh NonRecursive = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return Recursive + _ -> do return NonRecursive + +instance Binary OverlapMode where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + get bh = do + h <- getByte bh + case h of + 0 -> (get bh) >>= \s -> return $ NoOverlap s + 1 -> (get bh) >>= \s -> return $ Overlaps s + 2 -> (get bh) >>= \s -> return $ Incoherent s + 3 -> (get bh) >>= \s -> return $ Overlapping s + 4 -> (get bh) >>= \s -> return $ Overlappable s + _ -> panic ("get OverlapMode" ++ show h) + + +instance Binary OverlapFlag where + put_ bh flag = do put_ bh (overlapMode flag) + put_ bh (isSafeOverlap flag) + get bh = do + h <- get bh + b <- get bh + return OverlapFlag { overlapMode = h, isSafeOverlap = b } + +instance Binary FixityDirection where + put_ bh InfixL = do + putByte bh 0 + put_ bh InfixR = do + putByte bh 1 + put_ bh InfixN = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return InfixL + 1 -> do return InfixR + _ -> do return InfixN + +instance Binary Fixity where + put_ bh (Fixity src aa ab) = do + put_ bh src + put_ bh aa + put_ bh ab + get bh = do + src <- get bh + aa <- get bh + ab <- get bh + return (Fixity src aa ab) + +instance Binary WarningTxt where + put_ bh (WarningTxt s w) = do + putByte bh 0 + put_ bh s + put_ bh w + put_ bh (DeprecatedTxt s d) = do + putByte bh 1 + put_ bh s + put_ bh d + + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + w <- get bh + return (WarningTxt s w) + _ -> do s <- get bh + d <- get bh + return (DeprecatedTxt s d) + +instance Binary StringLiteral where + put_ bh (StringLiteral st fs) = do + put_ bh st + put_ bh fs + get bh = do + st <- get bh + fs <- get bh + return (StringLiteral st fs) + +instance Binary a => Binary (Located a) where + put_ bh (L l x) = do + put_ bh l + put_ bh x + + get bh = do + l <- get bh + x <- get bh + return (L l x) + +instance Binary RealSrcSpan where + put_ bh ss = do + put_ bh (srcSpanFile ss) + put_ bh (srcSpanStartLine ss) + put_ bh (srcSpanStartCol ss) + put_ bh (srcSpanEndLine ss) + put_ bh (srcSpanEndCol ss) + + get bh = do + f <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + return (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) + +instance Binary BufPos where + put_ bh (BufPos i) = put_ bh i + get bh = BufPos <$> get bh + +instance Binary BufSpan where + put_ bh (BufSpan start end) = do + put_ bh start + put_ bh end + get bh = do + start <- get bh + end <- get bh + return (BufSpan start end) + +instance Binary SrcSpan where + put_ bh (RealSrcSpan ss sb) = do + putByte bh 0 + put_ bh ss + put_ bh sb + + put_ bh (UnhelpfulSpan s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> do ss <- get bh + sb <- get bh + return (RealSrcSpan ss sb) + _ -> do s <- get bh + return (UnhelpfulSpan s) + +instance Binary Serialized where + put_ bh (Serialized the_type bytes) = do + put_ bh the_type + put_ bh bytes + get bh = do + the_type <- get bh + bytes <- get bh + return (Serialized the_type bytes) + +instance Binary SourceText where + put_ bh NoSourceText = putByte bh 0 + put_ bh (SourceText s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return NoSourceText + 1 -> do + s <- get bh + return (SourceText s) + _ -> panic $ "Binary SourceText:" ++ show h diff --git a/compiler/GHC/Utils/BufHandle.hs b/compiler/GHC/Utils/BufHandle.hs new file mode 100644 index 0000000000..b0b829f96f --- /dev/null +++ b/compiler/GHC/Utils/BufHandle.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- +-- Fast write-buffered Handles +-- +-- (c) The University of Glasgow 2005-2006 +-- +-- This is a simple abstraction over Handles that offers very fast write +-- buffering, but without the thread safety that Handles provide. It's used +-- to save time in GHC.Utils.Ppr.printDoc. +-- +----------------------------------------------------------------------------- + +module GHC.Utils.BufHandle ( + BufHandle(..), + newBufHandle, + bPutChar, + bPutStr, + bPutFS, + bPutFZS, + bPutPtrString, + bPutReplicate, + bFlush, + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import Control.Monad ( when ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Unsafe as BS +import Data.Char ( ord ) +import Foreign +import Foreign.C.String +import System.IO + +-- ----------------------------------------------------------------------------- + +data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) + {-#UNPACK#-}!FastMutInt + Handle + +newBufHandle :: Handle -> IO BufHandle +newBufHandle hdl = do + ptr <- mallocBytes buf_size + r <- newFastMutInt + writeFastMutInt r 0 + return (BufHandle ptr r hdl) + +buf_size :: Int +buf_size = 8192 + +bPutChar :: BufHandle -> Char -> IO () +bPutChar b@(BufHandle buf r hdl) !c = do + i <- readFastMutInt r + if (i >= buf_size) + then do hPutBuf hdl buf buf_size + writeFastMutInt r 0 + bPutChar b c + else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) + writeFastMutInt r (i+1) + +bPutStr :: BufHandle -> String -> IO () +bPutStr (BufHandle buf r hdl) !str = do + i <- readFastMutInt r + loop str i + where loop "" !i = do writeFastMutInt r i; return () + loop (c:cs) !i + | i >= buf_size = do + hPutBuf hdl buf buf_size + loop (c:cs) 0 + | otherwise = do + pokeElemOff buf i (fromIntegral (ord c)) + loop cs (i+1) + +bPutFS :: BufHandle -> FastString -> IO () +bPutFS b fs = bPutBS b $ bytesFS fs + +bPutFZS :: BufHandle -> FastZString -> IO () +bPutFZS b fs = bPutBS b $ fastZStringToByteString fs + +bPutBS :: BufHandle -> ByteString -> IO () +bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b + +bPutCStringLen :: BufHandle -> CStringLen -> IO () +bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do + i <- readFastMutInt r + if (i + len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl ptr len + else bPutCStringLen b cstr + else do + copyBytes (buf `plusPtr` i) ptr len + writeFastMutInt r (i + len) + +bPutPtrString :: BufHandle -> PtrString -> IO () +bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do + i <- readFastMutInt r + if (i+len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl a len + else bPutPtrString b l + else do + copyBytes (buf `plusPtr` i) a len + writeFastMutInt r (i+len) + +-- | Replicate an 8-bit character +bPutReplicate :: BufHandle -> Int -> Char -> IO () +bPutReplicate (BufHandle buf r hdl) len c = do + i <- readFastMutInt r + let oc = fromIntegral (ord c) + if (i+len) < buf_size + then do + fillBytes (buf `plusPtr` i) oc len + writeFastMutInt r (i+len) + else do + -- flush the current buffer + when (i /= 0) $ hPutBuf hdl buf i + if (len < buf_size) + then do + fillBytes buf oc len + writeFastMutInt r len + else do + -- fill a full buffer + fillBytes buf oc buf_size + -- flush it as many times as necessary + let go n | n >= buf_size = do + hPutBuf hdl buf buf_size + go (n-buf_size) + | otherwise = writeFastMutInt r n + go len + +bFlush :: BufHandle -> IO () +bFlush (BufHandle buf r hdl) = do + i <- readFastMutInt r + when (i > 0) $ hPutBuf hdl buf i + free buf + return () diff --git a/compiler/GHC/Utils/CliOption.hs b/compiler/GHC/Utils/CliOption.hs new file mode 100644 index 0000000000..9f2333d351 --- /dev/null +++ b/compiler/GHC/Utils/CliOption.hs @@ -0,0 +1,27 @@ +module GHC.Utils.CliOption + ( Option (..) + , showOpt + ) where + +import GHC.Prelude + +-- ----------------------------------------------------------------------------- +-- Command-line options + +-- | When invoking external tools as part of the compilation pipeline, we +-- pass these a sequence of options on the command-line. Rather than +-- just using a list of Strings, we use a type that allows us to distinguish +-- between filepaths and 'other stuff'. The reason for this is that +-- this type gives us a handle on transforming filenames, and filenames only, +-- to whatever format they're expected to be on a particular platform. +data Option + = FileOption -- an entry that _contains_ filename(s) / filepaths. + String -- a non-filepath prefix that shouldn't be + -- transformed (e.g., "/out=") + String -- the filepath/filename portion + | Option String + deriving ( Eq ) + +showOpt :: Option -> String +showOpt (FileOption pre f) = pre ++ f +showOpt (Option s) = s diff --git a/compiler/GHC/Utils/Encoding.hs b/compiler/GHC/Utils/Encoding.hs new file mode 100644 index 0000000000..165aa05e5b --- /dev/null +++ b/compiler/GHC/Utils/Encoding.hs @@ -0,0 +1,450 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 1997-2006 +-- +-- Character encodings +-- +-- ----------------------------------------------------------------------------- + +module GHC.Utils.Encoding ( + -- * UTF-8 + utf8DecodeChar#, + utf8PrevChar, + utf8CharStart, + utf8DecodeChar, + utf8DecodeByteString, + utf8DecodeStringLazy, + utf8EncodeChar, + utf8EncodeString, + utf8EncodedLength, + countUTF8Chars, + + -- * Z-encoding + zEncodeString, + zDecodeString, + + -- * Base62-encoding + toBase62, + toBase62Padded + ) where + +import GHC.Prelude + +import Foreign +import Foreign.ForeignPtr.Unsafe +import Data.Char +import qualified Data.Char as Char +import Numeric +import GHC.IO + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS + +import GHC.Exts + +-- ----------------------------------------------------------------------------- +-- UTF-8 + +-- We can't write the decoder as efficiently as we'd like without +-- resorting to unboxed extensions, unfortunately. I tried to write +-- an IO version of this function, but GHC can't eliminate boxed +-- results from an IO-returning function. +-- +-- We assume we can ignore overflow when parsing a multibyte character here. +-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences +-- before decoding them (see StringBuffer.hs). + +{-# INLINE utf8DecodeChar# #-} +utf8DecodeChar# :: Addr# -> (# Char#, Int# #) +utf8DecodeChar# a# = + let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in + case () of + _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #) + + | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) -> + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# + (ch1 -# 0x80#)), + 2# #) + + | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) -> + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in + if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else + (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch2 -# 0x80#)), + 3# #) + + | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) -> + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in + if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else + let !ch3 = word2Int# (indexWord8OffAddr# a# 3#) in + if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else + (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# + ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch3 -# 0x80#)), + 4# #) + + | otherwise -> fail 1# + where + -- all invalid sequences end up here: + fail :: Int# -> (# Char#, Int# #) + fail nBytes# = (# '\0'#, nBytes# #) + -- '\xFFFD' would be the usual replacement character, but + -- that's a valid symbol in Haskell, so will result in a + -- confusing parse error later on. Instead we use '\0' which + -- will signal a lexer error immediately. + +utf8DecodeChar :: Ptr Word8 -> (Char, Int) +utf8DecodeChar (Ptr a#) = + case utf8DecodeChar# a# of (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) + +-- UTF-8 is cleverly designed so that we can always figure out where +-- the start of the current character is, given any position in a +-- stream. This function finds the start of the previous character, +-- assuming there *is* a previous character. +utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) +utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) + +utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) +utf8CharStart p = go p + where go p = do w <- peek p + if w >= 0x80 && w < 0xC0 + then go (p `plusPtr` (-1)) + else return p + +utf8DecodeByteString :: ByteString -> [Char] +utf8DecodeByteString (BS.PS ptr offset len) + = utf8DecodeStringLazy ptr offset len + +utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char] +utf8DecodeStringLazy fptr offset len + = unsafeDupablePerformIO $ unpack start + where + !start = unsafeForeignPtrToPtr fptr `plusPtr` offset + !end = start `plusPtr` len + + unpack p + | p >= end = touchForeignPtr fptr >> return [] + | otherwise = + case utf8DecodeChar# (unPtr p) of + (# c#, nBytes# #) -> do + rest <- unsafeDupableInterleaveIO $ unpack (p `plusPtr#` nBytes#) + return (C# c# : rest) + +countUTF8Chars :: Ptr Word8 -> Int -> IO Int +countUTF8Chars ptr len = go ptr 0 + where + !end = ptr `plusPtr` len + + go p !n + | p >= end = return n + | otherwise = do + case utf8DecodeChar# (unPtr p) of + (# _, nBytes# #) -> go (p `plusPtr#` nBytes#) (n+1) + +unPtr :: Ptr a -> Addr# +unPtr (Ptr a) = a + +plusPtr# :: Ptr a -> Int# -> Ptr a +plusPtr# ptr nBytes# = ptr `plusPtr` (I# nBytes#) + +utf8EncodeChar :: Char -> Ptr Word8 -> IO (Ptr Word8) +utf8EncodeChar c ptr = + let x = ord c in + case () of + _ | x > 0 && x <= 0x007f -> do + poke ptr (fromIntegral x) + return (ptr `plusPtr` 1) + -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we + -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). + | x <= 0x07ff -> do + poke ptr (fromIntegral (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))) + pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x .&. 0x3F))) + return (ptr `plusPtr` 2) + | x <= 0xffff -> do + poke ptr (fromIntegral (0xE0 .|. (x `shiftR` 12) .&. 0x0F)) + pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x `shiftR` 6) .&. 0x3F)) + pokeElemOff ptr 2 (fromIntegral (0x80 .|. (x .&. 0x3F))) + return (ptr `plusPtr` 3) + | otherwise -> do + poke ptr (fromIntegral (0xF0 .|. (x `shiftR` 18))) + pokeElemOff ptr 1 (fromIntegral (0x80 .|. ((x `shiftR` 12) .&. 0x3F))) + pokeElemOff ptr 2 (fromIntegral (0x80 .|. ((x `shiftR` 6) .&. 0x3F))) + pokeElemOff ptr 3 (fromIntegral (0x80 .|. (x .&. 0x3F))) + return (ptr `plusPtr` 4) + +utf8EncodeString :: Ptr Word8 -> String -> IO () +utf8EncodeString ptr str = go ptr str + where go !_ [] = return () + go ptr (c:cs) = do + ptr' <- utf8EncodeChar c ptr + go ptr' cs + +utf8EncodedLength :: String -> Int +utf8EncodedLength str = go 0 str + where go !n [] = n + go n (c:cs) + | ord c > 0 && ord c <= 0x007f = go (n+1) cs + | ord c <= 0x07ff = go (n+2) cs + | ord c <= 0xffff = go (n+3) cs + | otherwise = go (n+4) cs + +-- ----------------------------------------------------------------------------- +-- The Z-encoding + +{- +This is the main name-encoding and decoding function. It encodes any +string into a string that is acceptable as a C name. This is done +right before we emit a symbol name into the compiled C or asm code. +Z-encoding of strings is cached in the FastString interface, so we +never encode the same string more than once. + +The basic encoding scheme is this. + +* Tuples (,,,) are coded as Z3T + +* Alphabetic characters (upper and lower) and digits + all translate to themselves; + except 'Z', which translates to 'ZZ' + and 'z', which translates to 'zz' + We need both so that we can preserve the variable/tycon distinction + +* Most other printable characters translate to 'zx' or 'Zx' for some + alphabetic character x + +* The others translate as 'znnnU' where 'nnn' is the decimal number + of the character + + Before After + -------------------------- + Trak Trak + foo_wib foozuwib + > zg + >1 zg1 + foo# foozh + foo## foozhzh + foo##1 foozhzh1 + fooZ fooZZ + :+ ZCzp + () Z0T 0-tuple + (,,,,) Z5T 5-tuple + (# #) Z1H unboxed 1-tuple (note the space) + (#,,,,#) Z5H unboxed 5-tuple + (NB: There is no Z1T nor Z0H.) +-} + +type UserString = String -- As the user typed it +type EncodedString = String -- Encoded form + + +zEncodeString :: UserString -> EncodedString +zEncodeString cs = case maybe_tuple cs of + Just n -> n -- Tuples go to Z2T etc + Nothing -> go cs + where + go [] = [] + go (c:cs) = encode_digit_ch c ++ go' cs + go' [] = [] + go' (c:cs) = encode_ch c ++ go' cs + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = c >= 'a' && c <= 'z' + || c >= 'A' && c <= 'Z' + || c >= '0' && c <= '9' + +-- If a digit is at the start of a symbol then we need to encode it. +-- Otherwise package names like 9pH-0.1 give linker errors. +encode_digit_ch :: Char -> EncodedString +encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c +encode_digit_ch c | otherwise = encode_ch c + +encode_ch :: Char -> EncodedString +encode_ch c | unencodedChar c = [c] -- Common case first + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = encode_as_unicode_char c + +encode_as_unicode_char :: Char -> EncodedString +encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str + else '0':hex_str + where hex_str = showHex (ord c) "U" + -- ToDo: we could improve the encoding here in various ways. + -- eg. strings of unicode characters come out as 'z1234Uz5678U', we + -- could remove the 'U' in the middle (the 'z' works as a separator). + +zDecodeString :: EncodedString -> UserString +zDecodeString [] = [] +zDecodeString ('Z' : d : rest) + | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : zDecodeString rest +zDecodeString ('z' : d : rest) + | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : zDecodeString rest +zDecodeString (c : rest) = c : zDecodeString rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch + +-- Characters not having a specific code are coded as z224U (in hex) +decode_num_esc :: Char -> EncodedString -> UserString +decode_num_esc d rest + = go (digitToInt d) rest + where + go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest + go n ('U' : rest) = chr n : zDecodeString rest + go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) + +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + -- NB. recurse back to zDecodeString after decoding the tuple, because + -- the tuple might be embedded in a longer name. + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ('T':rest) = "()" ++ zDecodeString rest + go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest + go 1 ('H':rest) = "(# #)" ++ zDecodeString rest + go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest + go n other = error ("decode_tuple: " ++ show n ++ ' ':other) + +{- +Tuples are encoded as + Z3T or Z3H +for 3-tuples or unboxed 3-tuples respectively. No other encoding starts + Z<digit> + +* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) + There are no unboxed 0-tuples. + +* "()" is the tycon for a boxed 0-tuple. + There are no boxed 1-tuples. +-} + +maybe_tuple :: UserString -> Maybe EncodedString + +maybe_tuple "(# #)" = Just("Z1H") +maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of + (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") + _ -> Nothing +maybe_tuple "()" = Just("Z0T") +maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of + (n, ')' : _) -> Just ('Z' : shows (n+1) "T") + _ -> Nothing +maybe_tuple _ = Nothing + +count_commas :: Int -> String -> (Int, String) +count_commas n (',' : cs) = count_commas (n+1) cs +count_commas n cs = (n,cs) + + +{- +************************************************************************ +* * + Base 62 +* * +************************************************************************ + +Note [Base 62 encoding 128-bit integers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of base-62 encoding a single 128-bit integer +(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers +(2 * ceil(10.75) characters). Luckily for us, it's the same number of +characters! +-} + +-------------------------------------------------------------------------- +-- Base 62 + +-- The base-62 code is based off of 'locators' +-- ((c) Operational Dynamics Consulting, BSD3 licensed) + +-- | Size of a 64-bit word when written as a base-62 string +word64Base62Len :: Int +word64Base62Len = 11 + +-- | Converts a 64-bit word into a base-62 string +toBase62Padded :: Word64 -> String +toBase62Padded w = pad ++ str + where + pad = replicate len '0' + len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) + str = toBase62 w + +toBase62 :: Word64 -> String +toBase62 w = showIntAtBase 62 represent w "" + where + represent :: Int -> Char + represent x + | x < 10 = Char.chr (48 + x) + | x < 36 = Char.chr (65 + x - 10) + | x < 62 = Char.chr (97 + x - 36) + | otherwise = error "represent (base 62): impossible!" diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs new file mode 100644 index 0000000000..4b3683465a --- /dev/null +++ b/compiler/GHC/Utils/Error.hs @@ -0,0 +1,976 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[ErrsUtils]{Utilities for error reporting} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Utils.Error ( + -- * Basic types + Validity(..), andValid, allValid, isValid, getInvalids, orValid, + Severity(..), + + -- * Messages + ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason, + ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary, + WarnMsg, MsgDoc, + Messages, ErrorMessages, WarningMessages, + unionMessages, + errMsgSpan, errMsgContext, + errorsFound, isEmptyMessages, + isWarnMsgFatal, + warningsToMessages, + + -- ** Formatting + pprMessageBag, pprErrMsgBagWithLoc, + pprLocErrMsg, printBagOfErrors, + formatErrDoc, + + -- ** Construction + emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning, + mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg, + mkPlainWarnMsg, + mkLongWarnMsg, + + -- * Utilities + doIfSet, doIfSet_dyn, + getCaretDiagnostic, + + -- * Dump files + dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, + dumpOptionsFromFlag, DumpOptions (..), + DumpFormat (..), DumpAction, dumpAction, defaultDumpAction, + TraceAction, traceAction, defaultTraceAction, + touchDumpFile, + + -- * Issuing messages during compilation + putMsg, printInfoForUser, printOutputForUser, + logInfo, logOutput, + errorMsg, warningMsg, + fatalErrorMsg, fatalErrorMsg'', + compilationProgressMsg, + showPass, + withTiming, withTimingSilent, withTimingD, withTimingSilentD, + debugTraceMsg, + ghcExit, + prettyPrintGhcErrors, + traceCmd + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Utils.Exception +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import qualified GHC.Utils.Ppr.Colour as Col +import GHC.Types.SrcLoc as SrcLoc +import GHC.Driver.Session +import GHC.Data.FastString (unpackFS) +import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) +import GHC.Utils.Json + +import System.Directory +import System.Exit ( ExitCode(..), exitWith ) +import System.FilePath ( takeDirectory, (</>) ) +import Data.List +import qualified Data.Set as Set +import Data.IORef +import Data.Maybe ( fromMaybe ) +import Data.Function +import Data.Time +import Debug.Trace +import Control.Monad +import Control.Monad.IO.Class +import System.IO +import System.IO.Error ( catchIOError ) +import GHC.Conc ( getAllocationCounter ) +import System.CPUTime + +------------------------- +type MsgDoc = SDoc + +------------------------- +data Validity + = IsValid -- ^ Everything is fine + | NotValid MsgDoc -- ^ A problem, and some indication of why + +isValid :: Validity -> Bool +isValid IsValid = True +isValid (NotValid {}) = False + +andValid :: Validity -> Validity -> Validity +andValid IsValid v = v +andValid v _ = v + +-- | If they aren't all valid, return the first +allValid :: [Validity] -> Validity +allValid [] = IsValid +allValid (v : vs) = v `andValid` allValid vs + +getInvalids :: [Validity] -> [MsgDoc] +getInvalids vs = [d | NotValid d <- vs] + +orValid :: Validity -> Validity -> Validity +orValid IsValid _ = IsValid +orValid _ v = v + +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. + +type Messages = (WarningMessages, ErrorMessages) +type WarningMessages = Bag WarnMsg +type ErrorMessages = Bag ErrMsg + +unionMessages :: Messages -> Messages -> Messages +unionMessages (warns1, errs1) (warns2, errs2) = + (warns1 `unionBags` warns2, errs1 `unionBags` errs2) + +data ErrMsg = ErrMsg { + errMsgSpan :: SrcSpan, + errMsgContext :: PrintUnqualified, + errMsgDoc :: ErrDoc, + -- | This has the same text as errDocImportant . errMsgDoc. + errMsgShortString :: String, + errMsgSeverity :: Severity, + errMsgReason :: WarnReason + } + -- The SrcSpan is used for sorting errors into line-number order + + +-- | Categorise error msgs by their importance. This is so each section can +-- be rendered visually distinct. See Note [Error report] for where these come +-- from. +data ErrDoc = ErrDoc { + -- | Primary error msg. + errDocImportant :: [MsgDoc], + -- | Context e.g. \"In the second argument of ...\". + errDocContext :: [MsgDoc], + -- | Supplementary information, e.g. \"Relevant bindings include ...\". + errDocSupplementary :: [MsgDoc] + } + +errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc +errDoc = ErrDoc + +type WarnMsg = ErrMsg + +data Severity + = SevOutput + | SevFatal + | SevInteractive + + | SevDump + -- ^ Log message intended for compiler developers + -- No file/line/column stuff + + | SevInfo + -- ^ Log messages intended for end users. + -- No file/line/column stuff. + + | SevWarning + | SevError + -- ^ SevWarning and SevError are used for warnings and errors + -- o The message has a file/line/column heading, + -- plus "warning:" or "error:", + -- added by mkLocMessags + -- o Output is intended for end users + deriving Show + + +instance ToJson Severity where + json s = JSString (show s) + + +instance Show ErrMsg where + show em = errMsgShortString em + +pprMessageBag :: Bag MsgDoc -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + +-- | Make an unannotated error message with location info. +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessage = mkLocMessageAnn Nothing + +-- | Make a possibly annotated error message with location info. +mkLocMessageAnn + :: Maybe String -- ^ optional annotation + -> Severity -- ^ severity + -> SrcSpan -- ^ location + -> MsgDoc -- ^ message + -> MsgDoc + -- Always print the location, even if it is unhelpful. Error messages + -- are supposed to be in a standard format, and one without a location + -- would look strange. Better to say explicitly "<no location info>". +mkLocMessageAnn ann severity locn msg + = sdocOption sdocColScheme $ \col_scheme -> + let locn' = sdocOption sdocErrorSpans $ \case + True -> ppr locn + False -> ppr (srcSpanStart locn) + + sevColour = getSeverityColour severity col_scheme + + -- Add optional information + optAnn = case ann of + Nothing -> text "" + Just i -> text " [" <> coloured sevColour (text i) <> text "]" + + -- Add prefixes, like Foo.hs:34: warning: + -- <the warning message> + header = locn' <> colon <+> + coloured sevColour sevText <> optAnn + + in coloured (Col.sMessage col_scheme) + (hang (coloured (Col.sHeader col_scheme) header) 4 + msg) + + where + sevText = + case severity of + SevWarning -> text "warning:" + SevError -> text "error:" + SevFatal -> text "fatal:" + _ -> empty + +getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour +getSeverityColour SevWarning = Col.sWarning +getSeverityColour SevError = Col.sError +getSeverityColour SevFatal = Col.sFatal +getSeverityColour _ = const mempty + +getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc +getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty +getCaretDiagnostic severity (RealSrcSpan span _) = do + caretDiagnostic <$> getSrcLine (srcSpanFile span) row + + where + getSrcLine fn i = + getLine i (unpackFS fn) + `catchIOError` \_ -> + pure Nothing + + getLine i fn = do + -- StringBuffer has advantages over readFile: + -- (a) no lazy IO, otherwise IO exceptions may occur in pure code + -- (b) always UTF-8, rather than some system-dependent encoding + -- (Haskell source code must be UTF-8 anyway) + content <- hGetStringBuffer fn + case atLine i content of + Just at_line -> pure $ + case lines (fix <$> lexemeToString at_line (len at_line)) of + srcLine : _ -> Just srcLine + _ -> Nothing + _ -> pure Nothing + + -- allow user to visibly see that their code is incorrectly encoded + -- (StringBuffer.nextChar uses \0 to represent undecodable characters) + fix '\0' = '\xfffd' + fix c = c + + row = srcSpanStartLine span + rowStr = show row + multiline = row /= srcSpanEndLine span + + caretDiagnostic Nothing = empty + caretDiagnostic (Just srcLineWithNewline) = + sdocOption sdocColScheme$ \col_scheme -> + let sevColour = getSeverityColour severity col_scheme + marginColour = Col.sMargin col_scheme + in + coloured marginColour (text marginSpace) <> + text ("\n") <> + coloured marginColour (text marginRow) <> + text (" " ++ srcLinePre) <> + coloured sevColour (text srcLineSpan) <> + text (srcLinePost ++ "\n") <> + coloured marginColour (text marginSpace) <> + coloured sevColour (text (" " ++ caretLine)) + + where + + -- expand tabs in a device-independent manner #13664 + expandTabs tabWidth i s = + case s of + "" -> "" + '\t' : cs -> replicate effectiveWidth ' ' ++ + expandTabs tabWidth (i + effectiveWidth) cs + c : cs -> c : expandTabs tabWidth (i + 1) cs + where effectiveWidth = tabWidth - i `mod` tabWidth + + srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline) + + start = srcSpanStartCol span - 1 + end | multiline = length srcLine + | otherwise = srcSpanEndCol span - 1 + width = max 1 (end - start) + + marginWidth = length rowStr + marginSpace = replicate marginWidth ' ' ++ " |" + marginRow = rowStr ++ " |" + + (srcLinePre, srcLineRest) = splitAt start srcLine + (srcLineSpan, srcLinePost) = splitAt width srcLineRest + + caretEllipsis | multiline = "..." + | otherwise = "" + caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis + +makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg +makeIntoWarning reason err = err + { errMsgSeverity = SevWarning + , errMsgReason = reason } + +-- ----------------------------------------------------------------------------- +-- Collecting up messages for later ordering and printing. + +mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg +mk_err_msg dflags sev locn print_unqual doc + = ErrMsg { errMsgSpan = locn + , errMsgContext = print_unqual + , errMsgDoc = doc + , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc)) + , errMsgSeverity = sev + , errMsgReason = NoReason } + +mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg +mkErrDoc dflags = mk_err_msg dflags SevError + +mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +-- ^ A long (multi-line) error message +mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +-- ^ A short (one-line) error message +mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg +-- ^ Variant that doesn't care about qualified/unqualified names + +mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra]) +mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] []) +mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] []) +mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra]) +mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] []) +mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] []) + +---------------- +emptyMessages :: Messages +emptyMessages = (emptyBag, emptyBag) + +isEmptyMessages :: Messages -> Bool +isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs + +errorsFound :: DynFlags -> Messages -> Bool +errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) + +warningsToMessages :: DynFlags -> WarningMessages -> Messages +warningsToMessages dflags = + partitionBagWith $ \warn -> + case isWarnMsgFatal dflags warn of + Nothing -> Left warn + Just err_reason -> + Right warn{ errMsgSeverity = SevError + , errMsgReason = ErrReason err_reason } + +printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () +printBagOfErrors dflags bag_of_errors + = sequence_ [ let style = mkErrStyle dflags unqual + ctx = initSDocContext dflags style + in putLogMsg dflags reason sev s style (formatErrDoc ctx doc) + | ErrMsg { errMsgSpan = s, + errMsgDoc = doc, + errMsgSeverity = sev, + errMsgReason = reason, + errMsgContext = unqual } <- sortMsgBag (Just dflags) + bag_of_errors ] + +formatErrDoc :: SDocContext -> ErrDoc -> SDoc +formatErrDoc ctx (ErrDoc important context supplementary) + = case msgs of + [msg] -> vcat msg + _ -> vcat $ map starred msgs + where + msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty ctx)) + [important, context, supplementary] + starred = (bullet<+>) . vcat + +pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] +pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ] + +pprLocErrMsg :: ErrMsg -> SDoc +pprLocErrMsg (ErrMsg { errMsgSpan = s + , errMsgDoc = doc + , errMsgSeverity = sev + , errMsgContext = unqual }) + = sdocWithContext $ \ctx -> + withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx doc) + +sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg] +sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList + where cmp + | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest + | otherwise = SrcLoc.leftmost_smallest + maybeLimit = case join (fmap maxErrors dflags) of + Nothing -> id + Just err_limit -> take err_limit + +ghcExit :: DynFlags -> Int -> IO () +ghcExit dflags val + | val == 0 = exitWith ExitSuccess + | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") + exitWith (ExitFailure val) + +doIfSet :: Bool -> IO () -> IO () +doIfSet flag action | flag = action + | otherwise = return () + +doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO() +doIfSet_dyn dflags flag action | gopt flag dflags = action + | otherwise = return () + +-- ----------------------------------------------------------------------------- +-- Dumping + +dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () +dumpIfSet dflags flag hdr doc + | not flag = return () + | otherwise = putLogMsg dflags + NoReason + SevDump + noSrcSpan + (defaultDumpStyle dflags) + (mkDumpDoc hdr doc) + +-- | a wrapper around 'dumpAction'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify + +-- | a wrapper around 'dumpAction'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +-- +-- Unlike 'dumpIfSet_dyn', has a printer argument +dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String + -> DumpFormat -> SDoc -> IO () +dumpIfSet_dyn_printer printer dflags flag hdr fmt doc + = when (dopt flag dflags) $ do + let sty = mkDumpStyle dflags printer + dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc + +mkDumpDoc :: String -> SDoc -> SDoc +mkDumpDoc hdr doc + = vcat [blankLine, + line <+> text hdr <+> line, + doc, + blankLine] + where + line = text (replicate 20 '=') + + +-- | Ensure that a dump file is created even if it stays empty +touchDumpFile :: DynFlags -> DumpOptions -> IO () +touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ())) + +-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a +-- file, otherwise 'Nothing'. +withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO () +withDumpFileHandle dflags dumpOpt action = do + let mFile = chooseDumpFile dflags dumpOpt + case mFile of + Just fileName -> do + let gdref = generatedDumps dflags + gd <- readIORef gdref + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + unless append $ + writeIORef gdref (Set.insert fileName gd) + createDirectoryIfMissing True (takeDirectory fileName) + withFile fileName mode $ \handle -> do + -- We do not want the dump file to be affected by + -- environment variables, but instead to always use + -- UTF8. See: + -- https://gitlab.haskell.org/ghc/ghc/issues/10762 + hSetEncoding handle utf8 + + action (Just handle) + Nothing -> action Nothing + + +-- | Write out a dump. +-- If --dump-to-file is set then this goes to a file. +-- otherwise emit to stdout. +-- +-- When @hdr@ is empty, we print in a more compact format (no separators and +-- blank lines) +dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO () +dumpSDocWithStyle sty dflags dumpOpt hdr doc = + withDumpFileHandle dflags dumpOpt writeDump + where + -- write dump to file + writeDump (Just handle) = do + doc' <- if null hdr + then return doc + else do t <- getCurrentTime + let timeStamp = if (gopt Opt_SuppressTimestamps dflags) + then empty + else text (show t) + let d = timeStamp + $$ blankLine + $$ doc + return $ mkDumpDoc hdr d + defaultLogActionHPrintDoc dflags handle doc' sty + + -- write the dump to stdout + writeDump Nothing = do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + putLogMsg dflags NoReason severity noSrcSpan sty doc' + + +-- | Choose where to put a dump file based on DynFlags +-- +chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath +chooseDumpFile dflags dumpOpt + + | gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt + , Just prefix <- getPrefix + = Just $ setDir (prefix ++ dumpSuffix dumpOpt) + + | otherwise + = Nothing + + where getPrefix + -- dump file location is being forced + -- by the --ddump-file-prefix flag. + | Just prefix <- dumpPrefixForce dflags + = Just prefix + -- dump file location chosen by GHC.Driver.Pipeline.runPipeline + | Just prefix <- dumpPrefix dflags + = Just prefix + -- we haven't got a place to put a dump file. + | otherwise + = Nothing + setDir f = case dumpDir dflags of + Just d -> d </> f + Nothing -> f + +-- | Dump options +-- +-- Dumps are printed on stdout by default except when the `dumpForcedToFile` +-- field is set to True. +-- +-- When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are +-- written into a file whose suffix is given in the `dumpSuffix` field. +-- +data DumpOptions = DumpOptions + { dumpForcedToFile :: Bool -- ^ Must be dumped into a file, even if + -- -ddump-to-file isn't set + , dumpSuffix :: String -- ^ Filename suffix used when dumped into + -- a file + } + +-- | Create dump options from a 'DumpFlag' +dumpOptionsFromFlag :: DumpFlag -> DumpOptions +dumpOptionsFromFlag Opt_D_th_dec_file = + DumpOptions -- -dth-dec-file dumps expansions of TH + { dumpForcedToFile = True -- splices into MODULE.th.hs even when + , dumpSuffix = "th.hs" -- -ddump-to-file isn't set + } +dumpOptionsFromFlag flag = + DumpOptions + { dumpForcedToFile = False + , dumpSuffix = suffix -- build a suffix from the flag name + } -- e.g. -ddump-asm => ".dump-asm" + where + str = show flag + suff = case stripPrefix "Opt_D_" str of + Just x -> x + Nothing -> panic ("Bad flag name: " ++ str) + suffix = map (\c -> if c == '_' then '-' else c) suff + + +-- ----------------------------------------------------------------------------- +-- Outputting messages from the compiler + +-- We want all messages to go through one place, so that we can +-- redirect them if necessary. For example, when GHC is used as a +-- library we might want to catch all messages that GHC tries to +-- output and do something else with them. + +ifVerbose :: DynFlags -> Int -> IO () -> IO () +ifVerbose dflags val act + | verbosity dflags >= val = act + | otherwise = return () + +errorMsg :: DynFlags -> MsgDoc -> IO () +errorMsg dflags msg + = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg + +warningMsg :: DynFlags -> MsgDoc -> IO () +warningMsg dflags msg + = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg + +fatalErrorMsg :: DynFlags -> MsgDoc -> IO () +fatalErrorMsg dflags msg = + putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg + +fatalErrorMsg'' :: FatalMessager -> String -> IO () +fatalErrorMsg'' fm msg = fm msg + +compilationProgressMsg :: DynFlags -> String -> IO () +compilationProgressMsg dflags msg = do + traceEventIO $ "GHC progress: " ++ msg + ifVerbose dflags 1 $ + logOutput dflags (defaultUserStyle dflags) (text msg) + +showPass :: DynFlags -> String -> IO () +showPass dflags what + = ifVerbose dflags 2 $ + logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon) + +data PrintTimings = PrintTimings | DontPrintTimings + deriving (Eq, Show) + +-- | Time a compilation phase. +-- +-- When timings are enabled (e.g. with the @-v2@ flag), the allocations +-- and CPU time used by the phase will be reported to stderr. Consider +-- a typical usage: +-- @withTiming getDynFlags (text "simplify") force PrintTimings pass@. +-- When timings are enabled the following costs are included in the +-- produced accounting, +-- +-- - The cost of executing @pass@ to a result @r@ in WHNF +-- - The cost of evaluating @force r@ to WHNF (e.g. @()@) +-- +-- The choice of the @force@ function depends upon the amount of forcing +-- desired; the goal here is to ensure that the cost of evaluating the result +-- is, to the greatest extent possible, included in the accounting provided by +-- 'withTiming'. Often the pass already sufficiently forces its result during +-- construction; in this case @const ()@ is a reasonable choice. +-- In other cases, it is necessary to evaluate the result to normal form, in +-- which case something like @Control.DeepSeq.rnf@ is appropriate. +-- +-- To avoid adversely affecting compiler performance when timings are not +-- requested, the result is only forced when timings are enabled. +-- +-- See Note [withTiming] for more. +withTiming :: MonadIO m + => DynFlags -- ^ DynFlags + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTiming dflags what force action = + withTiming' dflags what force PrintTimings action + +-- | Like withTiming but get DynFlags from the Monad. +withTimingD :: (MonadIO m, HasDynFlags m) + => SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTimingD what force action = do + dflags <- getDynFlags + withTiming' dflags what force PrintTimings action + + +-- | Same as 'withTiming', but doesn't print timings in the +-- console (when given @-vN@, @N >= 2@ or @-ddump-timings@). +-- +-- See Note [withTiming] for more. +withTimingSilent + :: MonadIO m + => DynFlags -- ^ DynFlags + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTimingSilent dflags what force action = + withTiming' dflags what force DontPrintTimings action + +-- | Same as 'withTiming', but doesn't print timings in the +-- console (when given @-vN@, @N >= 2@ or @-ddump-timings@) +-- and gets the DynFlags from the given Monad. +-- +-- See Note [withTiming] for more. +withTimingSilentD + :: (MonadIO m, HasDynFlags m) + => SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTimingSilentD what force action = do + dflags <- getDynFlags + withTiming' dflags what force DontPrintTimings action + +-- | Worker for 'withTiming' and 'withTimingSilent'. +withTiming' :: MonadIO m + => DynFlags -- ^ A means of getting a 'DynFlags' (often + -- 'getDynFlags' will work here) + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> PrintTimings -- ^ Whether to print the timings + -> m a -- ^ The body of the phase to be timed + -> m a +withTiming' dflags what force_result prtimings action + = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags + then do whenPrintTimings $ + logInfo dflags (defaultUserStyle dflags) $ + text "***" <+> what <> colon + let ctx = initDefaultSDocContext dflags + eventBegins ctx what + alloc0 <- liftIO getAllocationCounter + start <- liftIO getCPUTime + !r <- action + () <- pure $ force_result r + eventEnds ctx what + end <- liftIO getCPUTime + alloc1 <- liftIO getAllocationCounter + -- recall that allocation counter counts down + let alloc = alloc0 - alloc1 + time = realToFrac (end - start) * 1e-9 + + when (verbosity dflags >= 2 && prtimings == PrintTimings) + $ liftIO $ logInfo dflags (defaultUserStyle dflags) + (text "!!!" <+> what <> colon <+> text "finished in" + <+> doublePrec 2 time + <+> text "milliseconds" + <> comma + <+> text "allocated" + <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) + <+> text "megabytes") + + whenPrintTimings $ + dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText + $ text $ showSDocOneLine ctx + $ hsep [ what <> colon + , text "alloc=" <> ppr alloc + , text "time=" <> doublePrec 3 time + ] + pure r + else action + + where whenPrintTimings = liftIO . when (prtimings == PrintTimings) + eventBegins ctx w = do + whenPrintTimings $ traceMarkerIO (eventBeginsDoc ctx w) + liftIO $ traceEventIO (eventBeginsDoc ctx w) + eventEnds ctx w = do + whenPrintTimings $ traceMarkerIO (eventEndsDoc ctx w) + liftIO $ traceEventIO (eventEndsDoc ctx w) + + eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w + eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w + +debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () +debugTraceMsg dflags val msg = ifVerbose dflags val $ + logInfo dflags (defaultDumpStyle dflags) msg +putMsg :: DynFlags -> MsgDoc -> IO () +putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg + +printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printInfoForUser dflags print_unqual msg + = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg + +printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printOutputForUser dflags print_unqual msg + = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg + +logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () +logInfo dflags sty msg + = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg + +logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO () +-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' +logOutput dflags sty msg + = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg + +prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a +prettyPrintGhcErrors dflags + = ghandle $ \e -> case e of + PprPanic str doc -> + pprDebugAndThen dflags panic (text str) doc + PprSorry str doc -> + pprDebugAndThen dflags sorry (text str) doc + PprProgramError str doc -> + pprDebugAndThen dflags pgmError (text str) doc + _ -> + liftIO $ throwIO e + +-- | Checks if given 'WarnMsg' is a fatal warning. +isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) +isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} + = if wopt_fatal wflag dflags + then Just (Just wflag) + else Nothing +isWarnMsgFatal dflags _ + = if gopt Opt_WarnIsError dflags + then Just Nothing + else Nothing + +traceCmd :: DynFlags -> String -> String -> IO a -> IO a +-- trace the command (at two levels of verbosity) +traceCmd dflags phase_name cmd_line action + = do { let verb = verbosity dflags + ; showPass dflags phase_name + ; debugTraceMsg dflags 3 (text cmd_line) + ; case flushErr dflags of + FlushErr io -> io + + -- And run it! + ; action `catchIO` handle_exn verb + } + where + handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') + ; debugTraceMsg dflags 2 + (text "Failed:" + <+> text cmd_line + <+> text (show exn)) + ; throwGhcExceptionIO (ProgramError (show exn))} + +{- Note [withTiming] +~~~~~~~~~~~~~~~~~~~~ + +For reference: + + withTiming + :: MonadIO + => m DynFlags -- how to get the DynFlags + -> SDoc -- label for the computation we're timing + -> (a -> ()) -- how to evaluate the result + -> PrintTimings -- whether to report the timings when passed + -- -v2 or -ddump-timings + -> m a -- computation we're timing + -> m a + +withTiming lets you run an action while: + +(1) measuring the CPU time it took and reporting that on stderr + (when PrintTimings is passed), +(2) emitting start/stop events to GHC's event log, with the label + given as an argument. + +Evaluation of the result +------------------------ + +'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is +to evaluate the result "sufficiently". A given pass might return an 'm a' for +some monad 'm' and result type 'a', but where the 'a' is complex enough +that evaluating it to WHNF barely scratches its surface and leaves many +complex and time-consuming computations unevaluated. Those would only be +forced by the next pass, and the time needed to evaluate them would be +mis-attributed to that next pass. A more appropriate function would be +one that deeply evaluates the result, so as to assign the time spent doing it +to the pass we're timing. + +Note: as hinted at above, the time spent evaluating the application of the +forcing function to the result is included in the timings reported by +'withTiming'. + +How we use it +------------- + +We measure the time and allocations of various passes in GHC's pipeline by just +wrapping the whole pass with 'withTiming'. This also materializes by having +a label for each pass in the eventlog, where each pass is executed in one go, +during a continuous time window. + +However, from STG onwards, the pipeline uses streams to emit groups of +STG/Cmm/etc declarations one at a time, and process them until we get to +assembly code generation. This means that the execution of those last few passes +is interleaved and that we cannot measure how long they take by just wrapping +the whole thing with 'withTiming'. Instead we wrap the processing of each +individual stream element, all along the codegen pipeline, using the appropriate +label for the pass to which this processing belongs. That generates a lot more +data but allows us to get fine-grained timings about all the passes and we can +easily compute totals with tools like ghc-events-analyze (see below). + + +Producing an eventlog for GHC +----------------------------- + +To actually produce the eventlog, you need an eventlog-capable GHC build: + + With Hadrian: + $ hadrian/build -j "stage1.ghc-bin.ghc.link.opts += -eventlog" + + With Make: + $ make -j GhcStage2HcOpts+=-eventlog + +You can then produce an eventlog when compiling say hello.hs by simply +doing: + + If GHC was built by Hadrian: + $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l + + If GHC was built with Make: + $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l + +You could alternatively use -v<N> (with N >= 2) instead of -ddump-timings, +to ask GHC to report timings (on stderr and the eventlog). + +This will write the eventlog to ./ghc.eventlog in both cases. You can then +visualize it or look at the totals for each label by using ghc-events-analyze, +threadscope or any other eventlog consumer. Illustrating with +ghc-events-analyze: + + $ ghc-events-analyze --timed --timed-txt --totals \ + --start "GHC:started:" --stop "GHC:finished:" \ + ghc.eventlog + +This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation +of the execution through the various labels) and ghc.totals.txt (total time +spent in each label). + +-} + + +-- | Format of a dump +-- +-- Dump formats are loosely defined: dumps may contain various additional +-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint +-- (e.g. for syntax highlighters). +data DumpFormat + = FormatHaskell -- ^ Haskell + | FormatCore -- ^ Core + | FormatSTG -- ^ STG + | FormatByteCode -- ^ ByteCode + | FormatCMM -- ^ Cmm + | FormatASM -- ^ Assembly code + | FormatC -- ^ C code/header + | FormatLLVM -- ^ LLVM bytecode + | FormatText -- ^ Unstructured dump + deriving (Show,Eq) + +type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String + -> DumpFormat -> SDoc -> IO () + +type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a + +-- | Default action for 'dumpAction' hook +defaultDumpAction :: DumpAction +defaultDumpAction dflags sty dumpOpt title _fmt doc = do + dumpSDocWithStyle sty dflags dumpOpt title doc + +-- | Default action for 'traceAction' hook +defaultTraceAction :: TraceAction +defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc + +-- | Helper for `dump_action` +dumpAction :: DumpAction +dumpAction dflags = dump_action dflags dflags + +-- | Helper for `trace_action` +traceAction :: TraceAction +traceAction dflags = trace_action dflags dflags diff --git a/compiler/GHC/Utils/Error.hs-boot b/compiler/GHC/Utils/Error.hs-boot new file mode 100644 index 0000000000..20c6930fa5 --- /dev/null +++ b/compiler/GHC/Utils/Error.hs-boot @@ -0,0 +1,50 @@ +{-# LANGUAGE RankNTypes #-} + +module GHC.Utils.Error where + +import GHC.Prelude +import GHC.Utils.Outputable (SDoc, PprStyle ) +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Utils.Json +import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) + +type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String + -> DumpFormat -> SDoc -> IO () + +type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a + +data DumpOptions = DumpOptions + { dumpForcedToFile :: Bool + , dumpSuffix :: String + } + +data DumpFormat + = FormatHaskell + | FormatCore + | FormatSTG + | FormatByteCode + | FormatCMM + | FormatASM + | FormatC + | FormatLLVM + | FormatText + +data Severity + = SevOutput + | SevFatal + | SevInteractive + | SevDump + | SevInfo + | SevWarning + | SevError + + +type MsgDoc = SDoc + +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc +defaultDumpAction :: DumpAction +defaultTraceAction :: TraceAction + +instance ToJson Severity diff --git a/compiler/GHC/Utils/Exception.hs b/compiler/GHC/Utils/Exception.hs new file mode 100644 index 0000000000..e84221cdbe --- /dev/null +++ b/compiler/GHC/Utils/Exception.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module GHC.Utils.Exception + ( + module Control.Exception, + module GHC.Utils.Exception + ) + where + +import GHC.Prelude + +import Control.Exception +import Control.Monad.IO.Class + +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = Control.Exception.catch + +handleIO :: (IOException -> IO a) -> IO a -> IO a +handleIO = flip catchIO + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +-- | A monad that can catch exceptions. A minimal definition +-- requires a definition of 'gcatch'. +-- +-- Implementations on top of 'IO' should implement 'gmask' to +-- eventually call the primitive 'Control.Exception.mask'. +-- These are used for +-- implementations that support asynchronous exceptions. The default +-- implementations of 'gbracket' and 'gfinally' use 'gmask' +-- thus rarely require overriding. +-- +class MonadIO m => ExceptionMonad m where + + -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gcatch :: Exception e => m a -> (e -> m a) -> m a + + -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gmask :: ((m a -> m a) -> m b) -> m b + + -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c + + -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gfinally :: m a -> m b -> m a + + gbracket before after thing = + gmask $ \restore -> do + a <- before + r <- restore (thing a) `gonException` after a + _ <- after a + return r + + a `gfinally` sequel = + gmask $ \restore -> do + r <- restore a `gonException` sequel + _ <- sequel + return r + +instance ExceptionMonad IO where + gcatch = Control.Exception.catch + gmask f = mask (\x -> f x) + +gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) +gtry act = gcatch (act >>= \a -> return (Right a)) + (\e -> return (Left e)) + +-- | Generalised version of 'Control.Exception.handle', allowing an arbitrary +-- exception handling monad instead of just 'IO'. +ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a +ghandle = flip gcatch + +-- | Always executes the first argument. If this throws an exception the +-- second argument is executed and the exception is raised again. +gonException :: (ExceptionMonad m) => m a -> m b -> m a +gonException ioA cleanup = ioA `gcatch` \e -> + do _ <- cleanup + liftIO $ throwIO (e :: SomeException) + diff --git a/compiler/GHC/Utils/FV.hs b/compiler/GHC/Utils/FV.hs new file mode 100644 index 0000000000..167cf7fe02 --- /dev/null +++ b/compiler/GHC/Utils/FV.hs @@ -0,0 +1,199 @@ +{- +(c) Bartosz Nitka, Facebook 2015 + +-} + +{-# LANGUAGE BangPatterns #-} + +-- | Utilities for efficiently and deterministically computing free variables. +module GHC.Utils.FV ( + -- * Deterministic free vars computations + FV, InterestingVarFun, + + -- * Running the computations + fvVarList, fvVarSet, fvDVarSet, + + -- ** Manipulating those computations + unitFV, + emptyFV, + mkFVs, + unionFV, + unionsFV, + delFV, + delFVs, + filterFV, + mapUnionFV, + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Var.Set + +-- | Predicate on possible free variables: returns @True@ iff the variable is +-- interesting +type InterestingVarFun = Var -> Bool + +-- Note [Deterministic FV] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- When computing free variables, the order in which you get them affects +-- the results of floating and specialization. If you use UniqFM to collect +-- them and then turn that into a list, you get them in nondeterministic +-- order as described in Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +-- A naive algorithm for free variables relies on merging sets of variables. +-- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log +-- factor. It's cheaper to incrementally add to a list and use a set to check +-- for duplicates. +type FV = InterestingVarFun -- Used for filtering sets as we build them + -> VarSet -- Locally bound variables + -> VarAcc -- Accumulator + -> VarAcc + +type VarAcc = ([Var], VarSet) -- List to preserve ordering and set to check for membership, + -- so that the list doesn't have duplicates + -- For explanation of why using `VarSet` is not deterministic see + -- Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +-- Note [FV naming conventions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- To get the performance and determinism that FV provides, FV computations +-- need to built up from smaller FV computations and then evaluated with +-- one of `fvVarList`, `fvDVarSet` That means the functions +-- returning FV need to be exported. +-- +-- The conventions are: +-- +-- a) non-deterministic functions: +-- * a function that returns VarSet +-- e.g. `tyVarsOfType` +-- b) deterministic functions: +-- * a worker that returns FV +-- e.g. `tyFVsOfType` +-- * a function that returns [Var] +-- e.g. `tyVarsOfTypeList` +-- * a function that returns DVarSet +-- e.g. `tyVarsOfTypeDSet` +-- +-- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented +-- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet +-- respectively. + +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order and a non-deterministic set containing +-- those variables. +fvVarAcc :: FV -> ([Var], VarSet) +fvVarAcc fv = fv (const True) emptyVarSet ([], emptyVarSet) + +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order. +fvVarList :: FV -> [Var] +fvVarList = fst . fvVarAcc + +-- | Run a free variable computation, returning a deterministic set of free +-- variables. Note that this is just a wrapper around the version that +-- returns a deterministic list. If you need a list you should use +-- `fvVarList`. +fvDVarSet :: FV -> DVarSet +fvDVarSet = mkDVarSet . fvVarList + +-- | Run a free variable computation, returning a non-deterministic set of +-- free variables. Don't use if the set will be later converted to a list +-- and the order of that list will impact the generated code. +fvVarSet :: FV -> VarSet +fvVarSet = snd . fvVarAcc + +-- Note [FV eta expansion] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- Let's consider an eta-reduced implementation of freeVarsOf using FV: +-- +-- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b +-- +-- If GHC doesn't eta-expand it, after inlining unionFV we end up with +-- +-- freeVarsOf = \x -> +-- case x of +-- App a b -> \fv_cand in_scope acc -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which has to create a thunk, resulting in more allocations. +-- +-- On the other hand if it is eta-expanded: +-- +-- freeVarsOf (App a b) fv_cand in_scope acc = +-- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc +-- +-- after inlining unionFV we have: +-- +-- freeVarsOf = \x fv_cand in_scope acc -> +-- case x of +-- App a b -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which saves allocations. +-- +-- GHC when presented with knowledge about all the call sites, correctly +-- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets +-- exported to be composed with other functions, GHC doesn't have that +-- information and has to be more conservative here. +-- +-- Hence functions that get exported and return FV need to be manually +-- eta-expanded. See also #11146. + +-- | Add a variable - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. +unitFV :: Id -> FV +unitFV var fv_cand in_scope acc@(have, haveSet) + | var `elemVarSet` in_scope = acc + | var `elemVarSet` haveSet = acc + | fv_cand var = (var:have, extendVarSet haveSet var) + | otherwise = acc +{-# INLINE unitFV #-} + +-- | Return no free variables. +emptyFV :: FV +emptyFV _ _ acc = acc +{-# INLINE emptyFV #-} + +-- | Union two free variable computations. +unionFV :: FV -> FV -> FV +unionFV fv1 fv2 fv_cand in_scope acc = + fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc +{-# INLINE unionFV #-} + +-- | Mark the variable as not free by putting it in scope. +delFV :: Var -> FV -> FV +delFV var fv fv_cand !in_scope acc = + fv fv_cand (extendVarSet in_scope var) acc +{-# INLINE delFV #-} + +-- | Mark many free variables as not free. +delFVs :: VarSet -> FV -> FV +delFVs vars fv fv_cand !in_scope acc = + fv fv_cand (in_scope `unionVarSet` vars) acc +{-# INLINE delFVs #-} + +-- | Filter a free variable computation. +filterFV :: InterestingVarFun -> FV -> FV +filterFV fv_cand2 fv fv_cand1 in_scope acc = + fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc +{-# INLINE filterFV #-} + +-- | Map a free variable computation over a list and union the results. +mapUnionFV :: (a -> FV) -> [a] -> FV +mapUnionFV _f [] _fv_cand _in_scope acc = acc +mapUnionFV f (a:as) fv_cand in_scope acc = + mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc +{-# INLINABLE mapUnionFV #-} + +-- | Union many free variable computations. +unionsFV :: [FV] -> FV +unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc +{-# INLINE unionsFV #-} + +-- | Add multiple variables - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. +mkFVs :: [Var] -> FV +mkFVs vars fv_cand in_scope acc = + mapUnionFV unitFV vars fv_cand in_scope acc +{-# INLINE mkFVs #-} diff --git a/compiler/GHC/Utils/Fingerprint.hs b/compiler/GHC/Utils/Fingerprint.hs new file mode 100644 index 0000000000..b8c2091135 --- /dev/null +++ b/compiler/GHC/Utils/Fingerprint.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ---------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- Fingerprints for recompilation checking and ABI versioning. +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance +-- +-- ---------------------------------------------------------------------------- + +module GHC.Utils.Fingerprint ( + readHexFingerprint, + fingerprintByteString, + -- * Re-exported from GHC.Fingerprint + Fingerprint(..), fingerprint0, + fingerprintFingerprints, + fingerprintData, + fingerprintString, + getFileHash + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import Foreign +import GHC.IO +import Numeric ( readHex ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +import GHC.Fingerprint + +-- useful for parsing the output of 'md5sum', should we want to do that. +readHexFingerprint :: String -> Fingerprint +readHexFingerprint s = Fingerprint w1 w2 + where (s1,s2) = splitAt 16 s + [(w1,"")] = readHex s1 + [(w2,"")] = readHex (take 16 s2) + +fingerprintByteString :: BS.ByteString -> Fingerprint +fingerprintByteString bs = unsafeDupablePerformIO $ + BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len diff --git a/compiler/GHC/Utils/IO/Unsafe.hs b/compiler/GHC/Utils/IO/Unsafe.hs new file mode 100644 index 0000000000..27efe373f7 --- /dev/null +++ b/compiler/GHC/Utils/IO/Unsafe.hs @@ -0,0 +1,22 @@ +{- +(c) The University of Glasgow, 2000-2006 +-} + +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} + +module GHC.Utils.IO.Unsafe + ( inlinePerformIO, + ) +where + +#include "HsVersions.h" + +import GHC.Prelude () + +import GHC.Exts +import GHC.IO (IO(..)) + +-- Just like unsafeDupablePerformIO, but we inline it. +{-# INLINE inlinePerformIO #-} +inlinePerformIO :: IO a -> a +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r diff --git a/compiler/GHC/Utils/Json.hs b/compiler/GHC/Utils/Json.hs new file mode 100644 index 0000000000..21358847c0 --- /dev/null +++ b/compiler/GHC/Utils/Json.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GADTs #-} +module GHC.Utils.Json where + +import GHC.Prelude + +import GHC.Utils.Outputable +import Data.Char +import Numeric + +-- | Simple data type to represent JSON documents. +data JsonDoc where + JSNull :: JsonDoc + JSBool :: Bool -> JsonDoc + JSInt :: Int -> JsonDoc + JSString :: String -> JsonDoc + JSArray :: [JsonDoc] -> JsonDoc + JSObject :: [(String, JsonDoc)] -> JsonDoc + + +-- This is simple and slow as it is only used for error reporting +renderJSON :: JsonDoc -> SDoc +renderJSON d = + case d of + JSNull -> text "null" + JSBool b -> text $ if b then "true" else "false" + JSInt n -> ppr n + JSString s -> doubleQuotes $ text $ escapeJsonString s + JSArray as -> brackets $ pprList renderJSON as + JSObject fs -> braces $ pprList renderField fs + where + renderField :: (String, JsonDoc) -> SDoc + renderField (s, j) = doubleQuotes (text s) <> colon <+> renderJSON j + + pprList pp xs = hcat (punctuate comma (map pp xs)) + +escapeJsonString :: String -> String +escapeJsonString = concatMap escapeChar + where + escapeChar '\b' = "\\b" + escapeChar '\f' = "\\f" + escapeChar '\n' = "\\n" + escapeChar '\r' = "\\r" + escapeChar '\t' = "\\t" + escapeChar '"' = "\\\"" + escapeChar '\\' = "\\\\" + escapeChar c | isControl c || fromEnum c >= 0x7f = uni_esc c + escapeChar c = [c] + + uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) "")) + + pad n cs | len < n = replicate (n-len) '0' ++ cs + | otherwise = cs + where len = length cs + +class ToJson a where + json :: a -> JsonDoc diff --git a/compiler/GHC/Utils/Lexeme.hs b/compiler/GHC/Utils/Lexeme.hs index 44bdbf0895..6df962a54b 100644 --- a/compiler/GHC/Utils/Lexeme.hs +++ b/compiler/GHC/Utils/Lexeme.hs @@ -27,9 +27,9 @@ module GHC.Utils.Lexeme ( ) where -import GhcPrelude +import GHC.Prelude -import FastString +import GHC.Data.FastString import Data.Char import qualified Data.Set as Set diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs new file mode 100644 index 0000000000..b191507fca --- /dev/null +++ b/compiler/GHC/Utils/Misc.hs @@ -0,0 +1,1465 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Highly random utility functions +-- +module GHC.Utils.Misc ( + -- * Flags dependent on the compiler build + ghciSupported, debugIsOn, + isWindowsHost, isDarwinHost, + + -- * Miscellaneous higher-order functions + applyWhen, nTimes, + + -- * General list processing + zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, + + zipWithLazy, zipWith3Lazy, + + filterByList, filterByLists, partitionByList, + + unzipWith, + + mapFst, mapSnd, chkAppend, + mapAndUnzip, mapAndUnzip3, mapAccumL2, + filterOut, partitionWith, + + dropWhileEndLE, spanEnd, last2, lastMaybe, + + foldl1', foldl2, count, countWhile, all2, + + lengthExceeds, lengthIs, lengthIsNot, + lengthAtLeast, lengthAtMost, lengthLessThan, + listLengthCmp, atLength, + equalLength, compareLength, leLength, ltLength, + + isSingleton, only, singleton, + notNull, snocView, + + isIn, isn'tIn, + + chunkList, + + changeLast, + + whenNonEmpty, + + -- * Tuples + fstOf3, sndOf3, thdOf3, + firstM, first3M, secondM, + fst3, snd3, third3, + uncurry3, + liftFst, liftSnd, + + -- * List operations controlled by another list + takeList, dropList, splitAtList, split, + dropTail, capitalise, + + -- * Sorting + sortWith, minWith, nubSort, ordNub, + + -- * Comparisons + isEqual, eqListBy, eqMaybeBy, + thenCmp, cmpList, + removeSpaces, + (<&&>), (<||>), + + -- * Edit distance + fuzzyMatch, fuzzyLookup, + + -- * Transitive closures + transitiveClosure, + + -- * Strictness + seqList, strictMap, + + -- * Module names + looksLikeModuleName, + looksLikePackageName, + + -- * Argument processing + getCmd, toCmdArgs, toArgs, + + -- * Integers + exactLog2, + + -- * Floating point + readRational, + readHexRational, + + -- * IO-ish utilities + doesDirNameExist, + getModificationUTCTime, + modificationTimeIfExists, + withAtomicRename, + + global, consIORef, globalM, + sharedGlobal, sharedGlobalM, + + -- * Filenames and paths + Suffix, + splitLongestPrefix, + escapeSpaces, + Direction(..), reslash, + makeRelativeTo, + + -- * Utils for defining Data instances + abstractConstr, abstractDataType, mkNoRepType, + + -- * Utils for printing C code + charToC, + + -- * Hashing + hashString, + + -- * Call stacks + HasCallStack, + HasDebugCallStack, + + -- * Utils for flags + OverridingBool(..), + overrideWith, + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Utils.Exception +import GHC.Utils.Panic.Plain + +import Data.Data +import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.List hiding (group) +import Data.List.NonEmpty ( NonEmpty(..) ) + +import GHC.Exts +import GHC.Stack (HasCallStack) + +import Control.Applicative ( liftA2 ) +import Control.Monad ( liftM, guard ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import GHC.Conc.Sync ( sharedCAF ) +import System.IO.Error as IO ( isDoesNotExistError ) +import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) +import System.FilePath + +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper + , isHexDigit, digitToInt ) +import Data.Int +import Data.Ratio ( (%) ) +import Data.Ord ( comparing ) +import Data.Bits +import Data.Word +import qualified Data.IntMap as IM +import qualified Data.Set as Set + +import Data.Time + +#if defined(DEBUG) +import {-# SOURCE #-} GHC.Utils.Outputable ( warnPprTrace, text ) +#endif + +infixr 9 `thenCmp` + +{- +************************************************************************ +* * +\subsection{Is DEBUG on, are we on Windows, etc?} +* * +************************************************************************ + +These booleans are global constants, set by CPP flags. They allow us to +recompile a single module (this one) to change whether or not debug output +appears. They sometimes let us avoid even running CPP elsewhere. + +It's important that the flags are literal constants (True/False). Then, +with -0, tests of the flags in other modules will simplify to the correct +branch of the conditional, thereby dropping debug code altogether when +the flags are off. +-} + +ghciSupported :: Bool +#if defined(HAVE_INTERNAL_INTERPRETER) +ghciSupported = True +#else +ghciSupported = False +#endif + +debugIsOn :: Bool +#if defined(DEBUG) +debugIsOn = True +#else +debugIsOn = False +#endif + +isWindowsHost :: Bool +#if defined(mingw32_HOST_OS) +isWindowsHost = True +#else +isWindowsHost = False +#endif + +isDarwinHost :: Bool +#if defined(darwin_HOST_OS) +isDarwinHost = True +#else +isDarwinHost = False +#endif + +{- +************************************************************************ +* * +\subsection{Miscellaneous higher-order functions} +* * +************************************************************************ +-} + +-- | Apply a function iff some condition is met. +applyWhen :: Bool -> (a -> a) -> a -> a +applyWhen True f x = f x +applyWhen _ _ x = x + +-- | A for loop: Compose a function with itself n times. (nth rather than twice) +nTimes :: Int -> (a -> a) -> (a -> a) +nTimes 0 _ = id +nTimes 1 f = f +nTimes n f = f . nTimes (n-1) f + +fstOf3 :: (a,b,c) -> a +sndOf3 :: (a,b,c) -> b +thdOf3 :: (a,b,c) -> c +fstOf3 (a,_,_) = a +sndOf3 (_,b,_) = b +thdOf3 (_,_,c) = c + +fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) +fst3 f (a, b, c) = (f a, b, c) + +snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) +snd3 f (a, b, c) = (a, f b, c) + +third3 :: (c -> d) -> (a, b, c) -> (a, b, d) +third3 f (a, b, c) = (a, b, f c) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +liftFst :: (a -> b) -> (a, c) -> (b, c) +liftFst f (a,c) = (f a, c) + +liftSnd :: (a -> b) -> (c, a) -> (c, b) +liftSnd f (c,a) = (c, f a) + +firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) +firstM f (x, y) = liftM (\x' -> (x', y)) (f x) + +first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) +first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) + +secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) +secondM f (x, y) = (x,) <$> f y + +{- +************************************************************************ +* * +\subsection[Utils-lists]{General list processing} +* * +************************************************************************ +-} + +filterOut :: (a->Bool) -> [a] -> [a] +-- ^ Like filter, only it reverses the sense of the test +filterOut _ [] = [] +filterOut p (x:xs) | p x = filterOut p xs + | otherwise = x : filterOut p xs + +partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +-- ^ Uses a function to determine which of two output lists an input element should join +partitionWith _ [] = ([],[]) +partitionWith f (x:xs) = case f x of + Left b -> (b:bs, cs) + Right c -> (bs, c:cs) + where (bs,cs) = partitionWith f xs + +chkAppend :: [a] -> [a] -> [a] +-- Checks for the second argument being empty +-- Used in situations where that situation is common +chkAppend xs ys + | null ys = xs + | otherwise = xs ++ ys + +{- +A paranoid @zip@ (and some @zipWith@ friends) that checks the lists +are of equal length. Alastair Reid thinks this should only happen if +DEBUGging on; hey, why not? +-} + +zipEqual :: String -> [a] -> [b] -> [(a,b)] +zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] + +#if !defined(DEBUG) +zipEqual _ = zip +zipWithEqual _ = zipWith +zipWith3Equal _ = zipWith3 +zipWith4Equal _ = zipWith4 +#else +zipEqual _ [] [] = [] +zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs +zipEqual msg _ _ = panic ("zipEqual: unequal lists: "++msg) + +zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs +zipWithEqual _ _ [] [] = [] +zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists: "++msg) + +zipWith3Equal msg z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3Equal msg z as bs cs +zipWith3Equal _ _ [] [] [] = [] +zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists: "++msg) + +zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4Equal msg z as bs cs ds +zipWith4Equal _ _ [] [] [] [] = [] +zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) +#endif + +-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) +zipLazy :: [a] -> [b] -> [(a,b)] +zipLazy [] _ = [] +zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys + +-- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. +-- The length of the output is always the same as the length of the first +-- list. +zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] +zipWithLazy _ [] _ = [] +zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs + +-- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. +-- The length of the output is always the same as the length of the first +-- list. +zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] +zipWith3Lazy _ [] _ _ = [] +zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs + +-- | 'filterByList' takes a list of Bools and a list of some elements and +-- filters out these elements for which the corresponding value in the list of +-- Bools is False. This function does not check whether the lists have equal +-- length. +filterByList :: [Bool] -> [a] -> [a] +filterByList (True:bs) (x:xs) = x : filterByList bs xs +filterByList (False:bs) (_:xs) = filterByList bs xs +filterByList _ _ = [] + +-- | 'filterByLists' takes a list of Bools and two lists as input, and +-- outputs a new list consisting of elements from the last two input lists. For +-- each Bool in the list, if it is 'True', then it takes an element from the +-- former list. If it is 'False', it takes an element from the latter list. +-- The elements taken correspond to the index of the Bool in its list. +-- For example: +-- +-- @ +-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" +-- @ +-- +-- This function does not check whether the lists have equal length. +filterByLists :: [Bool] -> [a] -> [a] -> [a] +filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys +filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys +filterByLists _ _ _ = [] + +-- | 'partitionByList' takes a list of Bools and a list of some elements and +-- partitions the list according to the list of Bools. Elements corresponding +-- to 'True' go to the left; elements corresponding to 'False' go to the right. +-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ +-- This function does not check whether the lists have equal +-- length; when one list runs out, the function stops. +partitionByList :: [Bool] -> [a] -> ([a], [a]) +partitionByList = go [] [] + where + go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs + go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs + go trues falses _ _ = (reverse trues, reverse falses) + +stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] +-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in +-- the places where @p@ returns @True@ + +stretchZipWith _ _ _ [] _ = [] +stretchZipWith p z f (x:xs) ys + | p x = f x z : stretchZipWith p z f xs ys + | otherwise = case ys of + [] -> [] + (y:ys) -> f x y : stretchZipWith p z f xs ys + +mapFst :: (a->c) -> [(a,b)] -> [(c,b)] +mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] + +mapFst f xys = [(f x, y) | (x,y) <- xys] +mapSnd f xys = [(x, f y) | (x,y) <- xys] + +mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) + +mapAndUnzip _ [] = ([], []) +mapAndUnzip f (x:xs) + = let (r1, r2) = f x + (rs1, rs2) = mapAndUnzip f xs + in + (r1:rs1, r2:rs2) + +mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) + +mapAndUnzip3 _ [] = ([], [], []) +mapAndUnzip3 f (x:xs) + = let (r1, r2, r3) = f x + (rs1, rs2, rs3) = mapAndUnzip3 f xs + in + (r1:rs1, r2:rs2, r3:rs3) + +zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) +zipWithAndUnzip f (a:as) (b:bs) + = let (r1, r2) = f a b + (rs1, rs2) = zipWithAndUnzip f as bs + in + (r1:rs1, r2:rs2) +zipWithAndUnzip _ _ _ = ([],[]) + +-- | This has the effect of making the two lists have equal length by dropping +-- the tail of the longer one. +zipAndUnzip :: [a] -> [b] -> ([a],[b]) +zipAndUnzip (a:as) (b:bs) + = let (rs1, rs2) = zipAndUnzip as bs + in + (a:rs1, b:rs2) +zipAndUnzip _ _ = ([],[]) + +mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) +mapAccumL2 f s1 s2 xs = (s1', s2', ys) + where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of + (s1', s2', y) -> ((s1', s2'), y)) + (s1, s2) xs + +-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: +-- +-- @ +-- atLength atLenPred atEndPred ls n +-- | n < 0 = atLenPred ls +-- | length ls < n = atEndPred (n - length ls) +-- | otherwise = atLenPred (drop n ls) +-- @ +atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) + -- NB: arg passed to this function may be [] + -> b -- Called when length ls < n + -> [a] + -> Int + -> b +atLength atLenPred atEnd ls0 n0 + | n0 < 0 = atLenPred ls0 + | otherwise = go n0 ls0 + where + -- go's first arg n >= 0 + go 0 ls = atLenPred ls + go _ [] = atEnd -- n > 0 here + go n (_:xs) = go (n-1) xs + +-- Some special cases of atLength: + +-- | @(lengthExceeds xs n) = (length xs > n)@ +lengthExceeds :: [a] -> Int -> Bool +lengthExceeds lst n + | n < 0 + = True + | otherwise + = atLength notNull False lst n + +-- | @(lengthAtLeast xs n) = (length xs >= n)@ +lengthAtLeast :: [a] -> Int -> Bool +lengthAtLeast = atLength (const True) False + +-- | @(lengthIs xs n) = (length xs == n)@ +lengthIs :: [a] -> Int -> Bool +lengthIs lst n + | n < 0 + = False + | otherwise + = atLength null False lst n + +-- | @(lengthIsNot xs n) = (length xs /= n)@ +lengthIsNot :: [a] -> Int -> Bool +lengthIsNot lst n + | n < 0 = True + | otherwise = atLength notNull True lst n + +-- | @(lengthAtMost xs n) = (length xs <= n)@ +lengthAtMost :: [a] -> Int -> Bool +lengthAtMost lst n + | n < 0 + = False + | otherwise + = atLength null True lst n + +-- | @(lengthLessThan xs n) == (length xs < n)@ +lengthLessThan :: [a] -> Int -> Bool +lengthLessThan = atLength (const False) True + +listLengthCmp :: [a] -> Int -> Ordering +listLengthCmp = atLength atLen atEnd + where + atEnd = LT -- Not yet seen 'n' elts, so list length is < n. + + atLen [] = EQ + atLen _ = GT + +equalLength :: [a] -> [b] -> Bool +-- ^ True if length xs == length ys +equalLength [] [] = True +equalLength (_:xs) (_:ys) = equalLength xs ys +equalLength _ _ = False + +compareLength :: [a] -> [b] -> Ordering +compareLength [] [] = EQ +compareLength (_:xs) (_:ys) = compareLength xs ys +compareLength [] _ = LT +compareLength _ [] = GT + +leLength :: [a] -> [b] -> Bool +-- ^ True if length xs <= length ys +leLength xs ys = case compareLength xs ys of + LT -> True + EQ -> True + GT -> False + +ltLength :: [a] -> [b] -> Bool +-- ^ True if length xs < length ys +ltLength xs ys = case compareLength xs ys of + LT -> True + EQ -> False + GT -> False + +---------------------------- +singleton :: a -> [a] +singleton x = [x] + +isSingleton :: [a] -> Bool +isSingleton [_] = True +isSingleton _ = False + +notNull :: [a] -> Bool +notNull [] = False +notNull _ = True + +only :: [a] -> a +#if defined(DEBUG) +only [a] = a +#else +only (a:_) = a +#endif +only _ = panic "Util: only" + +-- 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 = WARN(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 = WARN(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]] +chunkList _ [] = [] +chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs + +-- | Replace the last element of a list with another element. +changeLast :: [a] -> a -> [a] +changeLast [] _ = panic "changeLast" +changeLast [_] x = [x] +changeLast (x:xs) x' = x : changeLast xs x' + +whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () +whenNonEmpty [] _ = pure () +whenNonEmpty (x:xs) f = f (x :| xs) + +{- +************************************************************************ +* * +\subsubsection{Sort utils} +* * +************************************************************************ +-} + +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs) + +nubSort :: Ord a => [a] -> [a] +nubSort = Set.toAscList . Set.fromList + +-- | Remove duplicates but keep elements in order. +-- O(n * log n) +ordNub :: Ord a => [a] -> [a] +ordNub xs + = go Set.empty xs + where + go _ [] = [] + go s (x:xs) + | Set.member x s = go s xs + | otherwise = x : go (Set.insert x s) xs + + +{- +************************************************************************ +* * +\subsection[Utils-transitive-closure]{Transitive closure} +* * +************************************************************************ + +This algorithm for transitive closure is straightforward, albeit quadratic. +-} + +transitiveClosure :: (a -> [a]) -- Successor function + -> (a -> a -> Bool) -- Equality predicate + -> [a] + -> [a] -- The transitive closure + +transitiveClosure succ eq xs + = go [] xs + where + go done [] = done + go done (x:xs) | x `is_in` done = go done xs + | otherwise = go (x:done) (succ x ++ xs) + + _ `is_in` [] = False + x `is_in` (y:ys) | eq x y = True + | otherwise = x `is_in` ys + +{- +************************************************************************ +* * +\subsection[Utils-accum]{Accumulating} +* * +************************************************************************ + +A combination of foldl with zip. It works with equal length lists. +-} + +foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc +foldl2 _ z [] [] = z +foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs +foldl2 _ _ _ _ = panic "Util: foldl2" + +all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool +-- True if the lists are the same length, and +-- all corresponding elements satisfy the predicate +all2 _ [] [] = True +all2 p (x:xs) (y:ys) = p x y && all2 p xs ys +all2 _ _ _ = False + +-- Count the number of times a predicate is true + +count :: (a -> Bool) -> [a] -> Int +count p = go 0 + where go !n [] = n + go !n (x:xs) | p x = go (n+1) xs + | otherwise = go n xs + +countWhile :: (a -> Bool) -> [a] -> Int +-- Length of an /initial prefix/ of the list satisfying p +countWhile p = go 0 + where go !n (x:xs) | p x = go (n+1) xs + go !n _ = n + +{- +@splitAt@, @take@, and @drop@ but with length of another +list giving the break-off point: +-} + +takeList :: [b] -> [a] -> [a] +-- (takeList as bs) trims bs to the be same length +-- as as, unless as is longer in which case it's a no-op +takeList [] _ = [] +takeList (_:xs) ls = + case ls of + [] -> [] + (y:ys) -> y : takeList xs ys + +dropList :: [b] -> [a] -> [a] +dropList [] xs = xs +dropList _ xs@[] = xs +dropList (_:xs) (_:ys) = dropList xs ys + + +splitAtList :: [b] -> [a] -> ([a], [a]) +splitAtList [] xs = ([], xs) +splitAtList _ xs@[] = (xs, xs) +splitAtList (_:xs) (y:ys) = (y:ys', ys'') + where + (ys', ys'') = splitAtList xs ys + +-- drop from the end of a list +dropTail :: Int -> [a] -> [a] +-- Specification: dropTail n = reverse . drop n . reverse +-- Better implemention due to Joachim Breitner +-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html +dropTail n xs + = go (drop n xs) xs + where + go (_:ys) (x:xs) = x : go ys xs + go _ _ = [] -- Stop when ys runs out + -- It'll always run out before xs does + +-- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, +-- but is lazy in the elements and strict in the spine. For reasonably short lists, +-- such as path names and typical lines of text, dropWhileEndLE is generally +-- faster than dropWhileEnd. Its advantage is magnified when the predicate is +-- expensive--using dropWhileEndLE isSpace to strip the space off a line of text +-- is generally much faster than using dropWhileEnd isSpace for that purpose. +-- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse +-- Pay attention to the short-circuit (&&)! The order of its arguments is the only +-- difference between dropWhileEnd and dropWhileEndLE. +dropWhileEndLE :: (a -> Bool) -> [a] -> [a] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] + +-- | @spanEnd p l == reverse (span p (reverse l))@. The first list +-- returns actually comes after the second list (when you look at the +-- input list). +spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) +spanEnd p l = go l [] [] l + where go yes _rev_yes rev_no [] = (yes, reverse rev_no) + go yes rev_yes rev_no (x:xs) + | p x = go yes (x : rev_yes) rev_no xs + | otherwise = go xs [] (x : rev_yes ++ rev_no) xs + +-- | Get the last two elements in a list. Partial! +{-# INLINE last2 #-} +last2 :: [a] -> (a,a) +last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) + where + partialError = panic "last2 - list length less than two" + +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe xs = Just $ last xs + +-- | Split a list into its last element and the initial part of the list. +-- @snocView xs = Just (init xs, last xs)@ for non-empty lists. +-- @snocView xs = Nothing@ otherwise. +-- Unless both parts of the result are guaranteed to be used +-- prefer separate calls to @last@ + @init@. +-- If you are guaranteed to use both, this will +-- be more efficient. +snocView :: [a] -> Maybe ([a],a) +snocView [] = Nothing +snocView xs + | (xs,x) <- go xs + = Just (xs,x) + where + go :: [a] -> ([a],a) + go [x] = ([],x) + go (x:xs) + | !(xs',x') <- go xs + = (x:xs', x') + go [] = error "impossible" + +split :: Char -> String -> [String] +split c s = case rest of + [] -> [chunk] + _:rest -> chunk : split c rest + where (chunk, rest) = break (==c) s + +-- | Convert a word to title case by capitalising the first letter +capitalise :: String -> String +capitalise [] = [] +capitalise (c:cs) = toUpper c : cs + + +{- +************************************************************************ +* * +\subsection[Utils-comparison]{Comparisons} +* * +************************************************************************ +-} + +isEqual :: Ordering -> Bool +-- Often used in (isEqual (a `compare` b)) +isEqual GT = False +isEqual EQ = True +isEqual LT = False + +thenCmp :: Ordering -> Ordering -> Ordering +{-# INLINE thenCmp #-} +thenCmp EQ ordering = ordering +thenCmp ordering _ = ordering + +eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool +eqListBy _ [] [] = True +eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys +eqListBy _ _ _ = False + +eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool +eqMaybeBy _ Nothing Nothing = True +eqMaybeBy eq (Just x) (Just y) = eq x y +eqMaybeBy _ _ _ = False + +cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering + -- `cmpList' uses a user-specified comparer + +cmpList _ [] [] = EQ +cmpList _ [] _ = LT +cmpList _ _ [] = GT +cmpList cmp (a:as) (b:bs) + = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } + +removeSpaces :: String -> String +removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace + +-- Boolean operators lifted to Applicative +(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool +(<&&>) = liftA2 (&&) +infixr 3 <&&> -- same as (&&) + +(<||>) :: Applicative f => f Bool -> f Bool -> f Bool +(<||>) = liftA2 (||) +infixr 2 <||> -- same as (||) + +{- +************************************************************************ +* * +\subsection{Edit distance} +* * +************************************************************************ +-} + +-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. +-- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>. +-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing +-- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). +-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and +-- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation +restrictedDamerauLevenshteinDistance :: String -> String -> Int +restrictedDamerauLevenshteinDistance str1 str2 + = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + where + m = length str1 + n = length str2 + +restrictedDamerauLevenshteinDistanceWithLengths + :: Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + | m <= n + = if n <= 32 -- n must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 + + | otherwise + = if m <= 32 -- m must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 + +restrictedDamerauLevenshteinDistance' + :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 + | [] <- str1 = n + | otherwise = extractAnswer $ + foldl' (restrictedDamerauLevenshteinDistanceWorker + (matchVectors str1) top_bit_mask vector_mask) + (0, 0, m_ones, 0, m) str2 + where + m_ones@vector_mask = (2 ^ m) - 1 + top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy + extractAnswer (_, _, _, _, distance) = distance + +restrictedDamerauLevenshteinDistanceWorker + :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv + -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) +restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask + (pm, d0, vp, vn, distance) char2 + = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ + seq pm' $ seq d0' $ seq vp' $ seq vn' $ + seq distance'' $ seq char2 $ + (pm', d0', vp', vn', distance'') + where + pm' = IM.findWithDefault 0 (ord char2) str1_mvs + + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) + .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn + -- No need to mask the shiftL because of the restricted range of pm + + hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) + hn' = d0' .&. vp + + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask + hn'_shift = (hn' `shiftL` 1) .&. vector_mask + vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) + vn' = d0' .&. hp'_shift + + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance + distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' + +sizedComplement :: Bits bv => bv -> bv -> bv +sizedComplement vector_mask vect = vector_mask `xor` vect + +matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv +matchVectors = snd . foldl' go (0 :: Int, IM.empty) + where + go (ix, im) char = let ix' = ix + 1 + im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im + in seq ix' $ seq im' $ (ix', im') + +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Word32 -> Int -> Int -> String -> String -> Int #-} +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Integer -> Int -> Int -> String -> String -> Int #-} + +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Word32 -> Word32 -> Word32 + -> (Word32, Word32, Word32, Word32, Int) + -> Char -> (Word32, Word32, Word32, Word32, Int) #-} +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Integer -> Integer -> Integer + -> (Integer, Integer, Integer, Integer, Int) + -> Char -> (Integer, Integer, Integer, Integer, Int) #-} + +{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} +{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} + +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} + +fuzzyMatch :: String -> [String] -> [String] +fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] + +-- | Search for possible matches to the users input in the given list, +-- returning a small number of ranked results +fuzzyLookup :: String -> [(String,a)] -> [a] +fuzzyLookup user_entered possibilites + = map fst $ take mAX_RESULTS $ sortBy (comparing snd) + [ (poss_val, distance) | (poss_str, poss_val) <- possibilites + , let distance = restrictedDamerauLevenshteinDistance + poss_str user_entered + , distance <= fuzzy_threshold ] + where + -- Work out an appropriate match threshold: + -- We report a candidate if its edit distance is <= the threshold, + -- The threshold is set to about a quarter of the # of characters the user entered + -- Length Threshold + -- 1 0 -- Don't suggest *any* candidates + -- 2 1 -- for single-char identifiers + -- 3 1 + -- 4 1 + -- 5 1 + -- 6 2 + -- + fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) + mAX_RESULTS = 3 + +{- +************************************************************************ +* * +\subsection[Utils-pairs]{Pairs} +* * +************************************************************************ +-} + +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] +unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs + +seqList :: [a] -> b -> b +seqList [] b = b +seqList (x:xs) b = x `seq` seqList xs b + +strictMap :: (a -> b) -> [a] -> [b] +strictMap _ [] = [] +strictMap f (x : xs) = + let + !x' = f x + !xs' = strictMap f xs + in + x' : xs' + +{- +************************************************************************ +* * + Globals and the RTS +* * +************************************************************************ + +When a plugin is loaded, it currently gets linked against a *newly +loaded* copy of the GHC package. This would not be a problem, except +that the new copy has its own mutable state that is not shared with +that state that has already been initialized by the original GHC +package. + +(Note that if the GHC executable was dynamically linked this +wouldn't be a problem, because we could share the GHC library it +links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) + +The solution is to make use of @sharedCAF@ through @sharedGlobal@ +for globals that are shared between multiple copies of ghc packages. +-} + +-- Global variables: + +global :: a -> IORef a +global a = unsafePerformIO (newIORef a) + +consIORef :: IORef [a] -> a -> IO () +consIORef var x = do + atomicModifyIORef' var (\xs -> (x:xs,())) + +globalM :: IO a -> IORef a +globalM ma = unsafePerformIO (ma >>= newIORef) + +-- Shared global variables: + +sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobal a get_or_set = unsafePerformIO $ + newIORef a >>= flip sharedCAF get_or_set + +sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobalM ma get_or_set = unsafePerformIO $ + ma >>= newIORef >>= flip sharedCAF get_or_set + +-- Module names: + +looksLikeModuleName :: String -> Bool +looksLikeModuleName [] = False +looksLikeModuleName (c:cs) = isUpper c && go cs + where go [] = True + go ('.':cs) = looksLikeModuleName cs + go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs + +-- Similar to 'parse' for Distribution.Package.PackageName, +-- but we don't want to depend on Cabal. +looksLikePackageName :: String -> Bool +looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' + +{- +Akin to @Prelude.words@, but acts like the Bourne shell, treating +quoted strings as Haskell Strings, and also parses Haskell [String] +syntax. +-} + +getCmd :: String -> Either String -- Error + (String, String) -- (Cmd, Rest) +getCmd s = case break isSpace $ dropWhile isSpace s of + ([], _) -> Left ("Couldn't find command in " ++ show s) + res -> Right res + +toCmdArgs :: String -> Either String -- Error + (String, [String]) -- (Cmd, Args) +toCmdArgs s = case getCmd s of + Left err -> Left err + Right (cmd, s') -> case toArgs s' of + Left err -> Left err + Right args -> Right (cmd, args) + +toArgs :: String -> Either String -- Error + [String] -- Args +toArgs str + = case dropWhile isSpace str of + s@('[':_) -> case reads s of + [(args, spaces)] + | all isSpace spaces -> + Right args + _ -> + Left ("Couldn't read " ++ show str ++ " as [String]") + s -> toArgs' s + where + toArgs' :: String -> Either String [String] + -- Remove outer quotes: + -- > toArgs' "\"foo\" \"bar baz\"" + -- Right ["foo", "bar baz"] + -- + -- Keep inner quotes: + -- > toArgs' "-DFOO=\"bar baz\"" + -- Right ["-DFOO=\"bar baz\""] + toArgs' s = case dropWhile isSpace s of + [] -> Right [] + ('"' : _) -> do + -- readAsString removes outer quotes + (arg, rest) <- readAsString s + (arg:) `fmap` toArgs' rest + s' -> case break (isSpace <||> (== '"')) s' of + (argPart1, s''@('"':_)) -> do + (argPart2, rest) <- readAsString s'' + -- show argPart2 to keep inner quotes + ((argPart1 ++ show argPart2):) `fmap` toArgs' rest + (arg, s'') -> (arg:) `fmap` toArgs' s'' + + readAsString :: String -> Either String (String, String) + readAsString s = case reads s of + [(arg, rest)] + -- rest must either be [] or start with a space + | all isSpace (take 1 rest) -> + Right (arg, rest) + _ -> + Left ("Couldn't read " ++ show s ++ " as String") +----------------------------------------------------------------------------- +-- Integers + +-- | Determine the $\log_2$ of exact powers of 2 +exactLog2 :: Integer -> Maybe Integer +exactLog2 x + | x <= 0 = Nothing + | x > fromIntegral (maxBound :: Int32) = Nothing + | x' .&. (-x') /= x' = Nothing + | otherwise = Just (fromIntegral c) + where + x' = fromIntegral x :: Int32 + c = countTrailingZeros x' + +{- +-- ----------------------------------------------------------------------------- +-- Floats +-} + +readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" +readRational__ r = do + (n,d,s) <- readFix r + (k,t) <- readExp s + return ((n%1)*10^^(k-d), t) + where + readFix r = do + (ds,s) <- lexDecDigits r + (ds',t) <- lexDotDigits s + return (read (ds++ds'), length ds', t) + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = return (0,s) + + readExp' ('+':s) = readDec s + readExp' ('-':s) = do (k,t) <- readDec s + return (-k,t) + readExp' s = readDec s + + readDec s = do + (ds,r) <- nonnull isDigit s + return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], + r) + + lexDecDigits = nonnull isDigit + + lexDotDigits ('.':s) = return (span' isDigit s) + lexDotDigits s = return ("",s) + + nonnull p s = do (cs@(_:_),t) <- return (span' p s) + return (cs,t) + + span' _ xs@[] = (xs, xs) + span' p xs@(x:xs') + | x == '_' = span' p xs' -- skip "_" (#14473) + | p x = let (ys,zs) = span' p xs' in (x:ys,zs) + | otherwise = ([],xs) + +readRational :: String -> Rational -- NB: *does* handle a leading "-" +readRational top_s + = case top_s of + '-' : xs -> - (read_me xs) + xs -> read_me xs + where + read_me s + = case (do { (x,"") <- readRational__ s ; return x }) of + [x] -> x + [] -> error ("readRational: no parse:" ++ top_s) + _ -> error ("readRational: ambiguous parse:" ++ top_s) + + +readHexRational :: String -> Rational +readHexRational str = + case str of + '-' : xs -> - (readMe xs) + xs -> readMe xs + where + readMe as = + case readHexRational__ as of + Just n -> n + _ -> error ("readHexRational: no parse:" ++ str) + + +readHexRational__ :: String -> Maybe Rational +readHexRational__ ('0' : x : rest) + | x == 'X' || x == 'x' = + do let (front,rest2) = span' isHexDigit rest + guard (not (null front)) + let frontNum = steps 16 0 front + case rest2 of + '.' : rest3 -> + do let (back,rest4) = span' isHexDigit rest3 + guard (not (null back)) + let backNum = steps 16 frontNum back + exp1 = -4 * length back + case rest4 of + p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) + _ -> return (mk backNum exp1) + p : ps | isExp p -> fmap (mk frontNum) (getExp ps) + _ -> Nothing + + where + isExp p = p == 'p' || p == 'P' + + getExp ('+' : ds) = dec ds + getExp ('-' : ds) = fmap negate (dec ds) + getExp ds = dec ds + + mk :: Integer -> Int -> Rational + mk n e = fromInteger n * 2^^e + + dec cs = case span' isDigit cs of + (ds,"") | not (null ds) -> Just (steps 10 0 ds) + _ -> Nothing + + steps base n ds = foldl' (step base) n ds + step base n d = base * n + fromIntegral (digitToInt d) + + span' _ xs@[] = (xs, xs) + span' p xs@(x:xs') + | x == '_' = span' p xs' -- skip "_" (#14473) + | p x = let (ys,zs) = span' p xs' in (x:ys,zs) + | otherwise = ([],xs) + +readHexRational__ _ = Nothing + +----------------------------------------------------------------------------- +-- Verify that the 'dirname' portion of a FilePath exists. +-- +doesDirNameExist :: FilePath -> IO Bool +doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) + +----------------------------------------------------------------------------- +-- Backwards compatibility definition of getModificationTime + +getModificationUTCTime :: FilePath -> IO UTCTime +getModificationUTCTime = getModificationTime + +-- -------------------------------------------------------------- +-- check existence & modification time at the same time + +modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) +modificationTimeIfExists f = do + (do t <- getModificationUTCTime f; return (Just t)) + `catchIO` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- -------------------------------------------------------------- +-- atomic file writing by writing to a temporary file first (see #14533) +-- +-- This should be used in all cases where GHC writes files to disk +-- and uses their modification time to skip work later, +-- as otherwise a partially written file (e.g. due to crash or Ctrl+C) +-- also results in a skip. + +withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a +withAtomicRename targetFile f = do + -- The temp file must be on the same file system (mount) as the target file + -- to result in an atomic move on most platforms. + -- The standard way to ensure that is to place it into the same directory. + -- This can still be fooled when somebody mounts a different file system + -- at just the right time, but that is not a case we aim to cover here. + let temp = targetFile <.> "tmp" + res <- f temp + liftIO $ renameFile temp targetFile + return res + +-- -------------------------------------------------------------- +-- split a string at the last character where 'pred' is True, +-- returning a pair of strings. The first component holds the string +-- up (but not including) the last character for which 'pred' returned +-- True, the second whatever comes after (but also not including the +-- last character). +-- +-- If 'pred' returns False for all characters in the string, the original +-- string is returned in the first component (and the second one is just +-- empty). +splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) +splitLongestPrefix str pred + | null r_pre = (str, []) + | otherwise = (reverse (tail r_pre), reverse r_suf) + -- 'tail' drops the char satisfying 'pred' + where (r_suf, r_pre) = break pred (reverse str) + +escapeSpaces :: String -> String +escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" + +type Suffix = String + +-------------------------------------------------------------- +-- * Search path +-------------------------------------------------------------- + +data Direction = Forwards | Backwards + +reslash :: Direction -> FilePath -> FilePath +reslash d = f + where f ('/' : xs) = slash : f xs + f ('\\' : xs) = slash : f xs + f (x : xs) = x : f xs + f "" = "" + slash = case d of + Forwards -> '/' + Backwards -> '\\' + +makeRelativeTo :: FilePath -> FilePath -> FilePath +this `makeRelativeTo` that = directory </> thisFilename + where (thisDirectory, thisFilename) = splitFileName this + thatDirectory = dropFileName that + directory = joinPath $ f (splitPath thisDirectory) + (splitPath thatDirectory) + + f (x : xs) (y : ys) + | x == y = f xs ys + f xs ys = replicate (length ys) ".." ++ xs + +{- +************************************************************************ +* * +\subsection[Utils-Data]{Utils for defining Data instances} +* * +************************************************************************ + +These functions helps us to define Data instances for abstract types. +-} + +abstractConstr :: String -> Constr +abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix + +abstractDataType :: String -> DataType +abstractDataType n = mkDataType n [abstractConstr n] + +{- +************************************************************************ +* * +\subsection[Utils-C]{Utils for printing C code} +* * +************************************************************************ +-} + +charToC :: Word8 -> String +charToC w = + case chr (fromIntegral w) of + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] + | otherwise -> ['\\', + chr (ord '0' + ord c `div` 64), + chr (ord '0' + ord c `div` 8 `mod` 8), + chr (ord '0' + ord c `mod` 8)] + +{- +************************************************************************ +* * +\subsection[Utils-Hashing]{Utils for hashing} +* * +************************************************************************ +-} + +-- | A sample hash function for Strings. We keep multiplying by the +-- golden ratio and adding. The implementation is: +-- +-- > hashString = foldl' f golden +-- > where f m c = fromIntegral (ord c) * magic + hashInt32 m +-- > magic = 0xdeadbeef +-- +-- Where hashInt32 works just as hashInt shown above. +-- +-- Knuth argues that repeated multiplication by the golden ratio +-- will minimize gaps in the hash space, and thus it's a good choice +-- for combining together multiple keys to form one. +-- +-- Here we know that individual characters c are often small, and this +-- produces frequent collisions if we use ord c alone. A +-- particular problem are the shorter low ASCII and ISO-8859-1 +-- character strings. We pre-multiply by a magic twiddle factor to +-- obtain a good distribution. In fact, given the following test: +-- +-- > testp :: Int32 -> Int +-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls +-- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] +-- > hs = foldl' f golden +-- > f m c = fromIntegral (ord c) * k + hashInt32 m +-- > n = 100000 +-- +-- We discover that testp magic = 0. +hashString :: String -> Int32 +hashString = foldl' f golden + where f m c = fromIntegral (ord c) * magic + hashInt32 m + magic = fromIntegral (0xdeadbeef :: Word32) + +golden :: Int32 +golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 +-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 +-- but that has bad mulHi properties (even adding 2^32 to get its inverse) +-- Whereas the above works well and contains no hash duplications for +-- [-32767..65536] + +-- | A sample (and useful) hash function for Int32, +-- implemented by extracting the uppermost 32 bits of the 64-bit +-- result of multiplying by a 33-bit constant. The constant is from +-- Knuth, derived from the golden ratio: +-- +-- > golden = round ((sqrt 5 - 1) * 2^32) +-- +-- We get good key uniqueness on small inputs +-- (a problem with previous versions): +-- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 +-- +hashInt32 :: Int32 -> Int32 +hashInt32 x = mulHi x golden + x + +-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where r :: Int64 + r = fromIntegral a * fromIntegral b + +-- | A call stack constraint, but only when 'isDebugOn'. +#if defined(DEBUG) +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/Monad.hs b/compiler/GHC/Utils/Monad.hs new file mode 100644 index 0000000000..9e53edd0bb --- /dev/null +++ b/compiler/GHC/Utils/Monad.hs @@ -0,0 +1,215 @@ +-- | Utilities related to Monad and Applicative classes +-- Mostly for backwards compatibility. + +module GHC.Utils.Monad + ( Applicative(..) + , (<$>) + + , MonadFix(..) + , MonadIO(..) + + , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM + , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M + , mapAccumLM + , mapSndM + , concatMapM + , mapMaybeM + , fmapMaybeM, fmapEitherM + , anyM, allM, orM + , foldlM, foldlM_, foldrM + , maybeMapM + , whenM, unlessM + , filterOutM + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import GHC.Prelude + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.Foldable (sequenceA_, foldlM, foldrM) +import Data.List (unzip4, unzip5, zipWith4) + +------------------------------------------------------------------------------- +-- Common functions +-- These are used throughout the compiler +------------------------------------------------------------------------------- + +{- + +Note [Inline @zipWithNM@ functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The inline principle for 'zipWith3M', 'zipWith4M' and 'zipWith3M_' is the same +as for 'zipWithM' and 'zipWithM_' in "Control.Monad", see +Note [Fusion for zipN/zipWithN] in GHC/List.hs for more details. + +The 'zipWithM'/'zipWithM_' functions are inlined so that the `zipWith` and +`sequenceA` functions with which they are defined have an opportunity to fuse. + +Furthermore, 'zipWith3M'/'zipWith4M' and 'zipWith3M_' have been explicitly +rewritten in a non-recursive way similarly to 'zipWithM'/'zipWithM_', and for +more than just uniformity: after [D5241](https://phabricator.haskell.org/D5241) +for issue #14037, all @zipN@/@zipWithN@ functions fuse, meaning +'zipWith3M'/'zipWIth4M' and 'zipWith3M_'@ now behave like 'zipWithM' and +'zipWithM_', respectively, with regards to fusion. + +As such, since there are not any differences between 2-ary 'zipWithM'/ +'zipWithM_' and their n-ary counterparts below aside from the number of +arguments, the `INLINE` pragma should be replicated in the @zipWithNM@ +functions below as well. + +-} + +zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] +{-# INLINE zipWith3M #-} +-- Inline so that fusion with 'zipWith3' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith3M f xs ys zs = sequenceA (zipWith3 f xs ys zs) + +zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () +{-# INLINE zipWith3M_ #-} +-- Inline so that fusion with 'zipWith4' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith3M_ f xs ys zs = sequenceA_ (zipWith3 f xs ys zs) + +zipWith4M :: Monad m => (a -> b -> c -> d -> m e) + -> [a] -> [b] -> [c] -> [d] -> m [e] +{-# INLINE zipWith4M #-} +-- Inline so that fusion with 'zipWith5' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith4M f xs ys ws zs = sequenceA (zipWith4 f xs ys ws zs) + +zipWithAndUnzipM :: Monad m + => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) +{-# INLINABLE zipWithAndUnzipM #-} +-- See Note [flatten_args performance] in GHC.Tc.Solver.Flatten for why this +-- pragma is essential. +zipWithAndUnzipM f (x:xs) (y:ys) + = do { (c, d) <- f x y + ; (cs, ds) <- zipWithAndUnzipM f xs ys + ; return (c:cs, d:ds) } +zipWithAndUnzipM _ _ _ = return ([], []) + +{- + +Note [Inline @mapAndUnzipNM@ functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The inline principle is the same as 'mapAndUnzipM' in "Control.Monad". +The 'mapAndUnzipM' function is inlined so that the `unzip` and `traverse` +functions with which it is defined have an opportunity to fuse, see +Note [Inline @unzipN@ functions] in Data/OldList.hs for more details. + +Furthermore, the @mapAndUnzipNM@ functions have been explicitly rewritten in a +non-recursive way similarly to 'mapAndUnzipM', and for more than just +uniformity: after [D5249](https://phabricator.haskell.org/D5249) for Trac +ticket #14037, all @unzipN@ functions fuse, meaning 'mapAndUnzip3M', +'mapAndUnzip4M' and 'mapAndUnzip5M' now behave like 'mapAndUnzipM' with regards +to fusion. + +As such, since there are not any differences between 2-ary 'mapAndUnzipM' and +its n-ary counterparts below aside from the number of arguments, the `INLINE` +pragma should be replicated in the @mapAndUnzipNM@ functions below as well. + +-} + +-- | mapAndUnzipM for triples +mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) +{-# INLINE mapAndUnzip3M #-} +-- Inline so that fusion with 'unzip3' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip3M f xs = unzip3 <$> traverse f xs + +mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) +{-# INLINE mapAndUnzip4M #-} +-- Inline so that fusion with 'unzip4' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip4M f xs = unzip4 <$> traverse f xs + +mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) +{-# INLINE mapAndUnzip5M #-} +-- Inline so that fusion with 'unzip5' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip5M f xs = unzip5 <$> traverse f xs + +-- | Monadic version of mapAccumL +mapAccumLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> [x] -- ^ inputs + -> m (acc, [y]) -- ^ final state, outputs +mapAccumLM _ s [] = return (s, []) +mapAccumLM f s (x:xs) = do + (s1, x') <- f s x + (s2, xs') <- mapAccumLM f s1 xs + return (s2, x' : xs') + +-- | Monadic version of mapSnd +mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] +mapSndM _ [] = return [] +mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) } + +-- | Monadic version of concatMap +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + +-- | Applicative version of mapMaybe +mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = foldr g (pure []) + where g a = liftA2 (maybe id (:)) (f a) + +-- | Monadic version of fmap +fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) +fmapMaybeM _ Nothing = return Nothing +fmapMaybeM f (Just x) = f x >>= (return . Just) + +-- | Monadic version of fmap +fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) +fmapEitherM fl _ (Left a) = fl a >>= (return . Left) +fmapEitherM _ fr (Right b) = fr b >>= (return . Right) + +-- | Monadic version of 'any', aborts the computation at the first @True@ value +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = return False +anyM f (x:xs) = do b <- f x + if b then return True + else anyM f xs + +-- | Monad version of 'all', aborts the computation at the first @False@ value +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM _ [] = return True +allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False) + +-- | Monadic version of or +orM :: Monad m => m Bool -> m Bool -> m Bool +orM m1 m2 = m1 >>= \x -> if x then return True else m2 + +-- | Monadic version of foldl that discards its result +foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () +foldlM_ = foldM_ + +-- | Monadic version of fmap specialised for Maybe +maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) +maybeMapM _ Nothing = return Nothing +maybeMapM m (Just x) = liftM Just $ m x + +-- | Monadic version of @when@, taking the condition in the monad +whenM :: Monad m => m Bool -> m () -> m () +whenM mb thing = do { b <- mb + ; when b thing } + +-- | Monadic version of @unless@, taking the condition in the monad +unlessM :: Monad m => m Bool -> m () -> m () +unlessM condM acc = do { cond <- condM + ; unless cond acc } + +-- | Like 'filterM', only it reverses the sense of the test. +filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] +filterOutM p = + foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) diff --git a/compiler/GHC/Utils/Monad/State.hs b/compiler/GHC/Utils/Monad/State.hs new file mode 100644 index 0000000000..c7b9e3f591 --- /dev/null +++ b/compiler/GHC/Utils/Monad/State.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UnboxedTuples #-} + +module GHC.Utils.Monad.State where + +import GHC.Prelude + +newtype State s a = State { runState' :: s -> (# a, s #) } + deriving (Functor) + +instance Applicative (State s) where + pure x = State $ \s -> (# x, s #) + m <*> n = State $ \s -> case runState' m s of + (# f, s' #) -> case runState' n s' of + (# x, s'' #) -> (# f x, s'' #) + +instance Monad (State s) where + m >>= n = State $ \s -> case runState' m s of + (# r, s' #) -> runState' (n r) s' + +get :: State s s +get = State $ \s -> (# s, s #) + +gets :: (s -> a) -> State s a +gets f = State $ \s -> (# f s, s #) + +put :: s -> State s () +put s' = State $ \_ -> (# (), s' #) + +modify :: (s -> s) -> State s () +modify f = State $ \s -> (# (), f s #) + + +evalState :: State s a -> s -> a +evalState s i = case runState' s i of + (# a, _ #) -> a + + +execState :: State s a -> s -> s +execState s i = case runState' s i of + (# _, s' #) -> s' + + +runState :: State s a -> s -> (a, s) +runState s i = case runState' s i of + (# a, s' #) -> (a, s') diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs new file mode 100644 index 0000000000..178ac58818 --- /dev/null +++ b/compiler/GHC/Utils/Outputable.hs @@ -0,0 +1,1304 @@ +{-# LANGUAGE LambdaCase #-} + +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-1998 +-} + +-- | This module defines classes and functions for pretty-printing. It also +-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. +-- +-- The interface to this module is very similar to the standard Hughes-PJ pretty printing +-- module, except that it exports a number of additional functions that are rarely used, +-- and works over the 'SDoc' type. +module GHC.Utils.Outputable ( + -- * Type classes + Outputable(..), OutputableBndr(..), + + -- * Pretty printing combinators + SDoc, runSDoc, initSDocContext, + docToSDoc, + interppSP, interpp'SP, + pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, + pprWithBars, + empty, isEmpty, nest, + char, + text, ftext, ptext, ztext, + int, intWithCommas, integer, word, float, double, rational, doublePrec, + parens, cparen, brackets, braces, quotes, quote, + doubleQuotes, angleBrackets, + semi, comma, colon, dcolon, space, equals, dot, vbar, + arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + blankLine, forAllLit, bullet, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + hang, hangNotEmpty, punctuate, ppWhen, ppUnless, + ppWhenOption, ppUnlessOption, + speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, itsOrTheir, + unicodeSyntax, + + coloured, keyword, + + -- * Converting 'SDoc' into strings and outputting it + printSDoc, printSDocLn, printForUser, printForUserPartWay, + printForC, bufLeftRenderSDoc, + pprCode, mkCodeStyle, + showSDoc, showSDocUnsafe, showSDocOneLine, + showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, + showSDocUnqual, showPpr, + renderWithStyle, + + pprInfixVar, pprPrefixVar, + pprHsChar, pprHsString, pprHsBytes, + + primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, + primInt64Suffix, primWord64Suffix, primIntSuffix, + + pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, + + pprFastFilePath, pprFilePathString, + + -- * Controlling the style in which output is printed + BindingSite(..), + + PprStyle, CodeStyle(..), PrintUnqualified(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + reallyAlwaysQualify, reallyAlwaysQualifyNames, + alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, + neverQualify, neverQualifyNames, neverQualifyModules, + alwaysQualifyPackages, neverQualifyPackages, + QualifyName(..), queryQual, + sdocWithDynFlags, sdocOption, + updSDocContext, + SDocContext (..), sdocWithContext, + getPprStyle, withPprStyle, setStyleColoured, + pprDeeper, pprDeeperList, pprSetDepth, + codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, + qualName, qualModule, qualPackage, + mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, + mkUserStyle, cmdlineParserStyle, Depth(..), + withUserStyle, withErrStyle, + + ifPprDebug, whenPprDebug, getPprDebug, + + -- * Error handling and debugging utilities + pprPanic, pprSorry, assertPprPanic, pprPgmError, + pprTrace, pprTraceDebug, pprTraceWith, pprTraceIt, warnPprTrace, + pprSTrace, pprTraceException, pprTraceM, pprTraceWithFlags, + trace, pgmError, panic, sorry, assertPanic, + pprDebugAndThen, callStackDoc, + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Driver.Session + ( DynFlags, hasPprDebug, hasNoDebugOutput + , pprUserLength + , unsafeGlobalDynFlags, initSDocContext + ) +import {-# SOURCE #-} GHC.Types.Module( UnitId, Module, ModuleName, moduleName ) +import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) + +import GHC.Utils.BufHandle (BufHandle) +import GHC.Data.FastString +import qualified GHC.Utils.Ppr as Pretty +import GHC.Utils.Misc +import qualified GHC.Utils.Ppr.Colour as Col +import GHC.Utils.Ppr ( Doc, Mode(..) ) +import GHC.Utils.Panic +import GHC.Serialized +import GHC.LanguageExtensions (Extension) + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char +import qualified Data.Map as M +import Data.Int +import qualified Data.IntMap as IM +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Word +import System.IO ( Handle ) +import System.FilePath +import Text.Printf +import Numeric (showFFloat) +import Data.Graph (SCC(..)) +import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NEL + +import GHC.Fingerprint +import GHC.Show ( showMultiLineString ) +import GHC.Stack ( callStack, prettyCallStack ) +import Control.Monad.IO.Class +import GHC.Utils.Exception + +{- +************************************************************************ +* * +\subsection{The @PprStyle@ data type} +* * +************************************************************************ +-} + +data PprStyle + = PprUser PrintUnqualified Depth Coloured + -- Pretty-print in a way that will make sense to the + -- ordinary user; must be very close to Haskell + -- syntax, etc. + -- Assumes printing tidied code: non-system names are + -- printed without uniques. + + | PprDump PrintUnqualified + -- For -ddump-foo; less verbose than PprDebug, but more than PprUser + -- Does not assume tidied code: non-external names + -- are printed with uniques. + + | PprDebug -- Full debugging output + + | PprCode CodeStyle + -- Print code; either C or assembler + +data CodeStyle = CStyle -- The format of labels differs for C and assembler + | AsmStyle + +data Depth = AllTheWay + | PartWay Int -- 0 => stop + +data Coloured + = Uncoloured + | Coloured + +-- ----------------------------------------------------------------------------- +-- Printing original names + +-- | When printing code that contains original names, we need to map the +-- original names back to something the user understands. This is the +-- purpose of the triple of functions that gets passed around +-- when rendering 'SDoc'. +data PrintUnqualified = QueryQualify { + queryQualifyName :: QueryQualifyName, + queryQualifyModule :: QueryQualifyModule, + queryQualifyPackage :: QueryQualifyPackage +} + +-- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify +-- it. +type QueryQualifyName = Module -> OccName -> QualifyName + +-- | For a given module, we need to know whether to print it with +-- a package name to disambiguate it. +type QueryQualifyModule = Module -> Bool + +-- | For a given package, we need to know whether to print it with +-- the component id to disambiguate it. +type QueryQualifyPackage = UnitId -> Bool + +-- See Note [Printing original names] in GHC.Driver.Types +data QualifyName -- Given P:M.T + = NameUnqual -- It's in scope unqualified as "T" + -- OR nothing called "T" is in scope + + | NameQual ModuleName -- It's in scope qualified as "X.T" + + | NameNotInScope1 -- It's not in scope at all, but M.T is not bound + -- in the current scope, so we can refer to it as "M.T" + + | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in + -- the current scope, so we must refer to it as "P:M.T" + +instance Outputable QualifyName where + ppr NameUnqual = text "NameUnqual" + ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( + ppr NameNotInScope1 = text "NameNotInScope1" + ppr NameNotInScope2 = text "NameNotInScope2" + +reallyAlwaysQualifyNames :: QueryQualifyName +reallyAlwaysQualifyNames _ _ = NameNotInScope2 + +-- | NB: This won't ever show package IDs +alwaysQualifyNames :: QueryQualifyName +alwaysQualifyNames m _ = NameQual (moduleName m) + +neverQualifyNames :: QueryQualifyName +neverQualifyNames _ _ = NameUnqual + +alwaysQualifyModules :: QueryQualifyModule +alwaysQualifyModules _ = True + +neverQualifyModules :: QueryQualifyModule +neverQualifyModules _ = False + +alwaysQualifyPackages :: QueryQualifyPackage +alwaysQualifyPackages _ = True + +neverQualifyPackages :: QueryQualifyPackage +neverQualifyPackages _ = False + +reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +reallyAlwaysQualify + = QueryQualify reallyAlwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +alwaysQualify = QueryQualify alwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +neverQualify = QueryQualify neverQualifyNames + neverQualifyModules + neverQualifyPackages + +defaultUserStyle :: DynFlags -> PprStyle +defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay + +defaultDumpStyle :: DynFlags -> PprStyle + -- Print without qualifiers to reduce verbosity, unless -dppr-debug +defaultDumpStyle dflags + | hasPprDebug dflags = PprDebug + | otherwise = PprDump neverQualify + +mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle +mkDumpStyle dflags print_unqual + | hasPprDebug dflags = PprDebug + | otherwise = PprDump print_unqual + +defaultErrStyle :: DynFlags -> PprStyle +-- Default style for error messages, when we don't know PrintUnqualified +-- It's a bit of a hack because it doesn't take into account what's in scope +-- Only used for desugarer warnings, and typechecker errors in interface sigs +-- NB that -dppr-debug will still get into PprDebug style +defaultErrStyle dflags = mkErrStyle dflags neverQualify + +-- | Style for printing error messages +mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle +mkErrStyle dflags qual = + mkUserStyle dflags qual (PartWay (pprUserLength dflags)) + +cmdlineParserStyle :: DynFlags -> PprStyle +cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay + +mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle +mkUserStyle dflags unqual depth + | hasPprDebug dflags = PprDebug + | otherwise = PprUser unqual depth Uncoloured + +withUserStyle :: PrintUnqualified -> Depth -> SDoc -> SDoc +withUserStyle unqual depth doc = sdocOption sdocPprDebug $ \case + True -> withPprStyle PprDebug doc + False -> withPprStyle (PprUser unqual depth Uncoloured) doc + +withErrStyle :: PrintUnqualified -> SDoc -> SDoc +withErrStyle unqual doc = + sdocWithDynFlags $ \dflags -> + withPprStyle (mkErrStyle dflags unqual) doc + +setStyleColoured :: Bool -> PprStyle -> PprStyle +setStyleColoured col style = + case style of + PprUser q d _ -> PprUser q d c + _ -> style + where + c | col = Coloured + | otherwise = Uncoloured + +instance Outputable PprStyle where + ppr (PprUser {}) = text "user-style" + ppr (PprCode {}) = text "code-style" + ppr (PprDump {}) = text "dump-style" + ppr (PprDebug {}) = text "debug-style" + +{- +Orthogonal to the above printing styles are (possibly) some +command-line flags that affect printing (often carried with the +style). The most likely ones are variations on how much type info is +shown. + +The following test decides whether or not we are actually generating +code (either C or assembly), or generating interface files. + +************************************************************************ +* * +\subsection{The @SDoc@ data type} +* * +************************************************************************ +-} + +-- | Represents a pretty-printable document. +-- +-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', +-- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the +-- abstraction layer. +newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } + +data SDocContext = SDC + { sdocStyle :: !PprStyle + , sdocColScheme :: !Col.Scheme + , sdocLastColour :: !Col.PprColour + -- ^ The most recently used colour. + -- This allows nesting colours. + , sdocShouldUseColor :: !Bool + , sdocLineLength :: !Int + , sdocCanUseUnicode :: !Bool + -- ^ True if Unicode encoding is supported + -- and not disable by GHC_NO_UNICODE environment variable + , sdocHexWordLiterals :: !Bool + , sdocPprDebug :: !Bool + , sdocPrintUnicodeSyntax :: !Bool + , sdocPrintCaseAsLet :: !Bool + , sdocPrintTypecheckerElaboration :: !Bool + , sdocPrintAxiomIncomps :: !Bool + , sdocPrintExplicitKinds :: !Bool + , sdocPrintExplicitCoercions :: !Bool + , sdocPrintExplicitRuntimeReps :: !Bool + , sdocPrintExplicitForalls :: !Bool + , sdocPrintPotentialInstances :: !Bool + , sdocPrintEqualityRelations :: !Bool + , sdocSuppressTicks :: !Bool + , sdocSuppressTypeSignatures :: !Bool + , sdocSuppressTypeApplications :: !Bool + , sdocSuppressIdInfo :: !Bool + , sdocSuppressCoercions :: !Bool + , sdocSuppressUnfoldings :: !Bool + , sdocSuppressVarKinds :: !Bool + , sdocSuppressUniques :: !Bool + , sdocSuppressModulePrefixes :: !Bool + , sdocSuppressStgExts :: !Bool + , sdocErrorSpans :: !Bool + , sdocStarIsType :: !Bool + , sdocImpredicativeTypes :: !Bool + , sdocDynFlags :: DynFlags -- TODO: remove + } + +instance IsString SDoc where + fromString = text + +-- The lazy programmer's friend. +instance Outputable SDoc where + ppr = id + + +withPprStyle :: PprStyle -> SDoc -> SDoc +withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} + +pprDeeper :: SDoc -> SDoc +pprDeeper d = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..." + SDC{sdocStyle=PprUser q (PartWay n) c} -> + runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c} + _ -> runSDoc d ctx + +-- | Truncate a list that is longer than the current depth. +pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc +pprDeeperList f ds + | null ds = f [] + | otherwise = SDoc work + where + work ctx@SDC{sdocStyle=PprUser q (PartWay n) c} + | n==0 = Pretty.text "..." + | otherwise = + runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} + where + go _ [] = [] + go i (d:ds) | i >= n = [text "...."] + | otherwise = d : go (i+1) ds + work other_ctx = runSDoc (f ds) other_ctx + +pprSetDepth :: Depth -> SDoc -> SDoc +pprSetDepth depth doc = SDoc $ \ctx -> + case ctx of + SDC{sdocStyle=PprUser q _ c} -> + runSDoc doc ctx{sdocStyle = PprUser q depth c} + _ -> + runSDoc doc ctx + +getPprStyle :: (PprStyle -> SDoc) -> SDoc +getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx + +sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc +sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx + +sdocWithContext :: (SDocContext -> SDoc) -> SDoc +sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx + +sdocOption :: (SDocContext -> a) -> (a -> SDoc) -> SDoc +sdocOption f g = sdocWithContext (g . f) + +updSDocContext :: (SDocContext -> SDocContext) -> SDoc -> SDoc +updSDocContext upd doc + = SDoc $ \ctx -> runSDoc doc (upd ctx) + +qualName :: PprStyle -> QueryQualifyName +qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ +qualName (PprDump q) mod occ = queryQualifyName q mod occ +qualName _other mod _ = NameQual (moduleName mod) + +qualModule :: PprStyle -> QueryQualifyModule +qualModule (PprUser q _ _) m = queryQualifyModule q m +qualModule (PprDump q) m = queryQualifyModule q m +qualModule _other _m = True + +qualPackage :: PprStyle -> QueryQualifyPackage +qualPackage (PprUser q _ _) m = queryQualifyPackage q m +qualPackage (PprDump q) m = queryQualifyPackage q m +qualPackage _other _m = True + +queryQual :: PprStyle -> PrintUnqualified +queryQual s = QueryQualify (qualName s) + (qualModule s) + (qualPackage s) + +codeStyle :: PprStyle -> Bool +codeStyle (PprCode _) = True +codeStyle _ = False + +asmStyle :: PprStyle -> Bool +asmStyle (PprCode AsmStyle) = True +asmStyle _other = False + +dumpStyle :: PprStyle -> Bool +dumpStyle (PprDump {}) = True +dumpStyle _other = False + +debugStyle :: PprStyle -> Bool +debugStyle PprDebug = True +debugStyle _other = False + +userStyle :: PprStyle -> Bool +userStyle (PprUser {}) = True +userStyle _other = False + +getPprDebug :: (Bool -> SDoc) -> SDoc +getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty) + +ifPprDebug :: SDoc -> SDoc -> SDoc +-- ^ Says what to do with and without -dppr-debug +ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no + +whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style +-- ^ Says what to do with -dppr-debug; without, return empty +whenPprDebug d = ifPprDebug d empty + +-- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the +-- terminal doesn't get screwed up by the ANSI color codes if an exception +-- is thrown during pretty-printing. +printSDoc :: SDocContext -> Mode -> Handle -> SDoc -> IO () +printSDoc ctx mode handle doc = + Pretty.printDoc_ mode cols handle (runSDoc doc ctx) + `finally` + Pretty.printDoc_ mode cols handle + (runSDoc (coloured Col.colReset empty) ctx) + where + cols = sdocLineLength ctx + +-- | Like 'printSDoc' but appends an extra newline. +printSDocLn :: SDocContext -> Mode -> Handle -> SDoc -> IO () +printSDocLn ctx mode handle doc = + printSDoc ctx mode handle (doc $$ text "") + +printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () +printForUser dflags handle unqual doc + = printSDocLn ctx PageMode handle doc + where ctx = initSDocContext dflags (mkUserStyle dflags unqual AllTheWay) + +printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc + -> IO () +printForUserPartWay dflags handle d unqual doc + = printSDocLn ctx PageMode handle doc + where ctx = initSDocContext dflags (mkUserStyle dflags unqual (PartWay d)) + +-- | 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) + +-- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that +-- outputs to a 'BufHandle'. +bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO () +bufLeftRenderSDoc ctx bufHandle doc = + Pretty.bufLeftRender bufHandle (runSDoc doc ctx) + +pprCode :: CodeStyle -> SDoc -> SDoc +pprCode cs d = withPprStyle (PprCode cs) d + +mkCodeStyle :: CodeStyle -> PprStyle +mkCodeStyle = PprCode + +-- Can't make SDoc an instance of Show because SDoc is just a function type +-- However, Doc *is* an instance of Show +-- showSDoc just blasts it out as a string +showSDoc :: DynFlags -> SDoc -> String +showSDoc dflags sdoc = renderWithStyle (initSDocContext dflags (defaultUserStyle dflags)) sdoc + +-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be +-- initialised yet. +showSDocUnsafe :: SDoc -> String +showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc + +showPpr :: Outputable a => DynFlags -> a -> String +showPpr dflags thing = showSDoc dflags (ppr thing) + +showSDocUnqual :: DynFlags -> SDoc -> String +-- Only used by Haddock +showSDocUnqual dflags sdoc = showSDoc dflags sdoc + +showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +-- Allows caller to specify the PrintUnqualified to use +showSDocForUser dflags unqual doc + = renderWithStyle (initSDocContext dflags (mkUserStyle dflags unqual AllTheWay)) doc + +showSDocDump :: DynFlags -> SDoc -> String +showSDocDump dflags d = renderWithStyle (initSDocContext dflags (defaultDumpStyle dflags)) d + +showSDocDebug :: DynFlags -> SDoc -> String +showSDocDebug dflags d = renderWithStyle (initSDocContext dflags PprDebug) d + +renderWithStyle :: SDocContext -> SDoc -> String +renderWithStyle ctx sdoc + = let s = Pretty.style{ Pretty.mode = PageMode, + Pretty.lineLength = sdocLineLength ctx } + in Pretty.renderStyle s $ runSDoc sdoc ctx + +-- This shows an SDoc, but on one line only. It's cheaper than a full +-- showSDoc, designed for when we're getting results like "Foo.bar" +-- and "foo{uniq strictness}" so we don't want fancy layout anyway. +showSDocOneLine :: SDocContext -> SDoc -> String +showSDocOneLine ctx d + = let s = Pretty.style{ Pretty.mode = OneLineMode, + Pretty.lineLength = sdocLineLength ctx } in + Pretty.renderStyle s $ + runSDoc d ctx + +showSDocDumpOneLine :: DynFlags -> SDoc -> String +showSDocDumpOneLine dflags d + = let s = Pretty.style{ Pretty.mode = OneLineMode, + Pretty.lineLength = irrelevantNCols } in + Pretty.renderStyle s $ + runSDoc d (initSDocContext dflags (defaultDumpStyle dflags)) + +irrelevantNCols :: Int +-- Used for OneLineMode and LeftMode when number of cols isn't used +irrelevantNCols = 1 + +isEmpty :: SDocContext -> SDoc -> Bool +isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocStyle = PprDebug}) + +docToSDoc :: Doc -> SDoc +docToSDoc d = SDoc (\_ -> d) + +empty :: SDoc +char :: Char -> SDoc +text :: String -> SDoc +ftext :: FastString -> SDoc +ptext :: PtrString -> SDoc +ztext :: FastZString -> SDoc +int :: Int -> SDoc +integer :: Integer -> SDoc +word :: Integer -> SDoc +float :: Float -> SDoc +double :: Double -> SDoc +rational :: Rational -> SDoc + +empty = docToSDoc $ Pretty.empty +char c = docToSDoc $ Pretty.char c + +text s = docToSDoc $ Pretty.text s +{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire + +ftext s = docToSDoc $ Pretty.ftext s +ptext s = docToSDoc $ Pretty.ptext s +ztext s = docToSDoc $ Pretty.ztext s +int n = docToSDoc $ Pretty.int n +integer n = docToSDoc $ Pretty.integer n +float n = docToSDoc $ Pretty.float n +double n = docToSDoc $ Pretty.double n +rational n = docToSDoc $ Pretty.rational n + -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr +word n = sdocOption sdocHexWordLiterals $ \case + True -> docToSDoc $ Pretty.hex n + False -> docToSDoc $ Pretty.integer n + +-- | @doublePrec p n@ shows a floating point number @n@ with @p@ +-- digits of precision after the decimal point. +doublePrec :: Int -> Double -> SDoc +doublePrec p n = text (showFFloat (Just p) n "") + +parens, braces, brackets, quotes, quote, + doubleQuotes, angleBrackets :: SDoc -> SDoc + +parens d = SDoc $ Pretty.parens . runSDoc d +braces d = SDoc $ Pretty.braces . runSDoc d +brackets d = SDoc $ Pretty.brackets . runSDoc d +quote d = SDoc $ Pretty.quote . runSDoc d +doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +angleBrackets d = char '<' <> d <> char '>' + +cparen :: Bool -> SDoc -> SDoc +cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d + +-- 'quotes' encloses something in single quotes... +-- but it omits them if the thing begins or ends in a single quote +-- so that we don't get `foo''. Instead we just have foo'. +quotes d = sdocOption sdocCanUseUnicode $ \case + True -> char '‘' <> d <> char '’' + False -> SDoc $ \sty -> + let pp_d = runSDoc d sty + str = show pp_d + in case (str, lastMaybe str) of + (_, Just '\'') -> pp_d + ('\'' : _, _) -> pp_d + _other -> Pretty.quotes pp_d + +semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc +arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc +lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc + +blankLine = docToSDoc $ Pretty.text "" +dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") +arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") +larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") +darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") +arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") +larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") +arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") +larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") +semi = docToSDoc $ Pretty.semi +comma = docToSDoc $ Pretty.comma +colon = docToSDoc $ Pretty.colon +equals = docToSDoc $ Pretty.equals +space = docToSDoc $ Pretty.space +underscore = char '_' +dot = char '.' +vbar = char '|' +lparen = docToSDoc $ Pretty.lparen +rparen = docToSDoc $ Pretty.rparen +lbrack = docToSDoc $ Pretty.lbrack +rbrack = docToSDoc $ Pretty.rbrack +lbrace = docToSDoc $ Pretty.lbrace +rbrace = docToSDoc $ Pretty.rbrace + +forAllLit :: SDoc +forAllLit = unicodeSyntax (char '∀') (text "forall") + +bullet :: SDoc +bullet = unicode (char '•') (char '*') + +unicodeSyntax :: SDoc -> SDoc -> SDoc +unicodeSyntax unicode plain = + sdocOption sdocCanUseUnicode $ \can_use_unicode -> + sdocOption sdocPrintUnicodeSyntax $ \print_unicode_syntax -> + if can_use_unicode && print_unicode_syntax + then unicode + else plain + +unicode :: SDoc -> SDoc -> SDoc +unicode unicode plain = sdocOption sdocCanUseUnicode $ \case + True -> unicode + False -> plain + +nest :: Int -> SDoc -> SDoc +-- ^ Indent 'SDoc' some specified amount +(<>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally without a gap +(<+>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally with a gap between them +($$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically; if there is +-- no vertical overlap it "dovetails" the two onto one line +($+$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically + +nest n d = SDoc $ Pretty.nest n . runSDoc d +(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) +(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) +($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) +($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) + +hcat :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' horizontally +hsep :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' horizontally with a space between each one +vcat :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' vertically with dovetailing +sep :: [SDoc] -> SDoc +-- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits +cat :: [SDoc] -> SDoc +-- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits +fsep :: [SDoc] -> SDoc +-- ^ A paragraph-fill combinator. It's much like sep, only it +-- keeps fitting things on one line until it can't fit any more. +fcat :: [SDoc] -> SDoc +-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' + + +hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] +hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] +vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] +sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] +cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] +fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] +fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] + +hang :: SDoc -- ^ The header + -> Int -- ^ Amount to indent the hung body + -> SDoc -- ^ The hung body, indented and placed below the header + -> SDoc +hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) + +-- | This behaves like 'hang', but does not indent the second document +-- when the header is empty. +hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc +hangNotEmpty d1 n d2 = + SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty) + +punctuate :: SDoc -- ^ The punctuation + -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [SDoc] -- ^ Punctuated list +punctuate _ [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es + +ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen True doc = doc +ppWhen False _ = empty + +ppUnless True _ = empty +ppUnless False doc = doc + +ppWhenOption :: (SDocContext -> Bool) -> SDoc -> SDoc +ppWhenOption f doc = sdocOption f $ \case + True -> doc + False -> empty + +ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc +ppUnlessOption f doc = sdocOption f $ \case + True -> empty + False -> doc + +-- | Apply the given colour\/style for the argument. +-- +-- Only takes effect if colours are enabled. +coloured :: Col.PprColour -> SDoc -> SDoc +coloured col sdoc = sdocOption sdocShouldUseColor $ \case + True -> SDoc $ \case + ctx@SDC{ sdocLastColour = lastCol, sdocStyle = PprUser _ _ Coloured } -> + let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in + Pretty.zeroWidthText (Col.renderColour col) + Pretty.<> runSDoc sdoc ctx' + Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) + ctx -> runSDoc sdoc ctx + False -> sdoc + +keyword :: SDoc -> SDoc +keyword = coloured Col.colBold + +{- +************************************************************************ +* * +\subsection[Outputable-class]{The @Outputable@ class} +* * +************************************************************************ +-} + +-- | Class designating that some type has an 'SDoc' representation +class Outputable a where + ppr :: a -> SDoc + pprPrec :: Rational -> a -> SDoc + -- 0 binds least tightly + -- We use Rational because there is always a + -- Rational between any other two Rationals + + ppr = pprPrec 0 + pprPrec _ = ppr + +instance Outputable Char where + ppr c = text [c] + +instance Outputable Bool where + ppr True = text "True" + ppr False = text "False" + +instance Outputable Ordering where + ppr LT = text "LT" + ppr EQ = text "EQ" + ppr GT = text "GT" + +instance Outputable Int32 where + ppr n = integer $ fromIntegral n + +instance Outputable Int64 where + ppr n = integer $ fromIntegral n + +instance Outputable Int where + ppr n = int n + +instance Outputable Integer where + ppr n = integer n + +instance Outputable Word16 where + ppr n = integer $ fromIntegral n + +instance Outputable Word32 where + ppr n = integer $ fromIntegral n + +instance Outputable Word where + ppr n = integer $ fromIntegral n + +instance Outputable Float where + ppr f = float f + +instance Outputable Double where + ppr f = double f + +instance Outputable () where + ppr _ = text "()" + +instance (Outputable a) => Outputable [a] where + ppr xs = brackets (fsep (punctuate comma (map ppr xs))) + +instance (Outputable a) => Outputable (NonEmpty a) where + ppr = ppr . NEL.toList + +instance (Outputable a) => Outputable (Set a) where + ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) + +instance (Outputable a, Outputable b) => Outputable (a, b) where + ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) + +instance Outputable a => Outputable (Maybe a) where + ppr Nothing = text "Nothing" + ppr (Just x) = text "Just" <+> ppr x + +instance (Outputable a, Outputable b) => Outputable (Either a b) where + ppr (Left x) = text "Left" <+> ppr x + ppr (Right y) = text "Right" <+> ppr y + +-- ToDo: may not be used +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where + ppr (x,y,z) = + parens (sep [ppr x <> comma, + ppr y <> comma, + ppr z ]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d) => + Outputable (a, b, c, d) where + ppr (a,b,c,d) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => + Outputable (a, b, c, d, e) where + ppr (a,b,c,d,e) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => + Outputable (a, b, c, d, e, f) where + ppr (a,b,c,d,e,f) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => + Outputable (a, b, c, d, e, f, g) where + ppr (a,b,c,d,e,f,g) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f <> comma, + ppr g]) + +instance Outputable FastString where + ppr fs = ftext fs -- Prints an unadorned string, + -- no double quotes or anything + +instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where + ppr m = ppr (M.toList m) +instance (Outputable elt) => Outputable (IM.IntMap elt) where + ppr m = ppr (IM.toList m) + +instance Outputable Fingerprint where + ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) + +instance Outputable a => Outputable (SCC a) where + ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) + ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) + +instance Outputable Serialized where + ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) + +instance Outputable Extension where + ppr = text . show + +{- +************************************************************************ +* * +\subsection{The @OutputableBndr@ class} +* * +************************************************************************ +-} + +-- | 'BindingSite' is used to tell the thing that prints binder what +-- language construct is binding the identifier. This can be used +-- to decide how much info to print. +-- Also see Note [Binding-site specific printing] in GHC.Core.Ppr +data BindingSite + = LambdaBind -- ^ The x in (\x. e) + | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } + | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } + | LetBind -- ^ The x in (let x = rhs in e) + +-- | When we print a binder, we often want to print its type too. +-- The @OutputableBndr@ class encapsulates this idea. +class Outputable a => OutputableBndr a where + pprBndr :: BindingSite -> a -> SDoc + pprBndr _b x = ppr x + + pprPrefixOcc, pprInfixOcc :: a -> SDoc + -- Print an occurrence of the name, suitable either in the + -- prefix position of an application, thus (f a b) or ((+) x) + -- or infix position, thus (a `f` b) or (x + y) + + bndrIsJoin_maybe :: a -> Maybe Int + bndrIsJoin_maybe _ = Nothing + -- When pretty-printing we sometimes want to find + -- whether the binder is a join point. You might think + -- we could have a function of type (a->Var), but Var + -- isn't available yet, alas + +{- +************************************************************************ +* * +\subsection{Random printing helpers} +* * +************************************************************************ +-} + +-- We have 31-bit Chars and will simply use Show instances of Char and String. + +-- | Special combinator for showing character literals. +pprHsChar :: Char -> SDoc +pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) + | otherwise = text (show c) + +-- | Special combinator for showing string literals. +pprHsString :: FastString -> SDoc +pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) + +-- | Special combinator for showing bytestring literals. +pprHsBytes :: ByteString -> SDoc +pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs + in vcat (map text (showMultiLineString escaped)) <> char '#' + where escape :: Word8 -> String + escape w = let c = chr (fromIntegral w) + in if isAscii c + then [c] + else '\\' : show w + +-- Postfix modifiers for unboxed literals. +-- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`. +primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc +primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc +primCharSuffix = char '#' +primFloatSuffix = char '#' +primIntSuffix = char '#' +primDoubleSuffix = text "##" +primWordSuffix = text "##" +primInt64Suffix = text "L#" +primWord64Suffix = text "L##" + +-- | Special combinator for showing unboxed literals. +pprPrimChar :: Char -> SDoc +pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc +pprPrimChar c = pprHsChar c <> primCharSuffix +pprPrimInt i = integer i <> primIntSuffix +pprPrimWord w = word w <> primWordSuffix +pprPrimInt64 i = integer i <> primInt64Suffix +pprPrimWord64 w = word w <> primWord64Suffix + +--------------------- +-- Put a name in parens if it's an operator +pprPrefixVar :: Bool -> SDoc -> SDoc +pprPrefixVar is_operator pp_v + | is_operator = parens pp_v + | otherwise = pp_v + +-- Put a name in backquotes if it's not an operator +pprInfixVar :: Bool -> SDoc -> SDoc +pprInfixVar is_operator pp_v + | is_operator = pp_v + | otherwise = char '`' <> pp_v <> char '`' + +--------------------- +pprFastFilePath :: FastString -> SDoc +pprFastFilePath path = text $ normalise $ unpackFS path + +-- | Normalise, escape and render a string representing a path +-- +-- e.g. "c:\\whatever" +pprFilePathString :: FilePath -> SDoc +pprFilePathString path = doubleQuotes $ text (escape (normalise path)) + where + escape [] = [] + escape ('\\':xs) = '\\':'\\':escape xs + escape (x:xs) = x:escape xs + +{- +************************************************************************ +* * +\subsection{Other helper functions} +* * +************************************************************************ +-} + +pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- comma-separated and finally packed into a paragraph. +pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) + +pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- bar-separated and finally packed into a paragraph. +pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) + +-- | Returns the separated concatenation of the pretty printed things. +interppSP :: Outputable a => [a] -> SDoc +interppSP xs = sep (map ppr xs) + +-- | Returns the comma-separated concatenation of the pretty printed things. +interpp'SP :: Outputable a => [a] -> SDoc +interpp'SP xs = sep (punctuate comma (map ppr xs)) + +-- | Returns the comma-separated concatenation of the quoted pretty printed things. +-- +-- > [x,y,z] ==> `x', `y', `z' +pprQuotedList :: Outputable a => [a] -> SDoc +pprQuotedList = quotedList . map ppr + +quotedList :: [SDoc] -> SDoc +quotedList xs = fsep (punctuate comma (map quotes xs)) + +quotedListWithOr :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' or `z' +quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) +quotedListWithOr xs = quotedList xs + +quotedListWithNor :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' nor `z' +quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) +quotedListWithNor xs = quotedList xs + +{- +************************************************************************ +* * +\subsection{Printing numbers verbally} +* * +************************************************************************ +-} + +intWithCommas :: Integral a => a -> SDoc +-- Prints a big integer with commas, eg 345,821 +intWithCommas n + | n < 0 = char '-' <> intWithCommas (-n) + | q == 0 = int (fromIntegral r) + | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) + where + (q,r) = n `quotRem` 1000 + zeroes | r >= 100 = empty + | r >= 10 = char '0' + | otherwise = text "00" + +-- | Converts an integer to a verbal index: +-- +-- > speakNth 1 = text "first" +-- > speakNth 5 = text "fifth" +-- > speakNth 21 = text "21st" +speakNth :: Int -> SDoc +speakNth 1 = text "first" +speakNth 2 = text "second" +speakNth 3 = text "third" +speakNth 4 = text "fourth" +speakNth 5 = text "fifth" +speakNth 6 = text "sixth" +speakNth n = hcat [ int n, text suffix ] + where + suffix | n <= 20 = "th" -- 11,12,13 are non-std + | last_dig == 1 = "st" + | last_dig == 2 = "nd" + | last_dig == 3 = "rd" + | otherwise = "th" + + last_dig = n `rem` 10 + +-- | Converts an integer to a verbal multiplicity: +-- +-- > speakN 0 = text "none" +-- > speakN 5 = text "five" +-- > speakN 10 = text "10" +speakN :: Int -> SDoc +speakN 0 = text "none" -- E.g. "he has none" +speakN 1 = text "one" -- E.g. "he has one" +speakN 2 = text "two" +speakN 3 = text "three" +speakN 4 = text "four" +speakN 5 = text "five" +speakN 6 = text "six" +speakN n = int n + +-- | Converts an integer and object description to a statement about the +-- multiplicity of those objects: +-- +-- > speakNOf 0 (text "melon") = text "no melons" +-- > speakNOf 1 (text "melon") = text "one melon" +-- > speakNOf 3 (text "melon") = text "three melons" +speakNOf :: Int -> SDoc -> SDoc +speakNOf 0 d = text "no" <+> d <> char 's' +speakNOf 1 d = text "one" <+> d -- E.g. "one argument" +speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" + +-- | Determines the pluralisation suffix appropriate for the length of a list: +-- +-- > plural [] = char 's' +-- > plural ["Hello"] = empty +-- > plural ["Hello", "World"] = char 's' +plural :: [a] -> SDoc +plural [_] = empty -- a bit frightening, but there you are +plural _ = char 's' + +-- | Determines the form of to be appropriate for the length of a list: +-- +-- > isOrAre [] = text "are" +-- > isOrAre ["Hello"] = text "is" +-- > isOrAre ["Hello", "World"] = text "are" +isOrAre :: [a] -> SDoc +isOrAre [_] = text "is" +isOrAre _ = text "are" + +-- | Determines the form of to do appropriate for the length of a list: +-- +-- > doOrDoes [] = text "do" +-- > doOrDoes ["Hello"] = text "does" +-- > doOrDoes ["Hello", "World"] = text "do" +doOrDoes :: [a] -> SDoc +doOrDoes [_] = text "does" +doOrDoes _ = text "do" + +-- | Determines the form of possessive appropriate for the length of a list: +-- +-- > itsOrTheir [x] = text "its" +-- > itsOrTheir [x,y] = text "their" +-- > itsOrTheir [] = text "their" -- probably avoid this +itsOrTheir :: [a] -> SDoc +itsOrTheir [_] = text "its" +itsOrTheir _ = text "their" + +{- +************************************************************************ +* * +\subsection{Error handling} +* * +************************************************************************ +-} + +callStackDoc :: HasCallStack => SDoc +callStackDoc = + hang (text "Call stack:") + 4 (vcat $ map text $ lines (prettyCallStack callStack)) + +pprPanic :: HasCallStack => String -> SDoc -> a +-- ^ Throw an exception saying "bug in GHC" +pprPanic s doc = panicDoc s (doc $$ callStackDoc) + +pprSorry :: String -> SDoc -> a +-- ^ Throw an exception saying "this isn't finished yet" +pprSorry = sorryDoc + + +pprPgmError :: String -> SDoc -> a +-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) +pprPgmError = pgmErrorDoc + +pprTraceDebug :: String -> SDoc -> a -> a +pprTraceDebug str doc x + | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x + | otherwise = x + +-- | If debug output is on, show some 'SDoc' on the screen +pprTrace :: String -> SDoc -> a -> a +pprTrace str doc x = pprTraceWithFlags unsafeGlobalDynFlags str doc x + +-- | If debug output is on, show some 'SDoc' on the screen +pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a +pprTraceWithFlags dflags str doc x + | hasNoDebugOutput dflags = x + | otherwise = pprDebugAndThen dflags trace (text str) doc x + +pprTraceM :: Applicative f => String -> SDoc -> f () +pprTraceM str doc = pprTrace str doc (pure ()) + +-- | @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 unsafeGlobalDynFlags (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) + +warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a +-- ^ Just warn about an assertion failure, recording the given file and line number. +-- Should typically be accessed with the WARN macros +warnPprTrace _ _ _ _ x | not debugIsOn = x +warnPprTrace _ _file _line _msg x + | hasNoDebugOutput unsafeGlobalDynFlags = x +warnPprTrace False _file _line _msg x = x +warnPprTrace True file line msg x + = pprDebugAndThen unsafeGlobalDynFlags trace heading + (msg $$ callStackDoc ) + x + where + heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] + +-- | Panic with an assertion failure, recording the given file and +-- line number. Should typically be accessed with the ASSERT family of macros +assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a +assertPprPanic _file _line msg + = pprPanic "ASSERT failed!" msg + +pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a +pprDebugAndThen dflags cont heading pretty_msg + = cont (showSDocDump dflags doc) + where + doc = sep [heading, nest 2 pretty_msg] diff --git a/compiler/GHC/Utils/Outputable.hs-boot b/compiler/GHC/Utils/Outputable.hs-boot new file mode 100644 index 0000000000..dee3d2039c --- /dev/null +++ b/compiler/GHC/Utils/Outputable.hs-boot @@ -0,0 +1,14 @@ +module GHC.Utils.Outputable where + +import GHC.Prelude +import GHC.Stack( HasCallStack ) + +data SDoc +data PprStyle +data SDocContext + +showSDocUnsafe :: SDoc -> String + +warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a + +text :: String -> SDoc diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs new file mode 100644 index 0000000000..48695e25d4 --- /dev/null +++ b/compiler/GHC/Utils/Panic.hs @@ -0,0 +1,259 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP Project, Glasgow University, 1992-2000 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} + +-- | Defines basic functions for printing error messages. +-- +-- It's hard to put these functions anywhere else without causing +-- some unnecessary loops in the module dependency graph. +module GHC.Utils.Panic ( + GhcException(..), showGhcException, + throwGhcException, throwGhcExceptionIO, + handleGhcException, + GHC.Utils.Panic.Plain.progName, + pgmError, + + panic, sorry, assertPanic, trace, + panicDoc, sorryDoc, pgmErrorDoc, + + cmdLineError, cmdLineErrorIO, + + Exception.Exception(..), showException, safeShowException, + try, tryMost, throwTo, + + withSignalHandlers, +) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Utils.Outputable (SDoc, showSDocUnsafe) +import GHC.Utils.Panic.Plain + +import GHC.Utils.Exception as Exception + +import Control.Monad.IO.Class +import Control.Concurrent +import Data.Typeable ( cast ) +import Debug.Trace ( trace ) +import System.IO.Unsafe + +#if !defined(mingw32_HOST_OS) +import System.Posix.Signals as S +#endif + +#if defined(mingw32_HOST_OS) +import GHC.ConsoleHandler as S +#endif + +import System.Mem.Weak ( deRefWeak ) + +-- | GHC's own exception type +-- error messages all take the form: +-- +-- @ +-- <location>: <error> +-- @ +-- +-- If the location is on the command line, or in GHC itself, then +-- <location>="ghc". All of the error types below correspond to +-- a <location> of "ghc", except for ProgramError (where the string is +-- assumed to contain a location already, so we don't print one). + +data GhcException + -- | Some other fatal signal (SIGHUP,SIGTERM) + = Signal Int + + -- | Prints the short usage msg after the error + | UsageError String + + -- | A problem with the command line arguments, but don't print usage. + | CmdLineError String + + -- | The 'impossible' happened. + | Panic String + | PprPanic String SDoc + + -- | The user tickled something that's known not to work yet, + -- but we're not counting it as a bug. + | Sorry String + | PprSorry String SDoc + + -- | An installation problem. + | InstallationError String + + -- | An error in the user's code, probably. + | ProgramError String + | PprProgramError String SDoc + +instance Exception GhcException where + fromException (SomeException e) + | Just ge <- cast e = Just ge + | Just pge <- cast e = Just $ + case pge of + PlainSignal n -> Signal n + PlainUsageError str -> UsageError str + PlainCmdLineError str -> CmdLineError str + PlainPanic str -> Panic str + PlainSorry str -> Sorry str + PlainInstallationError str -> InstallationError str + PlainProgramError str -> ProgramError str + | otherwise = Nothing + +instance Show GhcException where + showsPrec _ e@(ProgramError _) = showGhcException e + showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e + showsPrec _ e = showString progName . showString ": " . showGhcException e + +-- | Show an exception as a string. +showException :: Exception e => e -> String +showException = show + +-- | Show an exception which can possibly throw other exceptions. +-- Used when displaying exception thrown within TH code. +safeShowException :: Exception e => e -> IO String +safeShowException e = do + -- ensure the whole error message is evaluated inside try + r <- try (return $! forceList (showException e)) + case r of + Right msg -> return msg + Left e' -> safeShowException (e' :: SomeException) + where + forceList [] = [] + forceList xs@(x : xt) = x `seq` forceList xt `seq` xs + +-- | Append a description of the given exception to this string. +-- +-- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some +-- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called. +-- If the error message to be printed includes a pretty-printer document +-- which forces one of these fields this call may bottom. +showGhcException :: GhcException -> ShowS +showGhcException = showPlainGhcException . \case + Signal n -> PlainSignal n + UsageError str -> PlainUsageError str + CmdLineError str -> PlainCmdLineError str + Panic str -> PlainPanic str + Sorry str -> PlainSorry str + InstallationError str -> PlainInstallationError str + ProgramError str -> PlainProgramError str + + PprPanic str sdoc -> PlainPanic $ + concat [str, "\n\n", showSDocUnsafe sdoc] + PprSorry str sdoc -> PlainProgramError $ + concat [str, "\n\n", showSDocUnsafe sdoc] + PprProgramError str sdoc -> PlainProgramError $ + concat [str, "\n\n", showSDocUnsafe sdoc] + +throwGhcException :: GhcException -> a +throwGhcException = Exception.throw + +throwGhcExceptionIO :: GhcException -> IO a +throwGhcExceptionIO = Exception.throwIO + +handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a +handleGhcException = ghandle + +panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a +panicDoc x doc = throwGhcException (PprPanic x doc) +sorryDoc x doc = throwGhcException (PprSorry x doc) +pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) + +-- | Like try, but pass through UserInterrupt and Panic exceptions. +-- Used when we want soft failures when reading interface files, for example. +-- TODO: I'm not entirely sure if this is catching what we really want to catch +tryMost :: IO a -> IO (Either SomeException a) +tryMost action = do r <- try action + case r of + Left se -> + case fromException se of + -- Some GhcException's we rethrow, + Just (Signal _) -> throwIO se + Just (Panic _) -> throwIO se + -- others we return + Just _ -> return (Left se) + Nothing -> + case fromException se of + -- All IOExceptions are returned + Just (_ :: IOException) -> + return (Left se) + -- Anything else is rethrown + Nothing -> throwIO se + Right v -> return (Right v) + +-- | We use reference counting for signal handlers +{-# NOINLINE signalHandlersRefCount #-} +#if !defined(mingw32_HOST_OS) +signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler + ,S.Handler,S.Handler)) +#else +signalHandlersRefCount :: MVar (Word, Maybe S.Handler) +#endif +signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing) + + +-- | Temporarily install standard signal handlers for catching ^C, which just +-- throw an exception in the current thread. +withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a +withSignalHandlers act = do + main_thread <- liftIO myThreadId + wtid <- liftIO (mkWeakThreadId main_thread) + + let + interrupt = do + r <- deRefWeak wtid + case r of + Nothing -> return () + Just t -> throwTo t UserInterrupt + +#if !defined(mingw32_HOST_OS) + let installHandlers = do + let installHandler' a b = installHandler a b Nothing + hdlQUIT <- installHandler' sigQUIT (Catch interrupt) + hdlINT <- installHandler' sigINT (Catch interrupt) + -- see #3656; in the future we should install these automatically for + -- all Haskell programs in the same way that we install a ^C handler. + let fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) + hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP)) + hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM)) + return (hdlQUIT,hdlINT,hdlHUP,hdlTERM) + + let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do + _ <- installHandler sigQUIT hdlQUIT Nothing + _ <- installHandler sigINT hdlINT Nothing + _ <- installHandler sigHUP hdlHUP Nothing + _ <- installHandler sigTERM hdlTERM Nothing + return () +#else + -- GHC 6.3+ has support for console events on Windows + -- NOTE: running GHCi under a bash shell for some reason requires + -- you to press Ctrl-Break rather than Ctrl-C to provoke + -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know + -- why --SDM 17/12/2004 + let sig_handler ControlC = interrupt + sig_handler Break = interrupt + sig_handler _ = return () + + let installHandlers = installHandler (Catch sig_handler) + let uninstallHandlers = installHandler -- directly install the old handler +#endif + + -- install signal handlers if necessary + let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case + (0,Nothing) -> do + hdls <- installHandlers + return (1,Just hdls) + (c,oldHandlers) -> return (c+1,oldHandlers) + + -- uninstall handlers if necessary + let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case + (1,Just hdls) -> do + _ <- uninstallHandlers hdls + return (0,Nothing) + (c,oldHandlers) -> return (c-1,oldHandlers) + + mayInstallHandlers + act `gfinally` mayUninstallHandlers diff --git a/compiler/GHC/Utils/Panic/Plain.hs b/compiler/GHC/Utils/Panic/Plain.hs new file mode 100644 index 0000000000..37e0574d4b --- /dev/null +++ b/compiler/GHC/Utils/Panic/Plain.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} + +-- | Defines a simple exception type and utilities to throw it. The +-- 'PlainGhcException' type is a subset of the 'Panic.GhcException' +-- type. It omits the exception constructors that involve +-- pretty-printing via 'Outputable.SDoc'. +-- +-- There are two reasons for this: +-- +-- 1. To avoid import cycles / use of boot files. "Outputable" has +-- many transitive dependencies. To throw exceptions from these +-- modules, the functions here can be used without introducing import +-- cycles. +-- +-- 2. To reduce the number of modules that need to be compiled to +-- object code when loading GHC into GHCi. See #13101 +module GHC.Utils.Panic.Plain + ( PlainGhcException(..) + , showPlainGhcException + + , panic, sorry, pgmError + , cmdLineError, cmdLineErrorIO + , assertPanic + + , progName + ) where + +#include "HsVersions.h" + +import Config +import GHC.Utils.Exception as Exception +import GHC.Stack +import GHC.Prelude +import System.Environment +import System.IO.Unsafe + +-- | This type is very similar to 'Panic.GhcException', but it omits +-- the constructors that involve pretty-printing via +-- 'Outputable.SDoc'. Due to the implementation of 'fromException' +-- for 'Panic.GhcException', this type can be caught as a +-- 'Panic.GhcException'. +-- +-- Note that this should only be used for throwing exceptions, not for +-- catching, as 'Panic.GhcException' will not be converted to this +-- type when catching. +data PlainGhcException + -- | Some other fatal signal (SIGHUP,SIGTERM) + = PlainSignal Int + + -- | Prints the short usage msg after the error + | PlainUsageError String + + -- | A problem with the command line arguments, but don't print usage. + | PlainCmdLineError String + + -- | The 'impossible' happened. + | PlainPanic String + + -- | The user tickled something that's known not to work yet, + -- but we're not counting it as a bug. + | PlainSorry String + + -- | An installation problem. + | PlainInstallationError String + + -- | An error in the user's code, probably. + | PlainProgramError String + +instance Exception PlainGhcException + +instance Show PlainGhcException where + showsPrec _ e@(PlainProgramError _) = showPlainGhcException e + showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e + showsPrec _ e = showString progName . showString ": " . showPlainGhcException e + +-- | The name of this GHC. +progName :: String +progName = unsafePerformIO (getProgName) +{-# NOINLINE progName #-} + +-- | Short usage information to display when we are given the wrong cmd line arguments. +short_usage :: String +short_usage = "Usage: For basic information, try the `--help' option." + +-- | Append a description of the given exception to this string. +showPlainGhcException :: PlainGhcException -> ShowS +showPlainGhcException = + \case + PlainSignal n -> showString "signal: " . shows n + PlainUsageError str -> showString str . showChar '\n' . showString short_usage + PlainCmdLineError str -> showString str + PlainPanic s -> panicMsg (showString s) + PlainSorry s -> sorryMsg (showString s) + PlainInstallationError str -> showString str + PlainProgramError str -> showString str + where + sorryMsg :: ShowS -> ShowS + sorryMsg s = + showString "sorry! (unimplemented feature or known bug)\n" + . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") + . s . showString "\n" + + panicMsg :: ShowS -> ShowS + panicMsg s = + showString "panic! (the 'impossible' happened)\n" + . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") + . s . showString "\n\n" + . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" + +throwPlainGhcException :: PlainGhcException -> a +throwPlainGhcException = Exception.throw + +-- | Panics and asserts. +panic, sorry, pgmError :: String -> a +panic x = unsafeDupablePerformIO $ do + stack <- ccsToStrings =<< getCurrentCCS x + if null stack + then throwPlainGhcException (PlainPanic x) + else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) + +sorry x = throwPlainGhcException (PlainSorry x) +pgmError x = throwPlainGhcException (PlainProgramError x) + +cmdLineError :: String -> a +cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO + +cmdLineErrorIO :: String -> IO a +cmdLineErrorIO x = do + stack <- ccsToStrings =<< getCurrentCCS x + if null stack + then throwPlainGhcException (PlainCmdLineError x) + else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack)) + +-- | Throw a failed assertion exception for a given filename and line number. +assertPanic :: String -> Int -> a +assertPanic file line = + Exception.throw (Exception.AssertionFailed + ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) diff --git a/compiler/GHC/Utils/Ppr.hs b/compiler/GHC/Utils/Ppr.hs new file mode 100644 index 0000000000..559088e415 --- /dev/null +++ b/compiler/GHC/Utils/Ppr.hs @@ -0,0 +1,1105 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Utils.Ppr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : David Terei <code@davidterei.com> +-- Stability : stable +-- Portability : portable +-- +-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators +-- +-- Based on /The Design of a Pretty-printing Library/ +-- in Advanced Functional Programming, +-- Johan Jeuring and Erik Meijer (eds), LNCS 925 +-- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps> +-- +----------------------------------------------------------------------------- + +{- +Note [Differences between libraries/pretty and compiler/utils/Pretty.hs] + +For historical reasons, there are two different copies of `Pretty` in the GHC +source tree: + * `libraries/pretty` is a submodule containing + https://github.com/haskell/pretty. This is the `pretty` library as released + on hackage. It is used by several other libraries in the GHC source tree + (e.g. template-haskell and Cabal). + * `compiler/utils/Pretty.hs` (this module). It is used by GHC only. + +There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and +https://gitlab.haskell.org/ghc/ghc/issues/10735 to try to get rid of GHC's copy +of Pretty. + +Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following +major differences: + * GHC's copy uses `Faststring` for performance reasons. + * GHC's copy has received a backported bugfix for #12227, which was + released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside", + https://github.com/haskell/pretty/pull/35). + +Other differences are minor. Both copies define some extra functions and +instances not defined in the other copy. To see all differences, do this in a +ghc git tree: + + $ cd libraries/pretty + $ git checkout v1.1.2.0 + $ cd - + $ vimdiff compiler/utils/Pretty.hs \ + libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs + +For parity with `pretty-1.1.2.1`, the following two `pretty` commits would +have to be backported: + * "Resolve foldr-strictness stack overflow bug" + (307b8173f41cd776eae8f547267df6d72bff2d68) + * "Special-case reduce for horiz/vert" + (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c) +This has not been done sofar, because these commits seem to cause more +allocation in the compiler (see thomie's comments in +https://github.com/haskell/pretty/pull/9). +-} + +module GHC.Utils.Ppr ( + + -- * The document type + Doc, TextDetails(..), + + -- * Constructing documents + + -- ** Converting values into documents + char, text, ftext, ptext, ztext, sizedText, zeroWidthText, + int, integer, float, double, rational, hex, + + -- ** Simple derived documents + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + -- ** Wrapping documents in delimiters + parens, brackets, braces, quotes, quote, doubleQuotes, + maybeParens, + + -- ** Combining documents + empty, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, + hang, hangNotEmpty, punctuate, + + -- * Predicates on documents + isEmpty, + + -- * Rendering documents + + -- ** Rendering with a particular style + Style(..), + style, + renderStyle, + Mode(..), + + -- ** General rendering + fullRender, txtPrinter, + + -- ** GHC-specific rendering + printDoc, printDoc_, + bufLeftRender -- performance hack + + ) where + +import GHC.Prelude hiding (error) + +import GHC.Utils.BufHandle +import GHC.Data.FastString +import GHC.Utils.Panic.Plain +import System.IO +import Numeric (showHex) + +--for a RULES +import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) ) +import GHC.Ptr ( Ptr(..) ) + +-- --------------------------------------------------------------------------- +-- The Doc calculus + +{- +Laws for $$ +~~~~~~~~~~~ +<a1> (x $$ y) $$ z = x $$ (y $$ z) +<a2> empty $$ x = x +<a3> x $$ empty = x + + ...ditto $+$... + +Laws for <> +~~~~~~~~~~~ +<b1> (x <> y) <> z = x <> (y <> z) +<b2> empty <> x = empty +<b3> x <> empty = x + + ...ditto <+>... + +Laws for text +~~~~~~~~~~~~~ +<t1> text s <> text t = text (s++t) +<t2> text "" <> x = x, if x non-empty + +** because of law n6, t2 only holds if x doesn't +** start with `nest'. + + +Laws for nest +~~~~~~~~~~~~~ +<n1> nest 0 x = x +<n2> nest k (nest k' x) = nest (k+k') x +<n3> nest k (x <> y) = nest k x <> nest k y +<n4> nest k (x $$ y) = nest k x $$ nest k y +<n5> nest k empty = empty +<n6> x <> nest k y = x <> y, if x non-empty + +** Note the side condition on <n6>! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ +<m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$ + nest (-length s) y) + +<m2> (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ +<l1> sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + +<l2> nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ +<o1> oneLiner (nest k p) = nest k (oneLiner p) +<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y + +You might think that the following version of <m1> would +be neater: + +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y) + +But it doesn't work, for if x=empty, we would have + + text s $$ y = text s <> (empty $$ nest (-length s) y) + = text s <> nest (-length s) y +-} + +-- --------------------------------------------------------------------------- +-- Operator fixity + +infixl 6 <> +infixl 6 <+> +infixl 5 $$, $+$ + + +-- --------------------------------------------------------------------------- +-- The Doc data type + +-- | The abstract type of documents. +-- A Doc represents a *set* of layouts. A Doc with +-- no occurrences of Union or NoDoc represents just one layout. +data Doc + = Empty -- empty + | NilAbove Doc -- text "" $$ x + | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x + | Nest {-# UNPACK #-} !Int Doc -- nest k x + | Union Doc Doc -- ul `union` ur + | NoDoc -- The empty set of documents + | Beside Doc Bool Doc -- True <=> space between + | Above Doc Bool Doc -- True <=> never overlap + +{- +Here are the invariants: + +1) The argument of NilAbove is never Empty. Therefore + a NilAbove occupies at least two lines. + +2) The argument of @TextBeside@ is never @Nest@. + +3) The layouts of the two arguments of @Union@ both flatten to the same + string. + +4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + +5) A @NoDoc@ may only appear on the first line of the left argument of an + union. Therefore, the right argument of an union can never be equivalent + to the empty set (@NoDoc@). + +6) An empty document is always represented by @Empty@. It can't be + hidden inside a @Nest@, or a @Union@ of two @Empty@s. + +7) The first line of every layout in the left argument of @Union@ is + longer than the first line of any layout in the right argument. + (1) ensures that the left argument has a first line. In view of + (3), this invariant means that the right argument must have at + least two lines. + +Notice the difference between + * NoDoc (no documents) + * Empty (one empty document; no height and no width) + * text "" (a document containing the empty string; + one line high, but has no width) +-} + + +-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. +type RDoc = Doc + +-- | The TextDetails data type +-- +-- A TextDetails represents a fragment of text that will be +-- output at some point. +data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment + | Str String -- ^ A whole String fragment + | PStr FastString -- a hashed string + | ZStr FastZString -- a z-encoded string + | LStr {-# UNPACK #-} !PtrString + -- a '\0'-terminated array of bytes + | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char + -- a repeated character (e.g., ' ') + +instance Show Doc where + showsPrec _ doc cont = fullRender (mode style) (lineLength style) + (ribbonsPerLine style) + txtPrinter cont doc + + +-- --------------------------------------------------------------------------- +-- Values and Predicates on GDocs and TextDetails + +-- | A document of height and width 1, containing a literal character. +char :: Char -> Doc +char c = textBeside_ (Chr c) 1 Empty + +-- | A document of height 1 containing a literal string. +-- 'text' satisfies the following laws: +-- +-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ +-- +-- * @'text' \"\" '<>' x = x@, if @x@ non-empty +-- +-- The side condition on the last law is necessary because @'text' \"\"@ +-- has height 1, while 'empty' has no height. +text :: String -> Doc +text s = textBeside_ (Str s) (length s) Empty +{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested + +-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the +-- intermediate packing/unpacking of the string. +{-# RULES "text/str" + forall a. text (unpackCString# a) = ptext (mkPtrString# a) + #-} +{-# RULES "text/unpackNBytes#" + forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n)) + #-} + +ftext :: FastString -> Doc +ftext s = textBeside_ (PStr s) (lengthFS s) Empty + +ptext :: PtrString -> Doc +ptext s = textBeside_ (LStr s) (lengthPS s) Empty + +ztext :: FastZString -> Doc +ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty + +-- | Some text with any width. (@text s = sizedText (length s) s@) +sizedText :: Int -> String -> Doc +sizedText l s = textBeside_ (Str s) l Empty + +-- | Some text, but without any width. Use for non-printing text +-- such as a HTML or Latex tags +zeroWidthText :: String -> Doc +zeroWidthText = sizedText 0 + +-- | The empty document, with no height and no width. +-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere +-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. +empty :: Doc +empty = Empty + +-- | Returns 'True' if the document is empty +isEmpty :: Doc -> Bool +isEmpty Empty = True +isEmpty _ = False + +{- +Q: What is the reason for negative indentation (i.e. argument to indent + is < 0) ? + +A: +This indicates an error in the library client's code. +If we compose a <> b, and the first line of b is more indented than some +other lines of b, the law <n6> (<> eats nests) may cause the pretty +printer to produce an invalid layout: + +doc |0123345 +------------------ +d1 |a...| +d2 |...b| + |c...| + +d1<>d2 |ab..| + c|....| + +Consider a <> b, let `s' be the length of the last line of `a', `k' the +indentation of the first line of b, and `k0' the indentation of the +left-most line b_i of b. + +The produced layout will have negative indentation if `k - k0 > s', as +the first line of b will be put on the (s+1)th column, effectively +translating b horizontally by (k-s). Now if the i^th line of b has an +indentation k0 < (k-s), it is translated out-of-page, causing +`negative indentation'. +-} + + +semi :: Doc -- ^ A ';' character +comma :: Doc -- ^ A ',' character +colon :: Doc -- ^ A ':' character +space :: Doc -- ^ A space character +equals :: Doc -- ^ A '=' character +lparen :: Doc -- ^ A '(' character +rparen :: Doc -- ^ A ')' character +lbrack :: Doc -- ^ A '[' character +rbrack :: Doc -- ^ A ']' character +lbrace :: Doc -- ^ A '{' character +rbrace :: Doc -- ^ A '}' character +semi = char ';' +comma = char ',' +colon = char ':' +space = char ' ' +equals = char '=' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +spaceText, nlText :: TextDetails +spaceText = Chr ' ' +nlText = Chr '\n' + +int :: Int -> Doc -- ^ @int n = text (show n)@ +integer :: Integer -> Doc -- ^ @integer n = text (show n)@ +float :: Float -> Doc -- ^ @float n = text (show n)@ +double :: Double -> Doc -- ^ @double n = text (show n)@ +rational :: Rational -> Doc -- ^ @rational n = text (show n)@ +hex :: Integer -> Doc -- ^ See Note [Print Hexadecimal Literals] +int n = text (show n) +integer n = text (show n) +float n = text (show n) +double n = text (show n) +rational n = text (show n) +hex n = text ('0' : 'x' : padded) + where + str = showHex n "" + strLen = max 1 (length str) + len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int) + padded = replicate (len - strLen) '0' ++ str + +parens :: Doc -> Doc -- ^ Wrap document in @(...)@ +brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ +braces :: Doc -> Doc -- ^ Wrap document in @{...}@ +quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ +quote :: Doc -> Doc +doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ +quotes p = char '`' <> p <> char '\'' +quote p = char '\'' <> p +doubleQuotes p = char '"' <> p <> char '"' +parens p = char '(' <> p <> char ')' +brackets p = char '[' <> p <> char ']' +braces p = char '{' <> p <> char '}' + +{- +Note [Print Hexadecimal Literals] + +Relevant discussions: + * Phabricator: https://phabricator.haskell.org/D4465 + * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872 + +There is a flag `-dword-hex-literals` that causes literals of +type `Word#` or `Word64#` to be displayed in hexadecimal instead +of decimal when dumping GHC core. It also affects the presentation +of these in GHC's error messages. Additionally, the hexadecimal +encoding of these numbers is zero-padded so that its length is +a power of two. As an example of what this does, +consider the following haskell file `Literals.hs`: + + module Literals where + + alpha :: Int + alpha = 100 + 200 + + beta :: Word -> Word + beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202 + +We get the following dumped core when we compile on a 64-bit +machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all +-dhex-word-literals literals.hs: + + ==================== Tidy Core ==================== + + ... omitted for brevity ... + + -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} + alpha + alpha = I# 300# + + -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0} + beta + beta + = \ x_aYE -> + case x_aYE of { W# x#_a1v0 -> + W# + (plusWord# + (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##) + 0x0202##) + } + +Notice that the word literals are in hexadecimals and that they have +been padded with zeroes so that their lengths are 16, 8, and 4, respectively. + +-} + +-- | Apply 'parens' to 'Doc' if boolean is true. +maybeParens :: Bool -> Doc -> Doc +maybeParens False = id +maybeParens True = parens + +-- --------------------------------------------------------------------------- +-- Structural operations on GDocs + +-- | Perform some simplification of a built up @GDoc@. +reduceDoc :: Doc -> RDoc +reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q) +reduceDoc (Above p g q) = p `seq` g `seq` (above p g $! reduceDoc q) +reduceDoc p = p + +-- | List version of '<>'. +hcat :: [Doc] -> Doc +hcat = reduceAB . foldr (beside_' False) empty + +-- | List version of '<+>'. +hsep :: [Doc] -> Doc +hsep = reduceAB . foldr (beside_' True) empty + +-- | List version of '$$'. +vcat :: [Doc] -> Doc +vcat = reduceAB . foldr (above_' False) empty + +-- | Nest (or indent) a document by a given number of positions +-- (which may also be negative). 'nest' satisfies the laws: +-- +-- * @'nest' 0 x = x@ +-- +-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ +-- +-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ +-- +-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ +-- +-- * @'nest' k 'empty' = 'empty'@ +-- +-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty +-- +-- The side condition on the last law is needed because +-- 'empty' is a left identity for '<>'. +nest :: Int -> Doc -> Doc +nest k p = mkNest k (reduceDoc p) + +-- | @hang d1 n d2 = sep [d1, nest n d2]@ +hang :: Doc -> Int -> Doc -> Doc +hang d1 n d2 = sep [d1, nest n d2] + +-- | Apply 'hang' to the arguments if the first 'Doc' is not empty. +hangNotEmpty :: Doc -> Int -> Doc -> Doc +hangNotEmpty d1 n d2 = if isEmpty d1 + then d2 + else hang d1 n d2 + +-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ +punctuate :: Doc -> [Doc] -> [Doc] +punctuate _ [] = [] +punctuate p (x:xs) = go x xs + where go y [] = [y] + go y (z:zs) = (y <> p) : go z zs + +-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest :: Int -> Doc -> Doc +mkNest k _ | k `seq` False = undefined +mkNest k (Nest k1 p) = mkNest (k + k1) p +mkNest _ NoDoc = NoDoc +mkNest _ Empty = Empty +mkNest 0 p = p +mkNest k p = nest_ k p + +-- mkUnion checks for an empty document +mkUnion :: Doc -> Doc -> Doc +mkUnion Empty _ = Empty +mkUnion p q = p `union_` q + +beside_' :: Bool -> Doc -> Doc -> Doc +beside_' _ p Empty = p +beside_' g p q = Beside p g q + +above_' :: Bool -> Doc -> Doc -> Doc +above_' _ p Empty = p +above_' g p q = Above p g q + +reduceAB :: Doc -> Doc +reduceAB (Above Empty _ q) = q +reduceAB (Beside Empty _ q) = q +reduceAB doc = doc + +nilAbove_ :: RDoc -> RDoc +nilAbove_ = NilAbove + +-- Arg of a TextBeside is always an RDoc +textBeside_ :: TextDetails -> Int -> RDoc -> RDoc +textBeside_ = TextBeside + +nest_ :: Int -> RDoc -> RDoc +nest_ = Nest + +union_ :: RDoc -> RDoc -> RDoc +union_ = Union + + +-- --------------------------------------------------------------------------- +-- Vertical composition @$$@ + +-- | Above, except that if the last line of the first argument stops +-- at least one position before the first line of the second begins, +-- these two lines are overlapped. For example: +-- +-- > text "hi" $$ nest 5 (text "there") +-- +-- lays out as +-- +-- > hi there +-- +-- rather than +-- +-- > hi +-- > there +-- +-- '$$' is associative, with identity 'empty', and also satisfies +-- +-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. +-- +($$) :: Doc -> Doc -> Doc +p $$ q = above_ p False q + +-- | Above, with no overlapping. +-- '$+$' is associative, with identity 'empty'. +($+$) :: Doc -> Doc -> Doc +p $+$ q = above_ p True q + +above_ :: Doc -> Bool -> Doc -> Doc +above_ p _ Empty = p +above_ Empty _ q = q +above_ p g q = Above p g q + +above :: Doc -> Bool -> RDoc -> RDoc +above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) +above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) +above p g q = aboveNest p g 0 (reduceDoc q) + +-- Specification: aboveNest p g k q = p $g$ (nest k q) +aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc +aboveNest _ _ k _ | k `seq` False = undefined +aboveNest NoDoc _ _ _ = NoDoc +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q + +aboveNest Empty _ k q = mkNest k q +aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) + -- p can't be Empty, so no need for mkNest + +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) +aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest + where + !k1 = k - sl + rest = case p of + Empty -> nilAboveNest g k1 q + _ -> aboveNest p g k1 q +aboveNest (Above {}) _ _ _ = error "aboveNest Above" +aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" + +-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q) +nilAboveNest :: Bool -> Int -> RDoc -> RDoc +nilAboveNest _ k _ | k `seq` False = undefined +nilAboveNest _ _ Empty = Empty + -- Here's why the "text s <>" is in the spec! +nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q +nilAboveNest g k q | not g && k > 0 -- No newline if no overlap + = textBeside_ (RStr k ' ') k q + | otherwise -- Put them really above + = nilAbove_ (mkNest k q) + + +-- --------------------------------------------------------------------------- +-- Horizontal composition @<>@ + +-- We intentionally avoid Data.Monoid.(<>) here due to interactions of +-- Data.Monoid.(<>) and (<+>). See +-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html + +-- | Beside. +-- '<>' is associative, with identity 'empty'. +(<>) :: Doc -> Doc -> Doc +p <> q = beside_ p False q + +-- | Beside, separated by space, unless one of the arguments is 'empty'. +-- '<+>' is associative, with identity 'empty'. +(<+>) :: Doc -> Doc -> Doc +p <+> q = beside_ p True q + +beside_ :: Doc -> Bool -> Doc -> Doc +beside_ p _ Empty = p +beside_ Empty _ q = q +beside_ p g q = Beside p g q + +-- Specification: beside g p q = p <g> q +beside :: Doc -> Bool -> RDoc -> RDoc +beside NoDoc _ _ = NoDoc +beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q +beside Empty _ q = q +beside (Nest k p) g q = nest_ k $! beside p g q +beside p@(Beside p1 g1 q1) g2 q2 + | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 + | otherwise = beside (reduceDoc p) g2 q2 +beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q +beside (NilAbove p) g q = nilAbove_ $! beside p g q +beside (TextBeside s sl p) g q = textBeside_ s sl rest + where + rest = case p of + Empty -> nilBeside g q + _ -> beside p g q + +-- Specification: text "" <> nilBeside g p +-- = text "" <g> p +nilBeside :: Bool -> RDoc -> RDoc +nilBeside _ Empty = Empty -- Hence the text "" in the spec +nilBeside g (Nest _ p) = nilBeside g p +nilBeside g p | g = textBeside_ spaceText 1 p + | otherwise = p + + +-- --------------------------------------------------------------------------- +-- Separate, @sep@ + +-- Specification: sep ps = oneLiner (hsep ps) +-- `union` +-- vcat ps + +-- | Either 'hsep' or 'vcat'. +sep :: [Doc] -> Doc +sep = sepX True -- Separate with spaces + +-- | Either 'hcat' or 'vcat'. +cat :: [Doc] -> Doc +cat = sepX False -- Don't + +sepX :: Bool -> [Doc] -> Doc +sepX _ [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps + + +-- Specification: sep1 g k ys = sep (x : map (nest k) ys) +-- = oneLiner (x <g> nest k (hsep ys)) +-- `union` x $$ nest k (vcat ys) +sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc +sep1 _ _ k _ | k `seq` False = undefined +sep1 _ NoDoc _ _ = NoDoc +sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` + aboveNest q False k (reduceDoc (vcat ys)) + +sep1 g Empty k ys = mkNest k (sepX g ys) +sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) + +sep1 _ (NilAbove p) k ys = nilAbove_ + (aboveNest p False k (reduceDoc (vcat ys))) +sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) +sep1 _ (Above {}) _ _ = error "sep1 Above" +sep1 _ (Beside {}) _ _ = error "sep1 Beside" + +-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys +-- Called when we have already found some text in the first item +-- We have to eat up nests +sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc +sepNB g (Nest _ p) k ys + = sepNB g p k ys -- Never triggered, because of invariant (2) +sepNB g Empty k ys + = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + nilAboveNest False k (reduceDoc (vcat ys)) + where + rest | g = hsep ys + | otherwise = hcat ys +sepNB g p k ys + = sep1 g p k ys + + +-- --------------------------------------------------------------------------- +-- @fill@ + +-- | \"Paragraph fill\" version of 'cat'. +fcat :: [Doc] -> Doc +fcat = fill False + +-- | \"Paragraph fill\" version of 'sep'. +fsep :: [Doc] -> Doc +fsep = fill True + +-- Specification: +-- +-- fill g docs = fillIndent 0 docs +-- +-- fillIndent k [] = [] +-- fillIndent k [p] = p +-- fillIndent k (p1:p2:ps) = +-- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0) +-- (remove_nests (oneLiner p2) : ps) +-- `Union` +-- (p1 $*$ nest (-k) (fillIndent 0 ps)) +-- +-- $*$ is defined for layouts (not Docs) as +-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 +-- | otherwise = layout1 $+$ layout2 + +fill :: Bool -> [Doc] -> RDoc +fill _ [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) 0 ps + +fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc +fill1 _ _ k _ | k `seq` False = undefined +fill1 _ NoDoc _ _ = NoDoc +fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` + aboveNest q False k (fill g ys) +fill1 g Empty k ys = mkNest k (fill g ys) +fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) +fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) +fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) +fill1 _ (Above {}) _ _ = error "fill1 Above" +fill1 _ (Beside {}) _ _ = error "fill1 Beside" + +fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc +fillNB _ _ k _ | k `seq` False = undefined +fillNB g (Nest _ p) k ys = fillNB g p k ys + -- Never triggered, because of invariant (2) +fillNB _ Empty _ [] = Empty +fillNB g Empty k (Empty:ys) = fillNB g Empty k ys +fillNB g Empty k (y:ys) = fillNBE g k y ys +fillNB g p k ys = fill1 g p k ys + + +fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc +fillNBE g k y ys + = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + `mkUnion` nilAboveNest False k (fill g (y:ys)) + where k' = if g then k - 1 else k + +elideNest :: Doc -> Doc +elideNest (Nest _ d) = d +elideNest d = d + +-- --------------------------------------------------------------------------- +-- Selecting the best layout + +best :: Int -- Line length + -> Int -- Ribbon length + -> RDoc + -> RDoc -- No unions in here! +best w0 r = get w0 + where + get :: Int -- (Remaining) width of line + -> Doc -> Doc + get w _ | w == 0 && False = undefined + get _ Empty = Empty + get _ NoDoc = NoDoc + get w (NilAbove p) = nilAbove_ (get w p) + get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) + get w (Nest k p) = nest_ k (get (w - k) p) + get w (p `Union` q) = nicest w r (get w p) (get w q) + get _ (Above {}) = error "best get Above" + get _ (Beside {}) = error "best get Beside" + + get1 :: Int -- (Remaining) width of line + -> Int -- Amount of first line already eaten up + -> Doc -- This is an argument to TextBeside => eat Nests + -> Doc -- No unions in here! + + get1 w _ _ | w == 0 && False = undefined + get1 _ _ Empty = Empty + get1 _ _ NoDoc = NoDoc + get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) + get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) + get1 w sl (Nest _ p) = get1 w sl p + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q) + get1 _ _ (Above {}) = error "best get1 Above" + get1 _ _ (Beside {}) = error "best get1 Beside" + +nicest :: Int -> Int -> Doc -> Doc -> Doc +nicest !w !r = nicest1 w r 0 + +nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc +nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p + | otherwise = q + +fits :: Int -- Space available + -> Doc + -> Bool -- True if *first line* of Doc fits in space available +fits n _ | n < 0 = False +fits _ NoDoc = False +fits _ Empty = True +fits _ (NilAbove _) = True +fits n (TextBeside _ sl p) = fits (n - sl) p +fits _ (Above {}) = error "fits Above" +fits _ (Beside {}) = error "fits Beside" +fits _ (Union {}) = error "fits Union" +fits _ (Nest {}) = error "fits Nest" + +-- | @first@ returns its first argument if it is non-empty, otherwise its second. +first :: Doc -> Doc -> Doc +first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused + | otherwise = q + +nonEmptySet :: Doc -> Bool +nonEmptySet NoDoc = False +nonEmptySet (_ `Union` _) = True +nonEmptySet Empty = True +nonEmptySet (NilAbove _) = True +nonEmptySet (TextBeside _ _ p) = nonEmptySet p +nonEmptySet (Nest _ p) = nonEmptySet p +nonEmptySet (Above {}) = error "nonEmptySet Above" +nonEmptySet (Beside {}) = error "nonEmptySet Beside" + +-- @oneLiner@ returns the one-line members of the given set of @GDoc@s. +oneLiner :: Doc -> Doc +oneLiner NoDoc = NoDoc +oneLiner Empty = Empty +oneLiner (NilAbove _) = NoDoc +oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) +oneLiner (Nest k p) = nest_ k (oneLiner p) +oneLiner (p `Union` _) = oneLiner p +oneLiner (Above {}) = error "oneLiner Above" +oneLiner (Beside {}) = error "oneLiner Beside" + + +-- --------------------------------------------------------------------------- +-- Rendering + +-- | A rendering style. +data Style + = Style { mode :: Mode -- ^ The rendering mode + , lineLength :: Int -- ^ Length of line, in chars + , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length + } + +-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). +style :: Style +style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } + +-- | Rendering mode. +data Mode = PageMode -- ^ Normal + | ZigZagMode -- ^ With zig-zag cuts + | LeftMode -- ^ No indentation, infinitely long lines + | OneLineMode -- ^ All on one line + +-- | Render the @Doc@ to a String using the given @Style@. +renderStyle :: Style -> Doc -> String +renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) + txtPrinter "" + +-- | Default TextDetails printer +txtPrinter :: TextDetails -> String -> String +txtPrinter (Chr c) s = c:s +txtPrinter (Str s1) s2 = s1 ++ s2 +txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 +txtPrinter (ZStr s1) s2 = zString s1 ++ s2 +txtPrinter (LStr s1) s2 = unpackPtrString s1 ++ s2 +txtPrinter (RStr n c) s2 = replicate n c ++ s2 + +-- | The general rendering interface. +fullRender :: Mode -- ^ Rendering mode + -> Int -- ^ Line length + -> Float -- ^ Ribbons per line + -> (TextDetails -> a -> a) -- ^ What to do with text + -> a -- ^ What to do at the end + -> Doc -- ^ The document + -> a -- ^ Result +fullRender OneLineMode _ _ txt end doc + = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) +fullRender LeftMode _ _ txt end doc + = easyDisplay nlText first txt end (reduceDoc doc) + +fullRender m lineLen ribbons txt rest doc + = display m lineLen ribbonLen txt rest doc' + where + doc' = best bestLineLen ribbonLen (reduceDoc doc) + + bestLineLen, ribbonLen :: Int + ribbonLen = round (fromIntegral lineLen / ribbons) + bestLineLen = case m of + ZigZagMode -> maxBound + _ -> lineLen + +easyDisplay :: TextDetails + -> (Doc -> Doc -> Doc) + -> (TextDetails -> a -> a) + -> a + -> Doc + -> a +easyDisplay nlSpaceText choose txt end + = lay + where + lay NoDoc = error "easyDisplay: NoDoc" + lay (Union p q) = lay (choose p q) + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = nlSpaceText `txt` lay p + lay (TextBeside s _ p) = s `txt` lay p + lay (Above {}) = error "easyDisplay Above" + lay (Beside {}) = error "easyDisplay Beside" + +display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a +display m !page_width !ribbon_width txt end doc + = case page_width - ribbon_width of { gap_width -> + case gap_width `quot` 2 of { shift -> + let + lay k _ | k `seq` False = undefined + lay k (Nest k1 p) = lay (k + k1) p + lay _ Empty = end + lay k (NilAbove p) = nlText `txt` lay k p + lay k (TextBeside s sl p) + = case m of + ZigZagMode | k >= gap_width + -> nlText `txt` ( + Str (replicate shift '/') `txt` ( + nlText `txt` + lay1 (k - shift) s sl p )) + + | k < 0 + -> nlText `txt` ( + Str (replicate shift '\\') `txt` ( + nlText `txt` + lay1 (k + shift) s sl p )) + + _ -> lay1 k s sl p + lay _ (Above {}) = error "display lay Above" + lay _ (Beside {}) = error "display lay Beside" + lay _ NoDoc = error "display lay NoDoc" + lay _ (Union {}) = error "display lay Union" + + lay1 !k s !sl p = let !r = k + sl + in indent k (s `txt` lay2 r p) + + lay2 k _ | k `seq` False = undefined + lay2 k (NilAbove p) = nlText `txt` lay k p + lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p + lay2 k (Nest _ p) = lay2 k p + lay2 _ Empty = end + lay2 _ (Above {}) = error "display lay2 Above" + lay2 _ (Beside {}) = error "display lay2 Beside" + lay2 _ NoDoc = error "display lay2 NoDoc" + lay2 _ (Union {}) = error "display lay2 Union" + + indent !n r = RStr n ' ' `txt` r + in + lay 0 doc + }} + +printDoc :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc adds a newline to the end +printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") + +printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc_ does not add a newline at the end, so that +-- successive calls can output stuff on the same line +-- Rather like putStr vs putStrLn +printDoc_ LeftMode _ hdl doc + = do { printLeftRender hdl doc; hFlush hdl } +printDoc_ mode pprCols hdl doc + = do { fullRender mode pprCols 1.5 put done doc ; + hFlush hdl } + where + put (Chr c) next = hPutChar hdl c >> next + put (Str s) next = hPutStr hdl s >> next + put (PStr s) next = hPutStr hdl (unpackFS s) >> next + -- NB. not hPutFS, we want this to go through + -- the I/O library's encoding layer. (#3398) + put (ZStr s) next = hPutFZS hdl s >> next + put (LStr s) next = hPutPtrString hdl s >> next + put (RStr n c) next = hPutStr hdl (replicate n c) >> next + + done = return () -- hPutChar hdl '\n' + + -- some versions of hPutBuf will barf if the length is zero +hPutPtrString :: Handle -> PtrString -> IO () +hPutPtrString _handle (PtrString _ 0) = return () +hPutPtrString handle (PtrString a l) = hPutBuf handle a l + +-- Printing output in LeftMode is performance critical: it's used when +-- dumping C and assembly output, so we allow ourselves a few dirty +-- hacks: +-- +-- (1) we specialise fullRender for LeftMode with IO output. +-- +-- (2) we add a layer of buffering on top of Handles. Handles +-- don't perform well with lots of hPutChars, which is mostly +-- what we're doing here, because Handles have to be thread-safe +-- and async exception-safe. We only have a single thread and don't +-- care about exceptions, so we add a layer of fast buffering +-- over the Handle interface. + +printLeftRender :: Handle -> Doc -> IO () +printLeftRender hdl doc = do + b <- newBufHandle hdl + bufLeftRender b doc + bFlush b + +bufLeftRender :: BufHandle -> Doc -> IO () +bufLeftRender b doc = layLeft b (reduceDoc doc) + +layLeft :: BufHandle -> Doc -> IO () +layLeft b _ | b `seq` False = undefined -- make it strict in b +layLeft _ NoDoc = error "layLeft: NoDoc" +layLeft b (Union p q) = layLeft b $! first p q +layLeft b (Nest _ p) = layLeft b $! p +layLeft b Empty = bPutChar b '\n' +layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) +layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) + where + put b _ | b `seq` False = undefined + put b (Chr c) = bPutChar b c + put b (Str s) = bPutStr b s + put b (PStr s) = bPutFS b s + put b (ZStr s) = bPutFZS b s + put b (LStr s) = bPutPtrString b s + put b (RStr n c) = bPutReplicate b n c +layLeft _ _ = panic "layLeft: Unhandled case" + +-- Define error=panic, for easier comparison with libraries/pretty. +error :: String -> a +error = panic diff --git a/compiler/GHC/Utils/Ppr/Colour.hs b/compiler/GHC/Utils/Ppr/Colour.hs new file mode 100644 index 0000000000..7283edd182 --- /dev/null +++ b/compiler/GHC/Utils/Ppr/Colour.hs @@ -0,0 +1,101 @@ +module GHC.Utils.Ppr.Colour where +import GHC.Prelude + +import Data.Maybe (fromMaybe) +import GHC.Utils.Misc (OverridingBool(..), split) +import Data.Semigroup as Semi + +-- | A colour\/style for use with 'coloured'. +newtype PprColour = PprColour { renderColour :: String } + +instance Semi.Semigroup PprColour where + PprColour s1 <> PprColour s2 = PprColour (s1 <> s2) + +-- | Allow colours to be combined (e.g. bold + red); +-- In case of conflict, right side takes precedence. +instance Monoid PprColour where + mempty = PprColour mempty + mappend = (<>) + +renderColourAfresh :: PprColour -> String +renderColourAfresh c = renderColour (colReset `mappend` c) + +colCustom :: String -> PprColour +colCustom "" = mempty +colCustom s = PprColour ("\27[" ++ s ++ "m") + +colReset :: PprColour +colReset = colCustom "0" + +colBold :: PprColour +colBold = colCustom ";1" + +colBlackFg :: PprColour +colBlackFg = colCustom "30" + +colRedFg :: PprColour +colRedFg = colCustom "31" + +colGreenFg :: PprColour +colGreenFg = colCustom "32" + +colYellowFg :: PprColour +colYellowFg = colCustom "33" + +colBlueFg :: PprColour +colBlueFg = colCustom "34" + +colMagentaFg :: PprColour +colMagentaFg = colCustom "35" + +colCyanFg :: PprColour +colCyanFg = colCustom "36" + +colWhiteFg :: PprColour +colWhiteFg = colCustom "37" + +data Scheme = + Scheme + { sHeader :: PprColour + , sMessage :: PprColour + , sWarning :: PprColour + , sError :: PprColour + , sFatal :: PprColour + , sMargin :: PprColour + } + +defaultScheme :: Scheme +defaultScheme = + Scheme + { sHeader = mempty + , sMessage = colBold + , sWarning = colBold `mappend` colMagentaFg + , sError = colBold `mappend` colRedFg + , sFatal = colBold `mappend` colRedFg + , sMargin = colBold `mappend` colBlueFg + } + +-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@ +-- environment variable). +parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme) +parseScheme "always" (_, cs) = (Always, cs) +parseScheme "auto" (_, cs) = (Auto, cs) +parseScheme "never" (_, cs) = (Never, cs) +parseScheme input (b, cs) = + ( b + , Scheme + { sHeader = fromMaybe (sHeader cs) (lookup "header" table) + , sMessage = fromMaybe (sMessage cs) (lookup "message" table) + , sWarning = fromMaybe (sWarning cs) (lookup "warning" table) + , sError = fromMaybe (sError cs) (lookup "error" table) + , sFatal = fromMaybe (sFatal cs) (lookup "fatal" table) + , sMargin = fromMaybe (sMargin cs) (lookup "margin" table) + } + ) + where + table = do + w <- split ':' input + let (k, v') = break (== '=') w + case v' of + '=' : v -> return (k, colCustom v) + _ -> [] |