From 1941ef4f050c0dfcb68229641fcbbde3a10f1072 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Wed, 18 Mar 2020 10:44:56 +0100 Subject: Modules: Types (#13009) Update Haddock submodule Metric Increase: haddock.compiler --- compiler/GHC.hs | 20 +- compiler/GHC/ByteCode/Asm.hs | 10 +- compiler/GHC/ByteCode/InfoTable.hs | 4 +- compiler/GHC/ByteCode/Instr.hs | 10 +- compiler/GHC/ByteCode/Linker.hs | 6 +- compiler/GHC/ByteCode/Types.hs | 8 +- compiler/GHC/Cmm.hs | 4 +- compiler/GHC/Cmm/BlockId.hs | 8 +- compiler/GHC/Cmm/BlockId.hs-boot | 2 +- compiler/GHC/Cmm/CLabel.hs | 14 +- compiler/GHC/Cmm/CommonBlockElim.hs | 4 +- compiler/GHC/Cmm/Dataflow.hs | 2 +- compiler/GHC/Cmm/Dataflow/Label.hs | 2 +- compiler/GHC/Cmm/DebugBlock.hs | 4 +- compiler/GHC/Cmm/Expr.hs | 4 +- compiler/GHC/Cmm/Graph.hs | 4 +- compiler/GHC/Cmm/Info.hs | 2 +- compiler/GHC/Cmm/Info/Build.hs | 12 +- compiler/GHC/Cmm/LayoutStack.hs | 8 +- compiler/GHC/Cmm/Lexer.x | 4 +- compiler/GHC/Cmm/Node.hs | 6 +- compiler/GHC/Cmm/Parser.y | 18 +- compiler/GHC/Cmm/Pipeline.hs | 2 +- compiler/GHC/Cmm/Ppr.hs | 2 +- compiler/GHC/Cmm/ProcPoint.hs | 2 +- compiler/GHC/Cmm/Sink.hs | 4 +- compiler/GHC/Cmm/Switch/Implement.hs | 2 +- compiler/GHC/Cmm/Utils.hs | 2 +- compiler/GHC/CmmToAsm.hs | 10 +- compiler/GHC/CmmToAsm/BlockLayout.hs | 4 +- compiler/GHC/CmmToAsm/CFG.hs | 2 +- compiler/GHC/CmmToAsm/Dwarf.hs | 6 +- compiler/GHC/CmmToAsm/Dwarf/Types.hs | 4 +- compiler/GHC/CmmToAsm/Monad.hs | 8 +- compiler/GHC/CmmToAsm/PIC.hs | 4 +- compiler/GHC/CmmToAsm/PPC/CodeGen.hs | 2 +- compiler/GHC/CmmToAsm/PPC/Instr.hs | 4 +- compiler/GHC/CmmToAsm/PPC/Ppr.hs | 2 +- compiler/GHC/CmmToAsm/PPC/RegInfo.hs | 2 +- compiler/GHC/CmmToAsm/PPC/Regs.hs | 2 +- compiler/GHC/CmmToAsm/Reg/Graph.hs | 6 +- compiler/GHC/CmmToAsm/Reg/Graph/Base.hs | 6 +- compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs | 6 +- compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs | 8 +- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs | 6 +- compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs | 4 +- compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs | 4 +- compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs | 2 +- compiler/GHC/CmmToAsm/Reg/Graph/X86.hs | 2 +- compiler/GHC/CmmToAsm/Reg/Linear.hs | 8 +- compiler/GHC/CmmToAsm/Reg/Linear/Base.hs | 6 +- compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs | 6 +- compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs | 4 +- compiler/GHC/CmmToAsm/Reg/Linear/State.hs | 4 +- compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs | 2 +- compiler/GHC/CmmToAsm/Reg/Liveness.hs | 6 +- compiler/GHC/CmmToAsm/Reg/Target.hs | 2 +- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs | 2 +- compiler/GHC/CmmToAsm/SPARC/Ppr.hs | 2 +- compiler/GHC/CmmToAsm/SPARC/Regs.hs | 2 +- compiler/GHC/CmmToAsm/X86/CodeGen.hs | 10 +- compiler/GHC/CmmToAsm/X86/Instr.hs | 8 +- compiler/GHC/CmmToAsm/X86/Ppr.hs | 4 +- compiler/GHC/CmmToAsm/X86/RegInfo.hs | 4 +- compiler/GHC/CmmToC.hs | 8 +- compiler/GHC/CmmToLlvm/Base.hs | 8 +- compiler/GHC/CmmToLlvm/CodeGen.hs | 6 +- compiler/GHC/CmmToLlvm/Ppr.hs | 2 +- compiler/GHC/CmmToLlvm/Regs.hs | 2 +- compiler/GHC/Core.hs | 22 +- compiler/GHC/Core/Arity.hs | 12 +- compiler/GHC/Core/Class.hs | 10 +- compiler/GHC/Core/Coercion.hs | 16 +- compiler/GHC/Core/Coercion.hs-boot | 4 +- compiler/GHC/Core/Coercion/Axiom.hs | 10 +- compiler/GHC/Core/Coercion/Opt.hs | 4 +- compiler/GHC/Core/ConLike.hs | 10 +- compiler/GHC/Core/ConLike.hs-boot | 2 +- compiler/GHC/Core/DataCon.hs | 24 +- compiler/GHC/Core/DataCon.hs-boot | 10 +- compiler/GHC/Core/FVs.hs | 18 +- compiler/GHC/Core/FamInstEnv.hs | 14 +- compiler/GHC/Core/InstEnv.hs | 16 +- compiler/GHC/Core/Lint.hs | 22 +- compiler/GHC/Core/Make.hs | 22 +- compiler/GHC/Core/Map.hs | 8 +- compiler/GHC/Core/Op/CSE.hs | 8 +- compiler/GHC/Core/Op/CallArity.hs | 10 +- compiler/GHC/Core/Op/ConstantFold.hs | 14 +- compiler/GHC/Core/Op/CprAnal.hs | 12 +- compiler/GHC/Core/Op/DmdAnal.hs | 22 +- compiler/GHC/Core/Op/Exitify.hs | 12 +- compiler/GHC/Core/Op/FloatIn.hs | 10 +- compiler/GHC/Core/Op/FloatOut.hs | 8 +- compiler/GHC/Core/Op/LiberateCase.hs | 4 +- compiler/GHC/Core/Op/Monad.hs | 14 +- compiler/GHC/Core/Op/OccurAnal.hs | 26 +- compiler/GHC/Core/Op/SetLevels.hs | 36 +- compiler/GHC/Core/Op/Simplify.hs | 32 +- compiler/GHC/Core/Op/Simplify/Driver.hs | 18 +- compiler/GHC/Core/Op/Simplify/Env.hs | 12 +- compiler/GHC/Core/Op/Simplify/Monad.hs | 12 +- compiler/GHC/Core/Op/Simplify/Utils.hs | 18 +- compiler/GHC/Core/Op/SpecConstr.hs | 24 +- compiler/GHC/Core/Op/Specialise.hs | 22 +- compiler/GHC/Core/Op/StaticArgs.hs | 18 +- compiler/GHC/Core/Op/Tidy.hs | 18 +- compiler/GHC/Core/Op/WorkWrap.hs | 14 +- compiler/GHC/Core/Op/WorkWrap/Lib.hs | 28 +- compiler/GHC/Core/PatSyn.hs | 10 +- compiler/GHC/Core/PatSyn.hs-boot | 6 +- compiler/GHC/Core/Ppr.hs | 18 +- compiler/GHC/Core/Ppr/TyThing.hs | 4 +- compiler/GHC/Core/Predicate.hs | 2 +- compiler/GHC/Core/Rules.hs | 25 +- compiler/GHC/Core/Seq.hs | 14 +- compiler/GHC/Core/SimpleOpt.hs | 22 +- compiler/GHC/Core/Stats.hs | 6 +- compiler/GHC/Core/Subst.hs | 14 +- compiler/GHC/Core/TyCo/FVs.hs | 8 +- compiler/GHC/Core/TyCo/Ppr.hs | 12 +- compiler/GHC/Core/TyCo/Rep.hs | 8 +- compiler/GHC/Core/TyCo/Rep.hs-boot | 2 +- compiler/GHC/Core/TyCo/Subst.hs | 14 +- compiler/GHC/Core/TyCo/Tidy.hs | 8 +- compiler/GHC/Core/TyCon.hs | 22 +- compiler/GHC/Core/Type.hs | 14 +- compiler/GHC/Core/Unfold.hs | 16 +- compiler/GHC/Core/Unify.hs | 12 +- compiler/GHC/Core/Utils.hs | 24 +- compiler/GHC/CoreToByteCode.hs | 26 +- compiler/GHC/CoreToIface.hs | 20 +- compiler/GHC/CoreToIface.hs-boot | 6 +- compiler/GHC/CoreToStg.hs | 24 +- compiler/GHC/CoreToStg/Prep.hs | 44 +- compiler/GHC/Driver/Backpack.hs | 12 +- compiler/GHC/Driver/Backpack/Syntax.hs | 4 +- compiler/GHC/Driver/CmdLine.hs | 2 +- compiler/GHC/Driver/CodeOutput.hs | 6 +- compiler/GHC/Driver/Finder.hs | 2 +- compiler/GHC/Driver/Hooks.hs | 14 +- compiler/GHC/Driver/Main.hs | 24 +- compiler/GHC/Driver/Make.hs | 16 +- compiler/GHC/Driver/MakeFile.hs | 4 +- compiler/GHC/Driver/Packages.hs | 16 +- compiler/GHC/Driver/Packages.hs-boot | 2 +- compiler/GHC/Driver/Pipeline.hs | 8 +- compiler/GHC/Driver/Pipeline/Monad.hs | 2 +- compiler/GHC/Driver/Plugins.hs | 2 +- compiler/GHC/Driver/Session.hs | 6 +- compiler/GHC/Driver/Types.hs | 36 +- compiler/GHC/Hs.hs | 6 +- compiler/GHC/Hs/Binds.hs | 14 +- compiler/GHC/Hs/Decls.hs | 18 +- compiler/GHC/Hs/Doc.hs | 4 +- compiler/GHC/Hs/Dump.hs | 15 +- compiler/GHC/Hs/Expr.hs | 16 +- compiler/GHC/Hs/Expr.hs-boot | 4 +- compiler/GHC/Hs/Extension.hs | 8 +- compiler/GHC/Hs/ImpExp.hs | 16 +- compiler/GHC/Hs/Lit.hs | 11 +- compiler/GHC/Hs/Pat.hs | 8 +- compiler/GHC/Hs/Types.hs | 12 +- compiler/GHC/Hs/Utils.hs | 16 +- compiler/GHC/HsToCore.hs | 22 +- compiler/GHC/HsToCore/Arrows.hs | 10 +- compiler/GHC/HsToCore/Binds.hs | 20 +- compiler/GHC/HsToCore/Coverage.hs | 18 +- compiler/GHC/HsToCore/Docs.hs | 6 +- compiler/GHC/HsToCore/Expr.hs | 18 +- compiler/GHC/HsToCore/Foreign/Call.hs | 10 +- compiler/GHC/HsToCore/Foreign/Decl.hs | 14 +- compiler/GHC/HsToCore/GuardedRHSs.hs | 2 +- compiler/GHC/HsToCore/ListComp.hs | 4 +- compiler/GHC/HsToCore/Match.hs | 16 +- compiler/GHC/HsToCore/Match.hs-boot | 6 +- compiler/GHC/HsToCore/Match/Constructor.hs | 10 +- compiler/GHC/HsToCore/Match/Literal.hs | 10 +- compiler/GHC/HsToCore/Monad.hs | 22 +- compiler/GHC/HsToCore/PmCheck.hs | 10 +- compiler/GHC/HsToCore/PmCheck/Oracle.hs | 20 +- compiler/GHC/HsToCore/PmCheck/Ppr.hs | 8 +- compiler/GHC/HsToCore/PmCheck/Types.hs | 14 +- compiler/GHC/HsToCore/Quote.hs | 33 +- compiler/GHC/HsToCore/Usage.hs | 10 +- compiler/GHC/HsToCore/Utils.hs | 18 +- compiler/GHC/Iface/Binary.hs | 14 +- compiler/GHC/Iface/Env.hs | 16 +- compiler/GHC/Iface/Env.hs-boot | 8 +- compiler/GHC/Iface/Ext/Ast.hs | 16 +- compiler/GHC/Iface/Ext/Binary.hs | 14 +- compiler/GHC/Iface/Ext/Debug.hs | 6 +- compiler/GHC/Iface/Ext/Types.hs | 8 +- compiler/GHC/Iface/Ext/Utils.hs | 8 +- compiler/GHC/Iface/Load.hs | 22 +- compiler/GHC/Iface/Load.hs-boot | 2 +- compiler/GHC/Iface/Make.hs | 24 +- compiler/GHC/Iface/Recomp.hs | 14 +- compiler/GHC/Iface/Rename.hs | 16 +- compiler/GHC/Iface/Syntax.hs | 30 +- compiler/GHC/Iface/Tidy.hs | 34 +- compiler/GHC/Iface/Type.hs | 8 +- compiler/GHC/Iface/Type.hs-boot | 2 +- compiler/GHC/IfaceToCore.hs | 38 +- compiler/GHC/IfaceToCore.hs-boot | 2 +- compiler/GHC/Llvm/Ppr.hs | 2 +- compiler/GHC/Llvm/Syntax.hs | 2 +- compiler/GHC/Llvm/Types.hs | 2 +- compiler/GHC/Platform/Reg.hs | 2 +- compiler/GHC/Platform/Reg/Class.hs | 4 +- compiler/GHC/Plugins.hs | 100 +- compiler/GHC/Rename/Binds.hs | 18 +- compiler/GHC/Rename/Doc.hs | 2 +- compiler/GHC/Rename/Env.hs | 18 +- compiler/GHC/Rename/Expr.hs | 14 +- compiler/GHC/Rename/Expr.hs-boot | 6 +- compiler/GHC/Rename/Fixity.hs | 12 +- compiler/GHC/Rename/Names.hs | 25 +- compiler/GHC/Rename/Pat.hs | 12 +- compiler/GHC/Rename/Source.hs | 26 +- compiler/GHC/Rename/Splice.hs | 14 +- compiler/GHC/Rename/Splice.hs-boot | 2 +- compiler/GHC/Rename/Types.hs | 12 +- compiler/GHC/Rename/Unbound.hs | 10 +- compiler/GHC/Rename/Utils.hs | 12 +- compiler/GHC/Runtime/Debugger.hs | 10 +- compiler/GHC/Runtime/Eval.hs | 22 +- compiler/GHC/Runtime/Eval/Types.hs | 10 +- compiler/GHC/Runtime/Heap/Inspect.hs | 12 +- compiler/GHC/Runtime/Heap/Layout.hs | 2 +- compiler/GHC/Runtime/Interpreter.hs | 10 +- compiler/GHC/Runtime/Interpreter/Types.hs | 2 +- compiler/GHC/Runtime/Linker.hs | 12 +- compiler/GHC/Runtime/Linker/Types.hs | 10 +- compiler/GHC/Runtime/Loader.hs | 24 +- compiler/GHC/Stg/CSE.hs | 6 +- compiler/GHC/Stg/DepAnal.hs | 12 +- compiler/GHC/Stg/FVs.hs | 4 +- compiler/GHC/Stg/Lift.hs | 8 +- compiler/GHC/Stg/Lift/Analysis.hs | 8 +- compiler/GHC/Stg/Lift/Monad.hs | 16 +- compiler/GHC/Stg/Lint.hs | 20 +- compiler/GHC/Stg/Pipeline.hs | 4 +- compiler/GHC/Stg/Stats.hs | 2 +- compiler/GHC/Stg/Subst.hs | 4 +- compiler/GHC/Stg/Syntax.hs | 14 +- compiler/GHC/Stg/Unarise.hs | 12 +- compiler/GHC/StgToCmm.hs | 12 +- compiler/GHC/StgToCmm/ArgRep.hs | 11 +- compiler/GHC/StgToCmm/Bind.hs | 14 +- compiler/GHC/StgToCmm/Closure.hs | 10 +- compiler/GHC/StgToCmm/DataCon.hs | 8 +- compiler/GHC/StgToCmm/Env.hs | 8 +- compiler/GHC/StgToCmm/Expr.hs | 10 +- compiler/GHC/StgToCmm/ExtCode.hs | 8 +- compiler/GHC/StgToCmm/Foreign.hs | 6 +- compiler/GHC/StgToCmm/Heap.hs | 8 +- compiler/GHC/StgToCmm/Hpc.hs | 2 +- compiler/GHC/StgToCmm/Layout.hs | 6 +- compiler/GHC/StgToCmm/Monad.hs | 12 +- compiler/GHC/StgToCmm/Prim.hs | 4 +- compiler/GHC/StgToCmm/Prof.hs | 4 +- compiler/GHC/StgToCmm/Ticky.hs | 8 +- compiler/GHC/StgToCmm/Utils.hs | 14 +- compiler/GHC/ThToHs.hs | 18 +- compiler/GHC/Types/Annotations.hs | 142 ++ compiler/GHC/Types/Avail.hs | 286 +++ compiler/GHC/Types/Basic.hs | 1736 ++++++++++++++++++ compiler/GHC/Types/CostCentre.hs | 359 ++++ compiler/GHC/Types/CostCentre/Init.hs | 64 + compiler/GHC/Types/CostCentre/State.hs | 41 + compiler/GHC/Types/Cpr.hs | 163 ++ compiler/GHC/Types/Demand.hs | 1974 +++++++++++++++++++++ compiler/GHC/Types/FieldLabel.hs | 132 ++ compiler/GHC/Types/ForeignCall.hs | 348 ++++ compiler/GHC/Types/Id.hs | 971 ++++++++++ compiler/GHC/Types/Id/Info.hs | 652 +++++++ compiler/GHC/Types/Id/Info.hs-boot | 11 + compiler/GHC/Types/Id/Make.hs | 1708 ++++++++++++++++++ compiler/GHC/Types/Id/Make.hs-boot | 15 + compiler/GHC/Types/Literal.hs | 847 +++++++++ compiler/GHC/Types/Module.hs | 1303 ++++++++++++++ compiler/GHC/Types/Module.hs-boot | 14 + compiler/GHC/Types/Name.hs | 693 ++++++++ compiler/GHC/Types/Name.hs-boot | 5 + compiler/GHC/Types/Name/Cache.hs | 120 ++ compiler/GHC/Types/Name/Env.hs | 175 ++ compiler/GHC/Types/Name/Occurrence.hs | 927 ++++++++++ compiler/GHC/Types/Name/Occurrence.hs-boot | 5 + compiler/GHC/Types/Name/Reader.hs | 1387 +++++++++++++++ compiler/GHC/Types/Name/Set.hs | 215 +++ compiler/GHC/Types/Name/Shape.hs | 31 +- compiler/GHC/Types/RepType.hs | 2 +- compiler/GHC/Types/SrcLoc.hs | 741 ++++++++ compiler/GHC/Types/Unique.hs | 448 +++++ compiler/GHC/Types/Unique/DFM.hs | 420 +++++ compiler/GHC/Types/Unique/DSet.hs | 141 ++ compiler/GHC/Types/Unique/FM.hs | 416 +++++ compiler/GHC/Types/Unique/Map.hs | 206 +++ compiler/GHC/Types/Unique/Set.hs | 195 ++ compiler/GHC/Types/Unique/Supply.hs | 224 +++ compiler/GHC/Types/Var.hs | 763 ++++++++ compiler/GHC/Types/Var.hs-boot | 14 + compiler/GHC/Types/Var/Env.hs | 632 +++++++ compiler/GHC/Types/Var/Set.hs | 354 ++++ compiler/GHC/Utils/Lexeme.hs | 240 +++ compiler/basicTypes/Avail.hs | 286 --- compiler/basicTypes/BasicTypes.hs | 1736 ------------------ compiler/basicTypes/Cpr.hs | 163 -- compiler/basicTypes/Demand.hs | 1974 --------------------- compiler/basicTypes/FieldLabel.hs | 130 -- compiler/basicTypes/Id.hs | 971 ---------- compiler/basicTypes/IdInfo.hs | 652 ------- compiler/basicTypes/IdInfo.hs-boot | 11 - compiler/basicTypes/Lexeme.hs | 240 --- compiler/basicTypes/Literal.hs | 847 --------- compiler/basicTypes/MkId.hs | 1708 ------------------ compiler/basicTypes/MkId.hs-boot | 15 - compiler/basicTypes/Module.hs | 1303 -------------- compiler/basicTypes/Module.hs-boot | 14 - compiler/basicTypes/Name.hs | 693 -------- compiler/basicTypes/Name.hs-boot | 5 - compiler/basicTypes/NameCache.hs | 120 -- compiler/basicTypes/NameEnv.hs | 175 -- compiler/basicTypes/NameSet.hs | 215 --- compiler/basicTypes/OccName.hs | 927 ---------- compiler/basicTypes/OccName.hs-boot | 5 - compiler/basicTypes/RdrName.hs | 1387 --------------- compiler/basicTypes/SrcLoc.hs | 741 -------- compiler/basicTypes/UniqSupply.hs | 224 --- compiler/basicTypes/Unique.hs | 448 ----- compiler/basicTypes/Var.hs | 763 -------- compiler/basicTypes/Var.hs-boot | 14 - compiler/basicTypes/VarEnv.hs | 632 ------- compiler/basicTypes/VarSet.hs | 354 ---- compiler/ghc.cabal.in | 69 +- compiler/iface/BinFingerprint.hs | 2 +- compiler/iface/BuildTyCl.hs | 20 +- compiler/iface/FlagChecker.hs | 4 +- compiler/main/Annotations.hs | 142 -- compiler/main/ErrUtils.hs | 2 +- compiler/main/ErrUtils.hs-boot | 2 +- compiler/main/HeaderInfo.hs | 6 +- compiler/main/HscStats.hs | 2 +- compiler/main/StaticPtrTable.hs | 6 +- compiler/main/SysTools.hs | 2 +- compiler/main/SysTools/ExtraObj.hs | 4 +- compiler/main/SysTools/Process.hs | 2 +- compiler/main/UnitInfo.hs | 4 +- compiler/main/UpdateCafInfos.hs | 10 +- compiler/parser/ApiAnnotation.hs | 4 +- compiler/parser/HaddockUtils.hs | 2 +- compiler/parser/Lexer.x | 12 +- compiler/parser/Parser.y | 18 +- compiler/parser/RdrHsSyn.hs | 16 +- compiler/prelude/ForeignCall.hs | 348 ---- compiler/prelude/KnownUniques.hs | 10 +- compiler/prelude/KnownUniques.hs-boot | 6 +- compiler/prelude/PrelInfo.hs | 18 +- compiler/prelude/PrelNames.hs | 14 +- compiler/prelude/PrelNames.hs-boot | 4 +- compiler/prelude/PrimOp.hs | 22 +- compiler/prelude/THNames.hs | 24 +- compiler/prelude/TysPrim.hs | 8 +- compiler/prelude/TysWiredIn.hs | 26 +- compiler/prelude/TysWiredIn.hs-boot | 4 +- compiler/profiling-notes | 303 ++++ compiler/profiling/CostCentre.hs | 359 ---- compiler/profiling/CostCentreState.hs | 36 - compiler/profiling/NOTES | 303 ---- compiler/profiling/ProfInit.hs | 64 - compiler/typecheck/ClsInst.hs | 8 +- compiler/typecheck/Constraint.hs | 10 +- compiler/typecheck/FamInst.hs | 10 +- compiler/typecheck/FunDeps.hs | 10 +- compiler/typecheck/Inst.hs | 16 +- compiler/typecheck/TcAnnotations.hs | 8 +- compiler/typecheck/TcArrows.hs | 8 +- compiler/typecheck/TcBackpack.hs | 22 +- compiler/typecheck/TcBinds.hs | 26 +- compiler/typecheck/TcCanonical.hs | 16 +- compiler/typecheck/TcClassDcl.hs | 16 +- compiler/typecheck/TcDefaults.hs | 2 +- compiler/typecheck/TcDeriv.hs | 16 +- compiler/typecheck/TcDerivInfer.hs | 6 +- compiler/typecheck/TcDerivUtils.hs | 12 +- compiler/typecheck/TcEnv.hs | 20 +- compiler/typecheck/TcEnv.hs-boot | 2 +- compiler/typecheck/TcErrors.hs | 20 +- compiler/typecheck/TcEvTerm.hs | 8 +- compiler/typecheck/TcEvidence.hs | 14 +- compiler/typecheck/TcExpr.hs | 22 +- compiler/typecheck/TcExpr.hs-boot | 2 +- compiler/typecheck/TcFlatten.hs | 8 +- compiler/typecheck/TcForeign.hs | 10 +- compiler/typecheck/TcGenDeriv.hs | 18 +- compiler/typecheck/TcGenFunctor.hs | 10 +- compiler/typecheck/TcGenGenerics.hs | 14 +- compiler/typecheck/TcHoleErrors.hs | 10 +- compiler/typecheck/TcHoleErrors.hs-boot | 2 +- compiler/typecheck/TcHoleFitTypes.hs | 6 +- compiler/typecheck/TcHsSyn.hs | 18 +- compiler/typecheck/TcHsType.hs | 22 +- compiler/typecheck/TcInstDcls.hs | 18 +- compiler/typecheck/TcInteract.hs | 14 +- compiler/typecheck/TcMType.hs | 20 +- compiler/typecheck/TcMatches.hs | 8 +- compiler/typecheck/TcMatches.hs-boot | 12 +- compiler/typecheck/TcOrigin.hs | 12 +- compiler/typecheck/TcPat.hs | 16 +- compiler/typecheck/TcPatSyn.hs | 26 +- compiler/typecheck/TcPluginM.hs | 10 +- compiler/typecheck/TcRnDriver.hs | 26 +- compiler/typecheck/TcRnDriver.hs-boot | 2 +- compiler/typecheck/TcRnExports.hs | 22 +- compiler/typecheck/TcRnMonad.hs | 26 +- compiler/typecheck/TcRnTypes.hs | 32 +- compiler/typecheck/TcRnTypes.hs-boot | 2 +- compiler/typecheck/TcRules.hs | 10 +- compiler/typecheck/TcSMonad.hs | 22 +- compiler/typecheck/TcSigs.hs | 14 +- compiler/typecheck/TcSimplify.hs | 14 +- compiler/typecheck/TcSplice.hs | 30 +- compiler/typecheck/TcSplice.hs-boot | 4 +- compiler/typecheck/TcTyClsDecls.hs | 22 +- compiler/typecheck/TcTyDecls.hs | 24 +- compiler/typecheck/TcType.hs | 14 +- compiler/typecheck/TcTypeNats.hs | 2 +- compiler/typecheck/TcTypeable.hs | 10 +- compiler/typecheck/TcUnify.hs | 10 +- compiler/typecheck/TcValidity.hs | 12 +- compiler/utils/Binary.hs | 8 +- compiler/utils/BooleanFormula.hs | 6 +- compiler/utils/Digraph.hs | 4 +- compiler/utils/FV.hs | 8 +- compiler/utils/FastStringEnv.hs | 8 +- compiler/utils/GraphBase.hs | 4 +- compiler/utils/GraphColor.hs | 6 +- compiler/utils/GraphOps.hs | 6 +- compiler/utils/GraphPpr.hs | 6 +- compiler/utils/IOEnv.hs | 2 +- compiler/utils/Outputable.hs | 4 +- compiler/utils/TrieMap.hs | 8 +- compiler/utils/UnVarGraph.hs | 8 +- compiler/utils/UniqDFM.hs | 420 ----- compiler/utils/UniqDSet.hs | 141 -- compiler/utils/UniqFM.hs | 416 ----- compiler/utils/UniqMap.hs | 206 --- compiler/utils/UniqSet.hs | 195 -- 449 files changed, 21494 insertions(+), 21465 deletions(-) create mode 100644 compiler/GHC/Types/Annotations.hs create mode 100644 compiler/GHC/Types/Avail.hs create mode 100644 compiler/GHC/Types/Basic.hs create mode 100644 compiler/GHC/Types/CostCentre.hs create mode 100644 compiler/GHC/Types/CostCentre/Init.hs create mode 100644 compiler/GHC/Types/CostCentre/State.hs create mode 100644 compiler/GHC/Types/Cpr.hs create mode 100644 compiler/GHC/Types/Demand.hs create mode 100644 compiler/GHC/Types/FieldLabel.hs create mode 100644 compiler/GHC/Types/ForeignCall.hs create mode 100644 compiler/GHC/Types/Id.hs create mode 100644 compiler/GHC/Types/Id/Info.hs create mode 100644 compiler/GHC/Types/Id/Info.hs-boot create mode 100644 compiler/GHC/Types/Id/Make.hs create mode 100644 compiler/GHC/Types/Id/Make.hs-boot create mode 100644 compiler/GHC/Types/Literal.hs create mode 100644 compiler/GHC/Types/Module.hs create mode 100644 compiler/GHC/Types/Module.hs-boot create mode 100644 compiler/GHC/Types/Name.hs create mode 100644 compiler/GHC/Types/Name.hs-boot create mode 100644 compiler/GHC/Types/Name/Cache.hs create mode 100644 compiler/GHC/Types/Name/Env.hs create mode 100644 compiler/GHC/Types/Name/Occurrence.hs create mode 100644 compiler/GHC/Types/Name/Occurrence.hs-boot create mode 100644 compiler/GHC/Types/Name/Reader.hs create mode 100644 compiler/GHC/Types/Name/Set.hs create mode 100644 compiler/GHC/Types/SrcLoc.hs create mode 100644 compiler/GHC/Types/Unique.hs create mode 100644 compiler/GHC/Types/Unique/DFM.hs create mode 100644 compiler/GHC/Types/Unique/DSet.hs create mode 100644 compiler/GHC/Types/Unique/FM.hs create mode 100644 compiler/GHC/Types/Unique/Map.hs create mode 100644 compiler/GHC/Types/Unique/Set.hs create mode 100644 compiler/GHC/Types/Unique/Supply.hs create mode 100644 compiler/GHC/Types/Var.hs create mode 100644 compiler/GHC/Types/Var.hs-boot create mode 100644 compiler/GHC/Types/Var/Env.hs create mode 100644 compiler/GHC/Types/Var/Set.hs create mode 100644 compiler/GHC/Utils/Lexeme.hs delete mode 100644 compiler/basicTypes/Avail.hs delete mode 100644 compiler/basicTypes/BasicTypes.hs delete mode 100644 compiler/basicTypes/Cpr.hs delete mode 100644 compiler/basicTypes/Demand.hs delete mode 100644 compiler/basicTypes/FieldLabel.hs delete mode 100644 compiler/basicTypes/Id.hs delete mode 100644 compiler/basicTypes/IdInfo.hs delete mode 100644 compiler/basicTypes/IdInfo.hs-boot delete mode 100644 compiler/basicTypes/Lexeme.hs delete mode 100644 compiler/basicTypes/Literal.hs delete mode 100644 compiler/basicTypes/MkId.hs delete mode 100644 compiler/basicTypes/MkId.hs-boot delete mode 100644 compiler/basicTypes/Module.hs delete mode 100644 compiler/basicTypes/Module.hs-boot delete mode 100644 compiler/basicTypes/Name.hs delete mode 100644 compiler/basicTypes/Name.hs-boot delete mode 100644 compiler/basicTypes/NameCache.hs delete mode 100644 compiler/basicTypes/NameEnv.hs delete mode 100644 compiler/basicTypes/NameSet.hs delete mode 100644 compiler/basicTypes/OccName.hs delete mode 100644 compiler/basicTypes/OccName.hs-boot delete mode 100644 compiler/basicTypes/RdrName.hs delete mode 100644 compiler/basicTypes/SrcLoc.hs delete mode 100644 compiler/basicTypes/UniqSupply.hs delete mode 100644 compiler/basicTypes/Unique.hs delete mode 100644 compiler/basicTypes/Var.hs delete mode 100644 compiler/basicTypes/Var.hs-boot delete mode 100644 compiler/basicTypes/VarEnv.hs delete mode 100644 compiler/basicTypes/VarSet.hs delete mode 100644 compiler/main/Annotations.hs delete mode 100644 compiler/prelude/ForeignCall.hs create mode 100644 compiler/profiling-notes delete mode 100644 compiler/profiling/CostCentre.hs delete mode 100644 compiler/profiling/CostCentreState.hs delete mode 100644 compiler/profiling/NOTES delete mode 100644 compiler/profiling/ProfInit.hs delete mode 100644 compiler/utils/UniqDFM.hs delete mode 100644 compiler/utils/UniqDSet.hs delete mode 100644 compiler/utils/UniqFM.hs delete mode 100644 compiler/utils/UniqMap.hs delete mode 100644 compiler/utils/UniqSet.hs (limited to 'compiler') diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 13beb050af..4c61779602 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -313,12 +313,12 @@ import GHC.Iface.Load ( loadSysInterface ) import TcRnTypes import GHC.Core.Predicate import GHC.Driver.Packages -import NameSet -import RdrName +import GHC.Types.Name.Set +import GHC.Types.Name.Reader import GHC.Hs import GHC.Core.Type hiding( typeKind ) import TcType -import Id +import GHC.Types.Id import TysPrim ( alphaTyVars ) import GHC.Core.TyCon import GHC.Core.TyCo.Ppr ( pprForAll ) @@ -327,9 +327,9 @@ import GHC.Core.DataCon import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts ) import GHC.Core.InstEnv -import Name hiding ( varName ) -import Avail -import SrcLoc +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Avail +import GHC.Types.SrcLoc import GHC.Core import GHC.Iface.Tidy import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename ) @@ -340,8 +340,8 @@ import GHC.Driver.Session hiding (WarnReason(..)) import GHC.Driver.Ways import SysTools import SysTools.BaseDir -import Annotations -import Module +import GHC.Types.Annotations +import GHC.Types.Module import Panic import GHC.Platform import Bag ( listToBag ) @@ -350,13 +350,13 @@ import MonadUtils import Util import StringBuffer import Outputable -import BasicTypes +import GHC.Types.Basic import FastString import qualified Parser import Lexer import ApiAnnotation import qualified GHC.LanguageExtensions as LangExt -import NameEnv +import GHC.Types.Name.Env import TcRnDriver import Inst import FamInst diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index 264dcdf980..f957215d38 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -24,9 +24,9 @@ import GHCi.RemoteTypes import GHC.Runtime.Interpreter import GHC.Driver.Types -import Name -import NameSet -import Literal +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Literal import GHC.Core.TyCon import FastString import GHC.StgToCmm.Layout ( ArgRep(..) ) @@ -35,8 +35,8 @@ import GHC.Driver.Session import Outputable import GHC.Platform import Util -import Unique -import UniqDSet +import GHC.Types.Unique +import GHC.Types.Unique.DSet -- From iserv import SizedSeq diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs index f5082717f3..93fc4970c4 100644 --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -15,8 +15,8 @@ import GHC.ByteCode.Types import GHC.Runtime.Interpreter import GHC.Driver.Session import GHC.Driver.Types -import Name ( Name, getName ) -import NameEnv +import GHC.Types.Name ( Name, getName ) +import GHC.Types.Name.Env import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import GHC.Types.RepType diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs index 8643752e2b..be1da0a2ef 100644 --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -20,13 +20,13 @@ import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Core.Ppr import Outputable import FastString -import Name -import Unique -import Id +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Id import GHC.Core -import Literal +import GHC.Types.Literal import GHC.Core.DataCon -import VarSet +import GHC.Types.Var.Set import PrimOp import GHC.Runtime.Heap.Layout diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs index 1e77b0967e..0e0dc3ca92 100644 --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -28,10 +28,10 @@ import SizedSeq import GHC.Runtime.Interpreter import GHC.ByteCode.Types import GHC.Driver.Types -import Name -import NameEnv +import GHC.Types.Name +import GHC.Types.Name.Env import PrimOp -import Module +import GHC.Types.Module import FastString import Panic import Outputable diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs index 491c4f99f9..dbd5152b5c 100644 --- a/compiler/GHC/ByteCode/Types.hs +++ b/compiler/GHC/ByteCode/Types.hs @@ -16,14 +16,14 @@ module GHC.ByteCode.Types import GhcPrelude import FastString -import Id -import Name -import NameEnv +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env import Outputable import PrimOp import SizedSeq import GHC.Core.Type -import SrcLoc +import GHC.Types.SrcLoc import GHCi.BreakArray import GHCi.RemoteTypes import GHCi.FFI diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index f8cf5789d7..d52c3ad801 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -26,8 +26,8 @@ module GHC.Cmm ( import GhcPrelude -import Id -import CostCentre +import GHC.Types.Id +import GHC.Types.CostCentre import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm.Node diff --git a/compiler/GHC/Cmm/BlockId.hs b/compiler/GHC/Cmm/BlockId.hs index f7f369551b..e458c29902 100644 --- a/compiler/GHC/Cmm/BlockId.hs +++ b/compiler/GHC/Cmm/BlockId.hs @@ -11,10 +11,10 @@ module GHC.Cmm.BlockId import GhcPrelude import GHC.Cmm.CLabel -import IdInfo -import Name -import Unique -import UniqSupply +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Unique.Supply import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel) diff --git a/compiler/GHC/Cmm/BlockId.hs-boot b/compiler/GHC/Cmm/BlockId.hs-boot index 76fd6180a9..4588ce1282 100644 --- a/compiler/GHC/Cmm/BlockId.hs-boot +++ b/compiler/GHC/Cmm/BlockId.hs-boot @@ -1,7 +1,7 @@ module GHC.Cmm.BlockId (BlockId, mkBlockId) where import GHC.Cmm.Dataflow.Label (Label) -import Unique (Unique) +import GHC.Types.Unique (Unique) type BlockId = Label diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index eea71d0ce9..89fa2f8867 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -115,20 +115,20 @@ module GHC.Cmm.CLabel ( import GhcPrelude -import IdInfo -import BasicTypes +import GHC.Types.Id.Info +import GHC.Types.Basic import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId) import GHC.Driver.Packages -import Module -import Name -import Unique +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Unique import PrimOp -import CostCentre +import GHC.Types.CostCentre import Outputable import FastString import GHC.Driver.Session import GHC.Platform -import UniqSet +import GHC.Types.Unique.Set import Util import GHC.Core.Ppr ( {- instances -} ) diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs index 29f019fa15..575e041e73 100644 --- a/compiler/GHC/Cmm/CommonBlockElim.hs +++ b/compiler/GHC/Cmm/CommonBlockElim.hs @@ -25,8 +25,8 @@ import Data.Word import qualified Data.Map as M import Outputable import qualified TrieMap as TM -import UniqFM -import Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique import Control.Arrow (first, second) -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/Dataflow.hs b/compiler/GHC/Cmm/Dataflow.hs index 4f900c32ac..d697240191 100644 --- a/compiler/GHC/Cmm/Dataflow.hs +++ b/compiler/GHC/Cmm/Dataflow.hs @@ -37,7 +37,7 @@ where import GhcPrelude import GHC.Cmm -import UniqSupply +import GHC.Types.Unique.Supply import Data.Array import Data.Maybe diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs index b27ff341e5..70027570d3 100644 --- a/compiler/GHC/Cmm/Dataflow/Label.hs +++ b/compiler/GHC/Cmm/Dataflow/Label.hs @@ -20,7 +20,7 @@ import Outputable -- TODO: This should really just use GHC's Unique and Uniq{Set,FM} import GHC.Cmm.Dataflow.Collections -import Unique (Uniquable(..)) +import GHC.Types.Unique (Uniquable(..)) import TrieMap diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs index 9d2da26b93..2129b3e7aa 100644 --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/compiler/GHC/Cmm/DebugBlock.hs @@ -34,10 +34,10 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Core import FastString ( nilFS, mkFastString ) -import Module +import GHC.Types.Module import Outputable import GHC.Cmm.Ppr.Expr ( pprExpr ) -import SrcLoc +import GHC.Types.SrcLoc import Util ( seqList ) import GHC.Cmm.Dataflow.Block diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs index 3c92c1e61b..1600588e2c 100644 --- a/compiler/GHC/Cmm/Expr.hs +++ b/compiler/GHC/Cmm/Expr.hs @@ -40,12 +40,12 @@ import GHC.Cmm.MachOp import GHC.Cmm.Type import GHC.Driver.Session import Outputable (panic) -import Unique +import GHC.Types.Unique import Data.Set (Set) import qualified Data.Set as Set -import BasicTypes (Alignment, mkAlignment, alignmentOf) +import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf) ----------------------------------------------------------------------------- -- CmmExpr diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs index 413bce3f1e..01fa4dc955 100644 --- a/compiler/GHC/Cmm/Graph.hs +++ b/compiler/GHC/Cmm/Graph.hs @@ -33,10 +33,10 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Driver.Session import FastString -import ForeignCall +import GHC.Types.ForeignCall import OrdList import GHC.Runtime.Heap.Layout (ByteOff) -import UniqSupply +import GHC.Types.Unique.Supply import Util import Panic diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index 7a1bc2d3d1..6da996ad45 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -49,7 +49,7 @@ import Maybes import GHC.Driver.Session import ErrUtils (withTimingSilent) import Panic -import UniqSupply +import GHC.Types.Unique.Supply import MonadUtils import Util import Outputable diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index 274345ab7a..6c8551587b 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -10,15 +10,15 @@ module GHC.Cmm.Info.Build import GhcPrelude hiding (succ) -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow -import Module +import GHC.Types.Module import GHC.Platform import Digraph import GHC.Cmm.CLabel @@ -28,8 +28,8 @@ import GHC.Driver.Session import Maybes import Outputable import GHC.Runtime.Heap.Layout -import UniqSupply -import CostCentre +import GHC.Types.Unique.Supply +import GHC.Types.CostCentre import GHC.StgToCmm.Heap import Control.Monad @@ -41,7 +41,7 @@ import Control.Monad.Trans.State import Control.Monad.Trans.Class import Data.List (unzip4) -import NameSet +import GHC.Types.Name.Set {- Note [SRTs] diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs index ba480a25b7..4cf7fcfdc1 100644 --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -8,14 +8,14 @@ import GhcPrelude hiding ((<*>)) import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation -import BasicTypes +import GHC.Types.Basic import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm.Utils import GHC.Cmm.Graph -import ForeignCall +import GHC.Types.ForeignCall import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint import GHC.Runtime.Heap.Layout @@ -24,9 +24,9 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label -import UniqSupply +import GHC.Types.Unique.Supply import Maybes -import UniqFM +import GHC.Types.Unique.FM import Util import GHC.Platform diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x index be2f676608..a1aebc9fb9 100644 --- a/compiler/GHC/Cmm/Lexer.x +++ b/compiler/GHC/Cmm/Lexer.x @@ -21,8 +21,8 @@ import GHC.Cmm.Expr import Lexer import GHC.Cmm.Monad -import SrcLoc -import UniqFM +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM import StringBuffer import FastString import Ctype diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index c809a99136..98314a8da3 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -33,11 +33,11 @@ import GHC.Cmm.Expr import GHC.Cmm.Switch import GHC.Driver.Session import FastString -import ForeignCall +import GHC.Types.ForeignCall import Outputable import GHC.Runtime.Heap.Layout import GHC.Core (Tickish) -import qualified Unique as U +import qualified GHC.Types.Unique as U import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph @@ -45,7 +45,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import Data.Maybe import Data.List (tails,sortBy) -import Unique (nonDetCmpUnique) +import GHC.Types.Unique (nonDetCmpUnique) import Util diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 6b07af8859..cb34fbc52f 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -234,14 +234,14 @@ import GHC.Cmm.Monad import GHC.Runtime.Heap.Layout import Lexer -import CostCentre -import ForeignCall -import Module +import GHC.Types.CostCentre +import GHC.Types.ForeignCall +import GHC.Types.Module import GHC.Platform -import Literal -import Unique -import UniqFM -import SrcLoc +import GHC.Types.Literal +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.SrcLoc import GHC.Driver.Session import ErrUtils import StringBuffer @@ -249,9 +249,9 @@ import FastString import Panic import Constants import Outputable -import BasicTypes +import GHC.Types.Basic import Bag ( emptyBag, unitBag ) -import Var +import GHC.Types.Var import Control.Monad import Data.Array diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index a2d47b3d48..e730cfda40 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -22,7 +22,7 @@ import GHC.Cmm.LayoutStack import GHC.Cmm.Sink import GHC.Cmm.Dataflow.Collections -import UniqSupply +import GHC.Types.Unique.Supply import GHC.Driver.Session import ErrUtils import GHC.Driver.Types diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs index 324fc8f1b1..d37b960c80 100644 --- a/compiler/GHC/Cmm/Ppr.hs +++ b/compiler/GHC/Cmm/Ppr.hs @@ -54,7 +54,7 @@ import GHC.Cmm.Ppr.Decl import GHC.Cmm.Ppr.Expr import Util -import BasicTypes +import GHC.Types.Basic import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs index 42bd342e86..9017c0eb0c 100644 --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -25,7 +25,7 @@ import Maybes import Control.Monad import Outputable import GHC.Platform -import UniqSupply +import GHC.Types.Unique.Supply import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs index 5dd7fac1d0..3ca4fe9c75 100644 --- a/compiler/GHC/Cmm/Sink.hs +++ b/compiler/GHC/Cmm/Sink.hs @@ -17,8 +17,8 @@ import GHC.Platform.Regs import GHC.Platform import GHC.Driver.Session -import Unique -import UniqFM +import GHC.Types.Unique +import GHC.Types.Unique.FM import qualified Data.IntSet as IntSet import Data.List (partition) diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs index 7df32dd2e8..b098917711 100644 --- a/compiler/GHC/Cmm/Switch/Implement.hs +++ b/compiler/GHC/Cmm/Switch/Implement.hs @@ -12,7 +12,7 @@ import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch -import UniqSupply +import GHC.Types.Unique.Supply import GHC.Driver.Session import MonadUtils (concatMapM) diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index 90cbaffd5f..82cb75a904 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -83,7 +83,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import Outputable import GHC.Driver.Session -import Unique +import GHC.Types.Unique import GHC.Platform.Regs import Data.ByteString (ByteString) diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 5b1847013c..4ccdad826d 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -83,19 +83,19 @@ import GHC.Cmm.Opt ( cmmMachOpFold ) import GHC.Cmm.Ppr import GHC.Cmm.CLabel -import UniqFM -import UniqSupply +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply import GHC.Driver.Session import Util -import BasicTypes ( Alignment ) +import GHC.Types.Basic ( Alignment ) import qualified Pretty import BufWrite import Outputable import FastString -import UniqSet +import GHC.Types.Unique.Set import ErrUtils -import Module +import GHC.Types.Module import Stream (Stream) import qualified Stream diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs index 0665e71433..7ff90e8c40 100644 --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -27,9 +27,9 @@ import GHC.Cmm.Dataflow.Label import GHC.Platform import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform) -import UniqFM +import GHC.Types.Unique.FM import Util -import Unique +import GHC.Types.Unique import Digraph import Outputable diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs index 0995ecab61..dca02b0eb5 100644 --- a/compiler/GHC/CmmToAsm/CFG.hs +++ b/compiler/GHC/CmmToAsm/CFG.hs @@ -60,7 +60,7 @@ import Util import Digraph import Maybes -import Unique +import GHC.Types.Unique import qualified GHC.CmmToAsm.CFG.Dominators as Dom import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet) diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index 9270a308a8..8075bdd27e 100644 --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/compiler/GHC/CmmToAsm/Dwarf.hs @@ -10,11 +10,11 @@ import Config ( cProjectName, cProjectVersion ) import GHC.Core ( Tickish(..) ) import GHC.Cmm.DebugBlock import GHC.Driver.Session -import Module +import GHC.Types.Module import Outputable import GHC.Platform -import Unique -import UniqSupply +import GHC.Types.Unique +import GHC.Types.Unique.Supply import GHC.CmmToAsm.Dwarf.Constants import GHC.CmmToAsm.Dwarf.Types diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs index c54815aff7..eaeb570595 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -31,9 +31,9 @@ import Encoding import FastString import Outputable import GHC.Platform -import Unique +import GHC.Types.Unique import GHC.Platform.Reg -import SrcLoc +import GHC.Types.SrcLoc import Util import GHC.CmmToAsm.Dwarf.Constants diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs index 89e64d5e79..f6e5515705 100644 --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -60,11 +60,11 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel ( CLabel ) import GHC.Cmm.DebugBlock import FastString ( FastString ) -import UniqFM -import UniqSupply -import Unique ( Unique ) +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Types.Unique ( Unique ) import GHC.Driver.Session -import Module +import GHC.Types.Module import Control.Monad ( ap ) diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs index a9668133fc..cb7d82a6c5 100644 --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -70,8 +70,8 @@ import GHC.Cmm.CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, import GHC.Cmm.CLabel ( mkForeignLabel ) -import BasicTypes -import Module +import GHC.Types.Basic +import GHC.Types.Module import Outputable diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index d597051b54..e5177b80b3 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -63,7 +63,7 @@ import Control.Monad ( mapAndUnzipM, when ) import Data.Bits import Data.Word -import BasicTypes +import GHC.Types.Basic import FastString import Util diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs index 26742b5a17..e622d801a8 100644 --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -45,8 +45,8 @@ import FastString import GHC.Cmm.CLabel import Outputable import GHC.Platform -import UniqFM (listToUFM, lookupUFM) -import UniqSupply +import GHC.Types.Unique.FM (listToUFM, lookupUFM) +import GHC.Types.Unique.Supply import Control.Monad (replicateM) import Data.Maybe (fromMaybe) diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index a66d1c2f99..90b85023a2 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -30,7 +30,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm.Ppr.Expr () -- For Outputable instances -import Unique ( pprUniqueAlways, getUnique ) +import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform import FastString import Outputable diff --git a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs index a75040d703..5a48ed28e0 100644 --- a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs +++ b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs @@ -27,7 +27,7 @@ import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.CLabel -import Unique +import GHC.Types.Unique import 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 90f8a62ab7..86675daf5f 100644 --- a/compiler/GHC/CmmToAsm/PPC/Regs.hs +++ b/compiler/GHC/CmmToAsm/PPC/Regs.hs @@ -57,7 +57,7 @@ import GHC.CmmToAsm.Format import GHC.Cmm import GHC.Cmm.CLabel ( CLabel ) -import Unique +import GHC.Types.Unique import GHC.Platform.Regs import Outputable diff --git a/compiler/GHC/CmmToAsm/Reg/Graph.hs b/compiler/GHC/CmmToAsm/Reg/Graph.hs index 7f0cacfcb4..443072b246 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph.hs @@ -23,9 +23,9 @@ import GHC.Platform.Reg import Bag import Outputable import GHC.Platform -import UniqFM -import UniqSet -import UniqSupply +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply import Util (seqList) import GHC.CmmToAsm.CFG diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs index 95fa174415..ba3f825149 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs @@ -24,9 +24,9 @@ module GHC.CmmToAsm.Reg.Graph.Base ( import GhcPrelude -import UniqSet -import UniqFM -import Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique import MonadUtils (concatMapM) diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs index d223137dd0..dd28981261 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs @@ -12,9 +12,9 @@ import GHC.Platform.Reg import GHC.Cmm import Bag import Digraph -import UniqFM -import UniqSet -import UniqSupply +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply -- | Do register coalescing on this top level thing diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs index a0e11433f7..5ae55334a2 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -18,10 +18,10 @@ import GHC.Cmm.Dataflow.Collections import MonadUtils import State -import Unique -import UniqFM -import UniqSet -import UniqSupply +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply import Outputable import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs index 6d14c7194b..ac784582e7 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -37,9 +37,9 @@ import GHC.Platform.Reg import GHC.Cmm.BlockId import GHC.Cmm -import UniqSet -import UniqFM -import Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique import State import Outputable import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs index e3e456e98d..6484a38d79 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs @@ -25,8 +25,8 @@ import GraphBase import GHC.Cmm.Dataflow.Collections (mapLookup) import GHC.Cmm.Dataflow.Label import GHC.Cmm -import UniqFM -import UniqSet +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set import Digraph (flattenSCCs) import Outputable import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs index 2285d3e908..a06a22fa05 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -30,8 +30,8 @@ import GHC.CmmToAsm.Reg.Target import GHC.Platform import Outputable -import UniqFM -import UniqSet +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set import State -- | Holds interesting statistics from the register allocator. diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs index ec7c5ad13e..4cf3d98eb1 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -15,7 +15,7 @@ import GHC.Platform.Reg import GraphBase -import UniqSet +import GHC.Types.Unique.Set import GHC.Platform import Panic diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs b/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs index 0d4c56ba21..c673c69c1d 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs @@ -18,7 +18,7 @@ module GHC.CmmToAsm.Reg.Graph.X86 ( import GhcPrelude import GHC.CmmToAsm.Reg.Graph.Base (Reg(..), RegSub(..), RegClass(..)) -import UniqSet +import GHC.Types.Unique.Set import qualified Data.Array as A diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs index 155d67c2c2..a093bad83a 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -127,10 +127,10 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm hiding (RegSet) import Digraph -import Unique -import UniqSet -import UniqFM -import UniqSupply +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply import Outputable import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs index 92b3ee19a3..95036adb26 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -25,9 +25,9 @@ import GHC.CmmToAsm.Config import GHC.Platform.Reg import Outputable -import Unique -import UniqFM -import UniqSupply +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply import GHC.Cmm.BlockId diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs index 0874cd0dbf..55735913d4 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -24,9 +24,9 @@ import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import Digraph import Outputable -import Unique -import UniqFM -import UniqSet +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set -- | For a jump instruction at the end of a block, generate fixup code so its -- vregs are in the correct regs for its destination. diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs index 00fcfd91c8..c2477fc18f 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs @@ -22,8 +22,8 @@ where import GhcPrelude -import UniqFM -import Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique -- | Identifier for a stack slot. diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs index 5a1e3a4c3f..cf8913e211 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs @@ -50,8 +50,8 @@ import GHC.Platform.Reg import GHC.Cmm.BlockId import GHC.Platform -import Unique -import UniqSupply +import GHC.Types.Unique +import GHC.Types.Unique.Supply import Control.Monad (ap) diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs index 1176b220a3..84acc3a417 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs @@ -12,7 +12,7 @@ import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr -import UniqFM +import GHC.Types.Unique.FM import Outputable import State diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs index d1c4c8f498..5f5d4c8ff3 100644 --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -53,9 +53,9 @@ import Digraph import MonadUtils import Outputable import GHC.Platform -import UniqSet -import UniqFM -import UniqSupply +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply import Bag import State diff --git a/compiler/GHC/CmmToAsm/Reg/Target.hs b/compiler/GHC/CmmToAsm/Reg/Target.hs index a45d70c826..183d329790 100644 --- a/compiler/GHC/CmmToAsm/Reg/Target.hs +++ b/compiler/GHC/CmmToAsm/Reg/Target.hs @@ -28,7 +28,7 @@ import GHC.Platform.Reg.Class import GHC.CmmToAsm.Format import Outputable -import Unique +import GHC.Types.Unique import GHC.Platform import qualified GHC.CmmToAsm.X86.Regs as X86 diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs index 67177ea0c6..ec7d59fe02 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -52,7 +52,7 @@ import GHC.Cmm.CLabel import GHC.CmmToAsm.CPrim -- The rest: -import BasicTypes +import GHC.Types.Basic import GHC.Driver.Session import FastString import OrdList diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs index 566b23c1d6..a65ac03458 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs @@ -45,7 +45,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections -import Unique ( pprUniqueAlways ) +import GHC.Types.Unique ( pprUniqueAlways ) import Outputable import GHC.Platform import FastString diff --git a/compiler/GHC/CmmToAsm/SPARC/Regs.hs b/compiler/GHC/CmmToAsm/SPARC/Regs.hs index ba22470912..d6d5d87bf6 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Regs.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Regs.hs @@ -39,7 +39,7 @@ import GHC.Platform.Reg import GHC.Platform.Reg.Class import GHC.CmmToAsm.Format -import Unique +import GHC.Types.Unique import Outputable {- diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index deabf01425..1a22fc27f0 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -65,9 +65,9 @@ import GHC.Platform.Reg import GHC.Platform -- Our intermediate code: -import BasicTypes +import GHC.Types.Basic import GHC.Cmm.BlockId -import Module ( primUnitId ) +import GHC.Types.Module ( primUnitId ) import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm @@ -77,16 +77,16 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel import GHC.Core ( Tickish(..) ) -import SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) -- The rest: -import ForeignCall ( CCallConv(..) ) +import GHC.Types.ForeignCall ( CCallConv(..) ) import OrdList import Outputable import FastString import GHC.Driver.Session import Util -import UniqSupply ( getUniqueM ) +import GHC.Types.Unique.Supply ( getUniqueM ) import Control.Monad import Data.Bits diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs index 71ee322516..846ef9b72f 100644 --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -38,11 +38,11 @@ import FastString import Outputable import GHC.Platform -import BasicTypes (Alignment) +import GHC.Types.Basic (Alignment) import GHC.Cmm.CLabel -import UniqSet -import Unique -import UniqSupply +import GHC.Types.Unique.Set +import GHC.Types.Unique +import GHC.Types.Unique.Supply import GHC.Cmm.DebugBlock (UnwindTable) import Control.Monad diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs index 0dfd394d8e..357e24a9cc 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -36,12 +36,12 @@ import GHC.CmmToAsm.Ppr import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import BasicTypes (Alignment, mkAlignment, alignmentBytes) +import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Driver.Session import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import Unique ( pprUniqueAlways ) +import GHC.Types.Unique ( pprUniqueAlways ) import GHC.Platform import FastString import Outputable diff --git a/compiler/GHC/CmmToAsm/X86/RegInfo.hs b/compiler/GHC/CmmToAsm/X86/RegInfo.hs index 597efe1c3e..5b2464c415 100644 --- a/compiler/GHC/CmmToAsm/X86/RegInfo.hs +++ b/compiler/GHC/CmmToAsm/X86/RegInfo.hs @@ -15,9 +15,9 @@ import GHC.Platform.Reg import Outputable import GHC.Platform -import Unique +import GHC.Types.Unique -import UniqFM +import GHC.Types.Unique.FM import GHC.CmmToAsm.X86.Regs diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index 71b0793057..8b130afc7c 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -30,7 +30,7 @@ import GhcPrelude import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import ForeignCall +import GHC.Types.ForeignCall import GHC.Cmm hiding (pprBBlock) import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Cmm.Dataflow.Block @@ -45,9 +45,9 @@ import GHC.Driver.Session import FastString import Outputable import GHC.Platform -import UniqSet -import UniqFM -import Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Unique import Util -- The rest diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index b16e4cd00b..981535e993 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -54,11 +54,11 @@ import GHC.Cmm hiding ( succ ) import GHC.Cmm.Utils (regsOverlap) import Outputable as Outp import GHC.Platform -import UniqFM -import Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique import BufWrite ( BufHandle ) -import UniqSet -import UniqSupply +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply import ErrUtils import qualified Stream diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs index a3f40ce306..7b3d198fa9 100644 --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -27,13 +27,13 @@ import GHC.Cmm.Dataflow.Collections import GHC.Driver.Session import FastString -import ForeignCall +import GHC.Types.ForeignCall import Outputable hiding (panic, pprPanic) import qualified Outputable import GHC.Platform import OrdList -import UniqSupply -import Unique +import GHC.Types.Unique.Supply +import GHC.Types.Unique import Util import Control.Monad.Trans.Class diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs index f4540c212c..fea3d351fa 100644 --- a/compiler/GHC/CmmToLlvm/Ppr.hs +++ b/compiler/GHC/CmmToLlvm/Ppr.hs @@ -20,7 +20,7 @@ import GHC.Cmm import FastString import Outputable -import Unique +import GHC.Types.Unique -- ---------------------------------------------------------------------------- -- * Top level diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs index 82a4ae18e2..6e9be62937 100644 --- a/compiler/GHC/CmmToLlvm/Regs.hs +++ b/compiler/GHC/CmmToLlvm/Regs.hs @@ -19,7 +19,7 @@ import GHC.Cmm.Expr import GHC.Platform import FastString import Outputable ( panic ) -import Unique +import GHC.Types.Unique -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: Platform -> GlobalReg -> LlvmVar diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 931fa5ae86..8c354b5298 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -102,22 +102,22 @@ module GHC.Core ( import GhcPrelude import GHC.Platform -import CostCentre -import VarEnv( InScopeSet ) -import Var +import GHC.Types.CostCentre +import GHC.Types.Var.Env( InScopeSet ) +import GHC.Types.Var import GHC.Core.Type import GHC.Core.Coercion -import Name -import NameSet -import NameEnv( NameEnv, emptyNameEnv ) -import Literal +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env( NameEnv, emptyNameEnv ) +import GHC.Types.Literal import GHC.Core.DataCon -import Module -import BasicTypes +import GHC.Types.Module +import GHC.Types.Basic import Outputable import Util -import UniqSet -import SrcLoc ( RealSrcSpan, containsSpan ) +import GHC.Types.Unique.Set +import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) import Binary import Data.Data hiding (TyCon) diff --git a/compiler/GHC/Core/Arity.hs b/compiler/GHC/Core/Arity.hs index df16701396..23e2eaf734 100644 --- a/compiler/GHC/Core/Arity.hs +++ b/compiler/GHC/Core/Arity.hs @@ -27,16 +27,16 @@ import GHC.Core import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Subst -import Demand -import Var -import VarEnv -import Id +import GHC.Types.Demand +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Id import GHC.Core.Type as Type import GHC.Core.TyCon ( initRecTc, checkRecTc ) import GHC.Core.Predicate ( isDictTy ) import GHC.Core.Coercion as Coercion -import BasicTypes -import Unique +import GHC.Types.Basic +import GHC.Types.Unique import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) import Outputable import FastString diff --git a/compiler/GHC/Core/Class.hs b/compiler/GHC/Core/Class.hs index 5020ce6617..454f7015dd 100644 --- a/compiler/GHC/Core/Class.hs +++ b/compiler/GHC/Core/Class.hs @@ -28,12 +28,12 @@ import GhcPrelude import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) -import Var -import Name -import BasicTypes -import Unique +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.Unique import Util -import SrcLoc +import GHC.Types.SrcLoc import Outputable import BooleanFormula (BooleanFormula, mkTrue) diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 06dfa2e02b..06de44f65b 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -132,21 +132,21 @@ import GHC.Core.TyCo.Tidy import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -import Var -import VarEnv -import VarSet -import Name hiding ( varName ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name hiding ( varName ) import Util -import BasicTypes +import GHC.Types.Basic import Outputable -import Unique +import GHC.Types.Unique import Pair -import SrcLoc +import GHC.Types.SrcLoc import PrelNames import TysPrim import ListSetOps import Maybes -import UniqFM +import GHC.Types.Unique.FM import Control.Monad (foldM, zipWithM) import Data.Function ( on ) diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot index 8354cf1ad4..8a10e09268 100644 --- a/compiler/GHC/Core/Coercion.hs-boot +++ b/compiler/GHC/Core/Coercion.hs-boot @@ -7,9 +7,9 @@ import GhcPrelude import {-# SOURCE #-} GHC.Core.TyCo.Rep import {-# SOURCE #-} GHC.Core.TyCon -import BasicTypes ( LeftOrRight ) +import GHC.Types.Basic ( LeftOrRight ) import GHC.Core.Coercion.Axiom -import Var +import GHC.Types.Var import Pair import Util diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs index b2a66033ac..9b8fb6e067 100644 --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -36,15 +36,15 @@ import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) import Outputable import FastString -import Name -import Unique -import Var +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Var import Util import Binary import Pair -import BasicTypes +import GHC.Types.Basic import Data.Typeable ( Typeable ) -import SrcLoc +import GHC.Types.SrcLoc import qualified Data.Data as Data import Data.Array import Data.List ( mapAccumL ) diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index 685d3a278c..c5de884963 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -16,8 +16,8 @@ import GHC.Core.Type as Type hiding( substTyVarBndr, substTy ) import TcType ( exactTyCoVarsOfType ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -import VarSet -import VarEnv +import GHC.Types.Var.Set +import GHC.Types.Var.Env import Outputable import GHC.Core.FamInstEnv ( flattenTys ) import Pair diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs index 14e859acd6..0d538af40a 100644 --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -31,12 +31,12 @@ import GhcPrelude import GHC.Core.DataCon import GHC.Core.PatSyn import Outputable -import Unique +import GHC.Types.Unique import Util -import Name -import BasicTypes +import GHC.Types.Name +import GHC.Types.Basic import GHC.Core.TyCo.Rep (Type, ThetaType) -import Var +import GHC.Types.Var import GHC.Core.Type(mkTyConApp) import qualified Data.Data as Data @@ -69,7 +69,7 @@ eqConLike x y = getUnique x == getUnique y -- There used to be an Ord ConLike instance here that used Unique for ordering. -- It was intentionally removed to prevent determinism problems. --- See Note [Unique Determinism] in Unique. +-- See Note [Unique Determinism] in GHC.Types.Unique. instance Uniquable ConLike where getUnique (RealDataCon dc) = getUnique dc diff --git a/compiler/GHC/Core/ConLike.hs-boot b/compiler/GHC/Core/ConLike.hs-boot index 8b007a2e0d..0a6e732d88 100644 --- a/compiler/GHC/Core/ConLike.hs-boot +++ b/compiler/GHC/Core/ConLike.hs-boot @@ -1,7 +1,7 @@ module GHC.Core.ConLike where import {-# SOURCE #-} GHC.Core.DataCon (DataCon) import {-# SOURCE #-} GHC.Core.PatSyn (PatSyn) -import Name ( Name ) +import GHC.Types.Name ( Name ) data ConLike = RealDataCon DataCon | PatSynCon PatSyn diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 5b3501b3a9..13470c93af 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -63,25 +63,25 @@ module GHC.Core.DataCon ( import GhcPrelude -import {-# SOURCE #-} MkId( DataConBoxer ) +import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) import GHC.Core.Type as Type import GHC.Core.Coercion import GHC.Core.Unify import GHC.Core.TyCon -import FieldLabel +import GHC.Types.FieldLabel import GHC.Core.Class -import Name +import GHC.Types.Name import PrelNames import GHC.Core.Predicate -import Var +import GHC.Types.Var import Outputable import Util -import BasicTypes +import GHC.Types.Basic import FastString -import Module +import GHC.Types.Module import Binary -import UniqSet -import Unique( mkAlphaTyVarUnique ) +import GHC.Types.Unique.Set +import GHC.Types.Unique( mkAlphaTyVarUnique ) import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB @@ -204,7 +204,7 @@ Note [Data constructor workers and wrappers] Note [The need for a wrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Why might the wrapper have anything to do? The full story is -in wrapper_reqd in MkId.mkDataConRep. +in wrapper_reqd in GHC.Types.Id.Make.mkDataConRep. * Unboxing strict fields (with -funbox-strict-fields) data T = MkT !(Int,Int) @@ -614,7 +614,7 @@ data DataConRep -- and *including* all evidence args , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys - -- See also Note [Data-con worker strictness] in MkId.hs + -- See also Note [Data-con worker strictness] in GHC.Types.Id.Make , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) -- about the original arguments; 1-1 with orig_arg_tys @@ -634,7 +634,7 @@ data DataConRep -- emit a warning (in checkValidDataCon) and treat it like -- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ data HsSrcBang = - HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes + HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.Basic SrcUnpackedness SrcStrictness deriving Data.Data @@ -740,7 +740,7 @@ Terminology: * However, if T was defined in an imported module, the importing module must follow the decisions made in the original module, regardless of the flag settings in the importing module. - Also see Note [Bangs on imported data constructors] in MkId + Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make * The dcr_bangs field of the dcRep field records the [HsImplBang] If T was defined in this module, Without -O the dcr_bangs might be diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot index 0d8957ea60..ab83a75117 100644 --- a/compiler/GHC/Core/DataCon.hs-boot +++ b/compiler/GHC/Core/DataCon.hs-boot @@ -1,13 +1,13 @@ module GHC.Core.DataCon where import GhcPrelude -import Var( TyVar, TyCoVar, TyVarBinder ) -import Name( Name, NamedThing ) +import GHC.Types.Var( TyVar, TyCoVar, TyVarBinder ) +import GHC.Types.Name( Name, NamedThing ) import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) -import FieldLabel ( FieldLabel ) -import Unique ( Uniquable ) +import GHC.Types.FieldLabel ( FieldLabel ) +import GHC.Types.Unique ( Uniquable ) import Outputable ( Outputable, OutputableBndr ) -import BasicTypes (Arity) +import GHC.Types.Basic (Arity) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType ) data DataCon diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index 31c10045d6..67577bcd9b 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -62,14 +62,14 @@ module GHC.Core.FVs ( import GhcPrelude import GHC.Core -import Id -import IdInfo -import NameSet -import UniqSet -import Unique (Uniquable (..)) -import Name -import VarSet -import Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name.Set +import GHC.Types.Unique.Set +import GHC.Types.Unique (Uniquable (..)) +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Var import GHC.Core.Type import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs @@ -79,7 +79,7 @@ import GHC.Core.FamInstEnv import TysPrim( funTyConName ) import Maybes( orElse ) import Util -import BasicTypes( Activation ) +import GHC.Types.Basic( Activation ) import Outputable import FV diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 1343544612..8ac78035bd 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -49,17 +49,17 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Coercion.Axiom -import VarSet -import VarEnv -import Name -import UniqDFM +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.Core.Map -import Unique +import GHC.Types.Unique import Util -import Var -import SrcLoc +import GHC.Types.Var +import GHC.Types.SrcLoc import FastString import Control.Monad import Data.List( mapAccumL ) diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index 51c1db1b25..7fcea8433e 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -36,19 +36,19 @@ import GhcPrelude import TcType -- InstEnv is really part of the type checker, -- and depends on TcType in many ways import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) -import Module +import GHC.Types.Module import GHC.Core.Class -import Var -import VarSet -import Name -import NameSet +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Set import GHC.Core.Unify import Outputable import ErrUtils -import BasicTypes -import UniqDFM +import GHC.Types.Basic +import GHC.Types.Unique.DFM import Util -import Id +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 47a0a9cd2d..86c7ebdeea 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -31,22 +31,22 @@ import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats ) import GHC.Core.Op.Monad import Bag -import Literal +import GHC.Types.Literal import GHC.Core.DataCon import TysWiredIn import TysPrim import TcType ( isFloatingTy ) -import Var -import VarEnv -import VarSet -import UniqSet( nonDetEltsUniqSet ) -import Name -import Id -import IdInfo +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set( nonDetEltsUniqSet ) +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core.Ppr import ErrUtils import GHC.Core.Coercion -import SrcLoc +import GHC.Types.SrcLoc import GHC.Core.Type as Type import GHC.Types.RepType import GHC.Core.TyCo.Rep -- checks validity of types/coercions @@ -55,7 +55,7 @@ import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr ( pprTyVar ) import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom -import BasicTypes +import GHC.Types.Basic import ErrUtils as Err import ListSetOps import PrelNames @@ -65,7 +65,7 @@ import Util import GHC.Core.InstEnv ( instanceDFunId ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Arity ( typeArity ) -import Demand ( splitStrictSig, isBotDiv ) +import GHC.Types.Demand ( splitStrictSig, isBotDiv ) import GHC.Driver.Types import GHC.Driver.Session diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index d1fe1b0aa1..b3622a7644 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -56,31 +56,31 @@ module GHC.Core.Make ( import GhcPrelude -import Id -import Var ( EvVar, setTyVarUnique ) +import GHC.Types.Id +import GHC.Types.Var ( EvVar, setTyVarUnique ) import GHC.Core import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) -import Literal +import GHC.Types.Literal import GHC.Driver.Types import GHC.Platform import TysWiredIn import PrelNames -import GHC.Hs.Utils ( mkChunkified, chunkify ) +import GHC.Hs.Utils ( mkChunkified, chunkify ) import GHC.Core.Type import GHC.Core.Coercion ( isCoVar ) import GHC.Core.DataCon ( DataCon, dataConWorkId ) import TysPrim -import IdInfo -import Demand -import Cpr -import Name hiding ( varName ) +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Name hiding ( varName ) import Outputable import FastString -import UniqSupply -import BasicTypes +import GHC.Types.Unique.Supply +import GHC.Types.Basic import Util import Data.List @@ -101,7 +101,7 @@ sortQuantVars :: [Var] -> [Var] -- and then other Ids -- It is a deterministic sort, meaining it doesn't look at the values of -- Uniques. For explanation why it's important See Note [Unique Determinism] --- in Unique. +-- in GHC.Types.Unique. sortQuantVars vs = sorted_tcvs ++ ids where (tcvs, ids) = partition (isTyVar <||> isCoVar) vs diff --git a/compiler/GHC/Core/Map.hs b/compiler/GHC/Core/Map.hs index c3e765ff2b..bb4eeb0fff 100644 --- a/compiler/GHC/Core/Map.hs +++ b/compiler/GHC/Core/Map.hs @@ -42,17 +42,17 @@ import GhcPrelude import TrieMap import GHC.Core import GHC.Core.Coercion -import Name +import GHC.Types.Name import GHC.Core.Type import GHC.Core.TyCo.Rep -import Var +import GHC.Types.Var import FastString(FastString) import Util import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import VarEnv -import NameEnv +import GHC.Types.Var.Env +import GHC.Types.Name.Env import Outputable import Control.Monad( (>=>) ) diff --git a/compiler/GHC/Core/Op/CSE.hs b/compiler/GHC/Core/Op/CSE.hs index dc93dacf07..790e9b97d3 100644 --- a/compiler/GHC/Core/Op/CSE.hs +++ b/compiler/GHC/Core/Op/CSE.hs @@ -16,9 +16,9 @@ module GHC.Core.Op.CSE (cseProgram, cseOneExpr) where import GhcPrelude import GHC.Core.Subst -import Var ( Var ) -import VarEnv ( mkInScopeSet ) -import Id ( Id, idType, idHasRules +import GHC.Types.Var ( Var ) +import GHC.Types.Var.Env ( mkInScopeSet ) +import GHC.Types.Id ( Id, idType, idHasRules , idInlineActivation, setInlineActivation , zapIdOccInfo, zapIdUsageInfo, idInlinePragma , isJoinId, isJoinId_maybe ) @@ -29,7 +29,7 @@ import GHC.Core.FVs ( exprFreeVars ) import GHC.Core.Type ( tyConAppArgs ) import GHC.Core import Outputable -import BasicTypes +import GHC.Types.Basic import GHC.Core.Map import Util ( filterOut, equalLength, debugIsOn ) import Data.List ( mapAccumL ) diff --git a/compiler/GHC/Core/Op/CallArity.hs b/compiler/GHC/Core/Op/CallArity.hs index aaf3372071..2ad5f169d8 100644 --- a/compiler/GHC/Core/Op/CallArity.hs +++ b/compiler/GHC/Core/Op/CallArity.hs @@ -9,17 +9,17 @@ module GHC.Core.Op.CallArity import GhcPrelude -import VarSet -import VarEnv +import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Driver.Session ( DynFlags ) -import BasicTypes +import GHC.Types.Basic import GHC.Core -import Id +import GHC.Types.Id import GHC.Core.Arity ( typeArity ) import GHC.Core.Utils ( exprIsCheap, exprIsTrivial ) import UnVarGraph -import Demand +import GHC.Types.Demand import Util import Control.Arrow ( first, second ) diff --git a/compiler/GHC/Core/Op/ConstantFold.hs b/compiler/GHC/Core/Op/ConstantFold.hs index 126666a509..9b897f8efd 100644 --- a/compiler/GHC/Core/Op/ConstantFold.hs +++ b/compiler/GHC/Core/Op/ConstantFold.hs @@ -28,12 +28,12 @@ where import GhcPrelude -import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId ) +import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId ) import GHC.Core import GHC.Core.Make -import Id -import Literal +import GHC.Types.Id +import GHC.Types.Literal import GHC.Core.SimpleOpt ( exprIsLiteral_maybe ) import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn @@ -47,13 +47,13 @@ import GHC.Core.Utils ( cheapEqExpr, cheapEqExpr', exprIsHNF, exprType , stripTicksTop, stripTicksTopT, mkTicks ) import GHC.Core.Unfold ( exprIsConApp_maybe ) import GHC.Core.Type -import OccName ( occNameFS ) +import GHC.Types.Name.Occurrence ( occNameFS ) import PrelNames import Maybes ( orElse ) -import Name ( Name, nameOccName ) +import GHC.Types.Name ( Name, nameOccName ) import Outputable import FastString -import BasicTypes +import GHC.Types.Basic import GHC.Platform import Util import GHC.Core.Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) @@ -2123,7 +2123,7 @@ tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adju tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the -- literal alternatives remain in Word/Int target ranges - -- (See Note [Word/Int underflow/overflow] in Literal and #13172). + -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172). adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer) -- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x diff --git a/compiler/GHC/Core/Op/CprAnal.hs b/compiler/GHC/Core/Op/CprAnal.hs index c8f7e314e9..8016c2c13d 100644 --- a/compiler/GHC/Core/Op/CprAnal.hs +++ b/compiler/GHC/Core/Op/CprAnal.hs @@ -15,17 +15,17 @@ import GhcPrelude import GHC.Core.Op.WorkWrap.Lib ( deepSplitProductType_maybe ) import GHC.Driver.Session -import Demand -import Cpr +import GHC.Types.Demand +import GHC.Types.Cpr import GHC.Core import GHC.Core.Seq import Outputable -import VarEnv -import BasicTypes +import GHC.Types.Var.Env +import GHC.Types.Basic import Data.List import GHC.Core.DataCon -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram ) import GHC.Core.TyCon import GHC.Core.Type diff --git a/compiler/GHC/Core/Op/DmdAnal.hs b/compiler/GHC/Core/Op/DmdAnal.hs index eb9f277f8a..88e96773ac 100644 --- a/compiler/GHC/Core/Op/DmdAnal.hs +++ b/compiler/GHC/Core/Op/DmdAnal.hs @@ -17,16 +17,16 @@ import GhcPrelude import GHC.Driver.Session import GHC.Core.Op.WorkWrap.Lib ( findTypeShape ) -import Demand -- All of it +import GHC.Types.Demand -- All of it import GHC.Core import GHC.Core.Seq ( seqBinds ) import Outputable -import VarEnv -import BasicTypes +import GHC.Types.Var.Env +import GHC.Types.Basic import Data.List ( mapAccumL ) import GHC.Core.DataCon -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type @@ -37,7 +37,7 @@ import Maybes ( isJust ) import TysWiredIn import TysPrim ( realWorldStatePrimTy ) import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) -import UniqSet +import GHC.Types.Unique.Set {- ************************************************************************ @@ -136,7 +136,7 @@ dmdAnalStar env dmd e , (dmd_ty, e') <- dmdAnal env cd e = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e ) -- The argument 'e' should satisfy the let/app invariant - -- See Note [Analysing with absent demand] in Demand.hs + -- See Note [Analysing with absent demand] in GHC.Types.Demand (postProcessDmdType dmd_shell dmd_ty, e') -- Main Demand Analsysis machinery @@ -389,7 +389,7 @@ Note [Demand on the scrutinee of a product case] When figuring out the demand on the scrutinee of a product case, we use the demands of the case alternative, i.e. id_dmds. But note that these include the demand on the case binder; -see Note [Demand on case-alternative binders] in Demand.hs. +see Note [Demand on case-alternative binders] in GHC.Types.Demand. This is crucial. Example: f x = case x of y { (a,b) -> k y a } If we just take scrut_demand = U(L,A), then we won't pass x to the @@ -730,7 +730,7 @@ trivial RHS (see Note [Demand analysis for trivial right-hand sides]). Because idArity of a function varies independently of its cardinality properties (cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth' -(cf. Note [Understanding DmdType and StrictSig] in Demand). It is unsound to +(cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand). It is unsound to unleash a demand signature when the incoming number of arguments is less than that. See Note [What are demand signatures?] for more details on soundness. @@ -777,7 +777,7 @@ reset or decrease arity. That's an unnecessary dependency, because * idArity is analysis information itself, thus volatile * We already *have* dmdTypeDepth, wo why not just use it to encode the threshold for when to unleash the signature - (cf. Note [Understanding DmdType and StrictSig] in Demand) + (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand) Consider the following expression, for example: @@ -1167,7 +1167,7 @@ findBndrsDmds env dmd_ty bndrs | otherwise = go dmd_ty bs findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) --- See Note [Trimming a demand to a type] in Demand.hs +-- See Note [Trimming a demand to a type] in GHC.Types.Demand findBndrDmd env arg_of_dfun dmd_ty id = (dmd_ty', dmd') where diff --git a/compiler/GHC/Core/Op/Exitify.hs b/compiler/GHC/Core/Op/Exitify.hs index 45f9451787..bc6bca21e9 100644 --- a/compiler/GHC/Core/Op/Exitify.hs +++ b/compiler/GHC/Core/Op/Exitify.hs @@ -36,15 +36,15 @@ Now `t` is no longer in a recursive function, and good things happen! -} import GhcPrelude -import Var -import Id -import IdInfo +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core import GHC.Core.Utils import State -import Unique -import VarSet -import VarEnv +import GHC.Types.Unique +import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Core.FVs import FastString import GHC.Core.Type diff --git a/compiler/GHC/Core/Op/FloatIn.hs b/compiler/GHC/Core/Op/FloatIn.hs index 454ce39dfb..381dd0ddba 100644 --- a/compiler/GHC/Core/Op/FloatIn.hs +++ b/compiler/GHC/Core/Op/FloatIn.hs @@ -28,16 +28,16 @@ import GHC.Core.Make hiding ( wrapFloats ) import GHC.Driver.Types ( ModGuts(..) ) import GHC.Core.Utils import GHC.Core.FVs -import GHC.Core.Op.Monad ( CoreM ) -import Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) -import Var +import GHC.Core.Op.Monad ( CoreM ) +import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) +import GHC.Types.Var import GHC.Core.Type -import VarSet +import GHC.Types.Var.Set import Util import GHC.Driver.Session import Outputable -- import Data.List ( mapAccumL ) -import BasicTypes ( RecFlag(..), isRec ) +import GHC.Types.Basic ( RecFlag(..), isRec ) {- Top-level interface function, @floatInwards@. Note that we do not diff --git a/compiler/GHC/Core/Op/FloatOut.hs b/compiler/GHC/Core/Op/FloatOut.hs index fb47b2b3ed..f4a9649f98 100644 --- a/compiler/GHC/Core/Op/FloatOut.hs +++ b/compiler/GHC/Core/Op/FloatOut.hs @@ -19,11 +19,11 @@ import GHC.Core.Arity ( etaExpand ) import GHC.Core.Op.Monad ( FloatOutSwitches(..) ) import GHC.Driver.Session -import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) -import Id ( Id, idArity, idType, isBottomingId, - isJoinId, isJoinId_maybe ) +import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Types.Id ( Id, idArity, idType, isBottomingId, + isJoinId, isJoinId_maybe ) import GHC.Core.Op.SetLevels -import UniqSupply ( UniqSupply ) +import GHC.Types.Unique.Supply ( UniqSupply ) import Bag import Util import Maybes diff --git a/compiler/GHC/Core/Op/LiberateCase.hs b/compiler/GHC/Core/Op/LiberateCase.hs index 399abf4c67..e753815736 100644 --- a/compiler/GHC/Core/Op/LiberateCase.hs +++ b/compiler/GHC/Core/Op/LiberateCase.hs @@ -15,8 +15,8 @@ import GHC.Driver.Session import GHC.Core import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) import TysWiredIn ( unitDataConId ) -import Id -import VarEnv +import GHC.Types.Id +import GHC.Types.Var.Env import Util ( notNull ) {- diff --git a/compiler/GHC/Core/Op/Monad.hs b/compiler/GHC/Core/Op/Monad.hs index a0a15bba6f..a2c12d638f 100644 --- a/compiler/GHC/Core/Op/Monad.hs +++ b/compiler/GHC/Core/Op/Monad.hs @@ -52,21 +52,21 @@ import GhcPrelude hiding ( read ) import GHC.Core import GHC.Driver.Types -import Module +import GHC.Types.Module import GHC.Driver.Session -import BasicTypes ( CompilerPhase(..) ) -import Annotations +import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Types.Annotations import IOEnv hiding ( liftIO, failM, failWithM ) import qualified IOEnv ( liftIO ) -import Var +import GHC.Types.Var import Outputable import FastString import ErrUtils( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) -import UniqSupply +import GHC.Types.Unique.Supply import MonadUtils -import NameEnv -import SrcLoc +import GHC.Types.Name.Env +import GHC.Types.SrcLoc import Data.Bifunctor ( bimap ) import ErrUtils (dumpAction) import Data.List (intersperse, groupBy, sortBy) diff --git a/compiler/GHC/Core/Op/OccurAnal.hs b/compiler/GHC/Core/Op/OccurAnal.hs index b676be38ae..ac1c665e1e 100644 --- a/compiler/GHC/Core/Op/OccurAnal.hs +++ b/compiler/GHC/Core/Op/OccurAnal.hs @@ -28,24 +28,24 @@ import GHC.Core.FVs import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, stripTicksTopE, mkTicks ) import GHC.Core.Arity ( joinRhsArity ) -import Id -import IdInfo -import Name( localiseName ) -import BasicTypes -import Module( Module ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name( localiseName ) +import GHC.Types.Basic +import GHC.Types.Module( Module ) import GHC.Core.Coercion import GHC.Core.Type -import VarSet -import VarEnv -import Var -import Demand ( argOneShots, argsOneShots ) +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 Unique -import UniqFM -import UniqSet +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set import Util import Outputable import Data.List @@ -1870,7 +1870,7 @@ occAnalApp env (Var fun, args, ticks) n_args = length args fun_uds = mkOneOcc env fun (if n_val_args > 0 then IsInteresting else NotInteresting) n_args is_exp = isExpandableApp fun n_val_args - -- See Note [CONLIKE pragma] in BasicTypes + -- See Note [CONLIKE pragma] in GHC.Types.Basic -- The definition of is_exp should match that in GHC.Core.Op.Simplify.prepareRhs one_shots = argsOneShots (idStrictness fun) guaranteed_val_args diff --git a/compiler/GHC/Core/Op/SetLevels.hs b/compiler/GHC/Core/Op/SetLevels.hs index a3b1fd75b3..0ac49a0c1c 100644 --- a/compiler/GHC/Core/Op/SetLevels.hs +++ b/compiler/GHC/Core/Op/SetLevels.hs @@ -79,28 +79,28 @@ import GHC.Core.FVs -- all of it import GHC.Core.Subst import GHC.Core.Make ( sortQuantVars ) -import Id -import IdInfo -import Var -import VarSet -import UniqSet ( nonDetFoldUniqSet ) -import UniqDSet ( getUniqDSet ) -import VarEnv -import Literal ( litIsTrivial ) -import Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) -import Cpr ( mkCprSig, botCpr ) -import Name ( getOccName, mkSystemVarName ) -import OccName ( occNameString ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Set ( nonDetFoldUniqSet ) +import GHC.Types.Unique.DSet ( getUniqDSet ) +import GHC.Types.Var.Env +import GHC.Types.Literal ( litIsTrivial ) +import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) +import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Name ( getOccName, mkSystemVarName ) +import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet ) -import BasicTypes ( Arity, RecFlag(..), isRec ) +import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) import GHC.Core.DataCon ( dataConOrigResTy ) import TysWiredIn -import UniqSupply +import GHC.Types.Unique.Supply import Util import Outputable import FastString -import UniqDFM +import GHC.Types.Unique.DFM import FV import Data.Maybe import MonadUtils ( mapAccumLM ) @@ -1352,7 +1352,7 @@ lvlLamBndrs env lvl bndrs is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) -- The "probably" part says "don't float things out of a -- probable one-shot lambda" - -- See Note [Computing one-shot info] in Demand.hs + -- See Note [Computing one-shot info] in GHC.Types.Demand lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar] -> (LevelEnv, [LevelledBndr]) @@ -1619,7 +1619,7 @@ abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] -- abstracted in deterministic order, not dependent on the values of -- Uniques. This is achieved by using DVarSets, deterministic free -- variable computation and deterministic sort. - -- See Note [Unique Determinism] in Unique for explanation of why + -- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why -- Uniques are not deterministic. abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs = -- NB: sortQuantVars might not put duplicates next to each other @@ -1667,7 +1667,7 @@ newPolyBndrs dest_lvl add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) - mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.hs + mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id transfer_join_info bndr $ mkSysLocal (mkFastString str) uniq poly_ty where diff --git a/compiler/GHC/Core/Op/Simplify.hs b/compiler/GHC/Core/Op/Simplify.hs index 760beeddb2..5d7d91a37f 100644 --- a/compiler/GHC/Core/Op/Simplify.hs +++ b/compiler/GHC/Core/Op/Simplify.hs @@ -21,13 +21,13 @@ import GHC.Core.Op.Simplify.Env import GHC.Core.Op.Simplify.Utils import GHC.Core.Op.OccurAnal ( occurAnalyseExpr ) import GHC.Core.FamInstEnv ( FamInstEnv ) -import Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 -import Id -import MkId ( seqId ) -import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 +import GHC.Types.Id +import GHC.Types.Id.Make ( seqId ) +import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) import qualified GHC.Core.Make -import IdInfo -import Name ( mkSystemVarName, isExternalName, getOccFS ) +import GHC.Types.Id.Info +import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) import GHC.Core.Coercion hiding ( substCo, substCoVar ) import GHC.Core.Coercion.Opt ( optCoercion ) import GHC.Core.FamInstEnv ( topNormaliseType_maybe ) @@ -37,27 +37,27 @@ import GHC.Core.DataCon , StrictnessMark (..) ) import GHC.Core.Op.Monad ( Tick(..), SimplMode(..) ) import GHC.Core -import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd +import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd , mkClosedStrictSig, topDmd, botDiv ) -import Cpr ( mkCprSig, botCpr ) +import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Core.Ppr ( pprCoreExpr ) import GHC.Core.Unfold import GHC.Core.Utils import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg , joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.Rules ( mkRuleInfo, lookupRule, getRules ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, +import GHC.Types.Basic ( TopLevelFlag(..), isNotTopLevel, isTopLevel, RecFlag(..), Arity ) import MonadUtils ( mapAccumLM, liftIO ) -import Var ( isTyCoVar ) +import GHC.Types.Var ( isTyCoVar ) import Maybes ( orElse ) import Control.Monad import Outputable import FastString import Util import ErrUtils -import Module ( moduleName, pprModuleName ) -import PrimOp ( PrimOp (SeqOp) ) +import GHC.Types.Module ( moduleName, pprModuleName ) +import PrimOp ( PrimOp (SeqOp) ) {- @@ -474,7 +474,7 @@ prepareRhs mode top_lvl occ _ rhs0 = return (is_exp, emptyLetFloats, Var fun) where is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP - -- See Note [CONLIKE pragma] in BasicTypes + -- See Note [CONLIKE pragma] in GHC.Types.Basic -- The definition of is_exp should match that in -- OccurAnal.occAnalApp @@ -2139,7 +2139,7 @@ If you find a match, rewrite it, and apply to 'rhs'. Notice that we can simply drop casts on the fly here, which makes it more likely that a rule will match. -See Note [User-defined RULES for seq] in MkId. +See Note [User-defined RULES for seq] in GHC.Types.Id.Make. Note [Occurrence-analyse after rule firing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2533,7 +2533,7 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont -- 2c. Try the seq rules if -- a) it binds only the case binder -- b) a rule for seq applies - -- See Note [User-defined RULES for seq] in MkId + -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make | is_plain_seq = do { mb_rule <- trySeqRules env scrut rhs cont ; case mb_rule of @@ -2757,7 +2757,7 @@ a case pattern. This is *important*. Consider We really must record that b is already evaluated so that we don't go and re-evaluate it when constructing the result. -See Note [Data-con worker strictness] in MkId.hs +See Note [Data-con worker strictness] in GHC.Types.Id.Make NB: simplLamBndrs preserves this eval info diff --git a/compiler/GHC/Core/Op/Simplify/Driver.hs b/compiler/GHC/Core/Op/Simplify/Driver.hs index b6ec392599..1b7bb0d1e3 100644 --- a/compiler/GHC/Core/Op/Simplify/Driver.hs +++ b/compiler/GHC/Core/Op/Simplify/Driver.hs @@ -21,7 +21,7 @@ import GHC.Core.Rules ( mkRuleBase, unionRuleBase, getRules ) import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Op.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) -import IdInfo +import GHC.Types.Id.Info import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) import GHC.Core.Utils ( mkTicks, stripTicksTop ) import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult, @@ -35,11 +35,11 @@ import qualified ErrUtils as Err import GHC.Core.Op.FloatIn ( floatInwards ) import GHC.Core.Op.FloatOut ( floatOutwards ) import GHC.Core.FamInstEnv -import Id +import GHC.Types.Id import ErrUtils ( withTiming, withTimingD, DumpFormat (..) ) -import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) -import VarSet -import VarEnv +import GHC.Types.Basic ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Core.Op.LiberateCase ( liberateCase ) import GHC.Core.Op.StaticArgs ( doStaticArgs ) import GHC.Core.Op.Specialise ( specProgram) @@ -49,14 +49,14 @@ import GHC.Core.Op.CprAnal ( cprAnalProgram ) import GHC.Core.Op.CallArity ( callArityAnalProgram ) import GHC.Core.Op.Exitify ( exitifyProgram ) import GHC.Core.Op.WorkWrap ( wwTopBinds ) -import SrcLoc +import GHC.Types.SrcLoc import Util -import Module +import GHC.Types.Module import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Runtime.Loader -- ( initializePlugins ) -import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) -import UniqFM +import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) +import GHC.Types.Unique.FM import Outputable import Control.Monad import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Core/Op/Simplify/Env.hs b/compiler/GHC/Core/Op/Simplify/Env.hs index 0e94f734af..47b95da59e 100644 --- a/compiler/GHC/Core/Op/Simplify/Env.hs +++ b/compiler/GHC/Core/Op/Simplify/Env.hs @@ -51,11 +51,11 @@ import GHC.Core.Op.Simplify.Monad import GHC.Core.Op.Monad ( SimplMode(..) ) import GHC.Core import GHC.Core.Utils -import Var -import VarEnv -import VarSet +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set import OrdList -import Id +import GHC.Types.Id as Id import GHC.Core.Make ( mkWildValBinder ) import GHC.Driver.Session ( DynFlags ) import TysWiredIn @@ -63,11 +63,11 @@ import qualified GHC.Core.Type as Type import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) import qualified GHC.Core.Coercion as Coercion import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) -import BasicTypes +import GHC.Types.Basic import MonadUtils import Outputable import Util -import UniqFM ( pprUniqFM ) +import GHC.Types.Unique.FM ( pprUniqFM ) import Data.List (mapAccumL) diff --git a/compiler/GHC/Core/Op/Simplify/Monad.hs b/compiler/GHC/Core/Op/Simplify/Monad.hs index e6b23734c4..d45dd13510 100644 --- a/compiler/GHC/Core/Op/Simplify/Monad.hs +++ b/compiler/GHC/Core/Op/Simplify/Monad.hs @@ -22,14 +22,14 @@ module GHC.Core.Op.Simplify.Monad ( import GhcPrelude -import Var ( Var, isId, mkLocalVar ) -import Name ( mkSystemVarName ) -import Id ( Id, mkSysLocalOrCoVar ) -import IdInfo ( IdDetails(..), vanillaIdInfo, setArityInfo ) +import GHC.Types.Var ( Var, isId, mkLocalVar ) +import GHC.Types.Name ( mkSystemVarName ) +import GHC.Types.Id ( Id, mkSysLocalOrCoVar ) +import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type ( Type, mkLamTypes ) import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Core ( RuleEnv(..) ) -import UniqSupply +import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Core.Op.Monad import Outputable @@ -38,7 +38,7 @@ import MonadUtils import ErrUtils as Err import Util ( count ) import Panic (throwGhcExceptionIO, GhcException (..)) -import BasicTypes ( IntWithInf, treatZeroAsInf, mkIntWithInf ) +import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) import Control.Monad ( ap ) {- diff --git a/compiler/GHC/Core/Op/Simplify/Utils.hs b/compiler/GHC/Core/Op/Simplify/Utils.hs index 5fb9ddcee4..4b85bff280 100644 --- a/compiler/GHC/Core/Op/Simplify/Utils.hs +++ b/compiler/GHC/Core/Op/Simplify/Utils.hs @@ -51,17 +51,17 @@ import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Arity import GHC.Core.Unfold -import Name -import Id -import IdInfo -import Var -import Demand +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var +import GHC.Types.Demand import GHC.Core.Op.Simplify.Monad import GHC.Core.Type hiding( substTy ) import GHC.Core.Coercion hiding( substCo ) import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) -import VarSet -import BasicTypes +import GHC.Types.Var.Set +import GHC.Types.Basic import Util import OrdList ( isNilOL ) import MonadUtils @@ -1801,9 +1801,9 @@ abstractFloats dflags top_lvl main_tvs floats body mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) mk_poly1 tvs_here var = do { uniq <- getUniqueM - ; let poly_name = setNameUnique (idName var) uniq -- Keep same name + ; let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course - poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs + poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id mkLocalId poly_name poly_ty ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } -- In the olden days, it was crucial to copy the occInfo of the original var, diff --git a/compiler/GHC/Core/Op/SpecConstr.hs b/compiler/GHC/Core/Op/SpecConstr.hs index 4522e2d23c..0a72edce8d 100644 --- a/compiler/GHC/Core/Op/SpecConstr.hs +++ b/compiler/GHC/Core/Op/SpecConstr.hs @@ -29,7 +29,7 @@ import GHC.Core.Utils import GHC.Core.Unfold ( couldBeSmallEnoughToInline ) import GHC.Core.FVs ( exprsFreeVarsList ) import GHC.Core.Op.Monad -import Literal ( litIsLifted ) +import GHC.Types.Literal ( litIsLifted ) import GHC.Driver.Types ( ModGuts(..) ) import GHC.Core.Op.WorkWrap.Lib ( isWorkerSmallEnough, mkWorkerArgs ) import GHC.Core.DataCon @@ -37,30 +37,30 @@ import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type hiding ( substTy ) import GHC.Core.TyCon ( tyConName ) -import Id +import GHC.Types.Id import GHC.Core.Ppr ( pprParendExpr ) import GHC.Core.Make ( mkImpossibleExpr ) -import VarEnv -import VarSet -import Name -import BasicTypes +import GHC.Types.Var.Env +import GHC.Types.Var.Set +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 Demand -import Cpr +import GHC.Types.Demand +import GHC.Types.Cpr import GHC.Serialized ( deserializeWithData ) import Util import Pair -import UniqSupply +import GHC.Types.Unique.Supply import Outputable import FastString -import UniqFM +import GHC.Types.Unique.FM import MonadUtils import Control.Monad ( zipWithM ) import Data.List import PrelNames ( specTyConName ) -import Module +import GHC.Types.Module import GHC.Core.TyCon ( TyCon ) import GHC.Exts( SpecConstrAnnotation(..) ) import Data.Ord( comparing ) @@ -2084,7 +2084,7 @@ callToPats env bndr_occs call@(Call _ args con_env) -- lambdas with different argument orders. See -- determinism/simplCore/should_compile/spec-inline-determ.hs -- for an example. For explanation of determinism - -- considerations See Note [Unique Determinism] in Unique. + -- considerations See Note [Unique Determinism] in GHC.Types.Unique. in_scope_vars = getInScopeVars in_scope is_in_scope v = v `elemVarSet` in_scope_vars diff --git a/compiler/GHC/Core/Op/Specialise.hs b/compiler/GHC/Core/Op/Specialise.hs index 250a0f7313..b43bc90ef1 100644 --- a/compiler/GHC/Core/Op/Specialise.hs +++ b/compiler/GHC/Core/Op/Specialise.hs @@ -15,30 +15,30 @@ module GHC.Core.Op.Specialise ( specProgram, specUnfolding ) where import GhcPrelude -import Id +import GHC.Types.Id import TcType hiding( substTy ) import GHC.Core.Type hiding( substTy, extendTvSubstList ) import GHC.Core.Predicate -import Module( Module, HasModule(..) ) +import GHC.Types.Module( Module, HasModule(..) ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Op.Monad import qualified GHC.Core.Subst import GHC.Core.Unfold -import Var ( isLocalVar ) -import VarSet -import VarEnv +import GHC.Types.Var ( isLocalVar ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Core import GHC.Core.Rules import GHC.Core.SimpleOpt ( collectBindersPushingCo ) import GHC.Core.Utils ( exprIsTrivial, mkCast, exprType ) import GHC.Core.FVs import GHC.Core.Arity ( etaExpandToJoinPointRule ) -import UniqSupply -import Name -import MkId ( voidArgId, voidPrimId ) +import GHC.Types.Unique.Supply +import GHC.Types.Name +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import Maybes ( mapMaybe, isJust ) import MonadUtils ( foldlM ) -import BasicTypes +import GHC.Types.Basic import GHC.Driver.Types import Bag import GHC.Driver.Session @@ -46,7 +46,7 @@ import Util import Outputable import FastString import State -import UniqDFM +import GHC.Types.Unique.DFM import GHC.Core.TyCo.Rep (TyCoBinder (..)) import Control.Monad @@ -2129,7 +2129,7 @@ emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv } type CallDetails = DIdEnv CallInfoSet -- The order of specialized binds and rules depends on how we linearize -- CallDetails, so to get determinism we must use a deterministic set here. - -- See Note [Deterministic UniqFM] in UniqDFM + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM data CallInfoSet = CIS Id (Bag CallInfo) -- The list of types and dictionaries is guaranteed to diff --git a/compiler/GHC/Core/Op/StaticArgs.hs b/compiler/GHC/Core/Op/StaticArgs.hs index e550fabfd9..835f1ffbaa 100644 --- a/compiler/GHC/Core/Op/StaticArgs.hs +++ b/compiler/GHC/Core/Op/StaticArgs.hs @@ -53,20 +53,20 @@ module GHC.Core.Op.StaticArgs ( doStaticArgs ) where import GhcPrelude -import Var +import GHC.Types.Var import GHC.Core import GHC.Core.Utils import GHC.Core.Type import GHC.Core.Coercion -import Id -import Name -import VarEnv -import UniqSupply +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var.Env +import GHC.Types.Unique.Supply import Util -import UniqFM -import VarSet -import Unique -import UniqSet +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Types.Unique +import GHC.Types.Unique.Set import Outputable import Data.List (mapAccumL) diff --git a/compiler/GHC/Core/Op/Tidy.hs b/compiler/GHC/Core/Op/Tidy.hs index 758c1daf6c..4759efa0e9 100644 --- a/compiler/GHC/Core/Op/Tidy.hs +++ b/compiler/GHC/Core/Op/Tidy.hs @@ -19,16 +19,16 @@ import GhcPrelude import GHC.Core import GHC.Core.Seq ( seqUnfolding ) -import Id -import IdInfo -import Demand ( zapUsageEnvSig ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand ( zapUsageEnvSig ) import GHC.Core.Type ( tidyType, tidyVarBndr ) import GHC.Core.Coercion ( tidyCo ) -import Var -import VarEnv -import UniqFM -import Name hiding (tidyNameOcc) -import SrcLoc +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import GHC.Types.Name hiding (tidyNameOcc) +import GHC.Types.SrcLoc import Maybes import Data.List @@ -277,7 +277,7 @@ We keep the OneShotInfo because we want it to propagate into the interface. Not all OneShotInfo is determined by a compiler analysis; some is added by a call of GHC.Exts.oneShot, which is then discarded before the end of the optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we -must preserve this info in inlinings. See Note [The oneShot function] in MkId. +must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make. This applies to lambda binders only, hence it is stored in IfaceLamBndr. -} diff --git a/compiler/GHC/Core/Op/WorkWrap.hs b/compiler/GHC/Core/Op/WorkWrap.hs index 241a295899..6abfb4733c 100644 --- a/compiler/GHC/Core/Op/WorkWrap.hs +++ b/compiler/GHC/Core/Op/WorkWrap.hs @@ -14,15 +14,15 @@ import GHC.Core import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) import GHC.Core.Utils ( exprType, exprIsHNF ) import GHC.Core.FVs ( exprFreeVars ) -import Var -import Id -import IdInfo +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core.Type -import UniqSupply -import BasicTypes +import GHC.Types.Unique.Supply +import GHC.Types.Basic import GHC.Driver.Session -import Demand -import Cpr +import GHC.Types.Demand +import GHC.Types.Cpr import GHC.Core.Op.WorkWrap.Lib import Util import Outputable diff --git a/compiler/GHC/Core/Op/WorkWrap/Lib.hs b/compiler/GHC/Core/Op/WorkWrap/Lib.hs index 3ce454e7a2..6245bb9099 100644 --- a/compiler/GHC/Core/Op/WorkWrap/Lib.hs +++ b/compiler/GHC/Core/Op/WorkWrap/Lib.hs @@ -19,28 +19,28 @@ import GhcPrelude import GHC.Core import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) -import Id -import IdInfo ( JoinArity ) +import GHC.Types.Id +import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon -import Demand -import Cpr +import GHC.Types.Demand +import GHC.Types.Cpr import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup , mkCoreApp, mkCoreLet ) -import MkId ( voidArgId, voidPrimId ) +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import TysWiredIn ( tupleDataCon ) import TysPrim ( voidPrimTy ) -import Literal ( absentLiteralOf, rubbishLit ) -import VarEnv ( mkInScopeSet ) -import VarSet ( VarSet ) +import GHC.Types.Literal ( absentLiteralOf, rubbishLit ) +import GHC.Types.Var.Env ( mkInScopeSet ) +import GHC.Types.Var.Set ( VarSet ) import GHC.Core.Type import GHC.Core.Predicate ( isClassPred ) import GHC.Types.RepType ( isVoidTy, typePrimRep ) import GHC.Core.Coercion import GHC.Core.FamInstEnv -import BasicTypes ( Boxity(..) ) +import GHC.Types.Basic ( Boxity(..) ) import GHC.Core.TyCon -import UniqSupply -import Unique +import GHC.Types.Unique.Supply +import GHC.Types.Unique import Maybes import Util import Outputable @@ -957,8 +957,8 @@ deepSplitCprType_maybe _ _ _ = Nothing findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type --- The data type TypeShape is defined in Demand --- See Note [Trimming a demand to a type] in Demand +-- The data type TypeShape is defined in GHC.Types.Demand +-- See Note [Trimming a demand to a type] in GHC.Types.Demand findTypeShape fam_envs ty | Just (tc, tc_args) <- splitTyConApp_maybe ty , Just con <- isDataProductTyCon_maybe tc @@ -1197,7 +1197,7 @@ mk_absent_let dflags fam_envs arg -- determinism, because with different uniques the strings -- will have different lengths and hence different costs for -- the inliner leading to different inlining. - -- See also Note [Unique Determinism] in Unique + -- See also Note [Unique Determinism] in GHC.Types.Unique unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs index 7f84e92e3f..cf2aaf1ad0 100644 --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -28,13 +28,13 @@ import GhcPrelude import GHC.Core.Type import GHC.Core.TyCo.Ppr -import Name +import GHC.Types.Name import Outputable -import Unique +import GHC.Types.Unique import Util -import BasicTypes -import Var -import FieldLabel +import GHC.Types.Basic +import GHC.Types.Var +import GHC.Types.FieldLabel import qualified Data.Data as Data import Data.Function diff --git a/compiler/GHC/Core/PatSyn.hs-boot b/compiler/GHC/Core/PatSyn.hs-boot index 8ce7621450..d4f816d13d 100644 --- a/compiler/GHC/Core/PatSyn.hs-boot +++ b/compiler/GHC/Core/PatSyn.hs-boot @@ -1,9 +1,9 @@ module GHC.Core.PatSyn where -import BasicTypes (Arity) +import GHC.Types.Basic (Arity) import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type) -import Var (TyVar) -import Name (Name) +import GHC.Types.Var (TyVar) +import GHC.Types.Name (Name) data PatSyn diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index 0ab98c3208..df12815e6c 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -21,23 +21,23 @@ import GhcPrelude import GHC.Core import GHC.Core.Stats (exprStats) -import Literal( pprLiteral ) -import Name( pprInfixName, pprPrefixName ) -import Var -import Id -import IdInfo -import Demand -import Cpr +import GHC.Types.Literal( pprLiteral ) +import GHC.Types.Name( pprInfixName, pprPrefixName ) +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.TyCo.Ppr import GHC.Core.Coercion -import BasicTypes +import GHC.Types.Basic import Maybes import Util import Outputable import FastString -import SrcLoc ( pprUserRealSpan ) +import GHC.Types.SrcLoc ( pprUserRealSpan ) {- ************************************************************************ diff --git a/compiler/GHC/Core/Ppr/TyThing.hs b/compiler/GHC/Core/Ppr/TyThing.hs index bf3450c447..6782ba1518 100644 --- a/compiler/GHC/Core/Ppr/TyThing.hs +++ b/compiler/GHC/Core/Ppr/TyThing.hs @@ -29,8 +29,8 @@ import GHC.Driver.Types( tyThingParent_maybe ) import GHC.Iface.Make ( tyThingToIfaceDecl ) import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType ) -import Name -import VarEnv( emptyTidyEnv ) +import GHC.Types.Name +import GHC.Types.Var.Env( emptyTidyEnv ) import Outputable -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs index e84333283d..b57278fba2 100644 --- a/compiler/GHC/Core/Predicate.hs +++ b/compiler/GHC/Core/Predicate.hs @@ -33,7 +33,7 @@ import GhcPrelude import GHC.Core.Type import GHC.Core.Class import GHC.Core.TyCon -import Var +import GHC.Types.Var import GHC.Core.Coercion import PrelNames diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 30b652655d..0b1c0cccb9 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -31,7 +31,7 @@ module GHC.Core.Rules ( import GhcPrelude import GHC.Core -- All of it -import Module ( Module, ModuleSet, elemModuleSet ) +import GHC.Types.Module ( Module, ModuleSet, elemModuleSet ) import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars @@ -47,18 +47,19 @@ import TcType ( tcSplitTyConApp_maybe ) import TysWiredIn ( anyTypeOfKind ) import GHC.Core.Coercion as Coercion import GHC.Core.Op.Tidy ( tidyRules ) -import Id -import IdInfo ( RuleInfo( RuleInfo ) ) -import Var -import VarEnv -import VarSet -import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) -import NameSet -import NameEnv -import UniqFM +import GHC.Types.Id +import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Unique.FM import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) -import BasicTypes -import GHC.Driver.Session hiding (ruleCheck) +import GHC.Types.Basic +import GHC.Driver.Session ( DynFlags, gopt, targetPlatform ) +import GHC.Driver.Flags import Outputable import FastString import Maybes diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 13a0841503..451a6fa4e3 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -13,15 +13,15 @@ module GHC.Core.Seq ( import GhcPrelude import GHC.Core -import IdInfo -import Demand( seqDemand, seqStrictSig ) -import Cpr( seqCprSig ) -import BasicTypes( seqOccInfo ) -import VarSet( seqDVarSet ) -import Var( varType, tyVarKind ) +import GHC.Types.Id.Info +import GHC.Types.Demand( seqDemand, seqStrictSig ) +import GHC.Types.Cpr( seqCprSig ) +import GHC.Types.Basic( seqOccInfo ) +import GHC.Types.Var.Set( seqDVarSet ) +import GHC.Types.Var( varType, tyVarKind ) import GHC.Core.Type( seqType, isTyVar ) import GHC.Core.Coercion( seqCo ) -import Id( Id, idInfo ) +import GHC.Types.Id( Id, idInfo ) -- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the -- compiler diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 3510fcc3ae..eebac97ade 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -32,14 +32,14 @@ import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding ) import GHC.Core.Make ( FloatBind(..) ) import GHC.Core.Ppr ( pprCoreBindings, pprRules ) import GHC.Core.Op.OccurAnal( occurAnalyseExpr, occurAnalysePgm ) -import Literal ( Literal(LitString) ) -import Id -import IdInfo ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) -import Var ( isNonCoVarId ) -import VarSet -import VarEnv +import GHC.Types.Literal ( Literal(LitString) ) +import GHC.Types.Id +import GHC.Types.Id.Info ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) +import GHC.Types.Var ( isNonCoVarId ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Core.DataCon -import Demand( etaExpandStrictSig ) +import GHC.Types.Demand( etaExpandStrictSig ) import GHC.Core.Coercion.Opt ( optCoercion ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) @@ -47,8 +47,8 @@ import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import GHC.Core.TyCon ( tyConArity ) import TysWiredIn import PrelNames -import BasicTypes -import Module ( Module ) +import GHC.Types.Basic +import GHC.Types.Module ( Module ) import ErrUtils import GHC.Driver.Session import Outputable @@ -673,7 +673,7 @@ unfolding. Also see Note [Desugaring coerce as cast] in GHC.HsToCore. However, we don't want to inline 'seq', which happens to also have a compulsory unfolding, so we only do this unfolding only for things -that are always-active. See Note [User-defined RULES for seq] in MkId. +that are always-active. See Note [User-defined RULES for seq] in GHC.Types.Id.Make. Note [Getting the map/coerce RULE to work] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -965,7 +965,7 @@ data ConCont = CC [CoreExpr] Coercion -- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers -- are unfolded late, but we really want to trigger case-of-known-constructor as -- early as possible. See also Note [Activation for data constructor wrappers] --- in MkId. +-- in GHC.Types.Id.Make. -- -- We also return the incoming InScopeSet, augmented with -- the binders from any [FloatBind] that we return diff --git a/compiler/GHC/Core/Stats.hs b/compiler/GHC/Core/Stats.hs index 148255e140..29f2f44df4 100644 --- a/compiler/GHC/Core/Stats.hs +++ b/compiler/GHC/Core/Stats.hs @@ -13,13 +13,13 @@ module GHC.Core.Stats ( import GhcPrelude -import BasicTypes +import GHC.Types.Basic import GHC.Core import Outputable import GHC.Core.Coercion -import Var +import GHC.Types.Var import GHC.Core.Type(Type, typeSize) -import Id (isJoinId) +import GHC.Types.Id (isJoinId) data CoreStats = CS { cs_tm :: !Int -- Terms , cs_ty :: !Int -- Types diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 672786aaa6..e36e4fb289 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -53,13 +53,13 @@ import GHC.Core.Type hiding import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import PrelNames -import VarSet -import VarEnv -import Id -import Name ( Name ) -import Var -import IdInfo -import UniqSupply +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Id +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 diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs index 82d7699ed3..30d16c1faf 100644 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -50,12 +50,12 @@ import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) import Data.Monoid as DM ( Endo(..), All(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon -import Var +import GHC.Types.Var import FV -import UniqFM -import VarSet -import VarEnv +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Types.Var.Env import Util import Panic diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index 3d4c065aba..bc4e9b48e5 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -43,16 +43,16 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs import GHC.Core.Class -import Var +import GHC.Types.Var import GHC.Iface.Type -import VarSet -import VarEnv +import GHC.Types.Var.Set +import GHC.Types.Var.Env import Outputable -import BasicTypes ( PprPrec(..), topPrec, sigPrec, opPrec - , funPrec, appPrec, maybeParen ) +import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec + , funPrec, appPrec, maybeParen ) {- %************************************************************************ @@ -71,7 +71,7 @@ works just by setting the initial context precedence very high. Note that any function which pretty-prints a @Type@ first converts the @Type@ to an @IfaceType@. See Note [IfaceType and pretty-printing] in GHC.Iface.Type. -See Note [Precedence in types] in BasicTypes. +See Note [Precedence in types] in GHC.Types.Basic. -} -------------------------------------------------------- diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 1f2fd6cf19..1f96dd563b 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -80,14 +80,14 @@ import {-# SOURCE #-} GHC.Core.ConLike ( ConLike(..), conLikeName ) -- friends: import GHC.Iface.Type -import Var -import VarSet -import Name hiding ( varName ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Name hiding ( varName ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -- others -import BasicTypes ( LeftOrRight(..), pickLR ) +import GHC.Types.Basic ( LeftOrRight(..), pickLR ) import Outputable import FastString import Util diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot index 2ffc19795c..c7ce05f0a6 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs-boot +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -1,7 +1,7 @@ module GHC.Core.TyCo.Rep where import Data.Data ( Data ) -import {-# SOURCE #-} Var( Var, ArgFlag, AnonArgFlag ) +import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag ) data Type data TyThing diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 14eee30633..a4d0c49b46 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -70,16 +70,16 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr -import Var -import VarSet -import VarEnv +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env import Pair import Util -import UniqSupply -import Unique -import UniqFM -import UniqSet +import GHC.Types.Unique.Supply +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set import Outputable import Data.List (mapAccumL) diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs index 3e41e922cc..f18ee4f132 100644 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -23,9 +23,9 @@ import GhcPrelude import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) -import Name hiding (varName) -import Var -import VarEnv +import GHC.Types.Name hiding (varName) +import GHC.Types.Var +import GHC.Types.Var.Env import Util (seqList) import Data.List (mapAccumL) @@ -59,7 +59,7 @@ tidyVarBndr tidy_env@(occ_env, subst) var avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv -- Seed the occ_env with clashes among the names, see --- Note [Tidying multiple names at once] in OccName +-- Note [Tidying multiple names at once] in GHC.Types.Names.OccName avoidNameClashes tvs (occ_env, subst) = (avoidClashesOccEnv occ_env occs, subst) where diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index e99f840bb9..11fd1cf5a9 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -150,24 +150,24 @@ import {-# SOURCE #-} GHC.Core.DataCon , isUnboxedSumCon ) import Binary -import Var -import VarSet +import GHC.Types.Var +import GHC.Types.Var.Set import GHC.Core.Class -import BasicTypes -import ForeignCall -import Name -import NameEnv +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Name +import GHC.Types.Name.Env import GHC.Core.Coercion.Axiom import PrelNames import Maybes import Outputable import FastStringEnv -import FieldLabel +import GHC.Types.FieldLabel import Constants import Util -import Unique( tyConRepNameUnique, dataConTyRepNameUnique ) -import UniqSet -import Module +import GHC.Types.Unique( tyConRepNameUnique, dataConTyRepNameUnique ) +import GHC.Types.Unique.Set +import GHC.Types.Module import qualified Data.Data as Data @@ -213,7 +213,7 @@ We also support injective type families -- see Note [Injective type families] Note [Data type families] ~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Wrappers for data instance tycons] in MkId.hs +See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make * Data type families are declared thus data family T a :: * diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 3e86e86cf4..03e71ad915 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -223,7 +223,7 @@ module GHC.Core.Type ( import GhcPrelude -import BasicTypes +import GHC.Types.Basic -- We import the representation and primitive functions from GHC.Core.TyCo.Rep. -- Many things are reexported, but not the representation! @@ -234,10 +234,10 @@ import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs -- friends: -import Var -import VarEnv -import VarSet -import UniqSet +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set import GHC.Core.TyCon import TysPrim @@ -245,7 +245,7 @@ import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind , typeSymbolKind, liftedTypeKind , liftedTypeKindTyCon , constraintKind ) -import Name( Name ) +import GHC.Types.Name( Name ) import PrelNames import GHC.Core.Coercion.Axiom import {-# SOURCE #-} GHC.Core.Coercion @@ -265,7 +265,7 @@ import Outputable import FastString import Pair import ListSetOps -import Unique ( nonDetCmpUnique ) +import GHC.Types.Unique ( nonDetCmpUnique ) import Maybes ( orElse ) import Data.Maybe ( isJust ) diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 49006c66b6..411a954428 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -50,23 +50,23 @@ import GHC.Driver.Session import GHC.Core import GHC.Core.Op.OccurAnal ( occurAnalyseExpr_NoBinderSwap ) import GHC.Core.SimpleOpt -import GHC.Core.Arity ( manifestArity ) +import GHC.Core.Arity ( manifestArity ) import GHC.Core.Utils -import Id -import Demand ( isBottomingSig ) +import GHC.Types.Id +import GHC.Types.Demand ( isBottomingSig ) import GHC.Core.DataCon -import Literal +import GHC.Types.Literal import PrimOp -import IdInfo -import BasicTypes ( Arity, InlineSpec(..), inlinePragmaSpec ) +import GHC.Types.Id.Info +import GHC.Types.Basic ( Arity, InlineSpec(..), inlinePragmaSpec ) import GHC.Core.Type import PrelNames import TysPrim ( realWorldStatePrimTy ) import Bag import Util import Outputable -import ForeignCall -import Name +import GHC.Types.ForeignCall +import GHC.Types.Name import ErrUtils import qualified Data.ByteString as BS diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index 10b1a85342..99c206472c 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -28,10 +28,10 @@ module GHC.Core.Unify ( import GhcPrelude -import Var -import VarEnv -import VarSet -import Name( Name ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name( Name ) import GHC.Core.Type hiding ( getTvSubstEnv ) import GHC.Core.Coercion hiding ( getCvSubstEnv ) import GHC.Core.TyCon @@ -42,8 +42,8 @@ import FV( FV, fvVarSet, fvVarList ) import Util import Pair import Outputable -import UniqFM -import UniqSet +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set import Control.Monad import qualified Control.Monad.Fail as MonadFail diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index e10029c988..4663f54b26 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -69,29 +69,29 @@ import GHC.Core import PrelNames ( makeStaticName ) import GHC.Core.Ppr import GHC.Core.FVs( exprFreeVars ) -import Var -import SrcLoc -import VarEnv -import VarSet -import Name -import Literal +import GHC.Types.Var +import GHC.Types.SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Literal import GHC.Core.DataCon import PrimOp -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import PrelNames( absentErrorIdKey ) import GHC.Core.Type as Type import GHC.Core.Predicate import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) import GHC.Core.Coercion import GHC.Core.TyCon -import Unique +import GHC.Types.Unique import Outputable import TysPrim import FastString import Maybes import ListSetOps ( minusList ) -import BasicTypes ( Arity, isConLike ) +import GHC.Types.Basic ( Arity, isConLike ) import Util import Pair import Data.ByteString ( ByteString ) @@ -100,7 +100,7 @@ import Data.List import Data.Ord ( comparing ) import OrdList import qualified Data.Set as Set -import UniqSet +import GHC.Types.Unique.Set {- ************************************************************************ @@ -1332,7 +1332,7 @@ expansion. Specifically: * True of constructor applications (K a b) -* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in BasicTypes. +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. (NB: exprIsCheap might not be true of this) * False of case-expressions. If we have diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index f16d77f782..75a2110e1d 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -21,20 +21,20 @@ import GHC.ByteCode.Types import GHC.Runtime.Interpreter import GHCi.FFI import GHCi.RemoteTypes -import BasicTypes +import GHC.Types.Basic import GHC.Driver.Session import Outputable import GHC.Platform -import Name -import MkId -import Id -import Var ( updateVarType ) -import ForeignCall +import GHC.Types.Name +import GHC.Types.Id.Make +import GHC.Types.Id +import GHC.Types.Var ( updateVarType ) +import GHC.Types.ForeignCall import GHC.Driver.Types import GHC.Core.Utils import GHC.Core import GHC.Core.Ppr -import Literal +import GHC.Types.Literal import PrimOp import GHC.Core.FVs import GHC.Core.Type @@ -42,20 +42,20 @@ import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon import Util -import VarSet +import GHC.Types.Var.Set import TysPrim import GHC.Core.TyCo.Ppr ( pprType ) import ErrUtils -import Unique +import GHC.Types.Unique import FastString import Panic -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) +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 VarEnv +import GHC.Types.Var.Env import PrelNames ( unsafeEqualityProofName ) import Data.List @@ -63,8 +63,8 @@ import Foreign import Control.Monad import Data.Char -import UniqSupply -import Module +import GHC.Types.Unique.Supply +import GHC.Types.Module import Control.Exception import Data.Array diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index ee24c60bee..7b54138925 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -49,29 +49,29 @@ import GhcPrelude import GHC.Iface.Syntax import GHC.Core.DataCon -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) import TysWiredIn ( heqTyCon ) -import MkId ( noinlineIdName ) +import GHC.Types.Id.Make ( noinlineIdName ) import PrelNames -import Name -import BasicTypes +import GHC.Types.Name +import GHC.Types.Basic import GHC.Core.Type import GHC.Core.PatSyn import Outputable import FastString import Util -import Var -import VarEnv -import VarSet +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Tidy ( tidyCo ) -import Demand ( isTopSig ) -import Cpr ( topCprSig ) +import GHC.Types.Demand ( isTopSig ) +import GHC.Types.Cpr ( topCprSig ) import Data.Maybe ( catMaybes ) diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot index 7daa190405..431d2b0aa5 100644 --- a/compiler/GHC/CoreToIface.hs-boot +++ b/compiler/GHC/CoreToIface.hs-boot @@ -3,10 +3,10 @@ module GHC.CoreToIface where import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion ) import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceForAllBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) -import Var ( TyCoVarBinder ) -import VarEnv ( TidyEnv ) +import GHC.Types.Var ( TyCoVarBinder ) +import GHC.Types.Var.Env ( TidyEnv ) import GHC.Core.TyCon ( TyCon ) -import VarSet( VarSet ) +import GHC.Types.Var.Set( VarSet ) -- For GHC.Core.TyCo.Rep toIfaceTypeX :: VarSet -> Type -> IfaceType diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index a866f57b6b..0ebe4a8f90 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -26,27 +26,27 @@ import GHC.Stg.Syntax import GHC.Core.Type import GHC.Types.RepType import GHC.Core.TyCon -import MkId ( coercionTokenId ) -import Id -import IdInfo +import GHC.Types.Id.Make ( coercionTokenId ) +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core.DataCon -import CostCentre -import VarEnv -import Module -import Name ( isExternalName, nameModule_maybe ) -import BasicTypes ( Arity ) +import GHC.Types.CostCentre +import GHC.Types.Var.Env +import GHC.Types.Module +import GHC.Types.Name ( isExternalName, nameModule_maybe ) +import GHC.Types.Basic ( Arity ) import TysWiredIn ( unboxedUnitDataCon, unitDataConId ) -import Literal +import GHC.Types.Literal import Outputable import MonadUtils import FastString import Util import GHC.Driver.Session import GHC.Driver.Ways -import ForeignCall -import Demand ( isUsedOnce ) +import GHC.Types.ForeignCall +import GHC.Types.Demand ( isUsedOnce ) import PrimOp ( PrimCall(..), primOpWrapperId ) -import SrcLoc ( mkGeneralSrcSpan ) +import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import PrelNames ( unsafeEqualityProofName ) import Data.List.NonEmpty (nonEmpty, toList) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index fb46438049..b6a14b4af5 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -24,30 +24,30 @@ import GHC.Core.Op.OccurAnal import GHC.Driver.Types import PrelNames -import MkId ( realWorldPrimId ) +import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Core.Utils import GHC.Core.Arity import GHC.Core.FVs -import GHC.Core.Op.Monad ( CoreToDo(..) ) +import GHC.Core.Op.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here import GHC.Core.Type -import Literal +import GHC.Types.Literal import GHC.Core.Coercion import TcEnv import GHC.Core.TyCon -import Demand -import Var -import VarSet -import VarEnv -import Id -import IdInfo +import GHC.Types.Demand +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.Id.Info import TysWiredIn import GHC.Core.DataCon -import BasicTypes -import Module -import UniqSupply +import GHC.Types.Basic +import GHC.Types.Module +import GHC.Types.Unique.Supply import Maybes import OrdList import ErrUtils @@ -56,12 +56,12 @@ import GHC.Driver.Ways import Util import Outputable import FastString -import Name ( NamedThing(..), nameSrcSpan, isInternalName ) -import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) +import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) +import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits import MonadUtils ( mapAccumLM ) import Control.Monad -import CostCentre ( CostCentre, ccFromThisModule ) +import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S {- @@ -112,7 +112,7 @@ The goal of this pass is to prepare for code generation. We want curried definitions for all of these in case they aren't inlined by some caller. -9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.hs +9. Replace (lazy e) by e. See Note [lazyId magic] in GHC.Types.Id.Make Also replace (noinline e) by e. 10. Convert (LitInteger i t) into the core representation @@ -658,7 +658,7 @@ cvtLitInteger :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr -- representation. Exactly how we do this depends on the -- library that implements Integer. If it's GMP we -- use the S# data constructor for small literals. --- See Note [Integer literals] in Literal +-- See Note [Integer literals] in GHC.Types.Literal cvtLitInteger platform _ (Just sdatacon) i | platformInIntRange platform i -- Special case for small integers = mkConApp sdatacon [Lit (mkLitInt platform i)] @@ -678,7 +678,7 @@ cvtLitInteger platform mk_integer _ i cvtLitNatural :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr -- Here we convert a literal Natural to the low-level -- representation. --- See Note [Natural literals] in Literal +-- See Note [Natural literals] in GHC.Types.Literal cvtLitNatural platform _ (Just sdatacon) i | platformInWordRange platform i -- Special case for small naturals = mkConApp sdatacon [Lit (mkLitWord platform i)] @@ -771,7 +771,7 @@ which happened in #11291, we do /not/ want to turn it into (case bot of {}) realWorldPrimId# because that gives a panic in CoreToStg.myCollectArgs, which expects only variables in function position. But if we are sure to make -runRW# strict (which we do in MkId), this can't happen +runRW# strict (which we do in GHC.Types.Id.Make), this can't happen -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) @@ -899,7 +899,7 @@ cpeApp top_env expr CpeApp arg@(Coercion {}) -> rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss CpeApp arg -> do - let (ss1, ss_rest) -- See Note [lazyId magic] in MkId + let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) (ss1 : ss_rest, False) -> (ss1, ss_rest) @@ -918,7 +918,7 @@ cpeApp top_env expr rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss isLazyExpr :: CoreExpr -> Bool --- See Note [lazyId magic] in MkId +-- See Note [lazyId magic] in GHC.Types.Id.Make isLazyExpr (Cast e _) = isLazyExpr e isLazyExpr (Tick _ e) = isLazyExpr e isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey @@ -1411,7 +1411,7 @@ The solution is CorePrep to have a miniature inlining pass which deals with cases like this. We can then drop the let-binding altogether. Why does the removal of 'lazy' have to occur in CorePrep? -The gory details are in Note [lazyId magic] in MkId, but the +The gory details are in Note [lazyId magic] in GHC.Types.Id.Make, but the main reason is that lazy must appear in unfoldings (optimizer output) and it must prevent call-by-value for catch# (which is implemented by CorePrep.) diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index a82c9c562f..61cac8bb40 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -32,23 +32,23 @@ import GHC.Driver.Monad import GHC.Driver.Session import TcRnMonad import TcRnDriver -import Module +import GHC.Types.Module import GHC.Driver.Types import StringBuffer import FastString import ErrUtils -import SrcLoc +import GHC.Types.SrcLoc import GHC.Driver.Main -import UniqFM -import UniqDFM +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM import Outputable import Maybes import HeaderInfo import GHC.Iface.Recomp import GHC.Driver.Make -import UniqDSet +import GHC.Types.Unique.DSet import PrelNames -import BasicTypes hiding (SuccessFlag(..)) +import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Driver.Finder import Util diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs index 709427ebd0..7a119907da 100644 --- a/compiler/GHC/Driver/Backpack/Syntax.hs +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -20,9 +20,9 @@ import GhcPrelude import GHC.Driver.Phases import GHC.Hs -import SrcLoc +import GHC.Types.SrcLoc import Outputable -import Module +import GHC.Types.Module import UnitInfo {- diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs index 9b71e3d3fb..243831cfc5 100644 --- a/compiler/GHC/Driver/CmdLine.hs +++ b/compiler/GHC/Driver/CmdLine.hs @@ -32,7 +32,7 @@ import Util import Outputable import Panic import Bag -import SrcLoc +import GHC.Types.SrcLoc import Json import Data.Function diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 507311c039..45c40d2c30 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -15,7 +15,7 @@ import GhcPrelude import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) -import UniqSupply ( mkSplitUniqSupply ) +import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) import GHC.Driver.Finder ( mkStubPaths ) import GHC.CmmToC ( writeC ) @@ -30,8 +30,8 @@ import FileCleanup import ErrUtils import Outputable -import Module -import SrcLoc +import GHC.Types.Module +import GHC.Types.SrcLoc import Control.Exception import System.Directory diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs index c7c9c1af1f..a9f0fda13e 100644 --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -35,7 +35,7 @@ module GHC.Driver.Finder ( import GhcPrelude -import Module +import GHC.Types.Module import GHC.Driver.Types import GHC.Driver.Packages import FastString diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index 0fbb10bb89..51ea03dac1 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -39,18 +39,18 @@ import GHC.Hs.Expr import OrdList import TcRnTypes import Bag -import RdrName -import Name -import Id +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Id import GHC.Core import GHCi.RemoteTypes -import SrcLoc +import GHC.Types.SrcLoc import GHC.Core.Type import System.Process -import BasicTypes -import Module +import GHC.Types.Basic +import GHC.Types.Module import GHC.Core.TyCon -import CostCentre +import GHC.Types.CostCentre import GHC.Stg.Syntax import Stream import GHC.Cmm diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 083bfd279a..1b35e34aff 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -88,7 +88,7 @@ import GhcPrelude import Data.Data hiding (Fixity, TyCon) import Data.Maybe ( fromJust ) -import Id +import GHC.Types.Id import GHC.Runtime.Interpreter ( addSptEntry ) import GHCi.RemoteTypes ( ForeignHValue ) import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs ) @@ -96,26 +96,26 @@ import GHC.Runtime.Linker import GHC.Core.Op.Tidy ( tidyExpr ) import GHC.Core.Type ( Type, Kind ) import GHC.Core.Lint ( lintInteractiveExpr ) -import VarEnv ( emptyTidyEnv ) +import GHC.Types.Var.Env ( emptyTidyEnv ) import Panic import GHC.Core.ConLike import ApiAnnotation -import Module +import GHC.Types.Module import GHC.Driver.Packages -import RdrName +import GHC.Types.Name.Reader import GHC.Hs import GHC.Hs.Dump import GHC.Core import StringBuffer import Parser import Lexer -import SrcLoc +import GHC.Types.SrcLoc import TcRnDriver import GHC.IfaceToCore ( typecheckIface ) import TcRnMonad import TcHsSyn ( ZonkFlexi (DefaultFlexi) ) -import NameCache ( initNameCache ) +import GHC.Types.Name.Cache ( initNameCache ) import PrelInfo import GHC.Core.Op.Simplify.Driver import GHC.HsToCore @@ -129,11 +129,11 @@ import GHC.Stg.Syntax import GHC.Stg.FVs ( annTopBindingsFreeVars ) import GHC.Stg.Pipeline ( stg2stg ) import qualified GHC.StgToCmm as StgToCmm ( codeGen ) -import CostCentre -import ProfInit +import GHC.Types.CostCentre +import GHC.Types.CostCentre.Init import GHC.Core.TyCon -import Name -import NameSet +import GHC.Types.Name +import GHC.Types.Name.Set import GHC.Cmm import GHC.Cmm.Parser ( parseCmmFile ) import GHC.Cmm.Info.Build @@ -153,11 +153,11 @@ import GHC.Driver.Session import ErrUtils import Outputable -import NameEnv +import GHC.Types.Name.Env import HscStats ( ppSourceStats ) import GHC.Driver.Types import FastString -import UniqSupply +import GHC.Types.Unique.Supply import Bag import Exception import qualified Stream diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index e1aa392771..051e9d56ce 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -45,31 +45,31 @@ import GHC.Driver.Finder import GHC.Driver.Monad import HeaderInfo import GHC.Driver.Types -import Module +import GHC.Types.Module import GHC.IfaceToCore ( typecheckIface ) import TcRnMonad ( initIfaceCheck ) import GHC.Driver.Main import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) -import BasicTypes +import GHC.Types.Basic import Digraph import Exception ( tryIO, gbracket, gfinally ) import FastString import Maybes ( expectJust ) -import Name +import GHC.Types.Name import MonadUtils ( allM ) import Outputable import Panic -import SrcLoc +import GHC.Types.SrcLoc import StringBuffer -import UniqFM -import UniqDSet +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import TcBackpack import GHC.Driver.Packages -import UniqSet +import GHC.Types.Unique.Set import Util import qualified GHC.LanguageExtensions as LangExt -import NameEnv +import GHC.Types.Name.Env import FileCleanup import Data.Either ( rights, partitionEithers ) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 7b621ca3c4..385b1de791 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -24,12 +24,12 @@ import GHC.Driver.Ways import Util import GHC.Driver.Types import qualified SysTools -import Module +import GHC.Types.Module import Digraph ( SCC(..) ) import GHC.Driver.Finder import Outputable import Panic -import SrcLoc +import GHC.Types.SrcLoc import Data.List import FastString import FileCleanup diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs index e8bed631ff..1f61d5df97 100644 --- a/compiler/GHC/Driver/Packages.hs +++ b/compiler/GHC/Driver/Packages.hs @@ -72,11 +72,11 @@ import GHC.PackageDb import UnitInfo import GHC.Driver.Session import GHC.Driver.Ways -import Name ( Name, nameModule_maybe ) -import UniqFM -import UniqDFM -import UniqSet -import Module +import GHC.Types.Name ( Name, nameModule_maybe ) +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.Platform @@ -995,7 +995,7 @@ pprTrustFlag flag = case flag of -- ----------------------------------------------------------------------------- -- Wired-in packages -- --- See Note [Wired-in packages] in Module +-- See Note [Wired-in packages] in GHC.Types.Module type WiredInUnitId = String type WiredPackagesMap = Map WiredUnitId WiredUnitId @@ -1015,7 +1015,7 @@ findWiredInPackages findWiredInPackages dflags prec_map pkgs vis_map = do -- Now we must find our wired-in packages, and rename them to -- their canonical names (eg. base-1.0 ==> base), as described - -- in Note [Wired-in packages] in Module + -- in Note [Wired-in packages] in GHC.Types.Module let matches :: UnitInfo -> WiredInUnitId -> Bool pc `matches` pid @@ -1119,7 +1119,7 @@ findWiredInPackages dflags prec_map pkgs vis_map = do -- Helper functions for rewiring Module and UnitId. These -- rewrite UnitIds of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in packages] in Module. +-- compiler, as described in Note [Wired-in packages] in GHC.Types.Module. -- -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in PrelNames. diff --git a/compiler/GHC/Driver/Packages.hs-boot b/compiler/GHC/Driver/Packages.hs-boot index 89fb2a1c18..73823c0d3b 100644 --- a/compiler/GHC/Driver/Packages.hs-boot +++ b/compiler/GHC/Driver/Packages.hs-boot @@ -1,7 +1,7 @@ module GHC.Driver.Packages where import GhcPrelude import {-# SOURCE #-} GHC.Driver.Session (DynFlags) -import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId) +import {-# SOURCE #-} GHC.Types.Module(ComponentId, UnitId, InstalledUnitId) data PackageState data UnitInfoMap data PackageDatabase diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 627efeeb41..01e89b5fbe 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -49,15 +49,15 @@ import GHC.Driver.Main import GHC.Driver.Finder import GHC.Driver.Types hiding ( Hsc ) import Outputable -import Module +import GHC.Types.Module import ErrUtils import GHC.Driver.Session import Panic import Util import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) -import BasicTypes ( SuccessFlag(..) ) +import GHC.Types.Basic ( SuccessFlag(..) ) import Maybes ( expectJust ) -import SrcLoc +import GHC.Types.SrcLoc import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import MonadUtils import GHC.Platform @@ -69,7 +69,7 @@ import FileCleanup import Ar import Bag ( unitBag ) import FastString ( mkFastString ) -import GHC.Iface.Make ( mkFullIface ) +import GHC.Iface.Make ( mkFullIface ) import UpdateCafInfos ( updateModDetailsCafInfos ) import Exception diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs index 5831f923ea..6e07924d1e 100644 --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -18,7 +18,7 @@ import Outputable import GHC.Driver.Session import GHC.Driver.Phases import GHC.Driver.Types -import Module +import GHC.Types.Module import FileCleanup (TempFileLifetime) import Control.Monad diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs index 437e68af71..bf2e9fe759 100644 --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -58,7 +58,7 @@ import GHC.Driver.Session import GHC.Driver.Types import GHC.Driver.Monad import GHC.Driver.Phases -import Module ( ModuleName, Module(moduleName)) +import GHC.Types.Module ( ModuleName, Module(moduleName)) import Fingerprint import Data.List (sort) import Outputable (Outputable(..), text, (<+>)) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index d511701ea1..56d53838f6 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -243,7 +243,7 @@ import GhcPrelude import GHC.Platform import GHC.UniqueSubdir (uniqueSubdir) import PlatformConstants -import Module +import GHC.Types.Module import {-# SOURCE #-} GHC.Driver.Plugins import {-# SOURCE #-} GHC.Driver.Hooks import {-# SOURCE #-} PrelNames ( mAIN ) @@ -263,8 +263,8 @@ import Util import Maybes import MonadUtils import qualified Pretty -import SrcLoc -import BasicTypes ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) +import GHC.Types.SrcLoc +import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) import FastString import Fingerprint import FileSettings diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index c2699f23e9..64e031e0f5 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -159,24 +159,24 @@ import GHC.Runtime.Eval.Types ( Resume ) import GHC.Runtime.Interpreter.Types (Interp) import GHC.ForeignSrcLang -import UniqFM +import GHC.Types.Unique.FM import GHC.Hs -import RdrName -import Avail -import Module +import GHC.Types.Name.Reader +import GHC.Types.Avail +import GHC.Types.Module import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) import GHC.Core.FamInstEnv import GHC.Core ( CoreProgram, RuleBase, CoreRule ) -import Name -import NameEnv -import VarSet -import Var -import Id -import IdInfo ( IdDetails(..), RecSelParent(..)) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var.Set +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info ( IdDetails(..), RecSelParent(..)) import GHC.Core.Type import ApiAnnotation ( ApiAnns ) -import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) +import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Coercion.Axiom @@ -193,13 +193,13 @@ import GHC.Driver.Phases ( Phase, HscSource(..), hscSourceString , isHsBootOrSig, isHsigFile ) import qualified GHC.Driver.Phases as Phase -import BasicTypes +import GHC.Types.Basic import GHC.Iface.Syntax import Maybes import Outputable -import SrcLoc -import Unique -import UniqDFM +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.DFM import FastString import StringBuffer ( StringBuffer ) import Fingerprint @@ -207,10 +207,10 @@ import MonadUtils import Bag import Binary import ErrUtils -import NameCache +import GHC.Types.Name.Cache import GHC.Platform import Util -import UniqDSet +import GHC.Types.Unique.DSet import GHC.Serialized ( Serialized ) import qualified GHC.LanguageExtensions as LangExt @@ -1611,7 +1611,7 @@ The Ids bound by previous Stmts in GHCi are currently global. (b) Having an External Name is important because of Note - [GlobalRdrEnv shadowing] in RdrName + [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName (c) Their types are tidied. This is important, because :info may ask to look at them, and :info expects the things it looks up to have diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index 999d59ea7a..98509398aa 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -45,15 +45,15 @@ import GHC.Hs.Lit import GHC.Hs.Extension import GHC.Hs.Pat import GHC.Hs.Types -import BasicTypes ( Fixity, WarningTxt ) +import GHC.Types.Basic ( Fixity, WarningTxt ) import GHC.Hs.Utils import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances -- others: import Outputable -import SrcLoc -import Module ( ModuleName ) +import GHC.Types.SrcLoc +import GHC.Types.Module ( ModuleName ) -- libraries: import Data.Data hiding ( Fixity ) diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 70da7903fc..efd4b7cd95 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -35,11 +35,11 @@ import GHC.Hs.Types import GHC.Core import TcEvidence import GHC.Core.Type -import NameSet -import BasicTypes +import GHC.Types.Name.Set +import GHC.Types.Basic import Outputable -import SrcLoc -import Var +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Var import Bag import FastString import BooleanFormula (LBooleanFormula) @@ -992,7 +992,7 @@ data Sig pass -- For details on above see note [Api annotations] in ApiAnnotation | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | A minimal complete definition pragma -- @@ -1005,7 +1005,7 @@ data Sig pass -- For details on above see note [Api annotations] in ApiAnnotation | MinimalSig (XMinimalSig pass) SourceText (LBooleanFormula (Located (IdP pass))) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | A "set cost centre" pragma for declarations -- @@ -1016,7 +1016,7 @@ data Sig pass -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig (XSCCFunSig pass) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic (Located (IdP pass)) -- Function name (Maybe (Located StringLiteral)) -- | A complete match pragma diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 84a9bb4dca..07cdb82a91 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -104,17 +104,17 @@ import GHC.Hs.Binds import GHC.Hs.Types import GHC.Hs.Doc import GHC.Core.TyCon -import BasicTypes +import GHC.Types.Basic import GHC.Core.Coercion -import ForeignCall +import GHC.Types.ForeignCall import GHC.Hs.Extension -import NameSet +import GHC.Types.Name.Set -- others: import GHC.Core.Class import Outputable import Util -import SrcLoc +import GHC.Types.SrcLoc import GHC.Core.Type import Bag @@ -438,7 +438,7 @@ Plan of attack: to ensure correct module and provenance is set These are the two places that we have to conjure up the magic derived -names. (The actual magic is in OccName.mkWorkerOcc, etc.) +names. (The actual magic is in GHC.Types.Name.Occurrence.mkWorkerOcc, etc.) Default methods ~~~~~~~~~~~~~~~ @@ -2241,7 +2241,7 @@ instance Outputable ForeignExport where -- | Located Rule Declarations type LRuleDecls pass = Located (RuleDecls pass) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | Rule Declarations data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass , rds_src :: SourceText @@ -2260,7 +2260,7 @@ data RuleDecl pass { rd_ext :: XHsRule pass -- ^ After renamer, free-vars from the LHS and RHS , rd_name :: Located (SourceText,RuleName) - -- ^ Note [Pragma source text] in BasicTypes + -- ^ Note [Pragma source text] in GHC.Types.Basic , rd_act :: Activation , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] -- ^ Forall'd type vars @@ -2387,7 +2387,7 @@ We use exported entities for things to deprecate. -- | Located Warning Declarations type LWarnDecls pass = Located (WarnDecls pass) - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic -- | Warning pragma Declarations data WarnDecls pass = Warnings { wd_ext :: XWarnings pass , wd_src :: SourceText @@ -2437,7 +2437,7 @@ type LAnnDecl pass = Located (AnnDecl pass) -- | Annotation Declaration data AnnDecl pass = HsAnnotation (XHsAnnotation pass) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic (AnnProvenance (IdP pass)) (Located (HsExpr pass)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnType' diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 18a820fa6e..7da56b1524 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -28,9 +28,9 @@ import GhcPrelude import Binary import Encoding import FastFunctions -import Name +import GHC.Types.Name import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Data.ByteString (ByteString) import qualified Data.ByteString as BS diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index 71a951a30a..2fe8711570 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -19,16 +19,15 @@ import GhcPrelude import Data.Data hiding (Fixity) import Bag -import BasicTypes +import GHC.Types.Basic import FastString -import NameSet -import Name +import GHC.Types.Name.Set +import GHC.Types.Name import GHC.Core.DataCon -import SrcLoc +import GHC.Types.SrcLoc import GHC.Hs -import OccName hiding (occName) -import Var -import Module +import GHC.Types.Var +import GHC.Types.Module import Outputable import qualified Data.ByteString as B @@ -110,7 +109,7 @@ showAstData b a0 = blankLine $$ showAstData' a0 occName n = braces $ text "OccName: " - <> text (OccName.occNameString n) + <> text (occNameString n) moduleName :: ModuleName -> SDoc moduleName m = braces $ text "ModuleName: " <> ppr m diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 52162a09c8..c34e7eb809 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -38,11 +38,11 @@ import GHC.Hs.Binds -- others: import TcEvidence import GHC.Core -import Name -import NameSet -import BasicTypes +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Basic import GHC.Core.ConLike -import SrcLoc +import GHC.Types.SrcLoc import Util import Outputable import FastString @@ -675,7 +675,7 @@ type instance XXExpr GhcTc = HsWrap HsExpr -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p = HsPragSCC (XSCC p) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic StringLiteral -- "set cost centre" SCC pragma -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, @@ -683,7 +683,7 @@ data HsPragE p -- For details on above see note [Api annotations] in ApiAnnotation | HsPragCore (XCoreAnn p) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic StringLiteral -- hdaume: core annotation -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', @@ -698,12 +698,12 @@ data HsPragE p -- For details on above see note [Api annotations] in ApiAnnotation | HsPragTick -- A pragma introduced tick (XTickPragma p) - SourceText -- Note [Pragma source text] in BasicTypes + SourceText -- Note [Pragma source text] in GHC.Types.Basic (StringLiteral,(Int,Int),(Int,Int)) -- external span for this tick ((SourceText,SourceText),(SourceText,SourceText)) -- Source text for the four integers used in the span. - -- See note [Pragma source text] in BasicTypes + -- See note [Pragma source text] in GHC.Types.Basic | XHsPragE (XXPragE p) diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot index 0fdbf773b2..87a4a2b38e 100644 --- a/compiler/GHC/Hs/Expr.hs-boot +++ b/compiler/GHC/Hs/Expr.hs-boot @@ -10,10 +10,10 @@ module GHC.Hs.Expr where -import SrcLoc ( Located ) +import GHC.Types.SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) -import BasicTypes ( SpliceExplicitFlag(..)) +import GHC.Types.Basic ( SpliceExplicitFlag(..)) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) import Data.Kind ( Type ) diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index 31e6a20f5d..45753eaf47 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -28,11 +28,11 @@ module GHC.Hs.Extension where import GhcPrelude import Data.Data hiding ( Fixity ) -import Name -import RdrName -import Var +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Var import Outputable -import SrcLoc (Located) +import GHC.Types.SrcLoc (Located) import Data.Kind diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 58a310a0c0..aa85a98564 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -18,15 +18,15 @@ module GHC.Hs.ImpExp where import GhcPrelude -import Module ( ModuleName ) -import GHC.Hs.Doc ( HsDocString ) -import OccName ( HasOccName(..), isTcOcc, isSymOcc ) -import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) -import FieldLabel ( FieldLbl(..) ) +import GHC.Types.Module ( ModuleName ) +import GHC.Hs.Doc ( HsDocString ) +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 SrcLoc +import GHC.Types.SrcLoc import GHC.Hs.Extension import Data.Data @@ -80,7 +80,7 @@ data ImportDecl pass = ImportDecl { ideclExt :: XCImportDecl pass, ideclSourceSrc :: SourceText, - -- Note [Pragma source text] in BasicTypes + -- Note [Pragma source text] in GHC.Types.Basic ideclName :: Located ModuleName, -- ^ Module name. ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import @@ -282,7 +282,7 @@ gives rise to IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) -See Note [Representing fields in AvailInfo] in Avail for more details. +See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details. -} ieName :: IE (GhcPass p) -> IdP (GhcPass p) diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index fa538f3089..a0e95c973d 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -22,9 +22,10 @@ module GHC.Hs.Lit where import GhcPrelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr ) -import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, - negateFractionalLit,SourceText(..),pprWithSourceText, - PprPrec(..), topPrec ) +import GHC.Types.Basic + ( IntegralLit(..), FractionalLit(..), negateIntegralLit + , negateFractionalLit, SourceText(..), pprWithSourceText + , PprPrec(..), topPrec ) import GHC.Core.Type import Outputable import FastString @@ -41,7 +42,7 @@ import Data.Data hiding ( Fixity ) ************************************************************************ -} --- Note [Literal source text] in BasicTypes for SourceText fields in +-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- Note [Trees that grow] in GHC.Hs.Extension for the Xxxxx fields in the following -- | Haskell Literal @@ -133,7 +134,7 @@ type instance XOverLit GhcTc = OverLitTc type instance XXOverLit (GhcPass _) = NoExtCon --- Note [Literal source text] in BasicTypes for SourceText fields in +-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- | Overloaded Literal Value data OverLitVal diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 1bddfa2c71..f8505875bf 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -56,19 +56,19 @@ import GHC.Hs.Lit import GHC.Hs.Extension import GHC.Hs.Types import TcEvidence -import BasicTypes +import GHC.Types.Basic -- others: import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Driver.Session ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) ) import TysWiredIn -import Var -import RdrName ( RdrName ) +import GHC.Types.Var +import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon import Outputable import GHC.Core.Type -import SrcLoc +import GHC.Types.SrcLoc import Bag -- collect ev vars from pats import Maybes -- libraries: diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index 354611836c..21f9f38abf 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -78,16 +78,16 @@ import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice ) import GHC.Hs.Extension -import Id ( Id ) -import Name( Name, NamedThing(getName) ) -import RdrName ( RdrName ) +import GHC.Types.Id ( Id ) +import GHC.Types.Name( Name, NamedThing(getName) ) +import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..) ) import TysWiredIn( mkTupleStr ) import GHC.Core.Type import GHC.Hs.Doc -import BasicTypes -import SrcLoc +import GHC.Types.Basic +import GHC.Types.SrcLoc import Outputable import FastString import Maybes( isJust ) @@ -750,7 +750,7 @@ type instance XWildCardTy (GhcPass _) = NoExtField type instance XXType (GhcPass _) = NewHsTypeX --- Note [Literal source text] in BasicTypes for SourceText fields in +-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in -- the following -- | Haskell Type Literal data HsTyLit diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index d7f37dac86..99763d25a3 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -110,20 +110,20 @@ import GHC.Hs.Lit import GHC.Hs.Extension import TcEvidence -import RdrName -import Var +import GHC.Types.Name.Reader +import GHC.Types.Var import GHC.Core.TyCo.Rep import GHC.Core.Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) import TysWiredIn ( unitTy ) import TcType import GHC.Core.DataCon import GHC.Core.ConLike -import Id -import Name -import NameSet hiding ( unitFV ) -import NameEnv -import BasicTypes -import SrcLoc +import GHC.Types.Id +import GHC.Types.Name +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 diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 145b7ade55..16d64ff5ff 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -27,12 +27,12 @@ import GHC.Hs import TcRnTypes import TcRnMonad ( finalSafeMode, fixSafeInstances ) import TcRnDriver ( runTcInteractive ) -import Id -import IdInfo -import Name +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name import GHC.Core.Type import GHC.Core.TyCon ( tyConDataCons ) -import Avail +import GHC.Types.Avail import GHC.Core import GHC.Core.FVs ( exprsSomeFreeVarsList ) import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) @@ -49,18 +49,18 @@ import GHC.Core.Coercion import TysWiredIn import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make -import Module -import NameSet -import NameEnv +import GHC.Types.Module +import GHC.Types.Name.Set +import GHC.Types.Name.Env import GHC.Core.Rules -import BasicTypes +import GHC.Types.Basic import GHC.Core.Op.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) -import VarSet +import GHC.Types.Var.Set import FastString import ErrUtils import Outputable -import SrcLoc +import GHC.Types.SrcLoc import GHC.HsToCore.Coverage import Util import MonadUtils @@ -560,7 +560,7 @@ Note [Patching magic definitions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes need to have access to defined Ids in pure contexts. Usually, we simply "wire in" these entities, as we do for types in TysWiredIn and for Ids -in MkId. See Note [Wired-in Ids] in MkId. +in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make. However, it is sometimes *much* easier to define entities in Haskell, even if we need pure access; note that wiring-in an Id requires all diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 27502bfda4..4d1dab9dc4 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -45,18 +45,18 @@ import GHC.Core.Utils import GHC.Core.Make import GHC.HsToCore.Binds (dsHsWrapper) -import Id +import GHC.Types.Id import GHC.Core.ConLike import TysWiredIn -import BasicTypes +import GHC.Types.Basic import PrelNames import Outputable -import VarSet -import SrcLoc +import GHC.Types.Var.Set +import GHC.Types.SrcLoc import ListSetOps( assocMaybe ) import Data.List import Util -import UniqDSet +import GHC.Types.Unique.DSet data DsCmdEnv = DsCmdEnv { arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 3becf64ca4..8dd04c5095 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -54,24 +54,24 @@ import TcType import GHC.Core.Type import GHC.Core.Coercion import TysWiredIn ( typeNatKind, typeSymbolKind ) -import Id -import MkId(proxyHashId) -import Name -import VarSet +import GHC.Types.Id +import GHC.Types.Id.Make(proxyHashId) +import GHC.Types.Name +import GHC.Types.Var.Set import GHC.Core.Rules -import VarEnv -import Var( EvVar ) +import GHC.Types.Var.Env +import GHC.Types.Var( EvVar ) import Outputable -import Module -import SrcLoc +import GHC.Types.Module +import GHC.Types.SrcLoc import Maybes import OrdList import Bag -import BasicTypes +import GHC.Types.Basic import GHC.Driver.Session import FastString import Util -import UniqSet( nonDetEltsUniqSet ) +import GHC.Types.Unique.Set( nonDetEltsUniqSet ) import MonadUtils import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 7bb1886bff..ba15a8b8e6 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -21,26 +21,26 @@ import GHC.ByteCode.Types import GHC.Stack.CCS import GHC.Core.Type import GHC.Hs -import Module +import GHC.Types.Module as Module import Outputable import GHC.Driver.Session import GHC.Core.ConLike import Control.Monad -import SrcLoc +import GHC.Types.SrcLoc import ErrUtils -import NameSet hiding (FreeVars) -import Name +import GHC.Types.Name.Set hiding (FreeVars) +import GHC.Types.Name import Bag -import CostCentre -import CostCentreState +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State import GHC.Core -import Id -import VarSet +import GHC.Types.Id +import GHC.Types.Var.Set import Data.List import FastString import GHC.Driver.Types import GHC.Core.TyCon -import BasicTypes +import GHC.Types.Basic import MonadUtils import Maybes import GHC.Cmm.CLabel diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index a34beae019..24dba94f7a 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -16,9 +16,9 @@ import GHC.Hs.Decls import GHC.Hs.Extension import GHC.Hs.Types import GHC.Hs.Utils -import Name -import NameSet -import SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.SrcLoc import TcRnTypes import Control.Applicative diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 147da687d0..7f29491ceb 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -33,8 +33,8 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.PmCheck ( checkGuardMatches ) -import Name -import NameEnv +import GHC.Types.Name +import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote import GHC.Hs @@ -50,19 +50,19 @@ import GHC.Core.Utils import GHC.Core.Make import GHC.Driver.Session -import CostCentre -import Id -import MkId -import Module +import GHC.Types.CostCentre +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Module import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCo.Ppr( pprWithTYPE ) import TysWiredIn import PrelNames -import BasicTypes +import GHC.Types.Basic import Maybes -import VarEnv -import SrcLoc +import GHC.Types.Var.Env +import GHC.Types.SrcLoc import Util import Bag import Outputable diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index 2abce51649..5cbf22f92a 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -30,21 +30,21 @@ import GHC.Core import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make -import MkId -import ForeignCall +import GHC.Types.Id.Make +import GHC.Types.ForeignCall import GHC.Core.DataCon import GHC.HsToCore.Utils import TcType import GHC.Core.Type -import Id ( Id ) +import GHC.Types.Id ( Id ) import GHC.Core.Coercion import PrimOp import TysPrim import GHC.Core.TyCon import TysWiredIn -import BasicTypes -import Literal +import GHC.Types.Basic +import GHC.Types.Literal import PrelNames import GHC.Driver.Session import Outputable diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 222bcc042d..8b6d9a3974 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -28,10 +28,10 @@ import GHC.HsToCore.Monad import GHC.Hs import GHC.Core.DataCon import GHC.Core.Unfold -import Id -import Literal -import Module -import Name +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Types.Module +import GHC.Types.Name import GHC.Core.Type import GHC.Types.RepType import GHC.Core.TyCon @@ -42,12 +42,12 @@ import TcType import GHC.Cmm.Expr import GHC.Cmm.Utils import GHC.Driver.Types -import ForeignCall +import GHC.Types.ForeignCall import TysWiredIn import TysPrim import PrelNames -import BasicTypes -import SrcLoc +import GHC.Types.Basic +import GHC.Types.SrcLoc import Outputable import FastString import GHC.Driver.Session diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs index 49beaf1da4..6a8bc53313 100644 --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -28,7 +28,7 @@ import GHC.HsToCore.Utils import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas ) import GHC.Core.Type ( Type ) import Util -import SrcLoc +import GHC.Types.SrcLoc import 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 1259780573..c67f1cbf64 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -28,12 +28,12 @@ import GHC.HsToCore.Utils import GHC.Driver.Session import GHC.Core.Utils -import Id +import GHC.Types.Id import GHC.Core.Type import TysWiredIn import GHC.HsToCore.Match import PrelNames -import SrcLoc +import GHC.Types.SrcLoc import Outputable import TcType import ListSetOps( getNth ) diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 657946ffcb..dd29a08d3e 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -28,7 +28,7 @@ import GHC.Platform import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) -import BasicTypes ( Origin(..) ) +import GHC.Types.Basic ( Origin(..) ) import GHC.Driver.Session import GHC.Hs import TcHsSyn @@ -36,14 +36,14 @@ import TcEvidence import TcRnMonad import GHC.HsToCore.PmCheck import GHC.Core -import Literal +import GHC.Types.Literal import GHC.Core.Utils import GHC.Core.Make import GHC.HsToCore.Monad import GHC.HsToCore.Binds import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils -import Id +import GHC.Types.Id import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn @@ -53,15 +53,15 @@ import GHC.Core.Type import GHC.Core.Coercion ( eqCoercion ) import GHC.Core.TyCon ( isNewTyCon ) import TysWiredIn -import SrcLoc +import GHC.Types.SrcLoc import Maybes import Util -import Name +import GHC.Types.Name import Outputable -import BasicTypes ( isGenerated, il_value, fl_value ) +import GHC.Types.Basic ( isGenerated, il_value, fl_value ) import FastString -import Unique -import UniqDFM +import GHC.Types.Unique +import GHC.Types.Unique.DFM import Control.Monad( unless ) import Data.List.NonEmpty (NonEmpty(..)) diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot index 6dd7729935..f1381707c8 100644 --- a/compiler/GHC/HsToCore/Match.hs-boot +++ b/compiler/GHC/HsToCore/Match.hs-boot @@ -1,10 +1,10 @@ module GHC.HsToCore.Match where import GhcPrelude -import Var ( Id ) +import GHC.Types.Var ( Id ) import TcType ( Type ) -import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) -import GHC.Core ( CoreExpr ) +import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) +import GHC.Core ( CoreExpr ) import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) import GHC.Hs.Extension ( GhcRn, GhcTc ) diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs index cae2dababd..f46780aee2 100644 --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -23,16 +23,16 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import GHC.Hs import GHC.HsToCore.Binds import GHC.Core.ConLike -import BasicTypes ( Origin(..) ) +import GHC.Types.Basic ( Origin(..) ) import TcType import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.Core.Make ( mkCoreLets ) import Util -import Id -import NameEnv -import FieldLabel ( flSelector ) -import SrcLoc +import GHC.Types.Id +import GHC.Types.Name.Env +import GHC.Types.FieldLabel ( flSelector ) +import GHC.Types.SrcLoc import Outputable import Control.Monad(liftM) import Data.List (groupBy) diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 5a5ef53655..4946c7b2ad 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -34,23 +34,23 @@ import GHC.HsToCore.Utils import GHC.Hs -import Id +import GHC.Types.Id import GHC.Core import GHC.Core.Make import GHC.Core.TyCon import GHC.Core.DataCon import TcHsSyn ( shortCutLit ) import TcType -import Name +import GHC.Types.Name import GHC.Core.Type import PrelNames import TysWiredIn import TysPrim -import Literal -import SrcLoc +import GHC.Types.Literal +import GHC.Types.SrcLoc import Data.Ratio import Outputable -import BasicTypes +import GHC.Types.Basic import GHC.Driver.Session import Util import FastString diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index bded17de2f..cd271b3abf 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -63,28 +63,28 @@ import GHC.Hs import GHC.IfaceToCore import TcMType ( checkForLevPolyX, formatLevPolyErr ) import PrelNames -import RdrName +import GHC.Types.Name.Reader import GHC.Driver.Types import Bag -import BasicTypes ( Origin ) +import GHC.Types.Basic ( Origin ) import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon import GHC.HsToCore.PmCheck.Types -import Id -import Module +import GHC.Types.Id +import GHC.Types.Module import Outputable -import SrcLoc +import GHC.Types.SrcLoc import GHC.Core.Type -import UniqSupply -import Name -import NameEnv +import GHC.Types.Unique.Supply +import GHC.Types.Name +import GHC.Types.Name.Env import GHC.Driver.Session import ErrUtils import FastString -import UniqFM ( lookupWithDefaultUFM ) -import Literal ( mkLitString ) -import CostCentreState +import GHC.Types.Unique.FM ( lookupWithDefaultUFM ) +import GHC.Types.Literal ( mkLitString ) +import GHC.Types.CostCentre.State import Data.IORef diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index ee1c0d8062..327b0525b0 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -27,23 +27,23 @@ import GhcPrelude import GHC.HsToCore.PmCheck.Types import GHC.HsToCore.PmCheck.Oracle import GHC.HsToCore.PmCheck.Ppr -import BasicTypes (Origin, isGenerated) +import GHC.Types.Basic (Origin, isGenerated) import GHC.Core (CoreExpr, Expr(Var,App)) import FastString (unpackFS, lengthFS) import GHC.Driver.Session import GHC.Hs import TcHsSyn ( shortCutLit ) -import Id +import GHC.Types.Id import GHC.Core.ConLike -import Name +import GHC.Types.Name import FamInst import TysWiredIn -import SrcLoc +import GHC.Types.SrcLoc import Util import Outputable import GHC.Core.DataCon import GHC.Core.TyCon -import Var (EvVar) +import GHC.Types.Var (EvVar) import GHC.Core.Coercion import TcEvidence ( HsWrapper(..), isIdHsWrapper ) import TcType (evVarPred) diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index 3c7884d7a0..67d10628dc 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -34,23 +34,23 @@ import Outputable import ErrUtils import Util import Bag -import UniqSet -import UniqDSet -import Unique -import Id -import VarEnv -import UniqDFM -import Var (EvVar) -import Name +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet +import GHC.Types.Unique +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.DFM +import GHC.Types.Var (EvVar) +import GHC.Types.Name import GHC.Core import GHC.Core.FVs (exprFreeVars) import GHC.Core.Map import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils (exprType) import GHC.Core.Make (mkListExpr, mkCharExpr) -import UniqSupply +import GHC.Types.Unique.Supply import FastString -import SrcLoc +import GHC.Types.SrcLoc import Maybes import GHC.Core.ConLike import GHC.Core.DataCon diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs index 7ea416bde9..2f62b5e9be 100644 --- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs +++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs @@ -12,10 +12,10 @@ module GHC.HsToCore.PmCheck.Ppr ( import GhcPrelude -import BasicTypes -import Id -import VarEnv -import UniqDFM +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.DFM import GHC.Core.ConLike import GHC.Core.DataCon import TysWiredIn diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs index 08f31c9f13..75652ac2b6 100644 --- a/compiler/GHC/HsToCore/PmCheck/Types.hs +++ b/compiler/GHC/HsToCore/PmCheck/Types.hs @@ -44,12 +44,12 @@ import GhcPrelude import Util import Bag import FastString -import Var (EvVar) -import Id -import VarEnv -import UniqDSet -import UniqDFM -import Name +import GHC.Types.Var (EvVar) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.DSet +import GHC.Types.Unique.DFM +import GHC.Types.Name import GHC.Core.DataCon import GHC.Core.ConLike import Outputable @@ -57,7 +57,7 @@ import ListSetOps (unionLists) import Maybes import GHC.Core.Type import GHC.Core.TyCon -import Literal +import GHC.Types.Literal import GHC.Core import GHC.Core.Map import GHC.Core.Utils (exprType) diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 06ea9e307f..4de99748e5 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -38,31 +38,26 @@ import qualified Language.Haskell.TH as TH import GHC.Hs import PrelNames --- To avoid clashes with GHC.HsToCore.Quote.varName we must make a local alias --- for OccName.varName. We do this by removing varName from the import of OccName --- above, making a qualified instance of OccName and using OccNameAlias.varName --- where varName ws previously used in this file. -import qualified OccName( isDataOcc, isVarOcc, isTcOcc ) - -import Module -import Id -import Name hiding( isVarOcc, isTcOcc, varName, tcName ) + +import GHC.Types.Module +import GHC.Types.Id +import GHC.Types.Name hiding( varName, tcName ) import THNames -import NameEnv +import GHC.Types.Name.Env import TcType import GHC.Core.TyCon import TysWiredIn import GHC.Core import GHC.Core.Make import GHC.Core.Utils -import SrcLoc -import Unique -import BasicTypes +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique +import GHC.Types.Basic import Outputable import Bag import GHC.Driver.Session import FastString -import ForeignCall +import GHC.Types.ForeignCall import Util import Maybes import MonadUtils @@ -72,7 +67,7 @@ import Control.Monad.Trans.Class import GHC.Core.Class import GHC.Driver.Types ( MonadThings ) import GHC.Core.DataCon -import Var +import GHC.Types.Var import GHC.HsToCore.Binds import GHC.TypeLits @@ -2105,10 +2100,10 @@ globalVar name name_mod = moduleNameString (moduleName mod) name_pkg = unitIdString (moduleUnitId mod) name_occ = nameOccName name - mk_varg | OccName.isDataOcc name_occ = mkNameG_dName - | OccName.isVarOcc name_occ = mkNameG_vName - | OccName.isTcOcc name_occ = mkNameG_tcName - | otherwise = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name) + mk_varg | isDataOcc name_occ = mkNameG_dName + | isVarOcc name_occ = mkNameG_vName + | isTcOcc name_occ = mkNameG_tcName + | otherwise = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name) lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp)) -> MetaM Type -- The type diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index 1eb6079c1e..26e708dded 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -17,13 +17,13 @@ import GHC.Driver.Session import GHC.Driver.Ways import GHC.Driver.Types import TcRnTypes -import Name -import NameSet -import Module +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Module import Outputable import Util -import UniqSet -import UniqFM +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM import Fingerprint import Maybes import GHC.Driver.Packages diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 0b80959f09..f7889e01ae 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -57,9 +57,9 @@ import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make -import MkId -import Id -import Literal +import GHC.Types.Id.Make +import GHC.Types.Id +import GHC.Types.Literal import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.PatSyn @@ -67,15 +67,15 @@ import GHC.Core.Type import GHC.Core.Coercion import TysPrim import TysWiredIn -import BasicTypes +import GHC.Types.Basic import GHC.Core.ConLike -import UniqSet -import UniqSupply -import Module +import GHC.Types.Unique.Set +import GHC.Types.Unique.Supply +import GHC.Types.Module import PrelNames -import Name( isInternalName ) +import GHC.Types.Name( isInternalName ) import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Util import GHC.Driver.Session import FastString diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index c4ddfa2ece..cc8472e040 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -39,19 +39,19 @@ import TcRnMonad import PrelInfo ( isKnownKeyName, lookupKnownKeyName ) import GHC.Iface.Env import GHC.Driver.Types -import Module -import Name +import GHC.Types.Module +import GHC.Types.Name import GHC.Driver.Session -import UniqFM -import UniqSupply +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply import Panic import Binary -import SrcLoc +import GHC.Types.SrcLoc import ErrUtils import FastMutInt -import Unique +import GHC.Types.Unique import Outputable -import NameCache +import GHC.Types.Name.Cache import GHC.Platform import FastString import Constants diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index f7cea99b94..8b12f50345 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -27,16 +27,16 @@ import GhcPrelude import TcRnMonad import GHC.Driver.Types import GHC.Core.Type -import Var -import Name -import Avail -import Module +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Types.Module import FastString import FastStringEnv import GHC.Iface.Type -import NameCache -import UniqSupply -import SrcLoc +import GHC.Types.Name.Cache +import GHC.Types.Unique.Supply +import GHC.Types.SrcLoc import Outputable import Data.List ( partition ) @@ -48,7 +48,7 @@ import Data.List ( partition ) * * ********************************************************* -See Also: Note [The Name Cache] in NameCache +See Also: Note [The Name Cache] in GHC.Types.Name.Cache -} newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name diff --git a/compiler/GHC/Iface/Env.hs-boot b/compiler/GHC/Iface/Env.hs-boot index 2c326ab0ad..34d9a29960 100644 --- a/compiler/GHC/Iface/Env.hs-boot +++ b/compiler/GHC/Iface/Env.hs-boot @@ -1,9 +1,9 @@ module GHC.Iface.Env where -import Module -import OccName +import GHC.Types.Module +import GHC.Types.Name.Occurrence import TcRnMonad -import Name -import SrcLoc +import GHC.Types.Name +import GHC.Types.SrcLoc newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index d726a15c7b..a1f9a3cf32 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -18,26 +18,26 @@ module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) wh import GhcPrelude -import Avail ( Avails ) +import GHC.Types.Avail ( Avails ) import Bag ( Bag, bagToList ) -import BasicTypes +import GHC.Types.Basic import BooleanFormula import GHC.Core.Class ( FunDep ) import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike ( conLikeName ) import GHC.HsToCore ( deSugarExpr ) -import FieldLabel +import GHC.Types.FieldLabel import GHC.Hs import GHC.Driver.Types -import Module ( ModuleName, ml_hs_file ) +import GHC.Types.Module ( ModuleName, ml_hs_file ) import MonadUtils ( concatMapM, liftIO ) -import Name ( Name, nameSrcSpan, setNameLoc ) -import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) -import SrcLoc +import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc ) +import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) +import GHC.Types.SrcLoc import TcHsSyn ( hsLitType, hsPatType ) import GHC.Core.Type ( mkVisFunTys, Type ) import TysWiredIn ( mkListTy, mkSumTy ) -import Var ( Id, Var, setVarName, varName, varType ) +import GHC.Types.Var ( Id, Var, setVarName, varName, varType ) import TcRnTypes import GHC.Iface.Make ( mkIfaceExports ) import Panic diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs index d89a346d9f..1a231b95f7 100644 --- a/compiler/GHC/Iface/Ext/Binary.hs +++ b/compiler/GHC/Iface/Ext/Binary.hs @@ -23,15 +23,15 @@ import Binary import GHC.Iface.Binary ( getDictFastString ) import FastMutInt import FastString ( FastString ) -import Module ( Module ) -import Name -import NameCache +import GHC.Types.Module ( Module ) +import GHC.Types.Name +import GHC.Types.Name.Cache import Outputable import PrelInfo -import SrcLoc -import UniqSupply ( takeUniqFromSupply ) -import Unique -import UniqFM +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique.Supply ( takeUniqFromSupply ) +import GHC.Types.Unique +import GHC.Types.Unique.FM import Util import qualified Data.Array as A diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs index 25cc940834..e28f7ab03d 100644 --- a/compiler/GHC/Iface/Ext/Debug.hs +++ b/compiler/GHC/Iface/Ext/Debug.hs @@ -9,15 +9,15 @@ module GHC.Iface.Ext.Debug where import GhcPrelude -import SrcLoc -import Module +import GHC.Types.SrcLoc +import GHC.Types.Module import FastString import Outputable import GHC.Iface.Ext.Types import GHC.Iface.Ext.Binary import GHC.Iface.Ext.Utils -import Name +import GHC.Types.Name import qualified Data.Map as M import qualified Data.Set as S diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs index e56864bc04..3f87a91d34 100644 --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -16,11 +16,11 @@ import Config import Binary import FastString ( FastString ) import GHC.Iface.Type -import Module ( ModuleName, Module ) -import Name ( Name ) +import GHC.Types.Module ( ModuleName, Module ) +import GHC.Types.Name ( Name ) import Outputable hiding ( (<>) ) -import SrcLoc ( RealSrcSpan ) -import Avail +import GHC.Types.SrcLoc ( RealSrcSpan ) +import GHC.Types.Avail 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 2caffe56b3..bbbe1084f1 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -10,15 +10,15 @@ import GHC.Core.Map import GHC.Driver.Session ( DynFlags ) import FastString ( FastString, mkFastString ) import GHC.Iface.Type -import Name hiding (varName) +import GHC.Types.Name hiding (varName) import Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext ) -import SrcLoc +import GHC.Types.SrcLoc import GHC.CoreToIface import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.Type -import Var -import VarEnv +import GHC.Types.Var +import GHC.Types.Var.Env import GHC.Iface.Ext.Types diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 7858fc6ce4..9bc073b6a9 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -45,29 +45,29 @@ import GHC.Iface.Syntax import GHC.Iface.Env import GHC.Driver.Types -import BasicTypes hiding (SuccessFlag(..)) +import GHC.Types.Basic hiding (SuccessFlag(..)) import TcRnMonad import Constants import PrelNames import PrelInfo import PrimOp ( allThePrimOps, primOpFixity, primOpOcc ) -import MkId ( seqId ) +import GHC.Types.Id.Make ( seqId ) import TysPrim ( funTyConName ) import GHC.Core.Rules import GHC.Core.TyCon -import Annotations +import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import Name -import NameEnv -import Avail -import Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Types.Module import Maybes import ErrUtils import GHC.Driver.Finder -import UniqFM -import SrcLoc +import GHC.Types.Unique.FM +import GHC.Types.SrcLoc import Outputable import GHC.Iface.Binary import Panic @@ -75,9 +75,9 @@ import Util import FastString import Fingerprint import GHC.Driver.Hooks -import FieldLabel +import GHC.Types.FieldLabel import GHC.Iface.Rename -import UniqDSet +import GHC.Types.Unique.DSet import GHC.Driver.Plugins import Control.Monad diff --git a/compiler/GHC/Iface/Load.hs-boot b/compiler/GHC/Iface/Load.hs-boot index a2af2a1a9a..7718eb99f3 100644 --- a/compiler/GHC/Iface/Load.hs-boot +++ b/compiler/GHC/Iface/Load.hs-boot @@ -1,6 +1,6 @@ module GHC.Iface.Load where -import Module (Module) +import GHC.Types.Module (Module) import TcRnMonad (IfM) import GHC.Driver.Types (ModIface) import Outputable (SDoc) diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index f903892f9a..5cf6aa5f27 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -29,8 +29,8 @@ import GHC.Iface.Load import GHC.CoreToIface import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) -import Id -import Annotations +import GHC.Types.Id +import GHC.Types.Annotations import GHC.Core import GHC.Core.Class import GHC.Core.TyCon @@ -45,17 +45,17 @@ import TcRnMonad import GHC.Hs import GHC.Driver.Types import GHC.Driver.Session -import VarEnv -import Var -import Name -import Avail -import RdrName -import NameEnv -import NameSet -import Module +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Types.Name.Reader +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Module import ErrUtils import Outputable -import BasicTypes hiding ( SuccessFlag(..) ) +import GHC.Types.Basic hiding ( SuccessFlag(..) ) import Util hiding ( eqListBy ) import FastString import Maybes @@ -228,7 +228,7 @@ mkIface_ hsc_env [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] -- The order of fixities returned from nameEnvElts is not -- deterministic, so we sort by OccName to canonicalize it. - -- See Note [Deterministic UniqFM] in UniqDFM for more details. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details. warns = src_warns iface_rules = map coreRuleToIfaceRule rules iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 0890c6ffa0..12830ab20e 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -19,27 +19,27 @@ import BinFingerprint import GHC.Iface.Load import FlagChecker -import Annotations +import GHC.Types.Annotations import GHC.Core import TcRnMonad import GHC.Hs import GHC.Driver.Types import GHC.Driver.Finder import GHC.Driver.Session -import Name -import NameSet -import Module +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Module import ErrUtils import Digraph -import SrcLoc +import GHC.Types.SrcLoc import Outputable -import Unique +import GHC.Types.Unique import Util hiding ( eqListBy ) import Maybes import Binary import Fingerprint import Exception -import UniqSet +import GHC.Types.Unique.Set import GHC.Driver.Packages import Control.Monad diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 83632434bd..5d084155db 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -19,22 +19,22 @@ module GHC.Iface.Rename ( import GhcPrelude -import SrcLoc +import GHC.Types.SrcLoc import Outputable import GHC.Driver.Types -import Module -import UniqFM -import Avail +import GHC.Types.Module +import GHC.Types.Unique.FM +import GHC.Types.Avail import GHC.Iface.Syntax -import FieldLabel -import Var +import GHC.Types.FieldLabel +import GHC.Types.Var import ErrUtils -import Name +import GHC.Types.Name import TcRnMonad import Util import Fingerprint -import BasicTypes +import GHC.Types.Basic -- a bit vexing import {-# SOURCE #-} GHC.Iface.Load diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 1812c34d6b..1f82ccfc7f 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -47,29 +47,29 @@ import GhcPrelude import GHC.Iface.Type import BinFingerprint import GHC.Core( IsOrphan, isOrphan ) -import Demand -import Cpr +import GHC.Types.Demand +import GHC.Types.Cpr import GHC.Core.Class -import FieldLabel -import NameSet +import GHC.Types.FieldLabel +import GHC.Types.Name.Set import GHC.Core.Coercion.Axiom ( BranchIndex ) -import Name -import CostCentre -import Literal -import ForeignCall -import Annotations( AnnPayload, AnnTarget ) -import BasicTypes +import GHC.Types.Name +import GHC.Types.CostCentre +import GHC.Types.Literal +import GHC.Types.ForeignCall +import GHC.Types.Annotations( AnnPayload, AnnTarget ) +import GHC.Types.Basic import Outputable -import Module -import SrcLoc +import GHC.Types.Module +import GHC.Types.SrcLoc import Fingerprint import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) -import Var( VarBndr(..), binderVar ) +import GHC.Types.Var( VarBndr(..), binderVar ) import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) import Util( dropList, filterByList, notNull, unzipWith, debugIsOn ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) -import Lexeme (isLexSym) +import GHC.Utils.Lexeme (isLexSym) import TysWiredIn ( constraintKindTyConName ) import Util (seqList) @@ -262,7 +262,7 @@ data IfaceConDecl ifConStricts :: [IfaceBang], -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys - -- See Note [Bangs on imported data constructors] in MkId + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts type IfaceEqSpec = [(IfLclName,IfaceType)] diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index b3fd56c4d2..6459902a52 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -31,31 +31,31 @@ import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.Arity ( exprArity, exprBotStrictness_maybe ) import StaticPtrTable -import VarEnv -import VarSet -import Var -import Id -import MkId ( mkDictSelRhs ) -import IdInfo +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Make ( mkDictSelRhs ) +import GHC.Types.Id.Info import GHC.Core.InstEnv -import GHC.Core.Type ( tidyTopType ) -import Demand ( appIsBottom, isTopSig, isBottomingSig ) -import Cpr ( mkCprSig, botCpr ) -import BasicTypes -import Name hiding (varName) -import NameSet -import NameCache -import Avail +import GHC.Core.Type ( tidyTopType ) +import GHC.Types.Demand ( appIsBottom, isTopSig, isBottomingSig ) +import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Basic +import GHC.Types.Name hiding (varName) +import GHC.Types.Name.Set +import GHC.Types.Name.Cache +import GHC.Types.Avail import GHC.Iface.Env import TcEnv import TcRnMonad import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class -import Module +import GHC.Types.Module import GHC.Driver.Types import Maybes -import UniqSupply +import GHC.Types.Unique.Supply import Outputable import Util( filterOut ) import qualified ErrUtils as Err @@ -581,7 +581,7 @@ getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc - | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId + | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) getClassImplicitBinds :: Class -> [CoreBind] diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 8b154248ab..85b1a19f40 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -68,10 +68,10 @@ import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy ) import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom -import Var +import GHC.Types.Var import PrelNames -import Name -import BasicTypes +import GHC.Types.Name +import GHC.Types.Basic import Binary import Outputable import FastString @@ -119,7 +119,7 @@ ifaceBndrType (IfaceTvBndr (_, t)) = t type IfaceLamBndr = (IfaceBndr, IfaceOneShot) data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy - = IfaceNoOneShot -- and Note [The oneShot function] in MkId + = IfaceNoOneShot -- and Note [The oneShot function] in GHC.Types.Id.Make | IfaceOneShot diff --git a/compiler/GHC/Iface/Type.hs-boot b/compiler/GHC/Iface/Type.hs-boot index 30a0033c86..3876cb0618 100644 --- a/compiler/GHC/Iface/Type.hs-boot +++ b/compiler/GHC/Iface/Type.hs-boot @@ -4,7 +4,7 @@ module GHC.Iface.Type ) where -import Var (VarBndr, ArgFlag) +import GHC.Types.Var (VarBndr, ArgFlag) data IfaceAppArgs diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index df2457cd62..0024d92037 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -39,7 +39,7 @@ import GHC.Core.Coercion.Axiom import GHC.Core.TyCo.Rep -- needs to build types & coercions in a knot import GHC.Core.TyCo.Subst ( substTyCoVars ) import GHC.Driver.Types -import Annotations +import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core @@ -47,33 +47,33 @@ import GHC.Core.Utils import GHC.Core.Unfold import GHC.Core.Lint import GHC.Core.Make -import Id -import MkId -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Id.Info import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon import PrelNames import TysWiredIn -import Literal -import Var -import VarSet -import Name -import NameEnv -import NameSet +import GHC.Types.Literal +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set import GHC.Core.Op.OccurAnal ( occurAnalyseExpr ) -import Demand -import Module -import UniqFM -import UniqSupply +import GHC.Types.Demand +import GHC.Types.Module +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply import Outputable import Maybes -import SrcLoc +import GHC.Types.SrcLoc import GHC.Driver.Session import Util import FastString -import BasicTypes hiding ( SuccessFlag(..) ) +import GHC.Types.Basic hiding ( SuccessFlag(..) ) import ListSetOps import GHC.Fingerprint import qualified BooleanFormula as BF @@ -963,7 +963,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons -- decisions) to buildDataCon; it'll use -- these to guide the construction of a -- worker. - -- See Note [Bangs on imported data constructors] in MkId + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make lbl_names univ_tvs ex_tvs user_tv_bndrs eq_spec theta @@ -1384,13 +1384,13 @@ tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) tcIfaceLit :: Literal -> IfL Literal -- Integer literals deserialise to (LitInteger i ) -- so tcIfaceLit just fills in the type. --- See Note [Integer literals] in Literal +-- See Note [Integer literals] in GHC.Types.Literal tcIfaceLit (LitNumber LitNumInteger i _) = do t <- tcIfaceTyConByName integerTyConName return (mkLitInteger i (mkTyConTy t)) -- Natural literals deserialise to (LitNatural i ) -- so tcIfaceLit just fills in the type. --- See Note [Natural literals] in Literal +-- See Note [Natural literals] in GHC.Types.Literal tcIfaceLit (LitNumber LitNumNatural i _) = do t <- tcIfaceTyConByName naturalTyConName return (mkLitNatural i (mkTyConTy t)) diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot index 32e13c80d1..b1e08e2e01 100644 --- a/compiler/GHC/IfaceToCore.hs-boot +++ b/compiler/GHC/IfaceToCore.hs-boot @@ -9,7 +9,7 @@ import GHC.Core.InstEnv ( ClsInst ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core ( CoreRule ) import GHC.Driver.Types ( CompleteMatch ) -import Annotations ( Annotation ) +import GHC.Types.Annotations ( Annotation ) tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs index b7c3564240..4645c89e1a 100644 --- a/compiler/GHC/Llvm/Ppr.hs +++ b/compiler/GHC/Llvm/Ppr.hs @@ -34,7 +34,7 @@ import GHC.Platform import Data.List ( intersperse ) import Outputable -import Unique +import GHC.Types.Unique import FastString ( sLit ) -------------------------------------------------------------------------------- diff --git a/compiler/GHC/Llvm/Syntax.hs b/compiler/GHC/Llvm/Syntax.hs index d048215a0b..51324b396d 100644 --- a/compiler/GHC/Llvm/Syntax.hs +++ b/compiler/GHC/Llvm/Syntax.hs @@ -9,7 +9,7 @@ import GhcPrelude import GHC.Llvm.MetaData import GHC.Llvm.Types -import Unique +import GHC.Types.Unique -- | Block labels type LlvmBlockId = Unique diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs index e8b4bc283a..a52e05faac 100644 --- a/compiler/GHC/Llvm/Types.hs +++ b/compiler/GHC/Llvm/Types.hs @@ -19,7 +19,7 @@ import GHC.Platform import GHC.Driver.Session import FastString import Outputable -import Unique +import GHC.Types.Unique -- from NCG import GHC.CmmToAsm.Ppr diff --git a/compiler/GHC/Platform/Reg.hs b/compiler/GHC/Platform/Reg.hs index b856d7c3af..00cd254630 100644 --- a/compiler/GHC/Platform/Reg.hs +++ b/compiler/GHC/Platform/Reg.hs @@ -29,7 +29,7 @@ where import GhcPrelude import Outputable -import Unique +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 225ad05be5..8aa81c2fe9 100644 --- a/compiler/GHC/Platform/Reg/Class.hs +++ b/compiler/GHC/Platform/Reg/Class.hs @@ -6,8 +6,8 @@ where import GhcPrelude -import Outputable -import Unique +import Outputable +import GHC.Types.Unique -- | The class of a register. diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs index 05278f7da1..2e342100bf 100644 --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -7,39 +7,67 @@ -- -- Particularly interesting modules for plugin writers include -- "GHC.Core" and "GHC.Core.Op.Monad". -module GHC.Plugins( - module GHC.Driver.Plugins, - module RdrName, module OccName, module Name, module Var, module Id, module IdInfo, - module GHC.Core.Op.Monad, module GHC.Core, module Literal, module GHC.Core.DataCon, - module GHC.Core.Utils, module GHC.Core.Make, module GHC.Core.FVs, - module GHC.Core.Subst, module GHC.Core.Rules, module Annotations, - module GHC.Driver.Session, module GHC.Driver.Packages, - module Module, module GHC.Core.Type, module GHC.Core.TyCon, module GHC.Core.Coercion, - module TysWiredIn, module GHC.Driver.Types, module BasicTypes, - module VarSet, module VarEnv, module NameSet, module NameEnv, - module UniqSet, module UniqFM, module FiniteMap, - module Util, module GHC.Serialized, module SrcLoc, module Outputable, - module UniqSupply, module Unique, module FastString, - - -- * Getting 'Name's - thNameToGhcName - ) where +module GHC.Plugins + ( module GHC.Driver.Plugins + , module GHC.Types.Name.Reader + , module GHC.Types.Name.Occurrence + , module GHC.Types.Name + , module GHC.Types.Var + , module GHC.Types.Id + , module GHC.Types.Id.Info + , module GHC.Core.Op.Monad + , module GHC.Core + , module GHC.Types.Literal + , module GHC.Core.DataCon + , module GHC.Core.Utils + , module GHC.Core.Make + , module GHC.Core.FVs + , module GHC.Core.Subst + , module GHC.Core.Rules + , module GHC.Types.Annotations + , module GHC.Driver.Session + , module GHC.Driver.Packages + , module GHC.Types.Module + , module GHC.Core.Type + , module GHC.Core.TyCon + , module GHC.Core.Coercion + , module TysWiredIn + , module GHC.Driver.Types + , module GHC.Types.Basic + , module GHC.Types.Var.Set + , module GHC.Types.Var.Env + , module GHC.Types.Name.Set + , module GHC.Types.Name.Env + , module GHC.Types.Unique + , module GHC.Types.Unique.Set + , module GHC.Types.Unique.FM + , module FiniteMap + , module Util + , module GHC.Serialized + , module GHC.Types.SrcLoc + , module Outputable + , module GHC.Types.Unique.Supply + , module FastString + , -- * Getting 'Name's + thNameToGhcName + ) +where -- Plugin stuff itself import GHC.Driver.Plugins -- Variable naming -import RdrName -import OccName hiding ( varName {- conflicts with Var.varName -} ) -import Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) -import Var -import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) -import IdInfo +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence hiding ( varName {- conflicts with Var.varName -} ) +import GHC.Types.Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) +import GHC.Types.Var +import GHC.Types.Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) +import GHC.Types.Id.Info -- Core import GHC.Core.Op.Monad import GHC.Core -import Literal +import GHC.Types.Literal import GHC.Core.DataCon import GHC.Core.Utils import GHC.Core.Make @@ -49,14 +77,14 @@ import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) -- Core "extras" import GHC.Core.Rules -import Annotations +import GHC.Types.Annotations -- Pipeline-related stuff import GHC.Driver.Session import GHC.Driver.Packages -- Important GHC types -import Module +import GHC.Types.Module import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -} ( substTy, extendTvSubst, extendTvSubstList, isInScope ) import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -} @@ -64,15 +92,15 @@ import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -} import GHC.Core.TyCon import TysWiredIn import GHC.Driver.Types -import BasicTypes hiding ( Version {- conflicts with Packages.Version -} ) +import GHC.Types.Basic hiding ( Version {- conflicts with Packages.Version -} ) -- Collections and maps -import VarSet -import VarEnv -import NameSet -import NameEnv -import UniqSet -import UniqFM +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM -- Conflicts with UniqFM: --import LazyUniqFM import FiniteMap @@ -80,10 +108,10 @@ import FiniteMap -- Common utilities import Util import GHC.Serialized -import SrcLoc +import GHC.Types.SrcLoc import Outputable -import UniqSupply -import Unique ( Unique, Uniquable(..) ) +import GHC.Types.Unique.Supply +import GHC.Types.Unique ( Unique, Uniquable(..) ) import FastString import Data.Maybe diff --git a/compiler/GHC/Rename/Binds.hs b/compiler/GHC/Rename/Binds.hs index e50c97d54c..d0e4392fb8 100644 --- a/compiler/GHC/Rename/Binds.hs +++ b/compiler/GHC/Rename/Binds.hs @@ -45,19 +45,19 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn , checkUnusedRecordWildcard , checkDupAndShadowedNames, bindLocalNamesFV ) import GHC.Driver.Session -import Module -import Name -import NameEnv -import NameSet -import RdrName ( RdrName, rdrNameOcc ) -import SrcLoc +import GHC.Types.Module +import GHC.Types.Name +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 BasicTypes ( RecFlag(..), TypeOrKind(..) ) +import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) ) import Digraph ( SCC(..) ) import Bag import Util import Outputable -import UniqSet +import GHC.Types.Unique.Set import Maybes ( orElse ) import OrdList import qualified GHC.LanguageExtensions as LangExt @@ -577,7 +577,7 @@ depAnalBinds binds_w_dus sccs = depAnal (\(_, defs, _) -> defs) (\(_, _, uses) -> nonDetEltsUniqSet uses) -- It's OK to use nonDetEltsUniqSet here as explained in - -- Note [depAnal determinism] in NameEnv. + -- Note [depAnal determinism] in GHC.Types.Name.Env. (bagToList binds_w_dus) get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs index 2f6a796196..2ccf2bfe8d 100644 --- a/compiler/GHC/Rename/Doc.hs +++ b/compiler/GHC/Rename/Doc.hs @@ -6,7 +6,7 @@ import GhcPrelude import TcRnTypes import GHC.Hs -import SrcLoc +import GHC.Types.SrcLoc rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString) diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index a860bdb53f..5e4a5a7ba0 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -49,26 +49,26 @@ import GhcPrelude import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) import GHC.Iface.Env import GHC.Hs -import RdrName +import GHC.Types.Name.Reader import GHC.Driver.Types import TcEnv import TcRnMonad import RdrHsSyn ( filterCTuple, setRdrNameSpace ) import TysWiredIn -import Name -import NameSet -import NameEnv -import Avail -import Module +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Types.Module import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon import ErrUtils ( MsgDoc ) import PrelNames ( rOOT_MAIN ) -import BasicTypes ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) ) -import SrcLoc +import GHC.Types.Basic ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) ) +import GHC.Types.SrcLoc as SrcLoc import Outputable -import UniqSet ( uniqSetAny ) +import GHC.Types.Unique.Set ( uniqSetAny ) import Util import Maybes import GHC.Driver.Session diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 79df0331b3..87a98abd52 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -32,7 +32,7 @@ import GHC.Rename.Binds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBin import GHC.Hs import TcEnv ( isBrackStage ) import TcRnMonad -import Module ( getModule ) +import GHC.Types.Module ( getModule ) import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames @@ -47,17 +47,17 @@ import GHC.Rename.Pat import GHC.Driver.Session import PrelNames -import BasicTypes -import Name -import NameSet -import RdrName -import UniqSet +import GHC.Types.Basic +import GHC.Types.Name +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 SrcLoc +import GHC.Types.SrcLoc import FastString import Control.Monad import TysWiredIn ( nilDataConName ) diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot index 77dec1b56a..a5292471d8 100644 --- a/compiler/GHC/Rename/Expr.hs-boot +++ b/compiler/GHC/Rename/Expr.hs-boot @@ -1,9 +1,9 @@ module GHC.Rename.Expr where -import Name +import GHC.Types.Name import GHC.Hs -import NameSet ( FreeVars ) +import GHC.Types.Name.Set ( FreeVars ) import TcRnTypes -import SrcLoc ( Located ) +import GHC.Types.SrcLoc ( Located ) import Outputable ( Outputable ) rnLExpr :: LHsExpr GhcPs diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs index 4c55bb3e53..cf5ca883da 100644 --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -20,15 +20,15 @@ import GhcPrelude import GHC.Iface.Load import GHC.Hs -import RdrName +import GHC.Types.Name.Reader import GHC.Driver.Types import TcRnMonad -import Name -import NameEnv -import Module -import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Module +import GHC.Types.Basic ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity, SourceText(..) ) -import SrcLoc +import GHC.Types.SrcLoc import Outputable import Maybes import Data.List diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index b04260e3df..286de91a9e 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -44,23 +44,23 @@ import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) import GHC.Iface.Load ( loadSrcInterface ) import TcRnMonad import PrelNames -import Module -import Name -import NameEnv -import NameSet -import Avail -import FieldLabel +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.FieldLabel import GHC.Driver.Types -import RdrName +import GHC.Types.Name.Reader import RdrHsSyn ( setRdrNameSpace ) import Outputable import Maybes -import SrcLoc -import BasicTypes ( TopLevelFlag(..), StringLiteral(..) ) +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Basic ( TopLevelFlag(..), StringLiteral(..) ) import Util import FastString import FastStringEnv -import Id +import GHC.Types.Id import GHC.Core.Type import GHC.Core.PatSyn import qualified GHC.LanguageExtensions as LangExt @@ -1065,7 +1065,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) -- Look up the children in the sub-names of the parent let subnames = case ns of -- The tc is first in ns, [] -> [] -- if it is there at all - -- See the AvailTC Invariant in Avail.hs + -- See the AvailTC Invariant in + -- GHC.Types.Avail (n1:ns1) | n1 == name -> ns1 | otherwise -> ns case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of @@ -1350,7 +1351,7 @@ This code finds which import declarations are unused. The specification and implementation notes are here: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports -See also Note [Choosing the best import declaration] in RdrName +See also Note [Choosing the best import declaration] in GHC.Types.Name.Reader -} type ImportDeclUsage diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 34450620f0..7b83b8702d 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -63,15 +63,15 @@ import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames , checkTupSize , unknownSubordinateErr ) import GHC.Rename.Types import PrelNames -import Name -import NameSet -import RdrName -import BasicTypes +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 SrcLoc -import Literal ( inCharRange ) +import GHC.Types.SrcLoc +import GHC.Types.Literal ( inCharRange ) import TysWiredIn ( nilDataCon ) import GHC.Core.DataCon import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Rename/Source.hs b/compiler/GHC/Rename/Source.hs index 8237e32877..fabe5b817d 100644 --- a/compiler/GHC/Rename/Source.hs +++ b/compiler/GHC/Rename/Source.hs @@ -25,8 +25,8 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) import GHC.Hs -import FieldLabel -import RdrName +import GHC.Types.FieldLabel +import GHC.Types.Name.Reader import GHC.Rename.Types import GHC.Rename.Binds import GHC.Rename.Env @@ -41,30 +41,30 @@ import GHC.Rename.Doc ( rnHsDoc, rnMbLHsDoc ) import TcAnnotations ( annCtxt ) import TcRnMonad -import ForeignCall ( CCallTarget(..) ) -import Module -import GHC.Driver.Types ( Warnings(..), plusWarns ) +import GHC.Types.ForeignCall ( CCallTarget(..) ) +import GHC.Types.Module +import GHC.Driver.Types ( Warnings(..), plusWarns ) import PrelNames ( applicativeClassName, pureAName, thenAName , monadClassName, returnMName, thenMName , semigroupClassName, sappendName , monoidClassName, mappendName ) -import Name -import NameSet -import NameEnv -import Avail +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Avail import Outputable import Bag -import BasicTypes ( pprRuleName, TypeOrKind(..) ) +import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) ) import FastString -import SrcLoc +import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith ) -import GHC.Driver.Types ( HscEnv, hsc_dflags ) +import GHC.Driver.Types ( HscEnv, hsc_dflags ) import ListSetOps ( findDupsEq, removeDups, equivClasses ) import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) -import UniqSet +import GHC.Types.Unique.Set import OrdList import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 12496a9fb8..2275ca6ab8 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -16,10 +16,10 @@ module GHC.Rename.Splice ( import GhcPrelude -import Name -import NameSet +import GHC.Types.Name +import GHC.Types.Name.Set import GHC.Hs -import RdrName +import GHC.Types.Name.Reader import TcRnMonad import GHC.Rename.Env @@ -27,15 +27,15 @@ import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn ) import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Source ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) -import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) ) +import GHC.Types.Basic ( TopLevelFlag, isTopLevel, SourceText(..) ) import Outputable -import Module -import SrcLoc +import GHC.Types.Module +import GHC.Types.SrcLoc import GHC.Rename.Types ( rnLHsType ) import Control.Monad ( unless, when ) -import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) +import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) import TcEnv ( checkWellStaged ) import THNames ( liftName ) diff --git a/compiler/GHC/Rename/Splice.hs-boot b/compiler/GHC/Rename/Splice.hs-boot index b61a866331..f14be280fc 100644 --- a/compiler/GHC/Rename/Splice.hs-boot +++ b/compiler/GHC/Rename/Splice.hs-boot @@ -3,7 +3,7 @@ module GHC.Rename.Splice where import GhcPrelude import GHC.Hs import TcRnMonad -import NameSet +import GHC.Types.Name.Set rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) diff --git a/compiler/GHC/Rename/Types.hs b/compiler/GHC/Rename/Types.hs index d633ac6593..23e9fe0879 100644 --- a/compiler/GHC/Rename/Types.hs +++ b/compiler/GHC/Rename/Types.hs @@ -46,17 +46,17 @@ import GHC.Rename.Utils ( HsDocContext(..), withHsDocContext, mapFvRn import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) import TcRnMonad -import RdrName +import GHC.Types.Name.Reader import PrelNames import TysPrim ( funTyConName ) -import Name -import SrcLoc -import NameSet -import FieldLabel +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Name.Set +import GHC.Types.FieldLabel import Util import ListSetOps ( deleteBys ) -import BasicTypes ( compareFixity, funTyFixity, negateFixity +import GHC.Types.Basic ( compareFixity, funTyFixity, negateFixity , Fixity(..), FixityDirection(..), LexicalFixity(..) , TypeOrKind(..) ) import Outputable diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 78a49d954c..957a82e81c 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -19,12 +19,12 @@ where import GhcPrelude -import RdrName +import GHC.Types.Name.Reader import GHC.Driver.Types import TcRnMonad -import Name -import Module -import SrcLoc +import GHC.Types.Name +import GHC.Types.Module +import GHC.Types.SrcLoc as SrcLoc import Outputable import PrelNames ( mkUnboundName, isUnboundName, getUnique) import Util @@ -33,7 +33,7 @@ import GHC.Driver.Session import FastString import Data.List import Data.Function ( on ) -import UniqDFM (udfmToList) +import GHC.Types.Unique.DFM (udfmToList) {- ************************************************************************ diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 45bd55b31a..32ac27d12f 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -36,18 +36,18 @@ where import GhcPrelude import GHC.Hs -import RdrName +import GHC.Types.Name.Reader import GHC.Driver.Types import TcEnv import TcRnMonad -import Name -import NameSet -import NameEnv +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env import GHC.Core.DataCon -import SrcLoc +import GHC.Types.SrcLoc as SrcLoc import Outputable import Util -import BasicTypes ( TopLevelFlag(..) ) +import GHC.Types.Basic ( TopLevelFlag(..) ) import ListSetOps ( removeDups ) import GHC.Driver.Session import FastString diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 5ad6a2c6f0..50622d8fa9 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -23,13 +23,13 @@ import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHC.Driver.Monad import GHC.Driver.Types -import Id +import GHC.Types.Id import GHC.Iface.Syntax ( showToHeader ) import GHC.Iface.Env ( newInteractiveBinder ) -import Name -import Var hiding ( varName ) -import VarSet -import UniqSet +import GHC.Types.Name +import GHC.Types.Var hiding ( varName ) +import GHC.Types.Var.Set +import GHC.Types.Unique.Set import GHC.Core.Type import GHC import Outputable diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 6ef575490f..794aa30b55 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -69,27 +69,27 @@ import TcType import Constraint import TcOrigin import GHC.Core.Predicate -import Var -import Id -import Name hiding ( varName ) -import NameSet -import Avail -import RdrName -import VarEnv +import GHC.Types.Var +import GHC.Types.Id as Id +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.Name.Reader +import GHC.Types.Var.Env import GHC.ByteCode.Types import GHC.Runtime.Linker as Linker import GHC.Driver.Session import GHC.LanguageExtensions -import Unique -import UniqSupply +import GHC.Types.Unique +import GHC.Types.Unique.Supply import MonadUtils -import Module +import GHC.Types.Module import PrelNames ( toDynName, pretendNameIsInScope ) import TysWiredIn ( isCTupleTyConName ) import Panic import Maybes import ErrUtils -import SrcLoc +import GHC.Types.SrcLoc import GHC.Runtime.Heap.Inspect import Outputable import FastString diff --git a/compiler/GHC/Runtime/Eval/Types.hs b/compiler/GHC/Runtime/Eval/Types.hs index f1e3308f70..753f776f20 100644 --- a/compiler/GHC/Runtime/Eval/Types.hs +++ b/compiler/GHC/Runtime/Eval/Types.hs @@ -16,12 +16,12 @@ import GhcPrelude import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) -import Id -import Name -import Module -import RdrName +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Module +import GHC.Types.Name.Reader import GHC.Core.Type -import SrcLoc +import GHC.Types.SrcLoc import Exception import Data.Word diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 37d9af0d8b..5f34e9d2d2 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -37,7 +37,7 @@ import GHC.Core.DataCon import GHC.Core.Type import GHC.Types.RepType import qualified GHC.Core.Unify as U -import Var +import GHC.Types.Var import TcRnMonad import TcType import TcMType @@ -46,13 +46,13 @@ import TcUnify import TcEnv import GHC.Core.TyCon -import Name -import OccName -import Module +import GHC.Types.Name +import GHC.Types.Name.Occurrence as OccName +import GHC.Types.Module import GHC.Iface.Env import Util -import VarSet -import BasicTypes ( Boxity(..) ) +import GHC.Types.Var.Set +import GHC.Types.Basic ( Boxity(..) ) import TysPrim import PrelNames import TysWiredIn diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index c6a159345d..c469f00cb4 100644 --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -46,7 +46,7 @@ module GHC.Runtime.Heap.Layout ( import GhcPrelude -import BasicTypes( ConTagZ ) +import GHC.Types.Basic( ConTagZ ) import GHC.Driver.Session import Outputable import GHC.Platform diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index 82f0d5ffc4..61e5297184 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -62,20 +62,20 @@ import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) import Fingerprint import GHC.Driver.Types -import UniqFM +import GHC.Types.Unique.FM import Panic import GHC.Driver.Session import Exception -import BasicTypes +import GHC.Types.Basic import FastString import Util import GHC.Runtime.Eval.Types(BreakInfo(..)) import Outputable(brackets, ppr, showSDocUnqual) -import SrcLoc +import GHC.Types.SrcLoc import Maybes -import Module +import GHC.Types.Module import GHC.ByteCode.Types -import Unique +import GHC.Types.Unique #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs index 6cbf2620ee..9decf8abb2 100644 --- a/compiler/GHC/Runtime/Interpreter/Types.hs +++ b/compiler/GHC/Runtime/Interpreter/Types.hs @@ -14,7 +14,7 @@ import GhcPrelude import GHCi.RemoteTypes import GHCi.Message ( Pipe ) -import UniqFM +import GHC.Types.Unique.FM import Foreign import Control.Concurrent diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index c8b4b63a78..10f18a8525 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -44,20 +44,20 @@ import GHC.Driver.Phases import GHC.Driver.Finder import GHC.Driver.Types import GHC.Driver.Ways -import Name -import NameEnv -import Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Module import ListSetOps import GHC.Runtime.Linker.Types (DynLinker(..), LinkerUnitId, PersistentLinkerState(..)) import GHC.Driver.Session -import BasicTypes +import GHC.Types.Basic import Outputable import Panic import Util import ErrUtils -import SrcLoc +import GHC.Types.SrcLoc import qualified Maybes -import UniqDSet +import GHC.Types.Unique.DSet import FastString import GHC.Platform import SysTools diff --git a/compiler/GHC/Runtime/Linker/Types.hs b/compiler/GHC/Runtime/Linker/Types.hs index 5b2f506c6d..d8530a1460 100644 --- a/compiler/GHC/Runtime/Linker/Types.hs +++ b/compiler/GHC/Runtime/Linker/Types.hs @@ -19,13 +19,13 @@ import GhcPrelude ( FilePath, String, show ) import Data.Time ( UTCTime ) import Data.Maybe ( Maybe ) import Control.Concurrent.MVar ( MVar ) -import Module ( InstalledUnitId, Module ) -import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) +import GHC.Types.Module ( InstalledUnitId, Module ) +import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) import Outputable -import Var ( Id ) +import GHC.Types.Var ( Id ) import GHC.Fingerprint.Type ( Fingerprint ) -import NameEnv ( NameEnv ) -import Name ( Name ) +import GHC.Types.Name.Env ( NameEnv ) +import GHC.Types.Name ( Name ) import GHCi.RemoteTypes ( ForeignHValue ) type ClosureEnv = NameEnv (Name, ForeignHValue) diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 44737c48ed..16c965701a 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -26,26 +26,26 @@ import GHC.Driver.Session import GHC.Runtime.Linker ( linkModule, getHValue ) import GHC.Runtime.Interpreter ( wormhole, withInterp ) import GHC.Runtime.Interpreter.Types -import SrcLoc ( noSrcSpan ) -import GHC.Driver.Finder( findPluginModule, cannotFindModule ) -import TcRnMonad ( initTcInteractive, initIfaceTcRn ) -import GHC.Iface.Load ( loadPluginInterface ) -import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) - , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName - , gre_name, mkRdrQual ) -import OccName ( OccName, mkVarOcc ) +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Driver.Finder ( findPluginModule, cannotFindModule ) +import TcRnMonad ( initTcInteractive, initIfaceTcRn ) +import GHC.Iface.Load ( loadPluginInterface ) +import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) + , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName + , gre_name, mkRdrQual ) +import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) import GHC.Rename.Names ( gresFromAvails ) import GHC.Driver.Plugins import PrelNames ( pluginTyConName, frontendPluginTyConName ) import GHC.Driver.Types -import GHCi.RemoteTypes ( HValue ) +import GHCi.RemoteTypes ( HValue ) import GHC.Core.Type ( Type, eqType, mkTyConTy ) import GHC.Core.TyCo.Ppr ( pprTyThingCategory ) import GHC.Core.TyCon ( TyCon ) -import Name ( Name, nameModule_maybe ) -import Id ( idType ) -import Module ( Module, ModuleName ) +import GHC.Types.Name ( Name, nameModule_maybe ) +import GHC.Types.Id ( idType ) +import GHC.Types.Module ( Module, ModuleName ) import Panic import FastString import ErrUtils diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index ea9c8e61fa..538556c6af 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -89,15 +89,15 @@ module GHC.Stg.CSE (stgCse) where import GhcPrelude import GHC.Core.DataCon -import Id +import GHC.Types.Id import GHC.Stg.Syntax import Outputable -import VarEnv +import GHC.Types.Var.Env import GHC.Core (AltCon(..)) import Data.List (mapAccumL) import Data.Maybe (fromMaybe) import GHC.Core.Map -import NameEnv +import GHC.Types.Name.Env import Control.Monad( (>=>) ) -------------- diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs index 5729128126..90eec24f74 100644 --- a/compiler/GHC/Stg/DepAnal.hs +++ b/compiler/GHC/Stg/DepAnal.hs @@ -5,13 +5,13 @@ module GHC.Stg.DepAnal (depSortStgPgm) where import GhcPrelude import GHC.Stg.Syntax -import Id -import Name (Name, nameIsLocalOrFrom) -import NameEnv +import GHC.Types.Id +import GHC.Types.Name (Name, nameIsLocalOrFrom) +import GHC.Types.Name.Env import Outputable -import UniqSet (nonDetEltsUniqSet) -import VarSet -import Module (Module) +import GHC.Types.Unique.Set (nonDetEltsUniqSet) +import GHC.Types.Var.Set +import GHC.Types.Module (Module) import Data.Graph (SCC (..)) diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs index 6bd219d7a3..e323775c5f 100644 --- a/compiler/GHC/Stg/FVs.hs +++ b/compiler/GHC/Stg/FVs.hs @@ -45,8 +45,8 @@ module GHC.Stg.FVs ( import GhcPrelude import GHC.Stg.Syntax -import Id -import VarSet +import GHC.Types.Id +import GHC.Types.Var.Set import GHC.Core ( Tickish(Breakpoint) ) import Outputable import Util diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs index a0223707d7..f90ef519fe 100644 --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -19,17 +19,17 @@ where import GhcPrelude -import BasicTypes +import GHC.Types.Basic import GHC.Driver.Session -import Id +import GHC.Types.Id import GHC.Stg.FVs ( annBindingFreeVars ) import GHC.Stg.Lift.Analysis import GHC.Stg.Lift.Monad import GHC.Stg.Syntax import Outputable -import UniqSupply +import GHC.Types.Unique.Supply import Util -import VarSet +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 cc477e0eaa..13778237ea 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -23,10 +23,10 @@ module GHC.Stg.Lift.Analysis ( import GhcPrelude import GHC.Platform -import BasicTypes -import Demand +import GHC.Types.Basic +import GHC.Types.Demand import GHC.Driver.Session -import Id +import GHC.Types.Id import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Stg.Syntax import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep @@ -34,7 +34,7 @@ import qualified GHC.StgToCmm.Closure as StgToCmm.Closure import qualified GHC.StgToCmm.Layout as StgToCmm.Layout import Outputable import Util -import VarSet +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 8c0a6d27fc..28ec3e1e69 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -24,21 +24,21 @@ module GHC.Stg.Lift.Monad ( import GhcPrelude -import BasicTypes -import CostCentre ( isCurrentCCS, dontCareCCS ) +import GHC.Types.Basic +import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS ) import GHC.Driver.Session import FastString -import Id -import Name +import GHC.Types.Id +import GHC.Types.Name import Outputable import OrdList import GHC.Stg.Subst import GHC.Stg.Syntax import GHC.Core.Type -import UniqSupply +import GHC.Types.Unique.Supply import Util -import VarEnv -import VarSet +import GHC.Types.Var.Env +import GHC.Types.Var.Set import Control.Arrow ( second ) import Control.Monad.Trans.Class @@ -271,7 +271,7 @@ withLiftedBndr abs_ids bndr inner = do let str = "$l" ++ occNameString (getOccName bndr) let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr) let bndr' - -- See Note [transferPolyIdInfo] in Id.hs. We need to do this at least + -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least -- for arity information. = transferPolyIdInfo bndr (dVarSetElems abs_ids) . mkSysLocal (mkFastString str) uniq diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 3d06815832..bf4cfce443 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -42,20 +42,20 @@ import GhcPrelude import GHC.Stg.Syntax import GHC.Driver.Session -import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) -import BasicTypes ( TopLevelFlag(..), isTopLevel ) -import CostCentre ( isCurrentCCS ) -import Id ( Id, idType, isJoinId, idName ) -import VarSet +import 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 ) +import GHC.Types.Var.Set import GHC.Core.DataCon -import GHC.Core ( AltCon(..) ) -import Name ( getSrcLoc, nameIsLocalOrFrom ) -import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) +import GHC.Core ( AltCon(..) ) +import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) +import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) import GHC.Core.Type import GHC.Types.RepType -import SrcLoc +import GHC.Types.SrcLoc import Outputable -import Module ( Module ) +import GHC.Types.Module ( Module ) import qualified ErrUtils as Err import Control.Applicative ((<|>)) import Control.Monad diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index 457466291d..4b463cb95e 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -23,11 +23,11 @@ import GHC.Stg.DepAnal ( depSortStgPgm ) import GHC.Stg.Unarise ( unarise ) import GHC.Stg.CSE ( stgCse ) import GHC.Stg.Lift ( stgLiftLams ) -import Module ( Module ) +import GHC.Types.Module ( Module ) import GHC.Driver.Session import ErrUtils -import UniqSupply +import GHC.Types.Unique.Supply import Outputable import Control.Monad import Control.Monad.IO.Class diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs index 8a4fa7561b..c2d546d587 100644 --- a/compiler/GHC/Stg/Stats.hs +++ b/compiler/GHC/Stg/Stats.hs @@ -31,7 +31,7 @@ import GhcPrelude import GHC.Stg.Syntax -import Id (Id) +import GHC.Types.Id (Id) import Panic import Data.Map (Map) diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs index aa07c48b36..abbbfb0fd7 100644 --- a/compiler/GHC/Stg/Subst.hs +++ b/compiler/GHC/Stg/Subst.hs @@ -6,8 +6,8 @@ module GHC.Stg.Subst where import GhcPrelude -import Id -import VarEnv +import GHC.Types.Id +import GHC.Types.Var.Env import Control.Monad.Trans.State.Strict import Outputable import Util diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 534cdbfbcb..e31327c06c 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -64,22 +64,22 @@ module GHC.Stg.Syntax ( import GhcPrelude import GHC.Core ( AltCon, Tickish ) -import CostCentre ( CostCentreStack ) +import GHC.Types.CostCentre ( CostCentreStack ) import Data.ByteString ( ByteString ) import Data.Data ( Data ) import Data.List ( intersperse ) import GHC.Core.DataCon import GHC.Driver.Session -import ForeignCall ( ForeignCall ) -import Id -import VarSet -import Literal ( Literal, literalType ) -import Module ( Module ) +import GHC.Types.ForeignCall ( ForeignCall ) +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Literal ( Literal, literalType ) +import GHC.Types.Module ( Module ) import Outputable import GHC.Driver.Packages ( isDynLinkName ) import GHC.Platform import GHC.Core.Ppr( {- instances -} ) -import PrimOp ( PrimOp, PrimCall ) +import PrimOp ( PrimOp, PrimCall ) import GHC.Core.TyCon ( PrimRep(..), TyCon ) import GHC.Core.Type ( Type ) import GHC.Types.RepType ( typePrimRep1 ) diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index 98738470b2..6e163ab3e9 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -202,14 +202,14 @@ module GHC.Stg.Unarise (unarise) where import GhcPrelude -import BasicTypes +import GHC.Types.Basic import GHC.Core import GHC.Core.DataCon import FastString (FastString, mkFastString) -import Id -import Literal +import GHC.Types.Id +import GHC.Types.Literal import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) -import MkId (voidPrimId, voidArgId) +import GHC.Types.Id.Make (voidPrimId, voidArgId) import MonadUtils (mapAccumLM) import Outputable import GHC.Types.RepType @@ -217,9 +217,9 @@ import GHC.Stg.Syntax import GHC.Core.Type import TysPrim (intPrimTy,wordPrimTy,word64PrimTy) import TysWiredIn -import UniqSupply +import GHC.Types.Unique.Supply import Util -import VarEnv +import GHC.Types.Var.Env import Data.Bifunctor (second) import Data.Maybe (mapMaybe) diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 31ebdede81..4c4b5b5a9e 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -34,17 +34,17 @@ import GHC.Driver.Session import ErrUtils import GHC.Driver.Types -import CostCentre -import Id -import IdInfo +import GHC.Types.CostCentre +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon -import Module +import GHC.Types.Module import Outputable import Stream -import BasicTypes -import VarSet ( isEmptyDVarSet ) +import GHC.Types.Basic +import GHC.Types.Var.Set ( isEmptyDVarSet ) import OrdList import GHC.Cmm.Graph diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs index 2839a2ff56..a36aa4c268 100644 --- a/compiler/GHC/StgToCmm/ArgRep.hs +++ b/compiler/GHC/StgToCmm/ArgRep.hs @@ -20,13 +20,12 @@ module GHC.StgToCmm.ArgRep ( import GhcPrelude import GHC.Platform -import GHC.StgToCmm.Closure ( idPrimRep ) - +import GHC.StgToCmm.Closure ( idPrimRep ) import GHC.Runtime.Heap.Layout ( WordOff ) -import Id ( Id ) -import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) -import BasicTypes ( RepArity ) -import Constants ( wORD64_SIZE, dOUBLE_SIZE ) +import GHC.Types.Id ( Id ) +import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) +import GHC.Types.Basic ( RepArity ) +import Constants ( wORD64_SIZE, dOUBLE_SIZE ) import Outputable import FastString diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index d60e2805d4..8db97d8083 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -38,15 +38,15 @@ import GHC.Cmm.Info import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Stg.Syntax -import CostCentre -import Id -import IdInfo -import Name -import Module +import GHC.Types.CostCentre +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Module import ListSetOps import Util -import VarSet -import BasicTypes +import GHC.Types.Var.Set +import GHC.Types.Basic import Outputable import FastString import GHC.Driver.Session diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 7bb73111a9..3aa9dc8ef4 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -71,19 +71,19 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Ppr.Expr() -- For Outputable instances -import CostCentre +import GHC.Types.CostCentre import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core.DataCon -import Name +import GHC.Types.Name import GHC.Core.Type import GHC.Core.TyCo.Rep import TcType import GHC.Core.TyCon import GHC.Types.RepType -import BasicTypes +import GHC.Types.Basic import Outputable import GHC.Driver.Session import Util diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 2da91879b3..abf88ffbe3 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -34,14 +34,14 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Cmm.Graph import GHC.Runtime.Heap.Layout -import CostCentre -import Module +import GHC.Types.CostCentre +import GHC.Types.Module import GHC.Core.DataCon import GHC.Driver.Session import FastString -import Id +import GHC.Types.Id import GHC.Types.RepType (countConRepArgs) -import Literal +import GHC.Types.Literal import PrelInfo import Outputable import GHC.Platform diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index 47c46eed63..047353b89a 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -38,16 +38,16 @@ import GHC.Cmm.BlockId import GHC.Cmm.Expr import GHC.Cmm.Utils import GHC.Driver.Session -import Id +import GHC.Types.Id import GHC.Cmm.Graph -import Name +import GHC.Types.Name import Outputable import GHC.Stg.Syntax import GHC.Core.Type import TysPrim -import UniqFM +import GHC.Types.Unique.FM import Util -import VarEnv +import GHC.Types.Var.Env ------------------------------------- -- Manipulating CgIdInfo diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index f896b4d598..cb06799316 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -39,13 +39,13 @@ import GHC.Cmm.Info import GHC.Core import GHC.Core.DataCon import GHC.Driver.Session ( mAX_PTR_TAG ) -import ForeignCall -import Id +import GHC.Types.ForeignCall +import GHC.Types.Id import PrimOp import GHC.Core.TyCon -import GHC.Core.Type ( isUnliftedType ) -import GHC.Types.RepType ( isVoidTy, countConRepArgs ) -import CostCentre ( CostCentreStack, currentCCS ) +import GHC.Core.Type ( isUnliftedType ) +import GHC.Types.RepType ( isVoidTy, countConRepArgs ) +import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) import Maybes import Util import FastString diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs index 40472245ed..84195a67d2 100644 --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -49,10 +49,10 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Driver.Session import FastString -import Module -import UniqFM -import Unique -import UniqSupply +import GHC.Types.Module +import GHC.Types.Unique.FM +import GHC.Types.Unique +import GHC.Types.Unique.Supply import Control.Monad (ap) diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index 767e70939b..2a0578327a 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -36,13 +36,13 @@ import GHC.Core.Type import GHC.Types.RepType import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout -import ForeignCall +import GHC.Types.ForeignCall import GHC.Driver.Session import GHC.Platform import Maybes import Outputable -import UniqSupply -import BasicTypes +import GHC.Types.Unique.Supply +import GHC.Types.Basic import GHC.Core.TyCo.Rep import TysPrim diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 740103e3b1..9a66d77c7f 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -41,10 +41,10 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Utils -import CostCentre -import IdInfo( CafInfo(..), mayHaveCafRefs ) -import Id ( Id ) -import Module +import GHC.Types.CostCentre +import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs ) +import GHC.Types.Id ( Id ) +import GHC.Types.Module import GHC.Driver.Session import GHC.Platform import FastString( mkFastString, fsLit ) diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs index 886c0e12e8..1b7305da4e 100644 --- a/compiler/GHC/StgToCmm/Hpc.hs +++ b/compiler/GHC/StgToCmm/Hpc.hs @@ -16,7 +16,7 @@ import GHC.Platform import GHC.Cmm.Graph import GHC.Cmm.Expr import GHC.Cmm.CLabel -import Module +import GHC.Types.Module import GHC.Cmm.Utils import GHC.StgToCmm.Utils import GHC.Driver.Types diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 08e83b84d3..14ec8445c5 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -49,12 +49,12 @@ import GHC.Cmm.Utils import GHC.Cmm.Info import GHC.Cmm.CLabel import GHC.Stg.Syntax -import Id +import GHC.Types.Id import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) -import BasicTypes ( RepArity ) +import GHC.Types.Basic ( RepArity ) import GHC.Driver.Session import GHC.Platform -import Module +import GHC.Types.Module import Util import Data.List diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 9edff8bd66..a23d942c60 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -70,13 +70,13 @@ import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout -import Module -import Id -import VarEnv +import GHC.Types.Module +import GHC.Types.Id +import GHC.Types.Var.Env import OrdList -import BasicTypes( ConTagZ ) -import Unique -import UniqSupply +import GHC.Types.Basic( ConTagZ ) +import GHC.Types.Unique +import GHC.Types.Unique.Supply import FastString import Outputable import Util diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 5b43837417..665fdeb21d 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -37,12 +37,12 @@ import GHC.StgToCmm.Prof ( costCentreFrom ) import GHC.Driver.Session import GHC.Platform -import BasicTypes +import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm -import Module ( rtsUnitId ) +import GHC.Types.Module ( rtsUnitId ) import GHC.Core.Type ( Type, tyConAppTyCon ) import GHC.Core.TyCon import GHC.Cmm.CLabel diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index c97bd793be..54e49eee87 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -36,10 +36,10 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel -import CostCentre +import GHC.Types.CostCentre import GHC.Driver.Session import FastString -import Module +import GHC.Types.Module as Module import Outputable import Control.Monad diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index c472a2815b..d6cea4206c 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -120,10 +120,10 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout -import Module -import Name -import Id -import BasicTypes +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Basic import FastString import Outputable import Util diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 178572eb64..1f439db546 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -64,22 +64,22 @@ import GHC.Cmm.Utils hiding (mkDataLits, mkRODataLits, mkByteStringCLit) import GHC.Cmm.Switch import GHC.StgToCmm.CgUtils -import ForeignCall -import IdInfo +import GHC.Types.ForeignCall +import GHC.Types.Id.Info import GHC.Core.Type import GHC.Core.TyCon import GHC.Runtime.Heap.Layout -import Module -import Literal +import GHC.Types.Module +import GHC.Types.Literal import Digraph import Util -import Unique -import UniqSupply (MonadUnique(..)) +import GHC.Types.Unique +import GHC.Types.Unique.Supply (MonadUnique(..)) import GHC.Driver.Session import FastString import Outputable import GHC.Types.RepType -import CostCentre +import GHC.Types.CostCentre import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index b881186799..4eb52b4970 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -28,21 +28,21 @@ import GhcPrelude import GHC.Hs as Hs import PrelNames -import RdrName -import qualified Name -import Module +import GHC.Types.Name.Reader +import qualified GHC.Types.Name as Name +import GHC.Types.Module import RdrHsSyn -import OccName -import SrcLoc +import GHC.Types.Name.Occurrence as OccName +import GHC.Types.SrcLoc import GHC.Core.Type import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import TysWiredIn -import BasicTypes as Hs -import ForeignCall -import Unique +import GHC.Types.Basic as Hs +import GHC.Types.ForeignCall +import GHC.Types.Unique import ErrUtils import Bag -import Lexeme +import GHC.Utils.Lexeme import Util import FastString import Outputable diff --git a/compiler/GHC/Types/Annotations.hs b/compiler/GHC/Types/Annotations.hs new file mode 100644 index 0000000000..4dde431ab5 --- /dev/null +++ b/compiler/GHC/Types/Annotations.hs @@ -0,0 +1,142 @@ +-- | +-- Support for source code annotation feature of GHC. That is the ANN pragma. +-- +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +{-# LANGUAGE DeriveFunctor #-} +module GHC.Types.Annotations ( + -- * Main Annotation data types + Annotation(..), AnnPayload, + AnnTarget(..), CoreAnnTarget, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, + findAnns, findAnnsByTypeRep, + deserializeAnns + ) where + +import GhcPrelude + +import 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.Serialized + +import Control.Monad +import Data.Maybe +import Data.Typeable +import Data.Word ( Word8 ) + + +-- | Represents an annotation after it has been sufficiently desugared from +-- it's initial form of 'HsDecls.AnnDecl' +data Annotation = Annotation { + ann_target :: CoreAnnTarget, -- ^ The target of the annotation + ann_value :: AnnPayload + } + +type AnnPayload = Serialized -- ^ The "payload" of an annotation + -- allows recovery of its value at a given type, + -- and can be persisted to an interface file + +-- | An annotation target +data AnnTarget name + = NamedTarget name -- ^ We are annotating something with a name: + -- a type or identifier + | ModuleTarget Module -- ^ We are annotating a particular module + deriving (Functor) + +-- | The kind of annotation target found in the middle end of the compiler +type CoreAnnTarget = AnnTarget Name + +instance Outputable name => Outputable (AnnTarget name) where + ppr (NamedTarget nm) = text "Named target" <+> ppr nm + ppr (ModuleTarget mod) = text "Module target" <+> ppr mod + +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> liftM NamedTarget $ get bh + _ -> liftM ModuleTarget $ get bh + +instance Outputable Annotation where + ppr ann = ppr (ann_target ann) + +-- | A collection of annotations +data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload]) + , ann_name_env :: !(NameEnv [AnnPayload]) + } + +-- | An empty annotation environment. +emptyAnnEnv :: AnnEnv +emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv + +-- | Construct a new annotation environment that contains the list of +-- annotations provided. +mkAnnEnv :: [Annotation] -> AnnEnv +mkAnnEnv = extendAnnEnvList emptyAnnEnv + +-- | Add the given annotation to the environment. +extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv +extendAnnEnvList env = + foldl' extendAnnEnv env + +extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv +extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) = + case tgt of + NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload]) + ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env + +-- | Union two annotation environments. +plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv +plusAnnEnv a b = + MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b) + , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b) + } + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] +findAnns deserialize env + = mapMaybe (fromSerialized deserialize) . findAnnPayloads env + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] +findAnnsByTypeRep env target tyrep + = [ ws | Serialized tyrep' ws <- findAnnPayloads env target + , tyrep' == tyrep ] + +-- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'. +findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload] +findAnnPayloads env target = + case target of + ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod + NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name + +-- | Deserialize all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a]) +deserializeAnns deserialize env + = ( mapModuleEnv deserAnns (ann_mod_env env) + , mapNameEnv deserAnns (ann_name_env env) + ) + where deserAnns = mapMaybe (fromSerialized deserialize) + diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs new file mode 100644 index 0000000000..8730ce2e88 --- /dev/null +++ b/compiler/GHC/Types/Avail.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- +-- (c) The University of Glasgow +-- + +#include "HsVersions.h" + +module GHC.Types.Avail ( + Avails, + AvailInfo(..), + avail, + availsToNameSet, + availsToNameSetWithSelectors, + availsToNameEnv, + availName, availNames, availNonFldNames, + availNamesWithSelectors, + availFlds, + availsNamesWithOccs, + availNamesWithOccs, + stableAvailCmp, + plusAvail, + trimAvail, + filterAvail, + filterAvails, + nubAvails + + + ) where + +import GhcPrelude + +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 Data.Data ( Data ) +import Data.List ( find ) +import Data.Function + +-- ----------------------------------------------------------------------------- +-- The AvailInfo type + +-- | Records what things are \"available\", i.e. in scope +data AvailInfo + + -- | An ordinary identifier in scope + = Avail Name + + -- | A type or class in scope + -- + -- The __AvailTC Invariant__: If the type or class is itself to be in scope, + -- it must be /first/ in this list. Thus, typically: + -- + -- > AvailTC Eq [Eq, ==, \/=] [] + | AvailTC + Name -- ^ The name of the type or class + [Name] -- ^ The available pieces of type or class, + -- excluding field selectors. + [FieldLabel] -- ^ The record fields of the type + -- (see Note [Representing fields in AvailInfo]). + + deriving ( Eq -- ^ Used when deciding if the interface has changed + , Data ) + +-- | A collection of 'AvailInfo' - several things that are \"available\" +type Avails = [AvailInfo] + +{- +Note [Representing fields in AvailInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -XDuplicateRecordFields is disabled (the normal case), a +datatype like + + data T = MkT { foo :: Int } + +gives rise to the AvailInfo + + AvailTC T [T, MkT] [FieldLabel "foo" False foo] + +whereas if -XDuplicateRecordFields is enabled it gives + + AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] + +since the label does not match the selector name. + +The labels in a field list are not necessarily unique: +data families allow the same parent (the family tycon) to have +multiple distinct fields with the same label. For example, + + data family F a + data instance F Int = MkFInt { foo :: Int } + data instance F Bool = MkFBool { foo :: Bool} + +gives rise to + + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" True $sel:foo:MkFBool ] + +Moreover, note that the flIsOverloaded flag need not be the same for +all the elements of the list. In the example above, this occurs if +the two data instances are defined in different modules, one with +`-XDuplicateRecordFields` enabled and one with it disabled. Thus it +is possible to have + + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" False foo ] + +If the two data instances are defined in different modules, both +without `-XDuplicateRecordFields`, it will be impossible to export +them from the same module (even with `-XDuplicateRecordfields` +enabled), because they would be represented identically. The +workaround here is to enable `-XDuplicateRecordFields` on the defining +modules. +-} + +-- | Compare lexicographically +stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering +stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 +stableAvailCmp (Avail {}) (AvailTC {}) = LT +stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = + (n `stableNameCmp` m) `thenCmp` + (cmpList stableNameCmp ns ms) `thenCmp` + (cmpList (stableNameCmp `on` flSelector) nfs mfs) +stableAvailCmp (AvailTC {}) (Avail {}) = GT + +avail :: Name -> AvailInfo +avail n = Avail n + +-- ----------------------------------------------------------------------------- +-- Operations on AvailInfo + +availsToNameSet :: [AvailInfo] -> NameSet +availsToNameSet avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNames avail) + +availsToNameSetWithSelectors :: [AvailInfo] -> NameSet +availsToNameSetWithSelectors avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNamesWithSelectors avail) + +availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo +availsToNameEnv avails = foldr add emptyNameEnv avails + where add avail env = extendNameEnvList env + (zip (availNames avail) (repeat avail)) + +-- | Just the main name made available, i.e. not the available pieces +-- of type or class brought into scope by the 'GenAvailInfo' +availName :: AvailInfo -> Name +availName (Avail n) = n +availName (AvailTC n _ _) = n + +-- | All names made available by the availability information (excluding overloaded selectors) +availNames :: AvailInfo -> [Name] +availNames (Avail n) = [n] +availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] + +-- | All names made available by the availability information (including overloaded selectors) +availNamesWithSelectors :: AvailInfo -> [Name] +availNamesWithSelectors (Avail n) = [n] +availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs + +-- | Names for non-fields made available by the availability information +availNonFldNames :: AvailInfo -> [Name] +availNonFldNames (Avail n) = [n] +availNonFldNames (AvailTC _ ns _) = ns + +-- | Fields made available by the availability information +availFlds :: AvailInfo -> [FieldLabel] +availFlds (AvailTC _ _ fs) = fs +availFlds _ = [] + +availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] +availsNamesWithOccs = concatMap availNamesWithOccs + +-- | 'Name's made available by the availability information, paired with +-- the 'OccName' used to refer to each one. +-- +-- When @DuplicateRecordFields@ is in use, the 'Name' may be the +-- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the +-- 'OccName' will be the label of the field (e.g. @foo@). +-- +-- See Note [Representing fields in AvailInfo]. +availNamesWithOccs :: AvailInfo -> [(Name, OccName)] +availNamesWithOccs (Avail n) = [(n, nameOccName n)] +availNamesWithOccs (AvailTC _ ns fs) + = [ (n, nameOccName n) | n <- ns ] ++ + [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] + +-- ----------------------------------------------------------------------------- +-- Utility + +plusAvail :: AvailInfo -> AvailInfo -> AvailInfo +plusAvail a1 a2 + | debugIsOn && availName a1 /= availName a2 + = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) +plusAvail a1@(Avail {}) (Avail {}) = a1 +plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 +plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) + = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first + (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) + (fs1 `unionLists` fs2) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) + (fs1 `unionLists` fs2) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) + (fs1 `unionLists` fs2) + (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) + (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) + = AvailTC n1 ss1 (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) + = AvailTC n1 ss2 (fs1 `unionLists` fs2) +plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) + +-- | trims an 'AvailInfo' to keep only a single name +trimAvail :: AvailInfo -> Name -> AvailInfo +trimAvail (Avail n) _ = Avail n +trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of + Just x -> AvailTC n [] [x] + Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] + +-- | filters 'AvailInfo's by the given predicate +filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] +filterAvails keep avails = foldr (filterAvail keep) [] avails + +-- | filters an 'AvailInfo' by the given predicate +filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] +filterAvail keep ie rest = + case ie of + Avail n | keep n -> ie : rest + | otherwise -> rest + AvailTC tc ns fs -> + let ns' = filter keep ns + fs' = filter (keep . flSelector) fs in + if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest + + +-- | Combines 'AvailInfo's from the same family +-- 'avails' may have several items with the same availName +-- E.g import Ix( Ix(..), index ) +-- will give Ix(Ix,index,range) and Ix(index) +-- We want to combine these; addAvail does that +nubAvails :: [AvailInfo] -> [AvailInfo] +nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) + where + add env avail = extendNameEnv_C plusAvail env (availName avail) avail + +-- ----------------------------------------------------------------------------- +-- Printing + +instance Outputable AvailInfo where + ppr = pprAvail + +pprAvail :: AvailInfo -> SDoc +pprAvail (Avail n) + = ppr n +pprAvail (AvailTC n ns fs) + = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi + , fsep (punctuate comma (map (ppr . flLabel) fs))]) + +instance Binary AvailInfo where + put_ bh (Avail aa) = do + putByte bh 0 + put_ bh aa + put_ bh (AvailTC ab ac ad) = do + putByte bh 1 + put_ bh ab + put_ bh ac + put_ bh ad + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Avail aa) + _ -> do ab <- get bh + ac <- get bh + ad <- get bh + return (AvailTC ab ac ad) diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs new file mode 100644 index 0000000000..03988d9028 --- /dev/null +++ b/compiler/GHC/Types/Basic.hs @@ -0,0 +1,1736 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +\section[BasicTypes]{Miscellaneous types} + +This module defines a miscellaneously collection of very simple +types that + +\begin{itemize} +\item have no other obvious home +\item don't depend on any other complicated types +\item are used in more than one "part" of the compiler +\end{itemize} +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Types.Basic ( + Version, bumpVersion, initialVersion, + + LeftOrRight(..), + pickLR, + + ConTag, ConTagZ, fIRST_TAG, + + Arity, RepArity, JoinArity, + + Alignment, mkAlignment, alignmentOf, alignmentBytes, + + PromotionFlag(..), isPromoted, + FunctionOrData(..), + + WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), + + Fixity(..), FixityDirection(..), + defaultFixity, maxPrecedence, minPrecedence, + negateFixity, funTyFixity, + compareFixity, + LexicalFixity(..), + + RecFlag(..), isRec, isNonRec, boolToRecFlag, + Origin(..), isGenerated, + + RuleName, pprRuleName, + + TopLevelFlag(..), isTopLevel, isNotTopLevel, + + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, + + Boxity(..), isBoxed, + + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec, + maybeParen, + + TupleSort(..), tupleSortBoxity, boxityTupleSort, + tupleParens, + + sumParens, pprAlternative, + + -- ** The OneShotInfo type + OneShotInfo(..), + noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, + bestOneShot, worstOneShot, + + OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, + strongLoopBreaker, weakLoopBreaker, + + InsideLam(..), + OneBranch(..), + InterestingCxt(..), + TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, + isAlwaysTailCalled, + + EP(..), + + DefMethSpec(..), + SwapFlag(..), flipSwap, unSwap, isSwapped, + + CompilerPhase(..), PhaseNum, + + Activation(..), isActive, isActiveIn, competesWith, + isNeverActive, isAlwaysActive, isEarlyActive, + activeAfterInitial, activeDuringFinal, + + RuleMatchInfo(..), isConLike, isFunLike, + InlineSpec(..), noUserInlineSpec, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, + isInlinePragma, isInlinablePragma, isAnyInlinePragma, + inlinePragmaSpec, inlinePragmaSat, + inlinePragmaActivation, inlinePragmaRuleMatchInfo, + setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, + pprInline, pprInlineDebug, + + SuccessFlag(..), succeeded, failed, successIf, + + IntegralLit(..), FractionalLit(..), + negateIntegralLit, negateFractionalLit, + mkIntegralLit, mkFractionalLit, + integralFractionalLit, + + SourceText(..), pprWithSourceText, + + IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, + + SpliceExplicitFlag(..), + + TypeOrKind(..), isTypeLevel, isKindLevel + ) where + +import GhcPrelude + +import FastString +import Outputable +import GHC.Types.SrcLoc ( Located,unLoc ) +import Data.Data hiding (Fixity, Prefix, Infix) +import Data.Function (on) +import Data.Bits +import qualified Data.Semigroup as Semi + +{- +************************************************************************ +* * + Binary choice +* * +************************************************************************ +-} + +data LeftOrRight = CLeft | CRight + deriving( Eq, Data ) + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r + +instance Outputable LeftOrRight where + ppr CLeft = text "Left" + ppr CRight = text "Right" + +{- +************************************************************************ +* * +\subsection[Arity]{Arity} +* * +************************************************************************ +-} + +-- | The number of value arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has arity 0 +-- \x -> fib x has arity 1 +-- See also Note [Definition of arity] in GHC.Core.Arity +type Arity = Int + +-- | Representation Arity +-- +-- The number of represented arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has representation arity 0 +-- \x -> fib x has representation arity 1 +-- \(# x, y #) -> fib (x + y) has representation arity 2 +type RepArity = Int + +-- | The number of arguments that a join point takes. Unlike the arity of a +-- function, this is a purely syntactic property and is fixed when the join +-- point is created (or converted from a value). Both type and value arguments +-- are counted. +type JoinArity = Int + +{- +************************************************************************ +* * + Constructor tags +* * +************************************************************************ +-} + +-- | Constructor Tag +-- +-- Type of the tags associated with each constructor possibility or superclass +-- selector +type ConTag = Int + +-- | A *zero-indexed* constructor tag +type ConTagZ = Int + +fIRST_TAG :: ConTag +-- ^ Tags are allocated from here for real constructors +-- or for superclass selectors +fIRST_TAG = 1 + +{- +************************************************************************ +* * +\subsection[Alignment]{Alignment} +* * +************************************************************************ +-} + +-- | A power-of-two alignment +newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord) + +-- Builds an alignment, throws on non power of 2 input. This is not +-- ideal, but convenient for internal use and better then silently +-- passing incorrect data. +mkAlignment :: Int -> Alignment +mkAlignment n + | n == 1 = Alignment 1 + | n == 2 = Alignment 2 + | n == 4 = Alignment 4 + | n == 8 = Alignment 8 + | n == 16 = Alignment 16 + | n == 32 = Alignment 32 + | n == 64 = Alignment 64 + | n == 128 = Alignment 128 + | n == 256 = Alignment 256 + | n == 512 = Alignment 512 + | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512" + +-- Calculates an alignment of a number. x is aligned at N bytes means +-- the remainder from x / N is zero. Currently, interested in N <= 8, +-- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX +-- context. +alignmentOf :: Int -> Alignment +alignmentOf x = case x .&. 7 of + 0 -> Alignment 8 + 4 -> Alignment 4 + 2 -> Alignment 2 + _ -> Alignment 1 + +instance Outputable Alignment where + ppr (Alignment m) = ppr m +{- +************************************************************************ +* * + One-shot information +* * +************************************************************************ +-} + +-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound +-- variable info. Sometimes we know whether the lambda binding this variable +-- is a \"one-shot\" lambda; that is, whether it is applied at most once. +-- +-- This information may be useful in optimisation, as computations may +-- safely be floated inside such a lambda without risk of duplicating +-- work. +data OneShotInfo + = NoOneShotInfo -- ^ No information + | OneShotLam -- ^ The lambda is applied at most once. + deriving (Eq) + +-- | It is always safe to assume that an 'Id' has no lambda-bound variable information +noOneShotInfo :: OneShotInfo +noOneShotInfo = NoOneShotInfo + +isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool +isOneShotInfo OneShotLam = True +isOneShotInfo _ = False + +hasNoOneShotInfo NoOneShotInfo = True +hasNoOneShotInfo _ = False + +worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo +worstOneShot NoOneShotInfo _ = NoOneShotInfo +worstOneShot OneShotLam os = os + +bestOneShot NoOneShotInfo os = os +bestOneShot OneShotLam _ = OneShotLam + +pprOneShotInfo :: OneShotInfo -> SDoc +pprOneShotInfo NoOneShotInfo = empty +pprOneShotInfo OneShotLam = text "OneShot" + +instance Outputable OneShotInfo where + ppr = pprOneShotInfo + +{- +************************************************************************ +* * + Swap flag +* * +************************************************************************ +-} + +data SwapFlag + = NotSwapped -- Args are: actual, expected + | IsSwapped -- Args are: expected, actual + +instance Outputable SwapFlag where + ppr IsSwapped = text "Is-swapped" + ppr NotSwapped = text "Not-swapped" + +flipSwap :: SwapFlag -> SwapFlag +flipSwap IsSwapped = NotSwapped +flipSwap NotSwapped = IsSwapped + +isSwapped :: SwapFlag -> Bool +isSwapped IsSwapped = True +isSwapped NotSwapped = False + +unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b +unSwap NotSwapped f a b = f a b +unSwap IsSwapped f a b = f b a + + +{- ********************************************************************* +* * + Promotion flag +* * +********************************************************************* -} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + deriving ( Eq, Data ) + +isPromoted :: PromotionFlag -> Bool +isPromoted IsPromoted = True +isPromoted NotPromoted = False + +instance Outputable PromotionFlag where + ppr NotPromoted = text "NotPromoted" + ppr IsPromoted = text "IsPromoted" + +{- +************************************************************************ +* * +\subsection[FunctionOrData]{FunctionOrData} +* * +************************************************************************ +-} + +data FunctionOrData = IsFunction | IsData + deriving (Eq, Ord, Data) + +instance Outputable FunctionOrData where + ppr IsFunction = text "(function)" + ppr IsData = text "(data)" + +{- +************************************************************************ +* * +\subsection[Version]{Module and identifier version numbers} +* * +************************************************************************ +-} + +type Version = Int + +bumpVersion :: Version -> Version +bumpVersion v = v+1 + +initialVersion :: Version +initialVersion = 1 + +{- +************************************************************************ +* * + Deprecations +* * +************************************************************************ +-} + +-- | A String Literal in the source, including its original raw format for use by +-- source to source manipulation tools. +data StringLiteral = StringLiteral + { sl_st :: SourceText, -- literal raw source. + -- See not [Literal source text] + sl_fs :: FastString -- literal string value + } deriving Data + +instance Eq StringLiteral where + (StringLiteral _ a) == (StringLiteral _ b) = a == b + +instance Outputable StringLiteral where + ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) + +-- | Warning Text +-- +-- reason/explanation from a WARNING or DEPRECATED pragma +data WarningTxt = WarningTxt (Located SourceText) + [Located StringLiteral] + | DeprecatedTxt (Located SourceText) + [Located StringLiteral] + deriving (Eq, Data) + +instance Outputable WarningTxt where + ppr (WarningTxt lsrc ws) + = case unLoc lsrc of + NoSourceText -> pp_ws ws + SourceText src -> text src <+> pp_ws ws <+> text "#-}" + + ppr (DeprecatedTxt lsrc ds) + = case unLoc lsrc of + NoSourceText -> pp_ws ds + SourceText src -> text src <+> pp_ws ds <+> text "#-}" + +pp_ws :: [Located StringLiteral] -> SDoc +pp_ws [l] = ppr $ unLoc l +pp_ws ws + = text "[" + <+> vcat (punctuate comma (map (ppr . unLoc) ws)) + <+> text "]" + + +pprWarningTxtForMsg :: WarningTxt -> SDoc +pprWarningTxtForMsg (WarningTxt _ ws) + = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) +pprWarningTxtForMsg (DeprecatedTxt _ ds) + = text "Deprecated:" <+> + doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ +-} + +type RuleName = FastString + +pprRuleName :: RuleName -> SDoc +pprRuleName rn = doubleQuotes (ftext rn) + +{- +************************************************************************ +* * +\subsection[Fixity]{Fixity info} +* * +************************************************************************ +-} + +------------------------ +data Fixity = Fixity SourceText Int FixityDirection + -- Note [Pragma source text] + deriving Data + +instance Outputable Fixity where + ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] + +instance Eq Fixity where -- Used to determine if two fixities conflict + (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 + +------------------------ +data FixityDirection = InfixL | InfixR | InfixN + deriving (Eq, Data) + +instance Outputable FixityDirection where + ppr InfixL = text "infixl" + ppr InfixR = text "infixr" + ppr InfixN = text "infix" + +------------------------ +maxPrecedence, minPrecedence :: Int +maxPrecedence = 9 +minPrecedence = 0 + +defaultFixity :: Fixity +defaultFixity = Fixity NoSourceText maxPrecedence InfixL + +negateFixity, funTyFixity :: Fixity +-- Wired-in fixities +negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235 + +{- +Consider + +\begin{verbatim} + a `op1` b `op2` c +\end{verbatim} +@(compareFixity op1 op2)@ tells which way to arrange application, or +whether there's an error. +-} + +compareFixity :: Fixity -> Fixity + -> (Bool, -- Error please + Bool) -- Associate to the right: a op1 (b op2 c) +compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please + where + right = (False, True) + left = (False, False) + error_please = (True, False) + +-- |Captures the fixity of declarations as they are parsed. This is not +-- necessarily the same as the fixity declaration, as the normal fixity may be +-- overridden using parens or backticks. +data LexicalFixity = Prefix | Infix deriving (Data,Eq) + +instance Outputable LexicalFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + +{- +************************************************************************ +* * +\subsection[Top-level/local]{Top-level/not-top level flag} +* * +************************************************************************ +-} + +data TopLevelFlag + = TopLevel + | NotTopLevel + +isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool + +isNotTopLevel NotTopLevel = True +isNotTopLevel TopLevel = False + +isTopLevel TopLevel = True +isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = text "" + ppr NotTopLevel = text "" + +{- +************************************************************************ +* * + Boxity flag +* * +************************************************************************ +-} + +data Boxity + = Boxed + | Unboxed + deriving( Eq, Data ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +instance Outputable Boxity where + ppr Boxed = text "Boxed" + ppr Unboxed = text "Unboxed" + +{- +************************************************************************ +* * + Recursive/Non-Recursive flag +* * +************************************************************************ +-} + +-- | Recursivity Flag +data RecFlag = Recursive + | NonRecursive + deriving( Eq, Data ) + +isRec :: RecFlag -> Bool +isRec Recursive = True +isRec NonRecursive = False + +isNonRec :: RecFlag -> Bool +isNonRec Recursive = False +isNonRec NonRecursive = True + +boolToRecFlag :: Bool -> RecFlag +boolToRecFlag True = Recursive +boolToRecFlag False = NonRecursive + +instance Outputable RecFlag where + ppr Recursive = text "Recursive" + ppr NonRecursive = text "NonRecursive" + +{- +************************************************************************ +* * + Code origin +* * +************************************************************************ +-} + +data Origin = FromSource + | Generated + deriving( Eq, Data ) + +isGenerated :: Origin -> Bool +isGenerated Generated = True +isGenerated FromSource = False + +instance Outputable Origin where + ppr FromSource = text "FromSource" + ppr Generated = text "Generated" + +{- +************************************************************************ +* * + Instance overlap flag +* * +************************************************************************ +-} + +-- | The semantics allowed for overlapping instances for a particular +-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a +-- explanation of the `isSafeOverlap` field. +-- +-- - 'ApiAnnotation.AnnKeywordId' : +-- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or +-- @'\{-\# OVERLAPPING'@ or +-- @'\{-\# OVERLAPS'@ or +-- @'\{-\# INCOHERENT'@, +-- 'ApiAnnotation.AnnClose' @`\#-\}`@, + +-- For details on above see note [Api annotations] in ApiAnnotation +data OverlapFlag = OverlapFlag + { overlapMode :: OverlapMode + , isSafeOverlap :: Bool + } deriving (Eq, Data) + +setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag +setOverlapModeMaybe f Nothing = f +setOverlapModeMaybe f (Just m) = f { overlapMode = m } + +hasIncoherentFlag :: OverlapMode -> Bool +hasIncoherentFlag mode = + case mode of + Incoherent _ -> True + _ -> False + +hasOverlappableFlag :: OverlapMode -> Bool +hasOverlappableFlag mode = + case mode of + Overlappable _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +hasOverlappingFlag :: OverlapMode -> Bool +hasOverlappingFlag mode = + case mode of + Overlapping _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +data OverlapMode -- See Note [Rules for instance lookup] in GHC.Core.InstEnv + = NoOverlap SourceText + -- See Note [Pragma source text] + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + + | Overlapping SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + + | Overlaps SourceText + -- See Note [Pragma source text] + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent SourceText + -- See Note [Pragma source text] + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also note [Incoherent instances] in GHC.Core.InstEnv + + deriving (Eq, Data) + + +instance Outputable OverlapFlag where + ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) + +instance Outputable OverlapMode where + ppr (NoOverlap _) = empty + ppr (Overlappable _) = text "[overlappable]" + ppr (Overlapping _) = text "[overlapping]" + ppr (Overlaps _) = text "[overlap ok]" + ppr (Incoherent _) = text "[incoherent]" + +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = text "[safe]" +pprSafeOverlap False = empty + +{- +************************************************************************ +* * + Precedence +* * +************************************************************************ +-} + +-- | A general-purpose pretty-printing precedence type. +newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) +-- See Note [Precedence in types] + +topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec +topPrec = PprPrec 0 -- No parens +sigPrec = PprPrec 1 -- Explicit type signatures +funPrec = PprPrec 2 -- Function args; no parens for constructor apps + -- See [Type operator precedence] for why both + -- funPrec and opPrec exist. +opPrec = PprPrec 2 -- Infix operator +starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *) + -- See Note [Star kind precedence] +appPrec = PprPrec 4 -- Constructor args; no parens for atomic + +maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + +{- Note [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many pretty-printing functions have type + ppr_ty :: PprPrec -> Type -> SDoc + +The PprPrec gives the binding strength of the context. For example, in + T ty1 ty2 +we will pretty-print 'ty1' and 'ty2' with the call + (ppr_ty appPrec ty) +to indicate that the context is that of an argument of a TyConApp. + +We use this consistently for Type and HsType. + +Note [Type operator precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the +pretty printer follows the following precedence order: + + TyConPrec Type constructor application + TyOpPrec/FunPrec Operator application and function arrow + +We have funPrec and opPrec to represent the precedence of function +arrow and type operators respectively, but currently we implement +funPrec == opPrec, so that we don't distinguish the two. Reason: +it's hard to parse a type like + a ~ b => c * d -> e - f + +By treating opPrec = funPrec we end up with more parens + (a ~ b) => (c * d) -> (e - f) + +But the two are different constructors of PprPrec so we could make +(->) bind more or less tightly if we wanted. + +Note [Star kind precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We parenthesize the (*) kind to avoid two issues: + +1. Printing invalid or incorrect code. + For example, instead of type F @(*) x = x + GHC used to print type F @* x = x + However, (@*) is a type operator, not a kind application. + +2. Printing kinds that are correct but hard to read. + Should Either * Int be read as Either (*) Int + or as (*) Either Int ? + This depends on whether -XStarIsType is enabled, but it would be + easier if we didn't have to check for the flag when reading the code. + +At the same time, we cannot parenthesize (*) blindly. +Consider this Haskell98 kind: ((* -> *) -> *) -> * +With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*) + +The solution is to assign a special precedence to (*), 'starPrec', which is +higher than 'funPrec' but lower than 'appPrec': + + F * * * becomes F (*) (*) (*) + F A * B becomes F A (*) B + Proxy * becomes Proxy (*) + a * -> * becomes a (*) -> * +-} + +{- +************************************************************************ +* * + Tuples +* * +************************************************************************ +-} + +data TupleSort + = BoxedTuple + | UnboxedTuple + | ConstraintTuple + deriving( Eq, Data ) + +instance Outputable TupleSort where + ppr ts = text $ + case ts of + BoxedTuple -> "BoxedTuple" + UnboxedTuple -> "UnboxedTuple" + ConstraintTuple -> "ConstraintTuple" + +tupleSortBoxity :: TupleSort -> Boxity +tupleSortBoxity BoxedTuple = Boxed +tupleSortBoxity UnboxedTuple = Unboxed +tupleSortBoxity ConstraintTuple = Boxed + +boxityTupleSort :: Boxity -> TupleSort +boxityTupleSort Boxed = BoxedTuple +boxityTupleSort Unboxed = UnboxedTuple + +tupleParens :: TupleSort -> SDoc -> SDoc +tupleParens BoxedTuple p = parens p +tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") +tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) + = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) + (parens p) + +{- +************************************************************************ +* * + Sums +* * +************************************************************************ +-} + +sumParens :: SDoc -> SDoc +sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") + +-- | Pretty print an alternative in an unboxed sum e.g. "| a | |". +pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use + -> a -- ^ The things to be pretty printed + -> ConTag -- ^ Alternative (one-based) + -> Arity -- ^ Arity + -> SDoc -- ^ 'SDoc' where the alternative havs been pretty + -- printed and finally packed into a paragraph. +pprAlternative pp x alt arity = + fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) + +{- +************************************************************************ +* * +\subsection[Generic]{Generic flag} +* * +************************************************************************ + +This is the "Embedding-Projection pair" datatype, it contains +two pieces of code (normally either RenamedExpr's or Id's) +If we have a such a pair (EP from to), the idea is that 'from' and 'to' +represents functions of type + + from :: T -> Tring + to :: Tring -> T + +And we should have + + to (from x) = x + +T and Tring are arbitrary, but typically T is the 'main' type while +Tring is the 'representation' type. (This just helps us remember +whether to use 'from' or 'to'. +-} + +-- | Embedding Projection pair +data EP a = EP { fromEP :: a, -- :: T -> Tring + toEP :: a } -- :: Tring -> T + +{- +Embedding-projection pairs are used in several places: + +First of all, each type constructor has an EP associated with it, the +code in EP converts (datatype T) from T to Tring and back again. + +Secondly, when we are filling in Generic methods (in the typechecker, +tcMethodBinds), we are constructing bimaps by induction on the structure +of the type of the method signature. + + +************************************************************************ +* * +\subsection{Occurrence information} +* * +************************************************************************ + +This data type is used exclusively by the simplifier, but it appears in a +SubstResult, which is currently defined in GHC.Types.Var.Env, which is pretty +near the base of the module hierarchy. So it seemed simpler to put the defn of +OccInfo here, safely at the bottom +-} + +-- | identifier Occurrence Information +data OccInfo + = ManyOccs { occ_tail :: !TailCallInfo } + -- ^ There are many occurrences, or unknown occurrences + + | IAmDead -- ^ Marks unused variables. Sometimes useful for + -- lambda and case-bound variables. + + | OneOcc { occ_in_lam :: !InsideLam + , occ_one_br :: !OneBranch + , occ_int_cxt :: !InterestingCxt + , occ_tail :: !TailCallInfo } + -- ^ Occurs exactly once (per branch), not inside a rule + + -- | This identifier breaks a loop of mutually recursive functions. The field + -- marks whether it is only a loop breaker due to a reference in a rule + | IAmALoopBreaker { occ_rules_only :: !RulesOnly + , occ_tail :: !TailCallInfo } + -- Note [LoopBreaker OccInfo] + deriving (Eq) + +type RulesOnly = Bool + +{- +Note [LoopBreaker OccInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + IAmALoopBreaker True <=> A "weak" or rules-only loop breaker + Do not preInlineUnconditionally + + IAmALoopBreaker False <=> A "strong" loop breaker + Do not inline at all + +See OccurAnal Note [Weak loop breakers] +-} + +noOccInfo :: OccInfo +noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } + +isManyOccs :: OccInfo -> Bool +isManyOccs ManyOccs{} = True +isManyOccs _ = False + +seqOccInfo :: OccInfo -> () +seqOccInfo occ = occ `seq` () + +----------------- +-- | Interesting Context +data InterestingCxt + = IsInteresting + -- ^ Function: is applied + -- Data value: scrutinised by a case with at least one non-DEFAULT branch + | NotInteresting + deriving (Eq) + +-- | If there is any 'interesting' identifier occurrence, then the +-- aggregated occurrence info of that identifier is considered interesting. +instance Semi.Semigroup InterestingCxt where + NotInteresting <> x = x + IsInteresting <> _ = IsInteresting + +instance Monoid InterestingCxt where + mempty = NotInteresting + mappend = (Semi.<>) + +----------------- +-- | Inside Lambda +data InsideLam + = IsInsideLam + -- ^ Occurs inside a non-linear lambda + -- Substituting a redex for this occurrence is + -- dangerous because it might duplicate work. + | NotInsideLam + deriving (Eq) + +-- | If any occurrence of an identifier is inside a lambda, then the +-- occurrence info of that identifier marks it as occurring inside a lambda +instance Semi.Semigroup InsideLam where + NotInsideLam <> x = x + IsInsideLam <> _ = IsInsideLam + +instance Monoid InsideLam where + mempty = NotInsideLam + mappend = (Semi.<>) + +----------------- +data OneBranch + = InOneBranch + -- ^ One syntactic occurrence: Occurs in only one case branch + -- so no code-duplication issue to worry about + | MultipleBranches + deriving (Eq) + +----------------- +data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] + | NoTailCallInfo + deriving (Eq) + +tailCallInfo :: OccInfo -> TailCallInfo +tailCallInfo IAmDead = NoTailCallInfo +tailCallInfo other = occ_tail other + +zapOccTailCallInfo :: OccInfo -> OccInfo +zapOccTailCallInfo IAmDead = IAmDead +zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } + +isAlwaysTailCalled :: OccInfo -> Bool +isAlwaysTailCalled occ + = case tailCallInfo occ of AlwaysTailCalled{} -> True + NoTailCallInfo -> False + +instance Outputable TailCallInfo where + ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] + ppr _ = empty + +----------------- +strongLoopBreaker, weakLoopBreaker :: OccInfo +strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo +weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo + +isWeakLoopBreaker :: OccInfo -> Bool +isWeakLoopBreaker (IAmALoopBreaker{}) = True +isWeakLoopBreaker _ = False + +isStrongLoopBreaker :: OccInfo -> Bool +isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True + -- Loop-breaker that breaks a non-rule cycle +isStrongLoopBreaker _ = False + +isDeadOcc :: OccInfo -> Bool +isDeadOcc IAmDead = True +isDeadOcc _ = False + +isOneOcc :: OccInfo -> Bool +isOneOcc (OneOcc {}) = True +isOneOcc _ = False + +zapFragileOcc :: OccInfo -> OccInfo +-- Keep only the most robust data: deadness, loop-breaker-hood +zapFragileOcc (OneOcc {}) = noOccInfo +zapFragileOcc occ = zapOccTailCallInfo occ + +instance Outputable OccInfo where + -- only used for debugging; never parsed. KSW 1999-07 + ppr (ManyOccs tails) = pprShortTailCallInfo tails + ppr IAmDead = text "Dead" + ppr (IAmALoopBreaker rule_only tails) + = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails + where + pp_ro | rule_only = char '!' + | otherwise = empty + ppr (OneOcc inside_lam one_branch int_cxt tail_info) + = text "Once" <> pp_lam inside_lam <> pp_br one_branch <> pp_args int_cxt <> pp_tail + where + pp_lam IsInsideLam = char 'L' + pp_lam NotInsideLam = empty + pp_br MultipleBranches = char '*' + pp_br InOneBranch = empty + pp_args IsInteresting = char '!' + pp_args NotInteresting = empty + pp_tail = pprShortTailCallInfo tail_info + +pprShortTailCallInfo :: TailCallInfo -> SDoc +pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) +pprShortTailCallInfo NoTailCallInfo = empty + +{- +Note [TailCallInfo] +~~~~~~~~~~~~~~~~~~~ +The occurrence analyser determines what can be made into a join point, but it +doesn't change the binder into a JoinId because then it would be inconsistent +with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to +change the IdDetails. + +The AlwaysTailCalled marker actually means slightly more than simply that the +function is always tail-called. See Note [Invariants on join points]. + +This info is quite fragile and should not be relied upon unless the occurrence +analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of +the join-point-hood of a binder; a join id itself will not be marked +AlwaysTailCalled. + +Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that +being tail-called would mean that the variable could only appear once per branch +(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join +point can also be invoked from other join points, not just from case branches: + + let j1 x = ... + j2 y = ... j1 z {- tail call -} ... + in case w of + A -> j1 v + B -> j2 u + C -> j2 q + +Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get +ManyOccs and j2 will get `OneOcc { occ_one_br = True }`. + +************************************************************************ +* * + Default method specification +* * +************************************************************************ + +The DefMethSpec enumeration just indicates what sort of default method +is used for a class. It is generated from source code, and present in +interface files; it is converted to Class.DefMethInfo before begin put in a +Class object. +-} + +-- | Default Method Specification +data DefMethSpec ty + = VanillaDM -- Default method given with polymorphic code + | GenericDM ty -- Default method given with code of this type + +instance Outputable (DefMethSpec ty) where + ppr VanillaDM = text "{- Has default method -}" + ppr (GenericDM {}) = text "{- Has generic default method -}" + +{- +************************************************************************ +* * +\subsection{Success flag} +* * +************************************************************************ +-} + +data SuccessFlag = Succeeded | Failed + +instance Outputable SuccessFlag where + ppr Succeeded = text "Succeeded" + ppr Failed = text "Failed" + +successIf :: Bool -> SuccessFlag +successIf True = Succeeded +successIf False = Failed + +succeeded, failed :: SuccessFlag -> Bool +succeeded Succeeded = True +succeeded Failed = False + +failed Succeeded = False +failed Failed = True + +{- +************************************************************************ +* * +\subsection{Source Text} +* * +************************************************************************ +Keeping Source Text for source to source conversions + +Note [Pragma source text] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer does a case-insensitive match for pragmas, as well as +accepting both UK and US spelling variants. + +So + + {-# SPECIALISE #-} + {-# SPECIALIZE #-} + {-# Specialize #-} + +will all generate ITspec_prag token for the start of the pragma. + +In order to be able to do source to source conversions, the original +source text for the token needs to be preserved, hence the +`SourceText` field. + +So the lexer will then generate + + ITspec_prag "{ -# SPECIALISE" + ITspec_prag "{ -# SPECIALIZE" + ITspec_prag "{ -# Specialize" + +for the cases above. + [without the space between '{' and '-', otherwise this comment won't parse] + + +Note [Literal source text] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer/parser converts literals from their original source text +versions to an appropriate internal representation. This is a problem +for tools doing source to source conversions, so the original source +text is stored in literals where this can occur. + +Motivating examples for HsLit + + HsChar '\n' == '\x20` + HsCharPrim '\x41`# == `A` + HsString "\x20\x41" == " A" + HsStringPrim "\x20"# == " "# + HsInt 001 == 1 + HsIntPrim 002# == 2# + HsWordPrim 003## == 3## + HsInt64Prim 004## == 4## + HsWord64Prim 005## == 5## + HsInteger 006 == 6 + +For OverLitVal + + HsIntegral 003 == 0x003 + HsIsString "\x41nd" == "And" +-} + + -- Note [Literal source text],[Pragma source text] +data SourceText = SourceText String + | NoSourceText -- ^ For when code is generated, e.g. TH, + -- deriving. The pretty printer will then make + -- its own representation of the item. + deriving (Data, Show, Eq ) + +instance Outputable SourceText where + ppr (SourceText s) = text "SourceText" <+> text s + ppr NoSourceText = text "NoSourceText" + +-- | Special combinator for showing string literals. +pprWithSourceText :: SourceText -> SDoc -> SDoc +pprWithSourceText NoSourceText d = d +pprWithSourceText (SourceText src) _ = text src + +{- +************************************************************************ +* * +\subsection{Activation} +* * +************************************************************************ + +When a rule or inlining is active +-} + +-- | Phase Number +type PhaseNum = Int -- Compilation phase + -- Phases decrease towards zero + -- Zero is the last phase + +data CompilerPhase + = Phase PhaseNum + | InitialPhase -- The first phase -- number = infinity! + +instance Outputable CompilerPhase where + ppr (Phase n) = int n + ppr InitialPhase = text "InitialPhase" + +activeAfterInitial :: Activation +-- Active in the first phase after the initial phase +-- Currently we have just phases [2,1,0] +activeAfterInitial = ActiveAfter NoSourceText 2 + +activeDuringFinal :: Activation +-- Active in the final simplification phase (which is repeated) +activeDuringFinal = ActiveAfter NoSourceText 0 + +-- See note [Pragma source text] +data Activation = NeverActive + | AlwaysActive + | ActiveBefore SourceText PhaseNum + -- Active only *strictly before* this phase + | ActiveAfter SourceText PhaseNum + -- Active in this phase and later + deriving( Eq, Data ) + -- Eq used in comparing rules in GHC.Hs.Decls + +-- | Rule Match Information +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] + | FunLike + deriving( Eq, Data, Show ) + -- Show needed for Lexer.x + +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_src :: SourceText -- Note [Pragma source text] + , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] + + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args + -- That is, inl_sat describes the number of *source-code* + -- arguments the thing must be applied to. We add on the + -- number of implicit, dictionary arguments when making + -- the Unfolding, and don't look at inl_sat further + + , inl_act :: Activation -- Says during which phases inlining is allowed + -- See Note [inl_inline and inl_act] + + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq, Data ) + +-- | Inline Specification +data InlineSpec -- What the user's INLINE pragma looked like + = Inline -- User wrote INLINE + | Inlinable -- User wrote INLINABLE + | NoInline -- User wrote NOINLINE + | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE + -- e.g. in `defaultInlinePragma` or when created by CSE + deriving( Eq, Data, Show ) + -- Show needed for Lexer.x + +{- Note [InlinePragma] +~~~~~~~~~~~~~~~~~~~~~~ +This data type mirrors what you can write in an INLINE or NOINLINE pragma in +the source program. + +If you write nothing at all, you get defaultInlinePragma: + inl_inline = NoUserInline + inl_act = AlwaysActive + inl_rule = FunLike + +It's not possible to get that combination by *writing* something, so +if an Id has defaultInlinePragma it means the user didn't specify anything. + +If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. + +If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair + +Note [inl_inline and inl_act] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* inl_inline says what the user wrote: did she say INLINE, NOINLINE, + INLINABLE, or nothing at all + +* inl_act says in what phases the unfolding is active or inactive + E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 + If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 + If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 + So note that inl_act does not say what pragma you wrote: it just + expresses its consequences + +* inl_act just says when the unfolding is active; it doesn't say what + to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, + but in addition f will get a "stable unfolding" with UnfoldingGuidance + that tells the inliner to be pretty eager about it. + +Note [CONLIKE pragma] +~~~~~~~~~~~~~~~~~~~~~ +The ConLike constructor of a RuleMatchInfo is aimed at the following. +Consider first + {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} + g b bs = let x = b:bs in ..x...x...(r x)... +Now, the rule applies to the (r x) term, because GHC "looks through" +the definition of 'x' to see that it is (b:bs). + +Now consider + {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} + g v = let x = f v in ..x...x...(r x)... +Normally the (r x) would *not* match the rule, because GHC would be +scared about duplicating the redex (f v), so it does not "look +through" the bindings. + +However the CONLIKE modifier says to treat 'f' like a constructor in +this situation, and "look through" the unfolding for x. So (r x) +fires, yielding (f (v+1)). + +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} + +The main effects of CONLIKE are: + + - The occurrence analyser (OccAnal) and simplifier (Simplify) treat + CONLIKE thing like constructors, by ANF-ing them + + - New function GHC.Core.Utils.exprIsExpandable is like exprIsCheap, but + additionally spots applications of CONLIKE functions + + - A CoreUnfolding has a field that caches exprIsExpandable + + - The rule matcher consults this field. See + Note [Expanding variables] in GHC.Core.Rules. +-} + +isConLike :: RuleMatchInfo -> Bool +isConLike ConLike = True +isConLike _ = False + +isFunLike :: RuleMatchInfo -> Bool +isFunLike FunLike = True +isFunLike _ = False + +noUserInlineSpec :: InlineSpec -> Bool +noUserInlineSpec NoUserInline = True +noUserInlineSpec _ = False + +defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma + :: InlinePragma +defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = NoUserInline + , inl_sat = Nothing } + +alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } +neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } + +inlinePragmaSpec :: InlinePragma -> InlineSpec +inlinePragmaSpec = inl_inline + +-- A DFun has an always-active inline activation so that +-- exprIsConApp_maybe can "see" its unfolding +-- (However, its actual Unfolding is a DFunUnfolding, which is +-- never inlined other than via exprIsConApp_maybe.) +dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive + , inl_rule = ConLike } + +isDefaultInlinePragma :: InlinePragma -> Bool +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = case inl_inline prag of + Inline -> True + _ -> False + +isInlinablePragma :: InlinePragma -> Bool +isInlinablePragma prag = case inl_inline prag of + Inlinable -> True + _ -> False + +isAnyInlinePragma :: InlinePragma -> Bool +-- INLINE or INLINABLE +isAnyInlinePragma prag = case inl_inline prag of + Inline -> True + Inlinable -> True + _ -> False + +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat + +inlinePragmaActivation :: InlinePragma -> Activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation + +inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info + +setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma +setInlinePragmaActivation prag activation = prag { inl_act = activation } + +setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } + +instance Outputable Activation where + ppr AlwaysActive = empty + ppr NeverActive = brackets (text "~") + ppr (ActiveBefore _ n) = brackets (char '~' <> int n) + ppr (ActiveAfter _ n) = brackets (int n) + +instance Outputable RuleMatchInfo where + ppr ConLike = text "CONLIKE" + ppr FunLike = text "FUNLIKE" + +instance Outputable InlineSpec where + ppr Inline = text "INLINE" + ppr NoInline = text "NOINLINE" + ppr Inlinable = text "INLINABLE" + ppr NoUserInline = text "NOUSERINLINE" -- what is better? + +instance Outputable InlinePragma where + ppr = pprInline + +pprInline :: InlinePragma -> SDoc +pprInline = pprInline' True + +pprInlineDebug :: InlinePragma -> SDoc +pprInlineDebug = pprInline' False + +pprInline' :: Bool -- True <=> do not display the inl_inline field + -> InlinePragma + -> SDoc +pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info + where + pp_inl x = if emptyInline then empty else ppr x + + pp_act Inline AlwaysActive = empty + pp_act NoInline NeverActive = empty + pp_act _ act = ppr act + + pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) + | otherwise = empty + pp_info | isFunLike info = empty + | otherwise = ppr info + +isActive :: CompilerPhase -> Activation -> Bool +isActive InitialPhase AlwaysActive = True +isActive InitialPhase (ActiveBefore {}) = True +isActive InitialPhase _ = False +isActive (Phase p) act = isActiveIn p act + +isActiveIn :: PhaseNum -> Activation -> Bool +isActiveIn _ NeverActive = False +isActiveIn _ AlwaysActive = True +isActiveIn p (ActiveAfter _ n) = p <= n +isActiveIn p (ActiveBefore _ n) = p > n + +competesWith :: Activation -> Activation -> Bool +-- See Note [Activation competition] +competesWith NeverActive _ = False +competesWith _ NeverActive = False +competesWith AlwaysActive _ = True + +competesWith (ActiveBefore {}) AlwaysActive = True +competesWith (ActiveBefore {}) (ActiveBefore {}) = True +competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b + +competesWith (ActiveAfter {}) AlwaysActive = False +competesWith (ActiveAfter {}) (ActiveBefore {}) = False +competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b + +{- Note [Competing activations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes a RULE and an inlining may compete, or two RULES. +See Note [Rules and inlining/other rules] in GHC.HsToCore. + +We say that act1 "competes with" act2 iff + act1 is active in the phase when act2 *becomes* active +NB: remember that phases count *down*: 2, 1, 0! + +It's too conservative to ensure that the two are never simultaneously +active. For example, a rule might be always active, and an inlining +might switch on in phase 2. We could switch off the rule, but it does +no harm. +-} + +isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool +isNeverActive NeverActive = True +isNeverActive _ = False + +isAlwaysActive AlwaysActive = True +isAlwaysActive _ = False + +isEarlyActive AlwaysActive = True +isEarlyActive (ActiveBefore {}) = True +isEarlyActive _ = False + +-- | Integral Literal +-- +-- Used (instead of Integer) to represent negative zegative zero which is +-- required for NegativeLiterals extension to correctly parse `-0::Double` +-- as negative zero. See also #13211. +data IntegralLit + = IL { il_text :: SourceText + , il_neg :: Bool -- See Note [Negative zero] + , il_value :: Integer + } + deriving (Data, Show) + +mkIntegralLit :: Integral a => a -> IntegralLit +mkIntegralLit i = IL { il_text = SourceText (show i_integer) + , il_neg = i < 0 + , il_value = i_integer } + where + i_integer :: Integer + i_integer = toInteger i + +negateIntegralLit :: IntegralLit -> IntegralLit +negateIntegralLit (IL text neg value) + = case text of + SourceText ('-':src) -> IL (SourceText src) False (negate value) + SourceText src -> IL (SourceText ('-':src)) True (negate value) + NoSourceText -> IL NoSourceText (not neg) (negate value) + +-- | Fractional Literal +-- +-- Used (instead of Rational) to represent exactly the floating point literal that we +-- encountered in the user's source program. This allows us to pretty-print exactly what +-- the user wrote, which is important e.g. for floating point numbers that can't represented +-- as Doubles (we used to via Double for pretty-printing). See also #2245. +data FractionalLit + = FL { fl_text :: SourceText -- How the value was written in the source + , fl_neg :: Bool -- See Note [Negative zero] + , fl_value :: Rational -- Numeric value of the literal + } + deriving (Data, Show) + -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on + +mkFractionalLit :: Real a => a -> FractionalLit +mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) + -- Converting to a Double here may technically lose + -- precision (see #15502). We could alternatively + -- convert to a Rational for the most accuracy, but + -- it would cause Floats and Doubles to be displayed + -- strangely, so we opt not to do this. (In contrast + -- to mkIntegralLit, where we always convert to an + -- Integer for the highest accuracy.) + , fl_neg = r < 0 + , fl_value = toRational r } + +negateFractionalLit :: FractionalLit -> FractionalLit +negateFractionalLit (FL text neg value) + = case text of + SourceText ('-':src) -> FL (SourceText src) False value + SourceText src -> FL (SourceText ('-':src)) True value + NoSourceText -> FL NoSourceText (not neg) (negate value) + +integralFractionalLit :: Bool -> Integer -> FractionalLit +integralFractionalLit neg i = FL { fl_text = SourceText (show i), + fl_neg = neg, + fl_value = fromInteger i } + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) + +instance Eq IntegralLit where + (==) = (==) `on` il_value + +instance Ord IntegralLit where + compare = compare `on` il_value + +instance Outputable IntegralLit where + ppr (IL (SourceText src) _ _) = text src + ppr (IL NoSourceText _ value) = text (show value) + +instance Eq FractionalLit where + (==) = (==) `on` fl_value + +instance Ord FractionalLit where + compare = compare `on` fl_value + +instance Outputable FractionalLit where + ppr f = pprWithSourceText (fl_text f) (rational (fl_value f)) + +{- +************************************************************************ +* * + IntWithInf +* * +************************************************************************ + +Represents an integer or positive infinity + +-} + +-- | An integer or infinity +data IntWithInf = Int {-# UNPACK #-} !Int + | Infinity + deriving Eq + +-- | A representation of infinity +infinity :: IntWithInf +infinity = Infinity + +instance Ord IntWithInf where + compare Infinity Infinity = EQ + compare (Int _) Infinity = LT + compare Infinity (Int _) = GT + compare (Int a) (Int b) = a `compare` b + +instance Outputable IntWithInf where + ppr Infinity = char '∞' + ppr (Int n) = int n + +instance Num IntWithInf where + (+) = plusWithInf + (*) = mulWithInf + + abs Infinity = Infinity + abs (Int n) = Int (abs n) + + signum Infinity = Int 1 + signum (Int n) = Int (signum n) + + fromInteger = Int . fromInteger + + (-) = panic "subtracting IntWithInfs" + +intGtLimit :: Int -> IntWithInf -> Bool +intGtLimit _ Infinity = False +intGtLimit n (Int m) = n > m + +-- | Add two 'IntWithInf's +plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf +plusWithInf Infinity _ = Infinity +plusWithInf _ Infinity = Infinity +plusWithInf (Int a) (Int b) = Int (a + b) + +-- | Multiply two 'IntWithInf's +mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf +mulWithInf Infinity _ = Infinity +mulWithInf _ Infinity = Infinity +mulWithInf (Int a) (Int b) = Int (a * b) + +-- | Turn a positive number into an 'IntWithInf', where 0 represents infinity +treatZeroAsInf :: Int -> IntWithInf +treatZeroAsInf 0 = Infinity +treatZeroAsInf n = Int n + +-- | Inject any integer into an 'IntWithInf' +mkIntWithInf :: Int -> IntWithInf +mkIntWithInf = Int + +data SpliceExplicitFlag + = ExplicitSplice | -- ^ <=> $(f x y) + ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression + deriving Data + +{- ********************************************************************* +* * + Types vs Kinds +* * +********************************************************************* -} + +-- | Flag to see whether we're type-checking terms or kind-checking types +data TypeOrKind = TypeLevel | KindLevel + deriving Eq + +instance Outputable TypeOrKind where + ppr TypeLevel = text "TypeLevel" + ppr KindLevel = text "KindLevel" + +isTypeLevel :: TypeOrKind -> Bool +isTypeLevel TypeLevel = True +isTypeLevel KindLevel = False + +isKindLevel :: TypeOrKind -> Bool +isKindLevel TypeLevel = False +isKindLevel KindLevel = True diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs new file mode 100644 index 0000000000..5280d90d31 --- /dev/null +++ b/compiler/GHC/Types/CostCentre.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module GHC.Types.CostCentre ( + CostCentre(..), CcName, CCFlavour(..), + -- All abstract except to friend: ParseIface.y + + CostCentreStack, + CollectedCCs, emptyCollectedCCs, collectCC, + currentCCS, dontCareCCS, + isCurrentCCS, + maybeSingletonCCS, + + mkUserCC, mkAutoCC, mkAllCafsCC, + mkSingletonCCS, + isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, + + pprCostCentreCore, + costCentreUserName, costCentreUserNameFS, + costCentreSrcSpan, + + cmpCostCentre -- used for removing dups in a list + ) where + +import GhcPrelude + +import Binary +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Module +import GHC.Types.Unique +import Outputable +import GHC.Types.SrcLoc +import FastString +import Util +import GHC.Types.CostCentre.State + +import Data.Data + +----------------------------------------------------------------------------- +-- Cost Centres + +-- | A Cost Centre is a single @{-# SCC #-}@ annotation. + +data CostCentre + = NormalCC { + cc_flavour :: CCFlavour, + -- ^ Two cost centres may have the same name and + -- module but different SrcSpans, so we need a way to + -- distinguish them easily and give them different + -- object-code labels. So every CostCentre has an + -- associated flavour that indicates how it was + -- generated, and flavours that allow multiple instances + -- of the same name and module have a deterministic 0-based + -- index. + cc_name :: CcName, -- ^ Name of the cost centre itself + cc_mod :: Module, -- ^ Name of module defining this CC. + cc_loc :: SrcSpan + } + + | AllCafsCC { + cc_mod :: Module, -- Name of module defining this CC. + cc_loc :: SrcSpan + } + deriving Data + +type CcName = FastString + +-- | The flavour of a cost centre. +-- +-- Index fields represent 0-based indices giving source-code ordering of +-- centres with the same module, name, and flavour. +data CCFlavour = CafCC -- ^ Auto-generated top-level thunk + | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression + | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration + | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage + deriving (Eq, Ord, Data) + +-- | Extract the index from a flavour +flavourIndex :: CCFlavour -> Int +flavourIndex CafCC = 0 +flavourIndex (ExprCC x) = unCostCentreIndex x +flavourIndex (DeclCC x) = unCostCentreIndex x +flavourIndex (HpcCC x) = unCostCentreIndex x + +instance Eq CostCentre where + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } + +instance Ord CostCentre where + compare = cmpCostCentre + +cmpCostCentre :: CostCentre -> CostCentre -> Ordering + +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) + = m1 `compare` m2 + +cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1} + NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2} + -- first key is module name, then centre name, then flavour + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2) + +cmpCostCentre other_1 other_2 + = let + tag1 = tag_CC other_1 + tag2 = tag_CC other_2 + in + if tag1 < tag2 then LT else GT + where + tag_CC :: CostCentre -> Int + tag_CC (NormalCC {}) = 0 + tag_CC (AllCafsCC {}) = 1 + + +----------------------------------------------------------------------------- +-- Predicates on CostCentre + +isCafCC :: CostCentre -> Bool +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_flavour = CafCC}) = True +isCafCC _ = False + +-- | Is this a cost-centre which records scc counts +isSccCountCC :: CostCentre -> Bool +isSccCountCC cc | isCafCC cc = False + | otherwise = True + +-- | Is this a cost-centre which can be sccd ? +sccAbleCC :: CostCentre -> Bool +sccAbleCC cc | isCafCC cc = False + | otherwise = True + +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == m + + +----------------------------------------------------------------------------- +-- Building cost centres + +mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre +mkUserCC cc_name mod loc flavour + = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc, + cc_flavour = flavour + } + +mkAutoCC :: Id -> Module -> CostCentre +mkAutoCC id mod + = NormalCC { cc_name = str, cc_mod = mod, + cc_loc = nameSrcSpan (getName id), + cc_flavour = CafCC + } + where + name = getName id + -- beware: only external names are guaranteed to have unique + -- Occnames. If the name is not external, we must append its + -- Unique. + -- See bug #249, tests prof001, prof002, also #2411 + str | isExternalName name = occNameFS (getOccName id) + | otherwise = occNameFS (getOccName id) + `appendFS` + mkFastString ('_' : show (getUnique name)) +mkAllCafsCC :: Module -> SrcSpan -> CostCentre +mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } + +----------------------------------------------------------------------------- +-- Cost Centre Stacks + +-- | A Cost Centre Stack is something that can be attached to a closure. +-- This is either: +-- +-- * the current cost centre stack (CCCS) +-- * a pre-defined cost centre stack (there are several +-- pre-defined CCSs, see below). + +data CostCentreStack + = CurrentCCS -- Pinned on a let(rec)-bound + -- thunk/function/constructor, this says that the + -- cost centre to be attached to the object, when it + -- is allocated, is whatever is in the + -- current-cost-centre-stack register. + + | DontCareCCS -- We need a CCS to stick in static closures + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CCS is it. + + | SingletonCCS CostCentre + + deriving (Eq, Ord) -- needed for Ord on CLabel + + +-- synonym for triple which describes the cost centre info in the generated +-- code for a module. +type CollectedCCs + = ( [CostCentre] -- local cost-centres that need to be decl'd + , [CostCentreStack] -- pre-defined "singleton" cost centre stacks + ) + +emptyCollectedCCs :: CollectedCCs +emptyCollectedCCs = ([], []) + +collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs +collectCC cc ccs (c, cs) = (cc : c, ccs : cs) + +currentCCS, dontCareCCS :: CostCentreStack + +currentCCS = CurrentCCS +dontCareCCS = DontCareCCS + +----------------------------------------------------------------------------- +-- Predicates on Cost-Centre Stacks + +isCurrentCCS :: CostCentreStack -> Bool +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False + +isCafCCS :: CostCentreStack -> Bool +isCafCCS (SingletonCCS cc) = isCafCC cc +isCafCCS _ = False + +maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre +maybeSingletonCCS (SingletonCCS cc) = Just cc +maybeSingletonCCS _ = Nothing + +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = SingletonCCS cc + + +----------------------------------------------------------------------------- +-- Printing Cost Centre Stacks. + +-- The outputable instance for CostCentreStack prints the CCS as a C +-- expression. + +instance Outputable CostCentreStack where + ppr CurrentCCS = text "CCCS" + ppr DontCareCCS = text "CCS_DONT_CARE" + ppr (SingletonCCS cc) = ppr cc <> text "_ccs" + + +----------------------------------------------------------------------------- +-- Printing Cost Centres +-- +-- There are several different ways in which we might want to print a +-- cost centre: +-- +-- - the name of the cost centre, for profiling output (a C string) +-- - the label, i.e. C label for cost centre in .hc file. +-- - the debugging name, for output in -ddump things +-- - the interface name, for printing in _scc_ exprs in iface files. +-- +-- The last 3 are derived from costCentreStr below. The first is given +-- by costCentreName. + +instance Outputable CostCentre where + ppr cc = getPprStyle $ \ sty -> + if codeStyle sty + then ppCostCentreLbl cc + else text (costCentreUserName cc) + +-- Printing in Core +pprCostCentreCore :: CostCentre -> SDoc +pprCostCentreCore (AllCafsCC {cc_mod = m}) + = text "__sccC" <+> braces (ppr m) +pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n, + cc_mod = m, cc_loc = loc}) + = text "__scc" <+> braces (hsep [ + ppr m <> char '.' <> ftext n, + pprFlavourCore flavour, + whenPprDebug (ppr loc) + ]) + +-- ^ Print a flavour in Core +pprFlavourCore :: CCFlavour -> SDoc +pprFlavourCore CafCC = text "__C" +pprFlavourCore f = pprIdxCore $ flavourIndex f + +-- ^ Print a flavour's index in Core +pprIdxCore :: Int -> SDoc +pprIdxCore 0 = empty +pprIdxCore idx = whenPprDebug $ ppr idx + +-- Printing as a C label +ppCostCentreLbl :: CostCentre -> SDoc +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) + = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> + ppFlavourLblComponent f <> text "_cc" + +-- ^ Print the flavour component of a C label +ppFlavourLblComponent :: CCFlavour -> SDoc +ppFlavourLblComponent CafCC = text "CAF" +ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i +ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i +ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i + +-- ^ Print the flavour index component of a C label +ppIdxLblComponent :: CostCentreIndex -> SDoc +ppIdxLblComponent n = + case unCostCentreIndex n of + 0 -> empty + n -> ppr n + +-- This is the name to go in the user-displayed string, +-- recorded in the cost centre declaration +costCentreUserName :: CostCentre -> String +costCentreUserName = unpackFS . costCentreUserNameFS + +costCentreUserNameFS :: CostCentre -> FastString +costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" +costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf}) + = case is_caf of + CafCC -> mkFastString "CAF:" `appendFS` name + _ -> name + +costCentreSrcSpan :: CostCentre -> SrcSpan +costCentreSrcSpan = cc_loc + +instance Binary CCFlavour where + put_ bh CafCC = do + putByte bh 0 + put_ bh (ExprCC i) = do + putByte bh 1 + put_ bh i + put_ bh (DeclCC i) = do + putByte bh 2 + put_ bh i + put_ bh (HpcCC i) = do + putByte bh 3 + put_ bh i + get bh = do + h <- getByte bh + case h of + 0 -> do return CafCC + 1 -> ExprCC <$> get bh + 2 -> DeclCC <$> get bh + _ -> HpcCC <$> get bh + +instance Binary CostCentre where + put_ bh (NormalCC aa ab ac _ad) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh (AllCafsCC ae _af) = do + putByte bh 1 + put_ bh ae + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + ac <- get bh + return (NormalCC aa ab ac noSrcSpan) + _ -> do ae <- get bh + return (AllCafsCC ae noSrcSpan) + + -- We ignore the SrcSpans in CostCentres when we serialise them, + -- and set the SrcSpans to noSrcSpan when deserialising. This is + -- ok, because we only need the SrcSpan when declaring the + -- CostCentre in the original module, it is not used by importing + -- modules. diff --git a/compiler/GHC/Types/CostCentre/Init.hs b/compiler/GHC/Types/CostCentre/Init.hs new file mode 100644 index 0000000000..ad6a95e7ab --- /dev/null +++ b/compiler/GHC/Types/CostCentre/Init.hs @@ -0,0 +1,64 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- Generate code to initialise cost centres +-- +-- ----------------------------------------------------------------------------- + +module GHC.Types.CostCentre.Init (profilingInitCode) where + +import GhcPrelude + +import GHC.Cmm.CLabel +import GHC.Types.CostCentre +import GHC.Driver.Session +import Outputable +import GHC.Types.Module + +-- ----------------------------------------------------------------------------- +-- Initialising cost centres + +-- We must produce declarations for the cost-centres defined in this +-- module; + +profilingInitCode :: Module -> CollectedCCs -> SDoc +profilingInitCode this_mod (local_CCs, singleton_CCSs) + = sdocWithDynFlags $ \dflags -> + if not (gopt Opt_SccProfilingOn dflags) + then empty + else vcat + $ map emit_cc_decl local_CCs + ++ map emit_ccs_decl singleton_CCSs + ++ [emit_cc_list local_CCs] + ++ [emit_ccs_list singleton_CCSs] + ++ [ text "static void prof_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void prof_init_" <> ppr this_mod <> text "(void)" + , braces (vcat + [ text "registerCcList" <> parens local_cc_list_label <> semi + , text "registerCcsList" <> parens singleton_cc_list_label <> semi + ]) + ] + where + emit_cc_decl cc = + text "extern CostCentre" <+> cc_lbl <> text "[];" + where cc_lbl = ppr (mkCCLabel cc) + local_cc_list_label = text "local_cc_" <> ppr this_mod + emit_cc_list ccs = + text "static CostCentre *" <> local_cc_list_label <> text "[] =" + <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma + | cc <- ccs + ] ++ [text "NULL"]) + <> semi + + emit_ccs_decl ccs = + text "extern CostCentreStack" <+> ccs_lbl <> text "[];" + where ccs_lbl = ppr (mkCCSLabel ccs) + singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod + emit_ccs_list ccs = + text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] =" + <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma + | cc <- ccs + ] ++ [text "NULL"]) + <> semi diff --git a/compiler/GHC/Types/CostCentre/State.hs b/compiler/GHC/Types/CostCentre/State.hs new file mode 100644 index 0000000000..51c364f776 --- /dev/null +++ b/compiler/GHC/Types/CostCentre/State.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Types.CostCentre.State + ( CostCentreState + , newCostCentreState + , CostCentreIndex + , unCostCentreIndex + , getCCIndex + ) +where + +import GhcPrelude +import FastString +import FastStringEnv + +import Data.Data +import Binary + +-- | Per-module state for tracking cost centre indices. +-- +-- See documentation of 'CostCentre.cc_flavour' for more details. +newtype CostCentreState = CostCentreState (FastStringEnv Int) + +-- | Initialize cost centre state. +newCostCentreState :: CostCentreState +newCostCentreState = CostCentreState emptyFsEnv + +-- | An index into a given cost centre module,name,flavour set +newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } + deriving (Eq, Ord, Data, Binary) + +-- | Get a new index for a given cost centre name. +getCCIndex :: FastString + -> CostCentreState + -> (CostCentreIndex, CostCentreState) +getCCIndex nm (CostCentreState m) = + (CostCentreIndex idx, CostCentreState m') + where + m_idx = lookupFsEnv m nm + idx = maybe 0 id m_idx + m' = extendFsEnv m nm (idx + 1) diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs new file mode 100644 index 0000000000..16f5f1041d --- /dev/null +++ b/compiler/GHC/Types/Cpr.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +-- | Types for the Constructed Product Result lattice. "GHC.Core.Op.CprAnal" and "GHC.Core.Op.WorkWrap.Lib" +-- are its primary customers via 'idCprInfo'. +module GHC.Types.Cpr ( + CprResult, topCpr, botCpr, conCpr, asConCpr, + CprType (..), topCprType, botCprType, conCprType, + lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy, + CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig + ) where + +import GhcPrelude + +import GHC.Types.Basic +import Outputable +import Binary + +-- +-- * CprResult +-- + +-- | The constructed product result lattice. +-- +-- @ +-- NoCPR +-- | +-- ConCPR ConTag +-- | +-- BotCPR +-- @ +data CprResult = NoCPR -- ^ Top of the lattice + | ConCPR !ConTag -- ^ Returns a constructor from a data type + | BotCPR -- ^ Bottom of the lattice + deriving( Eq, Show ) + +lubCpr :: CprResult -> CprResult -> CprResult +lubCpr (ConCPR t1) (ConCPR t2) + | t1 == t2 = ConCPR t1 +lubCpr BotCPR cpr = cpr +lubCpr cpr BotCPR = cpr +lubCpr _ _ = NoCPR + +topCpr :: CprResult +topCpr = NoCPR + +botCpr :: CprResult +botCpr = BotCPR + +conCpr :: ConTag -> CprResult +conCpr = ConCPR + +trimCpr :: CprResult -> CprResult +trimCpr ConCPR{} = NoCPR +trimCpr cpr = cpr + +asConCpr :: CprResult -> Maybe ConTag +asConCpr (ConCPR t) = Just t +asConCpr NoCPR = Nothing +asConCpr BotCPR = Nothing + +-- +-- * CprType +-- + +-- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper. +data CprType + = CprType + { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression + -- eats before returning the 'ct_cpr' + , ct_cpr :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to + -- 'ct_arty' arguments + } + +instance Eq CprType where + a == b = ct_cpr a == ct_cpr b + && (ct_arty a == ct_arty b || ct_cpr a == topCpr) + +topCprType :: CprType +topCprType = CprType 0 topCpr + +botCprType :: CprType +botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments + +conCprType :: ConTag -> CprType +conCprType con_tag = CprType 0 (conCpr con_tag) + +lubCprType :: CprType -> CprType -> CprType +lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2) + -- The arity of bottom CPR types can be extended arbitrarily. + | cpr1 == botCpr && n1 <= n2 = ty2 + | cpr2 == botCpr && n2 <= n1 = ty1 + -- There might be non-bottom CPR types with mismatching arities. + -- Consider test DmdAnalGADTs. We want to return top in these cases. + | n1 == n2 = CprType n1 (lubCpr cpr1 cpr2) + | otherwise = topCprType + +applyCprTy :: CprType -> CprType +applyCprTy (CprType n res) + | n > 0 = CprType (n-1) res + | res == botCpr = botCprType + | otherwise = topCprType + +abstractCprTy :: CprType -> CprType +abstractCprTy (CprType n res) + | res == topCpr = topCprType + | otherwise = CprType (n+1) res + +ensureCprTyArity :: Arity -> CprType -> CprType +ensureCprTyArity n ty@(CprType m _) + | n == m = ty + | otherwise = topCprType + +trimCprTy :: CprType -> CprType +trimCprTy (CprType arty res) = CprType arty (trimCpr res) + +-- | The arity of the wrapped 'CprType' is the arity at which it is safe +-- to unleash. See Note [Understanding DmdType and StrictSig] in GHC.Types.Demand +newtype CprSig = CprSig { getCprSig :: CprType } + deriving (Eq, Binary) + +-- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig' +-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in +-- Demand +mkCprSigForArity :: Arity -> CprType -> CprSig +mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty) + +topCprSig :: CprSig +topCprSig = CprSig topCprType + +mkCprSig :: Arity -> CprResult -> CprSig +mkCprSig arty cpr = CprSig (CprType arty cpr) + +seqCprSig :: CprSig -> () +seqCprSig sig = sig `seq` () + +instance Outputable CprResult where + ppr NoCPR = empty + ppr (ConCPR n) = char 'm' <> int n + ppr BotCPR = char 'b' + +instance Outputable CprType where + ppr (CprType arty res) = ppr arty <> ppr res + +-- | Only print the CPR result +instance Outputable CprSig where + ppr (CprSig ty) = ppr (ct_cpr ty) + +instance Binary CprResult where + put_ bh (ConCPR n) = do { putByte bh 0; put_ bh n } + put_ bh NoCPR = putByte bh 1 + put_ bh BotCPR = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (ConCPR n) } + 1 -> return NoCPR + _ -> return BotCPR + +instance Binary CprType where + put_ bh (CprType arty cpr) = do + put_ bh arty + put_ bh cpr + get bh = CprType <$> get bh <*> get bh diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs new file mode 100644 index 0000000000..f9ca821872 --- /dev/null +++ b/compiler/GHC/Types/Demand.hs @@ -0,0 +1,1974 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Demand]{@Demand@: A decoupled implementation of a demand domain} +-} + +{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Types.Demand ( + StrDmd, UseDmd(..), Count, + + Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd, + mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, + toCleanDmd, + absDmd, topDmd, botDmd, seqDmd, + lubDmd, bothDmd, + lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, + isTopDmd, isAbsDmd, isSeqDmd, + peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, + addCaseBndrDmd, + + DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, + nopDmdType, botDmdType, mkDmdType, + addDemand, ensureArgs, + BothDmdArg, mkBothDmdArg, toBothDmdArg, + + DmdEnv, emptyDmdEnv, + peelFV, findIdDemand, + + Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv, + appIsBottom, isBottomingSig, pprIfaceStrictSig, + StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, + nopSig, botSig, cprProdSig, + isTopSig, hasDemandEnvSig, + splitStrictSig, strictSigDmdEnv, + increaseStrictSigArity, etaExpandStrictSig, + + seqDemand, seqDemandList, seqDmdType, seqStrictSig, + + evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, + splitDmdTy, splitFVs, + deferAfterIO, + postProcessUnsat, postProcessDmdType, + + splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, + mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, + dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, + TypeShape(..), peelTsFuns, trimToType, + + useCount, isUsedOnce, reuseEnv, + zapUsageDemand, zapUsageEnvSig, + zapUsedOnceDemand, zapUsedOnceSig, + strictifyDictDmd, strictifyDmd + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Outputable +import GHC.Types.Var ( Var ) +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import Util +import GHC.Types.Basic +import Binary +import Maybes ( orElse ) + +import GHC.Core.Type ( Type ) +import GHC.Core.TyCon ( isNewTyCon, isClassTyCon ) +import GHC.Core.DataCon ( splitDataProductType_maybe ) + +{- +************************************************************************ +* * + Joint domain for Strictness and Absence +* * +************************************************************************ +-} + +data JointDmd s u = JD { sd :: s, ud :: u } + deriving ( Eq, Show ) + +getStrDmd :: JointDmd s u -> s +getStrDmd = sd + +getUseDmd :: JointDmd s u -> u +getUseDmd = ud + +-- Pretty-printing +instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where + ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) + +-- Well-formedness preserving constructors for the joint domain +mkJointDmd :: s -> u -> JointDmd s u +mkJointDmd s u = JD { sd = s, ud = u } + +mkJointDmds :: [s] -> [u] -> [JointDmd s u] +mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as + + +{- +************************************************************************ +* * + Strictness domain +* * +************************************************************************ + + Lazy + | + HeadStr + / \ + SCall SProd + \ / + HyperStr + +Note [Exceptions and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to smart about catching exceptions, but we aren't anymore. +See #14998 for the way it's resolved at the moment. + +Here's a historic breakdown: + +Apparently, exception handling prim-ops didn't use to have any special +strictness signatures, thus defaulting to topSig, which assumes they use their +arguments lazily. Joachim was the first to realise that we could provide richer +information. Thus, in 0558911f91c (Dec 13), he added signatures to +primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call +their argument, which is useful information for usage analysis. Still with a +'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. + +In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a +'strictApply1Dmd' leads to substantial performance gains. That was at the cost +of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in +28638dfe79e (Dec 15). + +Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, +Ben opened #11222. Simon made the demand analyser "understand catch" in +9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call +its argument strictly, but also swallow any thrown exceptions in +'postProcessDivergence'. This was realized by extending the 'Str' constructor of +'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and +adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element +between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, +so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). + +This left the other variants like 'catchRetry#' having 'catchArgDmd', which is +where #14998 picked up. Item 1 was concerned with measuring the impact of also +making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that +there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 +(Apr 18). There was a lot of dead code resulting from that change, that we +removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and +removed any code that was dealing with the peculiarities. + +Where did the speed-ups vanish to? In #14998, item 3 established that +turning 'catch#' strict in its first argument didn't bring back any of the +alleged performance benefits. Item 2 of that ticket finally found out that it +was entirely due to 'catchException's new (since #11555) definition, which +was simply + + catchException !io handler = catch io handler + +While 'catchException' is arguably the saner semantics for 'catch', it is an +internal helper function in "GHC.IO". Its use in +"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: +Remove the bang and you find the regressions we originally wanted to avoid with +'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". + +So history keeps telling us that the only possibly correct strictness annotation +for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really +is not strict in its argument: Just try this in GHCi + + :set -XScopedTypeVariables + import Control.Exception + catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") + +Any analysis that assumes otherwise will be broken in some way or another +(beyond `-fno-pendantic-bottoms`). +-} + +-- | Vanilla strictness domain +data StrDmd + = HyperStr -- ^ Hyper-strict (bottom of the lattice). + -- See Note [HyperStr and Use demands] + + | SCall StrDmd -- ^ Call demand + -- Used only for values of function type + + | SProd [ArgStr] -- ^ Product + -- Used only for values of product type + -- Invariant: not all components are HyperStr (use HyperStr) + -- not all components are Lazy (use HeadStr) + + | HeadStr -- ^ Head-Strict + -- A polymorphic demand: used for values of all types, + -- including a type variable + + deriving ( Eq, Show ) + +-- | Strictness of a function argument. +type ArgStr = Str StrDmd + +-- | Strictness demand. +data Str s = Lazy -- ^ Lazy (top of the lattice) + | Str s -- ^ Strict + deriving ( Eq, Show ) + +-- Well-formedness preserving constructors for the Strictness domain +strBot, strTop :: ArgStr +strBot = Str HyperStr +strTop = Lazy + +mkSCall :: StrDmd -> StrDmd +mkSCall HyperStr = HyperStr +mkSCall s = SCall s + +mkSProd :: [ArgStr] -> StrDmd +mkSProd sx + | any isHyperStr sx = HyperStr + | all isLazy sx = HeadStr + | otherwise = SProd sx + +isLazy :: ArgStr -> Bool +isLazy Lazy = True +isLazy (Str {}) = False + +isHyperStr :: ArgStr -> Bool +isHyperStr (Str HyperStr) = True +isHyperStr _ = False + +-- Pretty-printing +instance Outputable StrDmd where + ppr HyperStr = char 'B' + ppr (SCall s) = char 'C' <> parens (ppr s) + ppr HeadStr = char 'S' + ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) + +instance Outputable ArgStr where + ppr (Str s) = ppr s + ppr Lazy = char 'L' + +lubArgStr :: ArgStr -> ArgStr -> ArgStr +lubArgStr Lazy _ = Lazy +lubArgStr _ Lazy = Lazy +lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) + +lubStr :: StrDmd -> StrDmd -> StrDmd +lubStr HyperStr s = s +lubStr (SCall s1) HyperStr = SCall s1 +lubStr (SCall _) HeadStr = HeadStr +lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) +lubStr (SCall _) (SProd _) = HeadStr +lubStr (SProd sx) HyperStr = SProd sx +lubStr (SProd _) HeadStr = HeadStr +lubStr (SProd s1) (SProd s2) + | s1 `equalLength` s2 = mkSProd (zipWith lubArgStr s1 s2) + | otherwise = HeadStr +lubStr (SProd _) (SCall _) = HeadStr +lubStr HeadStr _ = HeadStr + +bothArgStr :: ArgStr -> ArgStr -> ArgStr +bothArgStr Lazy s = s +bothArgStr s Lazy = s +bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) + +bothStr :: StrDmd -> StrDmd -> StrDmd +bothStr HyperStr _ = HyperStr +bothStr HeadStr s = s +bothStr (SCall _) HyperStr = HyperStr +bothStr (SCall s1) HeadStr = SCall s1 +bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) +bothStr (SCall _) (SProd _) = HyperStr -- Weird + +bothStr (SProd _) HyperStr = HyperStr +bothStr (SProd s1) HeadStr = SProd s1 +bothStr (SProd s1) (SProd s2) + | s1 `equalLength` s2 = mkSProd (zipWith bothArgStr s1 s2) + | otherwise = HyperStr -- Weird +bothStr (SProd _) (SCall _) = HyperStr + +-- utility functions to deal with memory leaks +seqStrDmd :: StrDmd -> () +seqStrDmd (SProd ds) = seqStrDmdList ds +seqStrDmd (SCall s) = seqStrDmd s +seqStrDmd _ = () + +seqStrDmdList :: [ArgStr] -> () +seqStrDmdList [] = () +seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds + +seqArgStr :: ArgStr -> () +seqArgStr Lazy = () +seqArgStr (Str s) = seqStrDmd s + +-- Splitting polymorphic demands +splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] +splitArgStrProdDmd n Lazy = Just (replicate n Lazy) +splitArgStrProdDmd n (Str s) = splitStrProdDmd n s + +splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] +splitStrProdDmd n HyperStr = Just (replicate n strBot) +splitStrProdDmd n HeadStr = Just (replicate n strTop) +splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), + text "splitStrProdDmd" $$ ppr n $$ ppr ds ) + Just ds +splitStrProdDmd _ (SCall {}) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (#9208) + +{- +************************************************************************ +* * + Absence domain +* * +************************************************************************ + + Used + / \ + UCall UProd + \ / + UHead + | + Count x - + | + Abs +-} + +-- | Domain for genuine usage +data UseDmd + = UCall Count UseDmd -- ^ Call demand for absence. + -- Used only for values of function type + + | UProd [ArgUse] -- ^ Product. + -- Used only for values of product type + -- See Note [Don't optimise UProd(Used) to Used] + -- + -- Invariant: Not all components are Abs + -- (in that case, use UHead) + + | UHead -- ^ May be used but its sub-components are + -- definitely *not* used. For product types, UHead + -- is equivalent to U(AAA); see mkUProd. + -- + -- UHead is needed only to express the demand + -- of 'seq' and 'case' which are polymorphic; + -- i.e. the scrutinised value is of type 'a' + -- rather than a product type. That's why we + -- can't use UProd [A,A,A] + -- + -- Since (UCall _ Abs) is ill-typed, UHead doesn't + -- make sense for lambdas + + | Used -- ^ May be used and its sub-components may be used. + -- (top of the lattice) + deriving ( Eq, Show ) + +-- Extended usage demand for absence and counting +type ArgUse = Use UseDmd + +data Use u + = Abs -- Definitely unused + -- Bottom of the lattice + + | Use Count u -- May be used with some cardinality + deriving ( Eq, Show ) + +-- | Abstract counting of usages +data Count = One | Many + deriving ( Eq, Show ) + +-- Pretty-printing +instance Outputable ArgUse where + ppr Abs = char 'A' + ppr (Use Many a) = ppr a + ppr (Use One a) = char '1' <> char '*' <> ppr a + +instance Outputable UseDmd where + ppr Used = char 'U' + ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) + ppr UHead = char 'H' + ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) + +instance Outputable Count where + ppr One = char '1' + ppr Many = text "" + +useBot, useTop :: ArgUse +useBot = Abs +useTop = Use Many Used + +mkUCall :: Count -> UseDmd -> UseDmd +--mkUCall c Used = Used c +mkUCall c a = UCall c a + +mkUProd :: [ArgUse] -> UseDmd +mkUProd ux + | all (== Abs) ux = UHead + | otherwise = UProd ux + +lubCount :: Count -> Count -> Count +lubCount _ Many = Many +lubCount Many _ = Many +lubCount x _ = x + +lubArgUse :: ArgUse -> ArgUse -> ArgUse +lubArgUse Abs x = x +lubArgUse x Abs = x +lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) + +lubUse :: UseDmd -> UseDmd -> UseDmd +lubUse UHead u = u +lubUse (UCall c u) UHead = UCall c u +lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) +lubUse (UCall _ _) _ = Used +lubUse (UProd ux) UHead = UProd ux +lubUse (UProd ux1) (UProd ux2) + | ux1 `equalLength` ux2 = UProd $ zipWith lubArgUse ux1 ux2 + | otherwise = Used +lubUse (UProd {}) (UCall {}) = Used +-- lubUse (UProd {}) Used = Used +lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) +lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) +lubUse Used _ = Used -- Note [Used should win] + +-- `both` is different from `lub` in its treatment of counting; if +-- `both` is computed for two used, the result always has +-- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). +-- Also, x `bothUse` x /= x (for anything but Abs). + +bothArgUse :: ArgUse -> ArgUse -> ArgUse +bothArgUse Abs x = x +bothArgUse x Abs = x +bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) + + +bothUse :: UseDmd -> UseDmd -> UseDmd +bothUse UHead u = u +bothUse (UCall c u) UHead = UCall c u + +-- Exciting special treatment of inner demand for call demands: +-- use `lubUse` instead of `bothUse`! +bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) + +bothUse (UCall {}) _ = Used +bothUse (UProd ux) UHead = UProd ux +bothUse (UProd ux1) (UProd ux2) + | ux1 `equalLength` ux2 = UProd $ zipWith bothArgUse ux1 ux2 + | otherwise = Used +bothUse (UProd {}) (UCall {}) = Used +-- bothUse (UProd {}) Used = Used -- Note [Used should win] +bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) +bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) +bothUse Used _ = Used -- Note [Used should win] + +peelUseCall :: UseDmd -> Maybe (Count, UseDmd) +peelUseCall (UCall c u) = Just (c,u) +peelUseCall _ = Nothing + +addCaseBndrDmd :: Demand -- On the case binder + -> [Demand] -- On the components of the constructor + -> [Demand] -- Final demands for the components of the constructor +-- See Note [Demand on case-alternative binders] +addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds + = case mu of + Abs -> alt_dmds + Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) + where + Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call + Just us = splitUseProdDmd arity u -- Ditto + where + arity = length alt_dmds + +{- Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand on a binder in a case alternative comes + (a) From the demand on the binder itself + (b) From the demand on the case binder +Forgetting (b) led directly to #10148. + +Example. Source code: + f x@(p,_) = if p then foo x else True + + foo (p,True) = True + foo (p,q) = foo (q,p) + +After strictness analysis: + f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> + case x_an1 + of wild_X7 [Dmd=] + { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> foo wild_X7 } + +It's true that ds_dnz is *itself* absent, but the use of wild_X7 means +that it is very much alive and demanded. See #10148 for how the +consequences play out. + +This is needed even for non-product types, in case the case-binder +is used but the components of the case alternative are not. + +Note [Don't optimise UProd(Used) to Used] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These two UseDmds: + UProd [Used, Used] and Used +are semantically equivalent, but we do not turn the former into +the latter, for a regrettable-subtle reason. Suppose we did. +then + f (x,y) = (y,x) +would get + StrDmd = Str = SProd [Lazy, Lazy] + UseDmd = Used = UProd [Used, Used] +But with the joint demand of doesn't convey any clue +that there is a product involved, and so the worthSplittingFun +will not fire. (We'd need to use the type as well to make it fire.) +Moreover, consider + g h p@(_,_) = h p +This too would get , but this time there really isn't any +point in w/w since the components of the pair are not used at all. + +So the solution is: don't aggressively collapse UProd [Used,Used] to +Used; instead leave it as-is. In effect we are using the UseDmd to do a +little bit of boxity analysis. Not very nice. + +Note [Used should win] +~~~~~~~~~~~~~~~~~~~~~~ +Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. +Why? Because Used carries the implication the whole thing is used, +box and all, so we don't want to w/w it. If we use it both boxed and +unboxed, then we are definitely using the box, and so we are quite +likely to pay a reboxing cost. So we make Used win here. + +Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer + +Baseline: (A) Not making Used win (UProd wins) +Compare with: (B) making Used win for lub and both + + Min -0.3% -5.6% -10.7% -11.0% -33.3% + Max +0.3% +45.6% +11.5% +11.5% +6.9% + Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% + +Baseline: (B) Making Used win for both lub and both +Compare with: (C) making Used win for both, but UProd win for lub + + Min -0.1% -0.3% -7.9% -8.0% -6.5% + Max +0.1% +1.0% +21.0% +21.0% +0.5% + Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% +-} + +-- If a demand is used multiple times (i.e. reused), than any use-once +-- mentioned there, that is not protected by a UCall, can happen many times. +markReusedDmd :: ArgUse -> ArgUse +markReusedDmd Abs = Abs +markReusedDmd (Use _ a) = Use Many (markReused a) + +markReused :: UseDmd -> UseDmd +markReused (UCall _ u) = UCall Many u -- No need to recurse here +markReused (UProd ux) = UProd (map markReusedDmd ux) +markReused u = u + +isUsedMU :: ArgUse -> Bool +-- True <=> markReusedDmd d = d +isUsedMU Abs = True +isUsedMU (Use One _) = False +isUsedMU (Use Many u) = isUsedU u + +isUsedU :: UseDmd -> Bool +-- True <=> markReused d = d +isUsedU Used = True +isUsedU UHead = True +isUsedU (UProd us) = all isUsedMU us +isUsedU (UCall One _) = False +isUsedU (UCall Many _) = True -- No need to recurse + +-- Squashing usage demand demands +seqUseDmd :: UseDmd -> () +seqUseDmd (UProd ds) = seqArgUseList ds +seqUseDmd (UCall c d) = c `seq` seqUseDmd d +seqUseDmd _ = () + +seqArgUseList :: [ArgUse] -> () +seqArgUseList [] = () +seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds + +seqArgUse :: ArgUse -> () +seqArgUse (Use c u) = c `seq` seqUseDmd u +seqArgUse _ = () + +-- Splitting polymorphic Maybe-Used demands +splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] +splitUseProdDmd n Used = Just (replicate n useTop) +splitUseProdDmd n UHead = Just (replicate n Abs) +splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), + text "splitUseProdDmd" $$ ppr n + $$ ppr ds ) + Just ds +splitUseProdDmd _ (UCall _ _) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (#9208) + +useCount :: Use u -> Count +useCount Abs = One +useCount (Use One _) = One +useCount _ = Many + + +{- +************************************************************************ +* * + Clean demand for Strictness and Usage +* * +************************************************************************ + +This domain differst from JointDemand in the sense that pure absence +is taken away, i.e., we deal *only* with non-absent demands. + +Note [Strict demands] +~~~~~~~~~~~~~~~~~~~~~ +isStrictDmd returns true only of demands that are + both strict + and used +In particular, it is False for , which can and does +arise in, say (#7319) + f x = raise# +Then 'x' is not used, so f gets strictness -> . +Now the w/w generates + fx = let x = absentError "unused" + in raise +At this point we really don't want to convert to + fx = case absentError "unused" of x -> raise +Since the program is going to diverge, this swaps one error for another, +but it's really a bad idea to *ever* evaluate an absent argument. +In #7319 we get + T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] + +Note [Dealing with call demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Call demands are constructed and deconstructed coherently for +strictness and absence. For instance, the strictness signature for the +following function + +f :: (Int -> (Int, Int)) -> (Int, Bool) +f g = (snd (g 3), True) + +should be: m +-} + +type CleanDemand = JointDmd StrDmd UseDmd + -- A demand that is at least head-strict + +bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand +bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) + = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } + +mkHeadStrict :: CleanDemand -> CleanDemand +mkHeadStrict cd = cd { sd = HeadStr } + +mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand +mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a } +mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a } + +evalDmd :: Demand +-- Evaluated strictly, and used arbitrarily deeply +evalDmd = JD { sd = Str HeadStr, ud = useTop } + +mkProdDmd :: [Demand] -> CleanDemand +mkProdDmd dx + = JD { sd = mkSProd $ map getStrDmd dx + , ud = mkUProd $ map getUseDmd dx } + +-- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@. +mkCallDmd :: CleanDemand -> CleanDemand +mkCallDmd (JD {sd = d, ud = u}) + = JD { sd = mkSCall d, ud = mkUCall One u } + +-- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. +mkCallDmds :: Arity -> CleanDemand -> CleanDemand +mkCallDmds arity cd = iterate mkCallDmd cd !! arity + +-- See Note [Demand on the worker] in GHC.Core.Op.WorkWrap +mkWorkerDemand :: Int -> Demand +mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } + where go 0 = Used + go n = mkUCall One $ go (n-1) + +cleanEvalDmd :: CleanDemand +cleanEvalDmd = JD { sd = HeadStr, ud = Used } + +cleanEvalProdDmd :: Arity -> CleanDemand +cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } + + +{- +************************************************************************ +* * + Demand: Combining Strictness and Usage +* * +************************************************************************ +-} + +type Demand = JointDmd ArgStr ArgUse + +lubDmd :: Demand -> Demand -> Demand +lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) + = JD { sd = s1 `lubArgStr` s2 + , ud = a1 `lubArgUse` a2 } + +bothDmd :: Demand -> Demand -> Demand +bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) + = JD { sd = s1 `bothArgStr` s2 + , ud = a1 `bothArgUse` a2 } + +lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand + +strictApply1Dmd = JD { sd = Str (SCall HeadStr) + , ud = Use Many (UCall One Used) } + +lazyApply1Dmd = JD { sd = Lazy + , ud = Use One (UCall One Used) } + +-- Second argument of catch#: +-- uses its arg at most once, applies it once +-- but is lazy (might not be called at all) +lazyApply2Dmd = JD { sd = Lazy + , ud = Use One (UCall One (UCall One Used)) } + +absDmd :: Demand +absDmd = JD { sd = Lazy, ud = Abs } + +topDmd :: Demand +topDmd = JD { sd = Lazy, ud = useTop } + +botDmd :: Demand +botDmd = JD { sd = strBot, ud = useBot } + +seqDmd :: Demand +seqDmd = JD { sd = Str HeadStr, ud = Use One UHead } + +oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u) +oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } +oneifyDmd jd = jd + +isTopDmd :: Demand -> Bool +-- Used to suppress pretty-printing of an uninformative demand +isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True +isTopDmd _ = False + +isAbsDmd :: JointDmd (Str s) (Use u) -> Bool +isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr +isAbsDmd _ = False -- for a bottom demand + +isSeqDmd :: Demand -> Bool +isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True +isSeqDmd _ = False + +isUsedOnce :: JointDmd (Str s) (Use u) -> Bool +isUsedOnce (JD { ud = a }) = case useCount a of + One -> True + Many -> False + +-- More utility functions for strictness +seqDemand :: Demand -> () +seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u + +seqDemandList :: [Demand] -> () +seqDemandList [] = () +seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds + +isStrictDmd :: JointDmd (Str s) (Use u) -> Bool +-- See Note [Strict demands] +isStrictDmd (JD {ud = Abs}) = False +isStrictDmd (JD {sd = Lazy}) = False +isStrictDmd _ = True + +isWeakDmd :: Demand -> Bool +isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a + +cleanUseDmd_maybe :: Demand -> Maybe UseDmd +cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u +cleanUseDmd_maybe _ = Nothing + +splitFVs :: Bool -- Thunk + -> DmdEnv -> (DmdEnv, DmdEnv) +splitFVs is_thunk rhs_fvs + | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs + -- It's OK to use nonDetFoldUFM_Directly because we + -- immediately forget the ordering by putting the elements + -- in the envs again + | otherwise = partitionVarEnv isWeakDmd rhs_fvs + where + add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv) + | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) + | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) + , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) ) + +data TypeShape = TsFun TypeShape + | TsProd [TypeShape] + | TsUnk + +instance Outputable TypeShape where + ppr TsUnk = text "TsUnk" + ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) + ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) + +-- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and +-- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise. +peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape +peelTsFuns 0 ts = Just ts +peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts +peelTsFuns _ _ = Nothing + +trimToType :: Demand -> TypeShape -> Demand +-- See Note [Trimming a demand to a type] +trimToType (JD { sd = ms, ud = mu }) ts + = JD (go_ms ms ts) (go_mu mu ts) + where + go_ms :: ArgStr -> TypeShape -> ArgStr + go_ms Lazy _ = Lazy + go_ms (Str s) ts = Str (go_s s ts) + + go_s :: StrDmd -> TypeShape -> StrDmd + go_s HyperStr _ = HyperStr + go_s (SCall s) (TsFun ts) = SCall (go_s s ts) + go_s (SProd mss) (TsProd tss) + | equalLength mss tss = SProd (zipWith go_ms mss tss) + go_s _ _ = HeadStr + + go_mu :: ArgUse -> TypeShape -> ArgUse + go_mu Abs _ = Abs + go_mu (Use c u) ts = Use c (go_u u ts) + + go_u :: UseDmd -> TypeShape -> UseDmd + go_u UHead _ = UHead + go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) + go_u (UProd mus) (TsProd tss) + | equalLength mus tss = UProd (zipWith go_mu mus tss) + go_u _ _ = Used + +{- +Note [Trimming a demand to a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f :: a -> Bool + f x = case ... of + A g1 -> case (x |> g1) of (p,q) -> ... + B -> error "urk" + +where A,B are the constructors of a GADT. We'll get a U(U,U) demand +on x from the A branch, but that's a stupid demand for x itself, which +has type 'a'. Indeed we get ASSERTs going off (notably in +splitUseProdDmd, #8569). + +Bottom line: we really don't want to have a binder whose demand is more +deeply-nested than its type. There are various ways to tackle this. +When processing (x |> g1), we could "trim" the incoming demand U(U,U) +to match x's type. But I'm currently doing so just at the moment when +we pin a demand on a binder, in GHC.Core.Op.DmdAnal.findBndrDmd. + + +Note [Threshold demands] +~~~~~~~~~~~~~~~~~~~~~~~~ +Threshold usage demand is generated to figure out if +cardinality-instrumented demands of a binding's free variables should +be unleashed. See also [Aggregated demand for cardinality]. + +Note [Replicating polymorphic demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some demands can be considered as polymorphic. Generally, it is +applicable to such beasts as tops, bottoms as well as Head-Used and +Head-stricts demands. For instance, + +S ~ S(L, ..., L) + +Also, when top or bottom is occurred as a result demand, it in fact +can be expanded to saturate a callee's arity. +-} + +splitProdDmd_maybe :: Demand -> Maybe [Demand] +-- Split a product into its components, iff there is any +-- useful information to be extracted thereby +-- The demand is not necessarily strict! +splitProdDmd_maybe (JD { sd = s, ud = u }) + = case (s,u) of + (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u + -> Just (mkJointDmds sx ux) + (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s + -> Just (mkJointDmds sx ux) + (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) + _ -> Nothing + +{- +************************************************************************ +* * + Termination +* * +************************************************************************ + +Divergence: Dunno + / + Diverges + +In a fixpoint iteration, start from Diverges +-} + +data Divergence + = Diverges -- Definitely diverges + | Dunno -- Might diverge or converge + deriving( Eq, Show ) + +lubDivergence :: Divergence -> Divergence ->Divergence +lubDivergence Diverges r = r +lubDivergence r Diverges = r +lubDivergence Dunno Dunno = Dunno +-- This needs to commute with defaultDmd, i.e. +-- defaultDmd (r1 `lubDivergence` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 +-- (See Note [Default demand on free variables] for why) + +bothDivergence :: Divergence -> Divergence -> Divergence +-- See Note [Asymmetry of 'both' for DmdType and Divergence] +bothDivergence _ Diverges = Diverges +bothDivergence r Dunno = r +-- This needs to commute with defaultDmd, i.e. +-- defaultDmd (r1 `bothDivergence` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 +-- (See Note [Default demand on free variables] for why) + +instance Outputable Divergence where + ppr Diverges = char 'b' + ppr Dunno = empty + +------------------------------------------------------------------------ +-- Combined demand result -- +------------------------------------------------------------------------ + +-- [cprRes] lets us switch off CPR analysis +-- by making sure that everything uses TopRes +topDiv, botDiv :: Divergence +topDiv = Dunno +botDiv = Diverges + +isTopDiv :: Divergence -> Bool +isTopDiv Dunno = True +isTopDiv _ = False + +-- | True if the result diverges or throws an exception +isBotDiv :: Divergence -> Bool +isBotDiv Diverges = True +isBotDiv _ = False + +-- See Notes [Default demand on free variables] +-- and [defaultDmd vs. resTypeArgDmd] +defaultDmd :: Divergence -> Demand +defaultDmd Dunno = absDmd +defaultDmd _ = botDmd -- Diverges + +resTypeArgDmd :: Divergence -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes === (Bot -> BotRes) === ... +-- TopRes === (Top -> TopRes) === ... +-- This function makes that concrete +-- Also see Note [defaultDmd vs. resTypeArgDmd] +resTypeArgDmd Dunno = topDmd +resTypeArgDmd _ = botDmd -- Diverges + +{- +Note [defaultDmd and resTypeArgDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +These functions are similar: They express the demand on something not +explicitly mentioned in the environment resp. the argument list. Yet they are +different: + * Variables not mentioned in the free variables environment are definitely + unused, so we can use absDmd there. + * Further arguments *can* be used, of course. Hence topDmd is used. + + +************************************************************************ +* * + Demand environments and types +* * +************************************************************************ +-} + +type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] + +data DmdType = DmdType + DmdEnv -- Demand on explicitly-mentioned + -- free variables + [Demand] -- Demand on arguments + Divergence -- See [Nature of result demand] + +{- +Note [Nature of result demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A Divergence contains information about termination (currently distinguishing +definite divergence and no information; it is possible to include definite +convergence here), and CPR information about the result. + +The semantics of this depends on whether we are looking at a DmdType, i.e. the +demand put on by an expression _under a specific incoming demand_ on its +environment, or at a StrictSig describing a demand transformer. + +For a + * DmdType, the termination information is true given the demand it was + generated with, while for + * a StrictSig it holds after applying enough arguments. + +The CPR information, though, is valid after the number of arguments mentioned +in the type is given. Therefore, when forgetting the demand on arguments, as in +dmdAnalRhs, this needs to be considered (via removeDmdTyArgs). + +Consider + b2 x y = x `seq` y `seq` error (show x) +this has a strictness signature of + b +meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but +for "b2 1 2 `seq` ()" we get definite divergence. + +For comparison, + b1 x = x `seq` error (show x) +has a strictness signature of + b +and "b1 1 `seq` ()" is known to terminate. + +Now consider a function h with signature "", and the expression + e1 = h b1 +now h puts a demand of onto its argument, and the demand transformer +turns it into + b +Now the Divergence "b" does apply to us, even though "b1 `seq` ()" does not +diverge, and we do not anything being passed to b. + +Note [Asymmetry of 'both' for DmdType and Divergence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'both' for DmdTypes is *asymmetrical*, because there is only one +result! For example, given (e1 e2), we get a DmdType dt1 for e1, use +its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). +Similarly with + case e of { p -> rhs } +we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then +compute (dt_rhs `bothType` dt_scrut). + +We + 1. combine the information on the free variables, + 2. take the demand on arguments from the first argument + 3. combine the termination results, but + 4. take CPR info from the first argument. + +3 and 4 are implemented in bothDivergence. +-} + +-- Equality needed for fixpoints in GHC.Core.Op.DmdAnal +instance Eq DmdType where + (==) (DmdType fv1 ds1 div1) + (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 + -- It's OK to use nonDetUFMToList here because we're testing for + -- equality and even though the lists will be in some arbitrary + -- Unique order, it is the same order for both + && ds1 == ds2 && div1 == div2 + +lubDmdType :: DmdType -> DmdType -> DmdType +lubDmdType d1 d2 + = DmdType lub_fv lub_ds lub_div + where + n = max (dmdTypeDepth d1) (dmdTypeDepth d2) + (DmdType fv1 ds1 r1) = ensureArgs n d1 + (DmdType fv2 ds2 r2) = ensureArgs n d2 + + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) + lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 + lub_div = lubDivergence r1 r2 + +{- +Note [The need for BothDmdArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, the right argument to bothDmdType, as well as the return value of +dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs +to know about the free variables and termination information, but nothing about +the demand put on arguments, nor cpr information. So we make that explicit by +only passing the relevant information. +-} + +type BothDmdArg = (DmdEnv, Divergence) + +mkBothDmdArg :: DmdEnv -> BothDmdArg +mkBothDmdArg env = (env, Dunno) + +toBothDmdArg :: DmdType -> BothDmdArg +toBothDmdArg (DmdType fv _ r) = (fv, go r) + where + go Dunno = Dunno + go Diverges = Diverges + +bothDmdType :: DmdType -> BothDmdArg -> DmdType +bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) + -- See Note [Asymmetry of 'both' for DmdType and Divergence] + -- 'both' takes the argument/result info from its *first* arg, + -- using its second arg just for its free-var info. + = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) + ds1 + (r1 `bothDivergence` t2) + +instance Outputable DmdType where + ppr (DmdType fv ds res) + = hsep [hcat (map ppr ds) <> ppr res, + if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts))] + where + pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + fv_elts = nonDetUFMToList fv + -- It's OK to use nonDetUFMToList here because we only do it for + -- pretty printing + +emptyDmdEnv :: VarEnv Demand +emptyDmdEnv = emptyVarEnv + +-- nopDmdType is the demand of doing nothing +-- (lazy, absent, no CPR information, no termination information). +-- Note that it is ''not'' the top of the lattice (which would be "may use everything"), +-- so it is (no longer) called topDmd +nopDmdType, botDmdType :: DmdType +nopDmdType = DmdType emptyDmdEnv [] topDiv +botDmdType = DmdType emptyDmdEnv [] botDiv + +isTopDmdType :: DmdType -> Bool +isTopDmdType (DmdType env [] res) + | isTopDiv res && isEmptyVarEnv env = True +isTopDmdType _ = False + +mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType +mkDmdType fv ds res = DmdType fv ds res + +dmdTypeDepth :: DmdType -> Arity +dmdTypeDepth (DmdType _ ds _) = length ds + +-- | This makes sure we can use the demand type with n arguments. +-- It extends the argument list with the correct resTypeArgDmd. +-- It also adjusts the Divergence: Divergence survives additional arguments, +-- CPR information does not (and definite converge also would not). +ensureArgs :: Arity -> DmdType -> DmdType +ensureArgs n d | n == depth = d + | otherwise = DmdType fv ds' r' + where depth = dmdTypeDepth d + DmdType fv ds r = d + + ds' = take n (ds ++ repeat (resTypeArgDmd r)) + r' = case r of -- See [Nature of result demand] + Dunno -> topDiv + _ -> r + + +seqDmdType :: DmdType -> () +seqDmdType (DmdType env ds res) = + seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () + +seqDmdEnv :: DmdEnv -> () +seqDmdEnv env = seqEltsUFM seqDemandList env + +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +-- We already have a suitable demand on all +-- free vars, so no need to add more! +splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) +splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) + +-- When e is evaluated after executing an IO action, and d is e's demand, then +-- what of this demand should we consider, given that the IO action can cleanly +-- exit? +-- * We have to kill all strictness demands (i.e. lub with a lazy demand) +-- * We can keep usage information (i.e. lub with an absent demand) +-- * We have to kill definite divergence +-- * We can keep CPR information. +-- See Note [IO hack in the demand analyser] in GHC.Core.Op.DmdAnal +deferAfterIO :: DmdType -> DmdType +deferAfterIO d@(DmdType _ _ res) = + case d `lubDmdType` nopDmdType of + DmdType fv ds _ -> DmdType fv ds (defer_res res) + where + defer_res r@(Dunno {}) = r + defer_res _ = topDiv -- Diverges + +strictenDmd :: Demand -> CleanDemand +strictenDmd (JD { sd = s, ud = u}) + = JD { sd = poke_s s, ud = poke_u u } + where + poke_s Lazy = HeadStr + poke_s (Str s) = s + poke_u Abs = UHead + poke_u (Use _ u) = u + +-- Deferring and peeling + +type DmdShell -- Describes the "outer shell" + -- of a Demand + = JointDmd (Str ()) (Use ()) + +toCleanDmd :: Demand -> (DmdShell, CleanDemand) +-- Splits a Demand into its "shell" and the inner "clean demand" +toCleanDmd (JD { sd = s, ud = u }) + = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) + -- See Note [Analyzing with lazy demand and lambdas] + -- See Note [Analysing with absent demand] + where + (ss, s') = case s of + Str s' -> (Str (), s') + Lazy -> (Lazy, HeadStr) + + (us, u') = case u of + Use c u' -> (Use c (), u') + Abs -> (Abs, Used) + +-- This is used in dmdAnalStar when post-processing +-- a function's argument demand. So we only care about what +-- does to free variables, and whether it terminates. +-- see Note [The need for BothDmdArg] +postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg +postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) + = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty) + +postProcessDivergence :: Str () -> Divergence -> Divergence +postProcessDivergence Lazy _ = topDiv +postProcessDivergence _ res = res + +postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv +postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env + | Abs <- us = emptyDmdEnv + -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild + -- of the environment. Be careful, bad things will happen if this doesn't + -- match postProcessDmd (see #13977). + | Str _ <- ss + , Use One _ <- us = env + | otherwise = mapVarEnv (postProcessDmd ds) env + -- For the Absent case just discard all usage information + -- We only processed the thing at all to analyse the body + -- See Note [Always analyse in virgin pass] + +reuseEnv :: DmdEnv -> DmdEnv +reuseEnv = mapVarEnv (postProcessDmd + (JD { sd = Str (), ud = Use Many () })) + +postProcessUnsat :: DmdShell -> DmdType -> DmdType +postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) + = DmdType (postProcessDmdEnv ds fv) + (map (postProcessDmd ds) args) + (postProcessDivergence ss res_ty) + +postProcessDmd :: DmdShell -> Demand -> Demand +postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) + = JD { sd = s', ud = a' } + where + s' = case ss of + Lazy -> Lazy + Str _ -> s + a' = case us of + Abs -> Abs + Use Many _ -> markReusedDmd a + Use One _ -> a + +-- Peels one call level from the demand, and also returns +-- whether it was unsaturated (separately for strictness and usage) +peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) +-- Exploiting the fact that +-- on the strictness side C(B) = B +-- and on the usage side C(U) = U +peelCallDmd (JD {sd = s, ud = u}) + = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) + where + (s', ss) = case s of + SCall s' -> (s', Str ()) + HyperStr -> (HyperStr, Str ()) + _ -> (HeadStr, Lazy) + (u', us) = case u of + UCall c u' -> (u', Use c ()) + _ -> (Used, Use Many ()) + -- The _ cases for usage includes UHead which seems a bit wrong + -- because the body isn't used at all! + -- c.f. the Abs case in toCleanDmd + +-- Peels that multiple nestings of calls clean demand and also returns +-- whether it was unsaturated (separately for strictness and usage +-- see Note [Demands from unsaturated function calls] +peelManyCalls :: Int -> CleanDemand -> DmdShell +peelManyCalls n (JD { sd = str, ud = abs }) + = JD { sd = go_str n str, ud = go_abs n abs } + where + go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer + go_str 0 _ = Str () + go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) + go_str n (SCall d') = go_str (n-1) d' + go_str _ _ = Lazy + + go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least + go_abs 0 _ = Use One () -- one UCall Many in the demand + go_abs n (UCall One d') = go_abs (n-1) d' + go_abs _ _ = Use Many () + +{- +Note [Demands from unsaturated function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider a demand transformer d1 -> d2 -> r for f. +If a sufficiently detailed demand is fed into this transformer, +e.g arising from "f x1 x2" in a strict, use-once context, +then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for +the free variable environment) and furthermore the result information r is the +one we want to use. + +An anonymous lambda is also an unsaturated function all (needs one argument, +none given), so this applies to that case as well. + +But the demand fed into f might be less than . There are a few cases: + * Not enough demand on the strictness side: + - In that case, we need to zap all strictness in the demand on arguments and + free variables. + - Furthermore, we remove CPR information. It could be left, but given the incoming + demand is not enough to evaluate so far we just do not bother. + - And finally termination information: If r says that f diverges for sure, + then this holds when the demand guarantees that two arguments are going to + be passed. If the demand is lower, we may just as well converge. + If we were tracking definite convegence, than that would still hold under + a weaker demand than expected by the demand transformer. + * Not enough demand from the usage side: The missing usage can be expanded + using UCall Many, therefore this is subsumed by the third case: + * At least one of the uses has a cardinality of Many. + - Even if f puts a One demand on any of its argument or free variables, if + we call f multiple times, we may evaluate this argument or free variable + multiple times. So forget about any occurrence of "One" in the demand. + +In dmdTransformSig, we call peelManyCalls to find out if we are in any of these +cases, and then call postProcessUnsat to reduce the demand appropriately. + +Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use +peelCallDmd, which peels only one level, but also returns the demand put on the +body of the function. +-} + +peelFV :: DmdType -> Var -> (DmdType, Demand) +peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) + (DmdType fv' ds res, dmd) + where + fv' = fv `delVarEnv` id + -- See Note [Default demand on free variables] + dmd = lookupVarEnv fv id `orElse` defaultDmd res + +addDemand :: Demand -> DmdType -> DmdType +addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res + +findIdDemand :: DmdType -> Var -> Demand +findIdDemand (DmdType fv _ res) id + = lookupVarEnv fv id `orElse` defaultDmd res + +{- +Note [Default demand on free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the variable is not mentioned in the environment of a demand type, +its demand is taken to be a result demand of the type. + For the strictness component, + if the result demand is a Diverges, then we use HyperStr + else we use Lazy + For the usage component, we use Absent. +So we use either absDmd or botDmd. + +Also note the equations for lubDivergence (resp. bothDivergence) noted there. + +Note [Always analyse in virgin pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tricky point: make sure that we analyse in the 'virgin' pass. Consider + rec { f acc x True = f (...rec { g y = ...g... }...) + f acc x False = acc } +In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. +That might mean that we analyse the sub-expression containing the +E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* +E, but just returned botType. + +Then in the *next* (non-virgin) iteration for 'f', we might analyse E +in a weaker demand, and that will trigger doing a fixpoint iteration +for g. But *because it's not the virgin pass* we won't start g's +iteration at bottom. Disaster. (This happened in $sfibToList' of +nofib/spectral/fibheaps.) + +So in the virgin pass we make sure that we do analyse the expression +at least once, to initialise its signatures. + +Note [Analyzing with lazy demand and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The insight for analyzing lambdas follows from the fact that for +strictness S = C(L). This polymorphic expansion is critical for +cardinality analysis of the following example: + +{-# NOINLINE build #-} +build g = (g (:) [], g (:) []) + +h c z = build (\x -> + let z1 = z ++ z + in if c + then \y -> x (y ++ z1) + else \y -> x (z1 ++ y)) + +One can see that `build` assigns to `g` demand . +Therefore, when analyzing the lambda `(\x -> ...)`, we +expect each lambda \y -> ... to be annotated as "one-shot" +one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a +demand . + +This is achieved by, first, converting the lazy demand L into the +strict S by the second clause of the analysis. + +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand . The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by postProcessDmdType. + +* In a previous incarnation of GHC we needed to be extra careful in the + case of an *unlifted type*, because unlifted values are evaluated + even if they are not used. Example (see #9254): + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here f's strictness signature says (correctly) that it calls its + argument function and ignores the first component of its result. + This is correct in the sense that it'd be fine to (say) modify the + function so that always returned 0# in the first component. + + But in function g, we *will* evaluate the 'case y of ...', because + it has type Int#. So 'y' will be evaluated. So we must record this + usage of 'y', else 'g' will say 'y' is absent, and will w/w so that + 'y' is bound to an aBSENT_ERROR thunk. + + However, the argument of toCleanDmd always satisfies the let/app + invariant; so if it is unlifted it is also okForSpeculation, and so + can be evaluated in a short finite time -- and that rules out nasty + cases like the one above. (I'm not quite sure why this was a + problem in an earlier version of GHC, but it isn't now.) + + +************************************************************************ +* * + Demand signatures +* * +************************************************************************ + +In a let-bound Id we record its strictness info. +In principle, this strictness info is a demand transformer, mapping +a demand on the Id into a DmdType, which gives + a) the free vars of the Id's value + b) the Id's arguments + c) an indication of the result of applying + the Id to its arguments + +However, in fact we store in the Id an extremely emascuated demand +transfomer, namely + + a single DmdType +(Nevertheless we dignify StrictSig as a distinct type.) + +This DmdType gives the demands unleashed by the Id when it is applied +to as many arguments as are given in by the arg demands in the DmdType. +Also see Note [Nature of result demand] for the meaning of a Divergence in a +strictness signature. + +If an Id is applied to less arguments than its arity, it means that +the demand on the function at a call site is weaker than the vanilla +call demand, used for signature inference. Therefore we place a top +demand on all arguments. Otherwise, the demand is specified by Id's +signature. + +For example, the demand transformer described by the demand signature + StrictSig (DmdType {x -> } m) +says that when the function is applied to two arguments, it +unleashes demand on the free var x, on the first arg, +and on the second, then returning a constructor. + +If this same function is applied to one arg, all we can say is that it +uses x with , and its arg with demand . + +Note [Understanding DmdType and StrictSig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand types are sound approximations of an expression's semantics relative to +the incoming demand we put the expression under. Consider the following +expression: + + \x y -> x `seq` (y, 2*x) + +Here is a table with demand types resulting from different incoming demands we +put that expression under. Note the monotonicity; a stronger incoming demand +yields a more precise demand type: + + incoming demand | demand type + ---------------------------------------------------- + | {} + | {} + | {} + +Note that in the first example, the depth of the demand type was *higher* than +the arity of the incoming call demand due to the anonymous lambda. +The converse is also possible and happens when we unleash demand signatures. +In @f x y@, the incoming call demand on f has arity 2. But if all we have is a +demand signature with depth 1 for @f@ (which we can safely unleash, see below), +the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1. + +So: Demand types are elicited by putting an expression under an incoming (call) +demand, the arity of which can be lower or higher than the depth of the +resulting demand type. +In contrast, a demand signature summarises a function's semantics *without* +immediately specifying the incoming demand it was produced under. Despite StrSig +being a newtype wrapper around DmdType, it actually encodes two things: + + * The threshold (i.e., minimum arity) to unleash the signature + * A demand type that is sound to unleash when the minimum arity requirement is + met. + +Here comes the subtle part: The threshold is encoded in the wrapped demand +type's depth! So in mkStrictSigForArity we make sure to trim the list of +argument demands to the given threshold arity. Call sites will make sure that +this corresponds to the arity of the call demand that elicited the wrapped +demand type. See also Note [What are demand signatures?] in GHC.Core.Op.DmdAnal. + +Besides trimming argument demands, mkStrictSigForArity will also trim CPR +information if necessary. +-} + +-- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe +-- to unleash. Better construct this through 'mkStrictSigForArity'. +-- See Note [Understanding DmdType and StrictSig] +newtype StrictSig = StrictSig DmdType + deriving( Eq ) + +instance Outputable StrictSig where + ppr (StrictSig ty) = ppr ty + +-- Used for printing top-level strictness pragmas in interface files +pprIfaceStrictSig :: StrictSig -> SDoc +pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) + = hcat (map ppr dmds) <> ppr res + +-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' +-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] +mkStrictSigForArity :: Arity -> DmdType -> StrictSig +mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty) + +mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig +mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) + +splitStrictSig :: StrictSig -> ([Demand], Divergence) +splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) + +increaseStrictSigArity :: Int -> StrictSig -> StrictSig +-- ^ Add extra arguments to a strictness signature. +-- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument +-- demands and leaves CPR info intact. +increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res)) + | isTopDmdType dmd_ty = sig + | arity_increase == 0 = sig + | arity_increase < 0 = WARN( True, text "increaseStrictSigArity:" + <+> text "negative arity increase" + <+> ppr arity_increase ) + nopSig + | otherwise = StrictSig (DmdType env dmds' res) + where + dmds' = replicate arity_increase topDmd ++ dmds + +etaExpandStrictSig :: Arity -> StrictSig -> StrictSig +-- ^ We are expanding (\x y. e) to (\x y z. e z). +-- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if +-- necessary, potentially destroying the signature's CPR property. +etaExpandStrictSig arity (StrictSig dmd_ty) + | arity < dmdTypeDepth dmd_ty + -- an arity decrease must zap the whole signature, because it was possibly + -- computed for a higher incoming call demand. + = nopSig + | otherwise + = StrictSig $ ensureArgs arity dmd_ty + +isTopSig :: StrictSig -> Bool +isTopSig (StrictSig ty) = isTopDmdType ty + +hasDemandEnvSig :: StrictSig -> Bool +hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) + +strictSigDmdEnv :: StrictSig -> DmdEnv +strictSigDmdEnv (StrictSig (DmdType env _ _)) = env + +-- | True if the signature diverges or throws an exception +isBottomingSig :: StrictSig -> Bool +isBottomingSig (StrictSig (DmdType _ _ res)) = isBotDiv res + +nopSig, botSig :: StrictSig +nopSig = StrictSig nopDmdType +botSig = StrictSig botDmdType + +cprProdSig :: Arity -> StrictSig +cprProdSig _arity = nopSig + +seqStrictSig :: StrictSig -> () +seqStrictSig (StrictSig ty) = seqDmdType ty + +dmdTransformSig :: StrictSig -> CleanDemand -> DmdType +-- (dmdTransformSig fun_sig dmd) considers a call to a function whose +-- signature is fun_sig, with demand dmd. We return the demand +-- that the function places on its context (eg its args) +dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd + = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty + -- see Note [Demands from unsaturated function calls] + +dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType +-- Same as dmdTransformSig but for a data constructor (worker), +-- which has a special kind of demand transformer. +-- If the constructor is saturated, we feed the demand on +-- the result into the constructor arguments. +dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) + (JD { sd = str, ud = abs }) + | Just str_dmds <- go_str arity str + , Just abs_dmds <- go_abs arity abs + = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res + -- Must remember whether it's a product, hence con_res, not TopRes + + | otherwise -- Not saturated + = nopDmdType + where + go_str 0 dmd = splitStrProdDmd arity dmd + go_str n (SCall s') = go_str (n-1) s' + go_str n HyperStr = go_str (n-1) HyperStr + go_str _ _ = Nothing + + go_abs 0 dmd = splitUseProdDmd arity dmd + go_abs n (UCall One u') = go_abs (n-1) u' + go_abs _ _ = Nothing + +dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType +-- Like dmdTransformDataConSig, we have a special demand transformer +-- for dictionary selectors. If the selector is saturated (ie has one +-- argument: the dictionary), we feed the demand on the result into +-- the indicated dictionary component. +dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd + | (cd',defer_use) <- peelCallDmd cd + , Just jds <- splitProdDmd_maybe dict_dmd + = postProcessUnsat defer_use $ + DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv + | otherwise + = nopDmdType -- See Note [Demand transformer for a dictionary selector] + where + enhance cd old | isAbsDmd old = old + | otherwise = mkOnceUsedDmd cd -- This is the one! + +dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" + +{- +Note [Demand transformer for a dictionary selector] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' +into the appropriate field of the dictionary. What *is* the appropriate field? +We just look at the strictness signature of the class op, which will be +something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. + +For single-method classes, which are represented by newtypes the signature +of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. +That's fine: if we are doing strictness analysis we are also doing inlining, +so we'll have inlined 'op' into a cast. So we can bale out in a conservative +way, returning nopDmdType. + +It is (just.. #8329) possible to be running strictness analysis *without* +having inlined class ops from single-method classes. Suppose you are using +ghc --make; and the first module has a local -O0 flag. So you may load a class +without interface pragmas, ie (currently) without an unfolding for the class +ops. Now if a subsequent module in the --make sweep has a local -O flag +you might do strictness analysis, but there is no inlining for the class op. +This is weird, so I'm not worried about whether this optimises brilliantly; but +it should not fall over. +-} + +argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] +-- See Note [Computing one-shot info] +argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args + | unsaturated_call = [] + | otherwise = go arg_ds + where + unsaturated_call = arg_ds `lengthExceeds` n_val_args + + go [] = [] + go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds + + -- Avoid list tail like [ [], [], [] ] + cons [] [] = [] + cons a as = a:as + +-- saturatedByOneShots n C1(C1(...)) = True, +-- <=> +-- there are at least n nested C1(..) calls +-- See Note [Demand on the worker] in GHC.Core.Op.WorkWrap +saturatedByOneShots :: Int -> Demand -> Bool +saturatedByOneShots n (JD { ud = usg }) + = case usg of + Use _ arg_usg -> go n arg_usg + _ -> False + where + go 0 _ = True + go n (UCall One u) = go (n-1) u + go _ _ = False + +argOneShots :: Demand -- depending on saturation + -> [OneShotInfo] +argOneShots (JD { ud = usg }) + = case usg of + Use _ arg_usg -> go arg_usg + _ -> [] + where + go (UCall One u) = OneShotLam : go u + go (UCall Many u) = NoOneShotInfo : go u + go _ = [] + +{- Note [Computing one-shot info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a call + f (\pqr. e1) (\xyz. e2) e3 +where f has usage signature + C1(C(C1(U))) C1(U) U +Then argsOneShots returns a [[OneShotInfo]] of + [[OneShot,NoOneShotInfo,OneShot], [OneShot]] +The occurrence analyser propagates this one-shot infor to the +binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. +-} + +-- | Returns true if an application to n args +-- would diverge or throw an exception +-- See Note [Unsaturated applications] +appIsBottom :: StrictSig -> Int -> Bool +appIsBottom (StrictSig (DmdType _ ds res)) n + | isBotDiv res = not $ lengthExceeds ds n +appIsBottom _ _ = False + +{- +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a function having bottom as its demand result is applied to a less +number of arguments than its syntactic arity, we cannot say for sure +that it is going to diverge. This is the reason why we use the +function appIsBottom, which, given a strictness signature and a number +of arguments, says conservatively if the function is going to diverge +or not. +-} + +zapUsageEnvSig :: StrictSig -> StrictSig +-- Remove the usage environment from the demand +zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r + +zapUsageDemand :: Demand -> Demand +-- Remove the usage info, but not the strictness info, from the demand +zapUsageDemand = kill_usage $ KillFlags + { kf_abs = True + , kf_used_once = True + , kf_called_once = True + } + +-- | Remove all 1* information (but not C1 information) from the demand +zapUsedOnceDemand :: Demand -> Demand +zapUsedOnceDemand = kill_usage $ KillFlags + { kf_abs = False + , kf_used_once = True + , kf_called_once = False + } + +-- | Remove all 1* information (but not C1 information) from the strictness +-- signature +zapUsedOnceSig :: StrictSig -> StrictSig +zapUsedOnceSig (StrictSig (DmdType env ds r)) + = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) + +data KillFlags = KillFlags + { kf_abs :: Bool + , kf_used_once :: Bool + , kf_called_once :: Bool + } + +kill_usage :: KillFlags -> Demand -> Demand +kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} + +zap_musg :: KillFlags -> ArgUse -> ArgUse +zap_musg kfs Abs + | kf_abs kfs = useTop + | otherwise = Abs +zap_musg kfs (Use c u) + | kf_used_once kfs = Use Many (zap_usg kfs u) + | otherwise = Use c (zap_usg kfs u) + +zap_usg :: KillFlags -> UseDmd -> UseDmd +zap_usg kfs (UCall c u) + | kf_called_once kfs = UCall Many (zap_usg kfs u) + | otherwise = UCall c (zap_usg kfs u) +zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) +zap_usg _ u = u + +-- If the argument is a used non-newtype dictionary, give it strict +-- demand. Also split the product type & demand and recur in order to +-- similarly strictify the argument's contained used non-newtype +-- superclass dictionaries. We use the demand as our recursive measure +-- to guarantee termination. +strictifyDictDmd :: Type -> Demand -> Demand +strictifyDictDmd ty dmd = case getUseDmd dmd of + Use n _ | + Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) + <- splitDataProductType_maybe ty, + not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary + -> seqDmd `bothDmd` -- main idea: ensure it's strict + case splitProdDmd_maybe dmd of + -- superclass cycles should not be a problem, since the demand we are + -- consuming would also have to be infinite in order for us to diverge + Nothing -> dmd -- no components have interesting demand, so stop + -- looking for superclass dicts + Just dmds + | all (not . isAbsDmd) dmds -> evalDmd + -- abstract to strict w/ arbitrary component use, since this + -- smells like reboxing; results in CBV boxed + -- + -- TODO revisit this if we ever do boxity analysis + | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of + JD {sd = s,ud = a} -> JD (Str s) (Use n a) + -- TODO could optimize with an aborting variant of zipWith since + -- the superclass dicts are always a prefix + _ -> dmd -- unused or not a dictionary + +strictifyDmd :: Demand -> Demand +strictifyDmd dmd@(JD { sd = str }) + = dmd { sd = str `bothArgStr` Str HeadStr } + +{- +Note [HyperStr and Use demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The information "HyperStr" needs to be in the strictness signature, and not in +the demand signature, because we still want to know about the demand on things. Consider + + f (x,y) True = error (show x) + f (x,y) False = x+1 + +The signature of f should be m. If we were not +distinguishing the uses on x and y in the True case, we could either not figure +out how deeply we can unpack x, or that we do not have to pass y. + + +************************************************************************ +* * + Serialisation +* * +************************************************************************ +-} + +instance Binary StrDmd where + put_ bh HyperStr = do putByte bh 0 + put_ bh HeadStr = do putByte bh 1 + put_ bh (SCall s) = do putByte bh 2 + put_ bh s + put_ bh (SProd sx) = do putByte bh 3 + put_ bh sx + get bh = do + h <- getByte bh + case h of + 0 -> do return HyperStr + 1 -> do return HeadStr + 2 -> do s <- get bh + return (SCall s) + _ -> do sx <- get bh + return (SProd sx) + +instance Binary ArgStr where + put_ bh Lazy = do + putByte bh 0 + put_ bh (Str s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return Lazy + _ -> do s <- get bh + return $ Str s + +instance Binary Count where + put_ bh One = do putByte bh 0 + put_ bh Many = do putByte bh 1 + + get bh = do h <- getByte bh + case h of + 0 -> return One + _ -> return Many + +instance Binary ArgUse where + put_ bh Abs = do + putByte bh 0 + put_ bh (Use c u) = do + putByte bh 1 + put_ bh c + put_ bh u + + get bh = do + h <- getByte bh + case h of + 0 -> return Abs + _ -> do c <- get bh + u <- get bh + return $ Use c u + +instance Binary UseDmd where + put_ bh Used = do + putByte bh 0 + put_ bh UHead = do + putByte bh 1 + put_ bh (UCall c u) = do + putByte bh 2 + put_ bh c + put_ bh u + put_ bh (UProd ux) = do + putByte bh 3 + put_ bh ux + + get bh = do + h <- getByte bh + case h of + 0 -> return $ Used + 1 -> return $ UHead + 2 -> do c <- get bh + u <- get bh + return (UCall c u) + _ -> do ux <- get bh + return (UProd ux) + +instance (Binary s, Binary u) => Binary (JointDmd s u) where + put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y + get bh = do + x <- get bh + y <- get bh + return $ JD { sd = x, ud = y } + +instance Binary StrictSig where + put_ bh (StrictSig aa) = do + put_ bh aa + get bh = do + aa <- get bh + return (StrictSig aa) + +instance Binary DmdType where + -- Ignore DmdEnv when spitting out the DmdType + put_ bh (DmdType _ ds dr) + = do put_ bh ds + put_ bh dr + get bh + = do ds <- get bh + dr <- get bh + return (DmdType emptyDmdEnv ds dr) + +instance Binary Divergence where + put_ bh Dunno = putByte bh 0 + put_ bh Diverges = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return Dunno + _ -> return Diverges } diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs new file mode 100644 index 0000000000..e73877b292 --- /dev/null +++ b/compiler/GHC/Types/FieldLabel.hs @@ -0,0 +1,132 @@ +{- +% +% (c) Adam Gundry 2013-2015 +% + +This module defines the representation of FieldLabels as stored in +TyCons. As well as a selector name, these have some extra structure +to support the DuplicateRecordFields extension. + +In the normal case (with NoDuplicateRecordFields), a datatype like + + data T = MkT { foo :: Int } + +has + + FieldLabel { flLabel = "foo" + , flIsOverloaded = False + , flSelector = foo }. + +In particular, the Name of the selector has the same string +representation as the label. If DuplicateRecordFields +is enabled, however, the same declaration instead gives + + FieldLabel { flLabel = "foo" + , flIsOverloaded = True + , flSelector = $sel:foo:MkT }. + +Now the name of the selector ($sel:foo:MkT) does not match the label of +the field (foo). We must be careful not to show the selector name to +the user! The point of mangling the selector name is to allow a +module to define the same field label in different datatypes: + + data T = MkT { foo :: Int } + data U = MkU { foo :: Bool } + +Now there will be two FieldLabel values for 'foo', one in T and one in +U. They share the same label (FieldLabelString), but the selector +functions differ. + +See also Note [Representing fields in AvailInfo] in GHC.Types.Avail. + +Note [Why selector names include data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As explained above, a selector name includes the name of the first +data constructor in the type, so that the same label can appear +multiple times in the same module. (This is irrespective of whether +the first constructor has that field, for simplicity.) + +We use a data constructor name, rather than the type constructor name, +because data family instances do not have a representation type +constructor name generated until relatively late in the typechecking +process. + +Of course, datatypes with no constructors cannot have any fields. + +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GHC.Types.FieldLabel + ( FieldLabelString + , FieldLabelEnv + , FieldLbl(..) + , FieldLabel + , mkFieldLabelOccs + ) +where + +import GhcPrelude + +import GHC.Types.Name.Occurrence +import GHC.Types.Name + +import FastString +import FastStringEnv +import Outputable +import Binary + +import Data.Data + +-- | Field labels are just represented as strings; +-- they are not necessarily unique (even within a module) +type FieldLabelString = FastString + +-- | A map from labels to all the auxiliary information +type FieldLabelEnv = DFastStringEnv FieldLabel + + +type FieldLabel = FieldLbl Name + +-- | Fields in an algebraic record type +data FieldLbl a = FieldLabel { + flLabel :: FieldLabelString, -- ^ User-visible label of the field + flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on + -- in the defining module for this datatype? + flSelector :: a -- ^ Record selector function + } + deriving (Eq, Functor, Foldable, Traversable) +deriving instance Data a => Data (FieldLbl a) + +instance Outputable a => Outputable (FieldLbl a) where + ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) + +instance Binary a => Binary (FieldLbl a) where + put_ bh (FieldLabel aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + ab <- get bh + ac <- get bh + ad <- get bh + return (FieldLabel ab ac ad) + + +-- | Record selector OccNames are built from the underlying field name +-- and the name of the first data constructor of the type, to support +-- duplicate record field names. +-- See Note [Why selector names include data constructors]. +mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName +mkFieldLabelOccs lbl dc is_overloaded + = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded + , flSelector = sel_occ } + where + str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc + sel_occ | is_overloaded = mkRecFldSelOcc str + | otherwise = mkVarOccFS lbl diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs new file mode 100644 index 0000000000..b745a6138f --- /dev/null +++ b/compiler/GHC/Types/ForeignCall.hs @@ -0,0 +1,348 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Foreign]{Foreign calls} +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.ForeignCall ( + ForeignCall(..), isSafeForeignCall, + Safety(..), playSafe, playInterruptible, + + CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, + CCallSpec(..), + CCallTarget(..), isDynamicTarget, + CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + + Header(..), CType(..), + ) where + +import GhcPrelude + +import FastString +import Binary +import Outputable +import GHC.Types.Module +import GHC.Types.Basic ( SourceText, pprWithSourceText ) + +import Data.Char +import Data.Data + +{- +************************************************************************ +* * +\subsubsection{Data types} +* * +************************************************************************ +-} + +newtype ForeignCall = CCall CCallSpec + deriving Eq + +isSafeForeignCall :: ForeignCall -> Bool +isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe + +-- We may need more clues to distinguish foreign calls +-- but this simple printer will do for now +instance Outputable ForeignCall where + ppr (CCall cc) = ppr cc + +data Safety + = PlaySafe -- Might invoke Haskell GC, or do a call back, or + -- switch threads, etc. So make sure things are + -- tidy before the call. Additionally, in the threaded + -- RTS we arrange for the external call to be executed + -- by a separate OS thread, i.e., _concurrently_ to the + -- execution of other Haskell threads. + + | PlayInterruptible -- Like PlaySafe, but additionally + -- the worker thread running this foreign call may + -- be unceremoniously killed, so it must be scheduled + -- on an unbound thread. + + | PlayRisky -- None of the above can happen; the call will return + -- without interacting with the runtime system at all + deriving ( Eq, Show, Data ) + -- Show used just for Show Lex.Token, I think + +instance Outputable Safety where + ppr PlaySafe = text "safe" + ppr PlayInterruptible = text "interruptible" + ppr PlayRisky = text "unsafe" + +playSafe :: Safety -> Bool +playSafe PlaySafe = True +playSafe PlayInterruptible = True +playSafe PlayRisky = False + +playInterruptible :: Safety -> Bool +playInterruptible PlayInterruptible = True +playInterruptible _ = False + +{- +************************************************************************ +* * +\subsubsection{Calling C} +* * +************************************************************************ +-} + +data CExportSpec + = CExportStatic -- foreign export ccall foo :: ty + SourceText -- of the CLabelString. + -- See note [Pragma source text] in GHC.Types.Basic + CLabelString -- C Name of exported function + CCallConv + deriving Data + +data CCallSpec + = CCallSpec CCallTarget -- What to call + CCallConv -- Calling convention to use. + Safety + deriving( Eq ) + +-- The call target: + +-- | How to call a particular function in C-land. +data CCallTarget + -- An "unboxed" ccall# to named function in a particular package. + = StaticTarget + SourceText -- of the CLabelString. + -- See note [Pragma source text] in GHC.Types.Basic + CLabelString -- C-land name of label. + + (Maybe UnitId) -- What package the function is in. + -- If Nothing, then it's taken to be in the current package. + -- Note: This information is only used for PrimCalls on Windows. + -- See CLabel.labelDynamic and CoreToStg.coreToStgApp + -- for the difference in representation between PrimCalls + -- and ForeignCalls. If the CCallTarget is representing + -- a regular ForeignCall then it's safe to set this to Nothing. + + -- The first argument of the import is the name of a function pointer (an Addr#). + -- Used when importing a label as "foreign import ccall "dynamic" ..." + Bool -- True => really a function + -- False => a value; only + -- allowed in CAPI imports + | DynamicTarget + + deriving( Eq, Data ) + +isDynamicTarget :: CCallTarget -> Bool +isDynamicTarget DynamicTarget = True +isDynamicTarget _ = False + +{- +Stuff to do with calling convention: + +ccall: Caller allocates parameters, *and* deallocates them. + +stdcall: Caller allocates parameters, callee deallocates. + Function name has @N after it, where N is number of arg bytes + e.g. _Foo@8. This convention is x86 (win32) specific. + +See: http://www.programmersheaven.com/2/Calling-conventions +-} + +-- any changes here should be replicated in the CallConv type in template haskell +data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv + deriving (Eq, Data) + +instance Outputable CCallConv where + ppr StdCallConv = text "stdcall" + ppr CCallConv = text "ccall" + ppr CApiConv = text "capi" + ppr PrimCallConv = text "prim" + ppr JavaScriptCallConv = text "javascript" + +defaultCCallConv :: CCallConv +defaultCCallConv = CCallConv + +ccallConvToInt :: CCallConv -> Int +ccallConvToInt StdCallConv = 0 +ccallConvToInt CCallConv = 1 +ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" +ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" +ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" + +{- +Generate the gcc attribute corresponding to the given +calling convention (used by PprAbsC): +-} + +ccallConvAttribute :: CCallConv -> SDoc +ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" +ccallConvAttribute CCallConv = empty +ccallConvAttribute CApiConv = empty +ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" +ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" + +type CLabelString = FastString -- A C label, completely unencoded + +pprCLabelString :: CLabelString -> SDoc +pprCLabelString lbl = ftext lbl + +isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label +isCLabelString lbl + = all ok (unpackFS lbl) + where + ok c = isAlphaNum c || c == '_' || c == '.' + -- The '.' appears in e.g. "foo.so" in the + -- module part of a ExtName. Maybe it should be separate + +-- Printing into C files: + +instance Outputable CExportSpec where + ppr (CExportStatic _ str _) = pprCLabelString str + +instance Outputable CCallSpec where + ppr (CCallSpec fun cconv safety) + = hcat [ whenPprDebug callconv, ppr_fun fun ] + where + callconv = text "{-" <> ppr cconv <> text "-}" + + gc_suf | playSafe safety = text "_GC" + | otherwise = empty + + ppr_fun (StaticTarget st _fn mPkgId isFun) + = text (if isFun then "__pkg_ccall" + else "__pkg_ccall_value") + <> gc_suf + <+> (case mPkgId of + Nothing -> empty + Just pkgId -> ppr pkgId) + <+> (pprWithSourceText st empty) + + ppr_fun DynamicTarget + = text "__dyn_ccall" <> gc_suf <+> text "\"\"" + +-- The filename for a C header file +-- Note [Pragma source text] in GHC.Types.Basic +data Header = Header SourceText FastString + deriving (Eq, Data) + +instance Outputable Header where + ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) + +-- | A C type, used in CAPI FFI calls +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, +-- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', +-- 'ApiAnnotation.AnnClose' @'\#-}'@, + +-- For details on above see note [Api annotations] in ApiAnnotation +data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.Basic + (Maybe Header) -- header to include for this type + (SourceText,FastString) -- the type itself + deriving (Eq, Data) + +instance Outputable CType where + ppr (CType stp mh (stct,ct)) + = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc + <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" + where hDoc = case mh of + Nothing -> empty + Just h -> ppr h + +{- +************************************************************************ +* * +\subsubsection{Misc} +* * +************************************************************************ +-} + +instance Binary ForeignCall where + put_ bh (CCall aa) = put_ bh aa + get bh = do aa <- get bh; return (CCall aa) + +instance Binary Safety where + put_ bh PlaySafe = do + putByte bh 0 + put_ bh PlayInterruptible = do + putByte bh 1 + put_ bh PlayRisky = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return PlaySafe + 1 -> do return PlayInterruptible + _ -> do return PlayRisky + +instance Binary CExportSpec where + put_ bh (CExportStatic ss aa ab) = do + put_ bh ss + put_ bh aa + put_ bh ab + get bh = do + ss <- get bh + aa <- get bh + ab <- get bh + return (CExportStatic ss aa ab) + +instance Binary CCallSpec where + put_ bh (CCallSpec aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + aa <- get bh + ab <- get bh + ac <- get bh + return (CCallSpec aa ab ac) + +instance Binary CCallTarget where + put_ bh (StaticTarget ss aa ab ac) = do + putByte bh 0 + put_ bh ss + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh DynamicTarget = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do ss <- get bh + aa <- get bh + ab <- get bh + ac <- get bh + return (StaticTarget ss aa ab ac) + _ -> do return DynamicTarget + +instance Binary CCallConv where + put_ bh CCallConv = do + putByte bh 0 + put_ bh StdCallConv = do + putByte bh 1 + put_ bh PrimCallConv = do + putByte bh 2 + put_ bh CApiConv = do + putByte bh 3 + put_ bh JavaScriptCallConv = do + putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> do return CCallConv + 1 -> do return StdCallConv + 2 -> do return PrimCallConv + 3 -> do return CApiConv + _ -> do return JavaScriptCallConv + +instance Binary CType where + put_ bh (CType s mh fs) = do put_ bh s + put_ bh mh + put_ bh fs + get bh = do s <- get bh + mh <- get bh + fs <- get bh + return (CType s mh fs) + +instance Binary Header where + put_ bh (Header s h) = put_ bh s >> put_ bh h + get bh = do s <- get bh + h <- get bh + return (Header s h) diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs new file mode 100644 index 0000000000..e62113390c --- /dev/null +++ b/compiler/GHC/Types/Id.hs @@ -0,0 +1,971 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Id]{@Ids@: Value and constructor identifiers} +-} + +{-# LANGUAGE CPP #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id' represents names that not only have a 'Name.Name' but also a +-- 'GHC.Core.TyCo.Rep.Type' and some additional details (a 'IdInfo.IdInfo' and +-- one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that are added, +-- modified and inspected by various compiler passes. These 'Var.Var' names +-- may either be global or local, see "Var#globalvslocal" +-- +-- * 'Var.Var': see "Var#name_types" + +module GHC.Types.Id ( + -- * The main types + Var, Id, isId, + + -- * In and Out variants + InVar, InId, + OutVar, OutId, + + -- ** Simple construction + mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, + mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, + mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, + mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, + mkUserLocal, mkUserLocalOrCoVar, + mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, + mkWorkerId, + + -- ** Taking an Id apart + idName, idType, idUnique, idInfo, idDetails, + recordSelectorTyCon, + + -- ** Modifying an Id + setIdName, setIdUnique, GHC.Types.Id.setIdType, + setIdExported, setIdNotExported, + globaliseId, localiseId, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, + zapIdUsedOnceInfo, zapIdTailCallInfo, + zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, + transferPolyIdInfo, + + -- ** Predicates on Ids + isImplicitId, isDeadBinder, + isStrictId, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, isNaughtyRecordSelector, + isPatSynRecordSelector, + isDataConRecordSelector, + isClassOpId_maybe, isDFunId, + isPrimOpId, isPrimOpId_maybe, + isFCallId, isFCallId_maybe, + isDataConWorkId, isDataConWorkId_maybe, + isDataConWrapId, isDataConWrapId_maybe, + isDataConId_maybe, + idDataCon, + isConLikeId, isBottomingId, idIsFrom, + hasNoBinding, + + -- ** Join variables + JoinId, isJoinId, isJoinId_maybe, idJoinArity, + asJoinId, asJoinId_maybe, zapJoinId, + + -- ** Inline pragma stuff + idInlinePragma, setInlinePragma, modifyInlinePragma, + idInlineActivation, setInlineActivation, idRuleMatchInfo, + + -- ** One-shot lambdas + isOneShotBndr, isProbablyOneShotLambda, + setOneShotLambda, clearOneShotLambda, + updOneShotInfo, setIdOneShotInfo, + isStateHackType, stateHackOneShot, typeOneShot, + + -- ** Reading 'IdInfo' fields + idArity, + idCallArity, idFunRepArity, + idUnfolding, realIdUnfolding, + idSpecialisation, idCoreRules, idHasRules, + idCafInfo, + idOneShotInfo, idStateHackOneShotInfo, + idOccInfo, + isNeverLevPolyId, + + -- ** Writing 'IdInfo' fields + setIdUnfolding, setCaseBndrEvald, + setIdArity, + setIdCallArity, + + setIdSpecialisation, + setIdCafInfo, + setIdOccInfo, zapIdOccInfo, + + setIdDemandInfo, + setIdStrictness, + setIdCprInfo, + + idDemandInfo, + idStrictness, + idCprInfo, + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Driver.Session +import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, + isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) + +import GHC.Types.Id.Info +import GHC.Types.Basic + +-- Imported and re-exported +import GHC.Types.Var( Id, CoVar, JoinId, + InId, InVar, + OutId, OutVar, + idInfo, idDetails, setIdDetails, globaliseId, + isId, isLocalId, isGlobalId, isExportedId ) +import qualified GHC.Types.Var as Var + +import GHC.Core.Type +import GHC.Types.RepType +import TysPrim +import GHC.Core.DataCon +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Types.Name +import GHC.Types.Module +import GHC.Core.Class +import {-# SOURCE #-} PrimOp (PrimOp) +import GHC.Types.ForeignCall +import Maybes +import GHC.Types.SrcLoc +import Outputable +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import FastString +import Util + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setIdUnfolding`, + `setIdArity`, + `setIdCallArity`, + `setIdOccInfo`, + `setIdOneShotInfo`, + + `setIdSpecialisation`, + `setInlinePragma`, + `setInlineActivation`, + `idCafInfo`, + + `setIdDemandInfo`, + `setIdStrictness`, + `setIdCprInfo`, + + `asJoinId`, + `asJoinId_maybe` + +{- +************************************************************************ +* * +\subsection{Basic Id manipulation} +* * +************************************************************************ +-} + +idName :: Id -> Name +idName = Var.varName + +idUnique :: Id -> Unique +idUnique = Var.varUnique + +idType :: Id -> Kind +idType = Var.varType + +setIdName :: Id -> Name -> Id +setIdName = Var.setVarName + +setIdUnique :: Id -> Unique -> Id +setIdUnique = Var.setVarUnique + +-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and +-- reduce space usage +setIdType :: Id -> Type -> Id +setIdType id ty = seqType ty `seq` Var.setVarType id ty + +setIdExported :: Id -> Id +setIdExported = Var.setIdExported + +setIdNotExported :: Id -> Id +setIdNotExported = Var.setIdNotExported + +localiseId :: Id -> Id +-- Make an Id with the same unique and type as the +-- incoming Id, but with an *Internal* Name and *LocalId* flavour +localiseId id + | ASSERT( isId id ) isLocalId id && isInternalName name + = id + | otherwise + = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) + where + name = idName id + +lazySetIdInfo :: Id -> IdInfo -> Id +lazySetIdInfo = Var.lazySetIdInfo + +setIdInfo :: Id -> IdInfo -> Id +setIdInfo id info = info `seq` (lazySetIdInfo id info) + -- Try to avoid space leaks by seq'ing + +modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id +modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) + +-- maybeModifyIdInfo tries to avoid unnecessary thrashing +maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id +maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info +maybeModifyIdInfo Nothing id = id + +{- +************************************************************************ +* * +\subsection{Simple Id construction} +* * +************************************************************************ + +Absolutely all Ids are made by mkId. It is just like Var.mkId, +but in addition it pins free-tyvar-info onto the Id's type, +where it can easily be found. + +Note [Free type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we cached the free type variables of the type of an Id +at the root of the type in a TyNote. The idea was to avoid repeating +the free-type-variable calculation. But it turned out to slow down +the compiler overall. I don't quite know why; perhaps finding free +type variables of an Id isn't all that common whereas applying a +substitution (which changes the free type variables) is more common. +Anyway, we removed it in March 2008. +-} + +-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" +mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId = Var.mkGlobalVar + +-- | Make a global 'Id' without any extra information at all +mkVanillaGlobal :: Name -> Type -> Id +mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo + +-- | Make a global 'Id' with no global information but some generic 'IdInfo' +mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo = mkGlobalId VanillaId + + +-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" +mkLocalId :: HasDebugCallStack => Name -> Type -> Id +mkLocalId name ty = ASSERT( not (isCoVarType ty) ) + mkLocalIdWithInfo name ty vanillaIdInfo + +-- | Make a local CoVar +mkLocalCoVar :: Name -> Type -> CoVar +mkLocalCoVar name ty + = ASSERT( isCoVarType ty ) + Var.mkLocalVar CoVarId name ty vanillaIdInfo + +-- | Like 'mkLocalId', but checks the type to see if it should make a covar +mkLocalIdOrCoVar :: Name -> Type -> Id +mkLocalIdOrCoVar name ty + | isCoVarType ty = mkLocalCoVar name ty + | otherwise = mkLocalId name ty + + -- proper ids only; no covars! +mkLocalIdWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id +mkLocalIdWithInfo name ty info = ASSERT( not (isCoVarType ty) ) + Var.mkLocalVar VanillaId name ty info + -- Note [Free type variables] + +-- | Create a local 'Id' that is marked as exported. +-- This prevents things attached to it from being removed as dead code. +-- See Note [Exported LocalIds] +mkExportedLocalId :: IdDetails -> Name -> Type -> Id +mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo + -- Note [Free type variables] + +mkExportedVanillaId :: Name -> Type -> Id +mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo + -- Note [Free type variables] + + +-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") +-- that are created by the compiler out of thin air +mkSysLocal :: FastString -> Unique -> Type -> Id +mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkSystemVarName uniq fs) ty + +-- | Like 'mkSysLocal', but checks to see if we have a covar type +mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id +mkSysLocalOrCoVar fs uniq ty + = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty + +mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id +mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) + +mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id +mkSysLocalOrCoVarM fs ty + = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) + +-- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize +mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id +mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkInternalName uniq occ loc) ty + +-- | Like 'mkUserLocal', but checks if we have a coercion type +mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id +mkUserLocalOrCoVar occ uniq ty loc + = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty + +{- +Make some local @Ids@ for a template @CoreExpr@. These have bogus +@Uniques@, but that's OK because the templates are supposed to be +instantiated before use. +-} + +-- | Workers get local names. "CoreTidy" will externalise these if necessary +mkWorkerId :: Unique -> Id -> Type -> Id +mkWorkerId uniq unwrkr ty + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty + +-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings +mkTemplateLocal :: Int -> Type -> Id +mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty + -- "OrCoVar" since this is used in a superclass selector, + -- and "~" and "~~" have coercion "superclasses". + +-- | Create a template local for a series of types +mkTemplateLocals :: [Type] -> [Id] +mkTemplateLocals = mkTemplateLocalsNum 1 + +-- | Create a template local for a series of type, but start from a specified template local +mkTemplateLocalsNum :: Int -> [Type] -> [Id] +mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys + +{- Note [Exported LocalIds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use mkExportedLocalId for things like + - Dictionary functions (DFunId) + - Wrapper and matcher Ids for pattern synonyms + - Default methods for classes + - Pattern-synonym matcher and builder Ids + - etc + +They marked as "exported" in the sense that they should be kept alive +even if apparently unused in other bindings, and not dropped as dead +code by the occurrence analyser. (But "exported" here does not mean +"brought into lexical scope by an import declaration". Indeed these +things are always internal Ids that the user never sees.) + +It's very important that they are *LocalIds*, not GlobalIds, for lots +of reasons: + + * We want to treat them as free variables for the purpose of + dependency analysis (e.g. GHC.Core.FVs.exprFreeVars). + + * Look them up in the current substitution when we come across + occurrences of them (in Subst.lookupIdSubst). Lacking this we + can get an out-of-date unfolding, which can in turn make the + simplifier go into an infinite loop (#9857) + + * Ensure that for dfuns that the specialiser does not float dict uses + above their defns, which would prevent good simplifications happening. + + * The strictness analyser treats a occurrence of a GlobalId as + imported and assumes it contains strictness in its IdInfo, which + isn't true if the thing is bound in the same module as the + occurrence. + +In CoreTidy we must make all these LocalIds into GlobalIds, so that in +importing modules (in --make mode) we treat them as properly global. +That is what is happening in, say tidy_insts in GHC.Iface.Tidy. + +************************************************************************ +* * +\subsection{Special Ids} +* * +************************************************************************ +-} + +-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. +recordSelectorTyCon :: Id -> RecSelParent +recordSelectorTyCon id + = case Var.idDetails id of + RecSelId { sel_tycon = parent } -> parent + _ -> panic "recordSelectorTyCon" + + +isRecordSelector :: Id -> Bool +isNaughtyRecordSelector :: Id -> Bool +isPatSynRecordSelector :: Id -> Bool +isDataConRecordSelector :: Id -> Bool +isPrimOpId :: Id -> Bool +isFCallId :: Id -> Bool +isDataConWorkId :: Id -> Bool +isDataConWrapId :: Id -> Bool +isDFunId :: Id -> Bool + +isClassOpId_maybe :: Id -> Maybe Class +isPrimOpId_maybe :: Id -> Maybe PrimOp +isFCallId_maybe :: Id -> Maybe ForeignCall +isDataConWorkId_maybe :: Id -> Maybe DataCon +isDataConWrapId_maybe :: Id -> Maybe DataCon + +isRecordSelector id = case Var.idDetails id of + RecSelId {} -> True + _ -> False + +isDataConRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelData _} -> True + _ -> False + +isPatSynRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelPatSyn _} -> True + _ -> False + +isNaughtyRecordSelector id = case Var.idDetails id of + RecSelId { sel_naughty = n } -> n + _ -> False + +isClassOpId_maybe id = case Var.idDetails id of + ClassOpId cls -> Just cls + _other -> Nothing + +isPrimOpId id = case Var.idDetails id of + PrimOpId _ -> True + _ -> False + +isDFunId id = case Var.idDetails id of + DFunId {} -> True + _ -> False + +isPrimOpId_maybe id = case Var.idDetails id of + PrimOpId op -> Just op + _ -> Nothing + +isFCallId id = case Var.idDetails id of + FCallId _ -> True + _ -> False + +isFCallId_maybe id = case Var.idDetails id of + FCallId call -> Just call + _ -> Nothing + +isDataConWorkId id = case Var.idDetails id of + DataConWorkId _ -> True + _ -> False + +isDataConWorkId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + _ -> Nothing + +isDataConWrapId id = case Var.idDetails id of + DataConWrapId _ -> True + _ -> False + +isDataConWrapId_maybe id = case Var.idDetails id of + DataConWrapId con -> Just con + _ -> Nothing + +isDataConId_maybe :: Id -> Maybe DataCon +isDataConId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + DataConWrapId con -> Just con + _ -> Nothing + +isJoinId :: Var -> Bool +-- It is convenient in GHC.Core.Op.SetLevels.lvlMFE to apply isJoinId +-- to the free vars of an expression, so it's convenient +-- if it returns False for type variables +isJoinId id + | isId id = case Var.idDetails id of + JoinId {} -> True + _ -> False + | otherwise = False + +isJoinId_maybe :: Var -> Maybe JoinArity +isJoinId_maybe id + | isId id = ASSERT2( isId id, ppr id ) + case Var.idDetails id of + JoinId arity -> Just arity + _ -> Nothing + | otherwise = Nothing + +idDataCon :: Id -> DataCon +-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. +-- +-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker +idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) + +hasNoBinding :: Id -> Bool +-- ^ Returns @True@ of an 'Id' which may not have a +-- binding, even though it is defined in this module. + +-- Data constructor workers used to be things of this kind, but +-- they aren't any more. Instead, we inject a binding for +-- them at the CorePrep stage. +-- +-- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs. +-- for the history of this. +-- +-- Note that CorePrep currently eta expands things no-binding things and this +-- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things +-- in CorePrep] in CorePrep for details. +-- +-- EXCEPT: unboxed tuples, which definitely have no binding +hasNoBinding id = case Var.idDetails id of + PrimOpId _ -> False -- See Note [Primop wrappers] in PrimOp.hs + FCallId _ -> True + DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc + _ -> isCompulsoryUnfolding (idUnfolding id) + -- See Note [Levity-polymorphic Ids] + +isImplicitId :: Id -> Bool +-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other +-- declarations, so we don't need to put its signature in an interface +-- file, even if it's mentioned in some other interface unfolding. +isImplicitId id + = case Var.idDetails id of + FCallId {} -> True + ClassOpId {} -> True + PrimOpId {} -> True + DataConWorkId {} -> True + DataConWrapId {} -> True + -- These are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl + _ -> False + +idIsFrom :: Module -> Id -> Bool +idIsFrom mod id = nameIsLocalOrFrom mod (idName id) + +{- Note [Levity-polymorphic Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some levity-polymorphic Ids must be applied and inlined, not left +un-saturated. Example: + unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b + +This has a compulsory unfolding because we can't lambda-bind those +arguments. But the compulsory unfolding may leave levity-polymorphic +lambdas if it is not applied to enough arguments; e.g. (#14561) + bad :: forall (a :: TYPE r). a -> a + bad = unsafeCoerce# + +The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop. +And we want that magic to apply to levity-polymorphic compulsory-inline things. +The easiest way to do this is for hasNoBinding to return True of all things +that have compulsory unfolding. Some Ids with a compulsory unfolding also +have a binding, but it does not harm to say they don't here, and its a very +simple way to fix #14561. +-} + +isDeadBinder :: Id -> Bool +isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) + | otherwise = False -- TyVars count as not dead + +{- +************************************************************************ +* * + Join variables +* * +************************************************************************ +-} + +idJoinArity :: JoinId -> JoinArity +idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) + +asJoinId :: Id -> JoinArity -> JoinId +asJoinId id arity = WARN(not (isLocalId id), + text "global id being marked as join var:" <+> ppr id) + WARN(not (is_vanilla_or_join id), + ppr id <+> pprIdDetails (idDetails id)) + id `setIdDetails` JoinId arity + where + is_vanilla_or_join id = case Var.idDetails id of + VanillaId -> True + JoinId {} -> True + _ -> False + +zapJoinId :: Id -> Id +-- May be a regular id already +zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId) + -- Core Lint may complain if still marked + -- as AlwaysTailCalled + | otherwise = jid + +asJoinId_maybe :: Id -> Maybe JoinArity -> Id +asJoinId_maybe id (Just arity) = asJoinId id arity +asJoinId_maybe id Nothing = zapJoinId id + +{- +************************************************************************ +* * +\subsection{IdInfo stuff} +* * +************************************************************************ +-} + + --------------------------------- + -- ARITY +idArity :: Id -> Arity +idArity id = arityInfo (idInfo id) + +setIdArity :: Id -> Arity -> Id +setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id + +idCallArity :: Id -> Arity +idCallArity id = callArityInfo (idInfo id) + +setIdCallArity :: Id -> Arity -> Id +setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id + +idFunRepArity :: Id -> RepArity +idFunRepArity x = countFunRepArgs (idArity x) (idType x) + +-- | Returns true if an application to n args would diverge +isBottomingId :: Var -> Bool +isBottomingId v + | isId v = isBottomingSig (idStrictness v) + | otherwise = False + +-- | Accesses the 'Id''s 'strictnessInfo'. +idStrictness :: Id -> StrictSig +idStrictness id = strictnessInfo (idInfo id) + +setIdStrictness :: Id -> StrictSig -> Id +setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id + +idCprInfo :: Id -> CprSig +idCprInfo id = cprInfo (idInfo id) + +setIdCprInfo :: Id -> CprSig -> Id +setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id + +zapIdStrictness :: Id -> Id +zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id + +-- | This predicate says whether the 'Id' has a strict demand placed on it or +-- has a type such that it can always be evaluated strictly (i.e an +-- unlifted type, as of GHC 7.6). We need to +-- check separately whether the 'Id' has a so-called \"strict type\" because if +-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict +-- type, we still want @isStrictId id@ to be @True@. +isStrictId :: Id -> Bool +isStrictId id + = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) + not (isJoinId id) && ( + (isStrictType (idType id)) || + -- Take the best of both strictnesses - old and new + (isStrictDmd (idDemandInfo id)) + ) + + --------------------------------- + -- UNFOLDING +idUnfolding :: Id -> Unfolding +-- Do not expose the unfolding of a loop breaker! +idUnfolding id + | isStrongLoopBreaker (occInfo info) = NoUnfolding + | otherwise = unfoldingInfo info + where + info = idInfo id + +realIdUnfolding :: Id -> Unfolding +-- Expose the unfolding if there is one, including for loop breakers +realIdUnfolding id = unfoldingInfo (idInfo id) + +setIdUnfolding :: Id -> Unfolding -> Id +setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id + +idDemandInfo :: Id -> Demand +idDemandInfo id = demandInfo (idInfo id) + +setIdDemandInfo :: Id -> Demand -> Id +setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id + +setCaseBndrEvald :: StrictnessMark -> Id -> Id +-- Used for variables bound by a case expressions, both the case-binder +-- itself, and any pattern-bound variables that are argument of a +-- strict constructor. It just marks the variable as already-evaluated, +-- so that (for example) a subsequent 'seq' can be dropped +setCaseBndrEvald str id + | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding + | otherwise = id + + --------------------------------- + -- SPECIALISATION + +-- See Note [Specialisations and RULES in IdInfo] in GHC.Types.Id.Info + +idSpecialisation :: Id -> RuleInfo +idSpecialisation id = ruleInfo (idInfo id) + +idCoreRules :: Id -> [CoreRule] +idCoreRules id = ruleInfoRules (idSpecialisation id) + +idHasRules :: Id -> Bool +idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) + +setIdSpecialisation :: Id -> RuleInfo -> Id +setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id + + --------------------------------- + -- CAF INFO +idCafInfo :: Id -> CafInfo +idCafInfo id = cafInfo (idInfo id) + +setIdCafInfo :: Id -> CafInfo -> Id +setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id + + --------------------------------- + -- Occurrence INFO +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) + +setIdOccInfo :: Id -> OccInfo -> Id +setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id + +zapIdOccInfo :: Id -> Id +zapIdOccInfo b = b `setIdOccInfo` noOccInfo + +{- + --------------------------------- + -- INLINING +The inline pragma tells us to be very keen to inline this Id, but it's still +OK not to if optimisation is switched off. +-} + +idInlinePragma :: Id -> InlinePragma +idInlinePragma id = inlinePragInfo (idInfo id) + +setInlinePragma :: Id -> InlinePragma -> Id +setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id + +modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id +modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id + +idInlineActivation :: Id -> Activation +idInlineActivation id = inlinePragmaActivation (idInlinePragma id) + +setInlineActivation :: Id -> Activation -> Id +setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) + +idRuleMatchInfo :: Id -> RuleMatchInfo +idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) + +isConLikeId :: Id -> Bool +isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) + +{- + --------------------------------- + -- ONE-SHOT LAMBDAS +-} + +idOneShotInfo :: Id -> OneShotInfo +idOneShotInfo id = oneShotInfo (idInfo id) + +-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account +-- See Note [The state-transformer hack] in GHC.Core.Arity +idStateHackOneShotInfo :: Id -> OneShotInfo +idStateHackOneShotInfo id + | isStateHackType (idType id) = stateHackOneShot + | otherwise = idOneShotInfo id + +-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once +-- This one is the "business end", called externally. +-- It works on type variables as well as Ids, returning True +-- Its main purpose is to encapsulate the Horrible State Hack +-- See Note [The state-transformer hack] in GHC.Core.Arity +isOneShotBndr :: Var -> Bool +isOneShotBndr var + | isTyVar var = True + | OneShotLam <- idStateHackOneShotInfo var = True + | otherwise = False + +-- | Should we apply the state hack to values of this 'Type'? +stateHackOneShot :: OneShotInfo +stateHackOneShot = OneShotLam + +typeOneShot :: Type -> OneShotInfo +typeOneShot ty + | isStateHackType ty = stateHackOneShot + | otherwise = NoOneShotInfo + +isStateHackType :: Type -> Bool +isStateHackType ty + | hasNoStateHack unsafeGlobalDynFlags + = False + | otherwise + = case tyConAppTyCon_maybe ty of + Just tycon -> tycon == statePrimTyCon + _ -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.hs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + +isProbablyOneShotLambda :: Id -> Bool +isProbablyOneShotLambda id = case idStateHackOneShotInfo id of + OneShotLam -> True + NoOneShotInfo -> False + +setOneShotLambda :: Id -> Id +setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id + +clearOneShotLambda :: Id -> Id +clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id + +setIdOneShotInfo :: Id -> OneShotInfo -> Id +setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id + +updOneShotInfo :: Id -> OneShotInfo -> Id +-- Combine the info in the Id with new info +updOneShotInfo id one_shot + | do_upd = setIdOneShotInfo id one_shot + | otherwise = id + where + do_upd = case (idOneShotInfo id, one_shot) of + (NoOneShotInfo, _) -> True + (OneShotLam, _) -> False + +-- The OneShotLambda functions simply fiddle with the IdInfo flag +-- But watch out: this may change the type of something else +-- f = \x -> e +-- If we change the one-shot-ness of x, f's type changes + +zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id +zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id + +zapLamIdInfo :: Id -> Id +zapLamIdInfo = zapInfo zapLamInfo + +zapFragileIdInfo :: Id -> Id +zapFragileIdInfo = zapInfo zapFragileInfo + +zapIdDemandInfo :: Id -> Id +zapIdDemandInfo = zapInfo zapDemandInfo + +zapIdUsageInfo :: Id -> Id +zapIdUsageInfo = zapInfo zapUsageInfo + +zapIdUsageEnvInfo :: Id -> Id +zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo + +zapIdUsedOnceInfo :: Id -> Id +zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo + +zapIdTailCallInfo :: Id -> Id +zapIdTailCallInfo = zapInfo zapTailCallInfo + +zapStableUnfolding :: Id -> Id +zapStableUnfolding id + | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding + | otherwise = id + +{- +Note [transferPolyIdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This transfer is used in three places: + FloatOut (long-distance let-floating) + GHC.Core.Op.Simplify.Utils.abstractFloats (short-distance let-floating) + StgLiftLams (selectively lambda-lift local functions to top-level) + +Consider the short-distance let-floating: + + f = /\a. let g = rhs in ... + +Then if we float thus + + g' = /\a. rhs + f = /\a. ...[g' a/g].... + +we *do not* want to lose g's + * strictness information + * arity + * inline pragma (though that is bit more debatable) + * occurrence info + +Mostly this is just an optimisation, but it's *vital* to +transfer the occurrence info. Consider + + NonRec { f = /\a. let Rec { g* = ..g.. } in ... } + +where the '*' means 'LoopBreaker'. Then if we float we must get + + Rec { g'* = /\a. ...(g' a)... } + NonRec { f = /\a. ...[g' a/g]....} + +where g' is also marked as LoopBreaker. If not, terrible things +can happen if we re-simplify the binding (and the Simplifier does +sometimes simplify a term twice); see #4345. + +It's not so simple to retain + * worker info + * rules +so we simply discard those. Sooner or later this may bite us. + +If we abstract wrt one or more *value* binders, we must modify the +arity and strictness info before transferring it. E.g. + f = \x. e +--> + g' = \y. \x. e + + substitute (g' y) for g +Notice that g' has an arity one more than the original g +-} + +transferPolyIdInfo :: Id -- Original Id + -> [Var] -- Abstract wrt these variables + -> Id -- New Id + -> Id +transferPolyIdInfo old_id abstract_wrt new_id + = modifyIdInfo transfer new_id + where + arity_increase = count isId abstract_wrt -- Arity increases by the + -- number of value binders + + old_info = idInfo old_id + old_arity = arityInfo old_info + old_inline_prag = inlinePragInfo old_info + old_occ_info = occInfo old_info + new_arity = old_arity + arity_increase + new_occ_info = zapOccTailCallInfo old_occ_info + + old_strictness = strictnessInfo old_info + new_strictness = increaseStrictSigArity arity_increase old_strictness + old_cpr = cprInfo old_info + + transfer new_info = new_info `setArityInfo` new_arity + `setInlinePragInfo` old_inline_prag + `setOccInfo` new_occ_info + `setStrictnessInfo` new_strictness + `setCprInfo` old_cpr + +isNeverLevPolyId :: Id -> Bool +isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs new file mode 100644 index 0000000000..e731fc1449 --- /dev/null +++ b/compiler/GHC/Types/Id/Info.hs @@ -0,0 +1,652 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} + +(And a pretty good illustration of quite a few things wrong with +Haskell. [WDP 94/11]) +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Types.Id.Info ( + -- * The IdDetails type + IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, + JoinArity, isJoinIdDetails_maybe, + RecSelParent(..), + + -- * The IdInfo type + IdInfo, -- Abstract + vanillaIdInfo, noCafIdInfo, + + -- ** The OneShotInfo type + OneShotInfo(..), + oneShotInfo, noOneShotInfo, hasNoOneShotInfo, + setOneShotInfo, + + -- ** Zapping various forms of Info + zapLamInfo, zapFragileInfo, + zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, + zapTailCallInfo, zapCallArityInfo, zapUnfolding, + + -- ** The ArityInfo type + ArityInfo, + unknownArity, + arityInfo, setArityInfo, ppArityInfo, + + callArityInfo, setCallArityInfo, + + -- ** Demand and strictness Info + strictnessInfo, setStrictnessInfo, + cprInfo, setCprInfo, + demandInfo, setDemandInfo, pprStrictness, + + -- ** Unfolding Info + unfoldingInfo, setUnfoldingInfo, + + -- ** The InlinePragInfo type + InlinePragInfo, + inlinePragInfo, setInlinePragInfo, + + -- ** The OccInfo type + OccInfo(..), + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, + occInfo, setOccInfo, + + InsideLam(..), OneBranch(..), + + TailCallInfo(..), + tailCallInfo, isAlwaysTailCalled, + + -- ** The RuleInfo type + RuleInfo(..), + emptyRuleInfo, + isEmptyRuleInfo, ruleInfoFreeVars, + ruleInfoRules, setRuleInfoHead, + ruleInfo, setRuleInfo, + + -- ** The CAFInfo type + CafInfo(..), + ppCafInfo, mayHaveCafRefs, + cafInfo, setCafInfo, + + -- ** Tick-box Info + TickBoxOp(..), TickBoxId, + + -- ** Levity info + LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, + isNeverLevPolyIdInfo + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core + +import GHC.Core.Class +import {-# SOURCE #-} PrimOp (PrimOp) +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.PatSyn +import GHC.Core.Type +import GHC.Types.ForeignCall +import Outputable +import GHC.Types.Module +import GHC.Types.Demand +import GHC.Types.Cpr +import Util + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setRuleInfo`, + `setArityInfo`, + `setInlinePragInfo`, + `setUnfoldingInfo`, + `setOneShotInfo`, + `setOccInfo`, + `setCafInfo`, + `setStrictnessInfo`, + `setCprInfo`, + `setDemandInfo`, + `setNeverLevPoly`, + `setLevityInfoWithType` + +{- +************************************************************************ +* * + IdDetails +* * +************************************************************************ +-} + +-- | Identifier Details +-- +-- The 'IdDetails' of an 'Id' give stable, and necessary, +-- information about the Id. +data IdDetails + = VanillaId + + -- | The 'Id' for a record selector + | RecSelId + { sel_tycon :: RecSelParent + , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: + -- data T = forall a. MkT { x :: a } + } -- See Note [Naughty record selectors] in TcTyClsDecls + + | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ + | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ + + -- [the only reasons we need to know is so that + -- a) to support isImplicitId + -- b) when desugaring a RecordCon we can get + -- from the Id back to the data con] + | ClassOpId Class -- ^ The 'Id' is a superclass selector, + -- or class operation of a class + + | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. + -- Type will be simple: no type families, newtypes, etc + + | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) + + | DFunId Bool -- ^ A dictionary function. + -- Bool = True <=> the class has only one method, so may be + -- implemented with a newtype, so it might be bad + -- to be strict on this dictionary + + | CoVarId -- ^ A coercion variable + -- This only covers /un-lifted/ coercions, of type + -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants + | JoinId JoinArity -- ^ An 'Id' for a join point taking n arguments + -- Note [Join points] in GHC.Core + +-- | Recursive Selector Parent +data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq + -- Either `TyCon` or `PatSyn` depending + -- on the origin of the record selector. + -- For a data type family, this is the + -- /instance/ 'TyCon' not the family 'TyCon' + +instance Outputable RecSelParent where + ppr p = case p of + RecSelData ty_con -> ppr ty_con + RecSelPatSyn ps -> ppr ps + +-- | Just a synonym for 'CoVarId'. Written separately so it can be +-- exported in the hs-boot file. +coVarDetails :: IdDetails +coVarDetails = CoVarId + +-- | Check if an 'IdDetails' says 'CoVarId'. +isCoVarDetails :: IdDetails -> Bool +isCoVarDetails CoVarId = True +isCoVarDetails _ = False + +isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity +isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity +isJoinIdDetails_maybe _ = Nothing + +instance Outputable IdDetails where + ppr = pprIdDetails + +pprIdDetails :: IdDetails -> SDoc +pprIdDetails VanillaId = empty +pprIdDetails other = brackets (pp other) + where + pp VanillaId = panic "pprIdDetails" + pp (DataConWorkId _) = text "DataCon" + pp (DataConWrapId _) = text "DataConWrapper" + pp (ClassOpId {}) = text "ClassOp" + pp (PrimOpId _) = text "PrimOp" + pp (FCallId _) = text "ForeignCall" + pp (TickBoxOpId _) = text "TickBoxOp" + pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") + pp (RecSelId { sel_naughty = is_naughty }) + = brackets $ text "RecSel" <> + ppWhen is_naughty (text "(naughty)") + pp CoVarId = text "CoVarId" + pp (JoinId arity) = text "JoinId" <> parens (int arity) + +{- +************************************************************************ +* * +\subsection{The main IdInfo type} +* * +************************************************************************ +-} + +-- | Identifier Information +-- +-- An 'IdInfo' gives /optional/ information about an 'Id'. If +-- present it never lies, but it may not be present, in which case there +-- is always a conservative assumption which can be made. +-- +-- Two 'Id's may have different info even though they have the same +-- 'Unique' (and are hence the same 'Id'); for example, one might lack +-- the properties attached to the other. +-- +-- Most of the 'IdInfo' gives information about the value, or definition, of +-- the 'Id', independent of its usage. Exceptions to this +-- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. +-- +-- Performance note: when we update 'IdInfo', we have to reallocate this +-- entire record, so it is a good idea not to let this data structure get +-- too big. +data IdInfo + = IdInfo { + arityInfo :: !ArityInfo, + -- ^ 'Id' arity, as computed by 'GHC.Core.Arity'. Specifies how many + -- arguments this 'Id' has to be applied to before it doesn any + -- meaningful work. + ruleInfo :: RuleInfo, + -- ^ Specialisations of the 'Id's function which exist. + -- See Note [Specialisations and RULES in IdInfo] + unfoldingInfo :: Unfolding, + -- ^ The 'Id's unfolding + cafInfo :: CafInfo, + -- ^ 'Id' CAF info + oneShotInfo :: OneShotInfo, + -- ^ Info about a lambda-bound variable, if the 'Id' is one + inlinePragInfo :: InlinePragma, + -- ^ Any inline pragma attached to the 'Id' + occInfo :: OccInfo, + -- ^ How the 'Id' occurs in the program + strictnessInfo :: StrictSig, + -- ^ A strictness signature. Digests how a function uses its arguments + -- if applied to at least 'arityInfo' arguments. + cprInfo :: CprSig, + -- ^ Information on whether the function will ultimately return a + -- freshly allocated constructor. + demandInfo :: Demand, + -- ^ ID demand information + callArityInfo :: !ArityInfo, + -- ^ How this is called. This is the number of arguments to which a + -- binding can be eta-expanded without losing any sharing. + -- n <=> all calls have at least n arguments + levityInfo :: LevityInfo + -- ^ when applied, will this Id ever have a levity-polymorphic type? + } + +-- Setters + +setRuleInfo :: IdInfo -> RuleInfo -> IdInfo +setRuleInfo info sp = sp `seq` info { ruleInfo = sp } +setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } +setOccInfo :: IdInfo -> OccInfo -> IdInfo +setOccInfo info oc = oc `seq` info { occInfo = oc } + -- Try to avoid space leaks by seq'ing + +setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo +setUnfoldingInfo info uf + = -- We don't seq the unfolding, as we generate intermediate + -- unfoldings which are just thrown away, so evaluating them is a + -- waste of time. + -- seqUnfolding uf `seq` + info { unfoldingInfo = uf } + +setArityInfo :: IdInfo -> ArityInfo -> IdInfo +setArityInfo info ar = info { arityInfo = ar } +setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo +setCallArityInfo info ar = info { callArityInfo = ar } +setCafInfo :: IdInfo -> CafInfo -> IdInfo +setCafInfo info caf = info { cafInfo = caf } + +setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo +setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb } + +setDemandInfo :: IdInfo -> Demand -> IdInfo +setDemandInfo info dd = dd `seq` info { demandInfo = dd } + +setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo +setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } + +setCprInfo :: IdInfo -> CprSig -> IdInfo +setCprInfo info cpr = cpr `seq` info { cprInfo = cpr } + +-- | Basic 'IdInfo' that carries no useful information whatsoever +vanillaIdInfo :: IdInfo +vanillaIdInfo + = IdInfo { + cafInfo = vanillaCafInfo, + arityInfo = unknownArity, + ruleInfo = emptyRuleInfo, + unfoldingInfo = noUnfolding, + oneShotInfo = NoOneShotInfo, + inlinePragInfo = defaultInlinePragma, + occInfo = noOccInfo, + demandInfo = topDmd, + strictnessInfo = nopSig, + cprInfo = topCprSig, + callArityInfo = unknownArity, + levityInfo = NoLevityInfo + } + +-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references +noCafIdInfo :: IdInfo +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Used for built-in type Ids in GHC.Types.Id.Make. + +{- +************************************************************************ +* * +\subsection[arity-IdInfo]{Arity info about an @Id@} +* * +************************************************************************ + +For locally-defined Ids, the code generator maintains its own notion +of their arities; so it should not be asking... (but other things +besides the code-generator need arity info!) +-} + +-- | Arity Information +-- +-- An 'ArityInfo' of @n@ tells us that partial application of this +-- 'Id' to up to @n-1@ value arguments does essentially no work. +-- +-- That is not necessarily the same as saying that it has @n@ leading +-- lambdas, because coerces may get in the way. +-- +-- The arity might increase later in the compilation process, if +-- an extra lambda floats up to the binding site. +type ArityInfo = Arity + +-- | It is always safe to assume that an 'Id' has an arity of 0 +unknownArity :: Arity +unknownArity = 0 + +ppArityInfo :: Int -> SDoc +ppArityInfo 0 = empty +ppArityInfo n = hsep [text "Arity", int n] + +{- +************************************************************************ +* * +\subsection{Inline-pragma information} +* * +************************************************************************ +-} + +-- | Inline Pragma Information +-- +-- Tells when the inlining is active. +-- When it is active the thing may be inlined, depending on how +-- big it is. +-- +-- If there was an @INLINE@ pragma, then as a separate matter, the +-- RHS will have been made to look small with a Core inline 'Note' +-- +-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves +-- entirely as a way to inhibit inlining until we want it +type InlinePragInfo = InlinePragma + +{- +************************************************************************ +* * + Strictness +* * +************************************************************************ +-} + +pprStrictness :: StrictSig -> SDoc +pprStrictness sig = ppr sig + +{- +************************************************************************ +* * + RuleInfo +* * +************************************************************************ + +Note [Specialisations and RULES in IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, a GlobalId has an *empty* RuleInfo. All their +RULES are contained in the globally-built rule-base. In principle, +one could attach the to M.f the RULES for M.f that are defined in M. +But we don't do that for instance declarations and so we just treat +them all uniformly. + +The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is +just for convenience really. + +However, LocalIds may have non-empty RuleInfo. We treat them +differently because: + a) they might be nested, in which case a global table won't work + b) the RULE might mention free variables, which we use to keep things alive + +In GHC.Iface.Tidy, when the LocalId becomes a GlobalId, its RULES are stripped off +and put in the global list. +-} + +-- | Rule Information +-- +-- Records the specializations of this 'Id' that we know about +-- in the form of rewrite 'CoreRule's that target them +data RuleInfo + = RuleInfo + [CoreRule] + DVarSet -- Locally-defined free vars of *both* LHS and RHS + -- of rules. I don't think it needs to include the + -- ru_fn though. + -- Note [Rule dependency info] in OccurAnal + +-- | Assume that no specializations exist: always safe +emptyRuleInfo :: RuleInfo +emptyRuleInfo = RuleInfo [] emptyDVarSet + +isEmptyRuleInfo :: RuleInfo -> Bool +isEmptyRuleInfo (RuleInfo rs _) = null rs + +-- | Retrieve the locally-defined free variables of both the left and +-- right hand sides of the specialization rules +ruleInfoFreeVars :: RuleInfo -> DVarSet +ruleInfoFreeVars (RuleInfo _ fvs) = fvs + +ruleInfoRules :: RuleInfo -> [CoreRule] +ruleInfoRules (RuleInfo rules _) = rules + +-- | Change the name of the function the rule is keyed on on all of the 'CoreRule's +setRuleInfoHead :: Name -> RuleInfo -> RuleInfo +setRuleInfoHead fn (RuleInfo rules fvs) + = RuleInfo (map (setRuleIdName fn) rules) fvs + +{- +************************************************************************ +* * +\subsection[CG-IdInfo]{Code generator-related information} +* * +************************************************************************ +-} + +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). + +-- | Constant applicative form Information +-- +-- Records whether an 'Id' makes Constant Applicative Form references +data CafInfo + = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: + -- + -- 1. A function or static constructor + -- that refers to one or more CAFs, or + -- + -- 2. A real live CAF + + | NoCafRefs -- ^ A function or static constructor + -- that refers to no CAFs. + deriving (Eq, Ord) + +-- | Assumes that the 'Id' has CAF references: definitely safe +vanillaCafInfo :: CafInfo +vanillaCafInfo = MayHaveCafRefs + +mayHaveCafRefs :: CafInfo -> Bool +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False + +instance Outputable CafInfo where + ppr = ppCafInfo + +ppCafInfo :: CafInfo -> SDoc +ppCafInfo NoCafRefs = text "NoCafRefs" +ppCafInfo MayHaveCafRefs = empty + +{- +************************************************************************ +* * +\subsection{Bulk operations on IdInfo} +* * +************************************************************************ +-} + +-- | This is used to remove information on lambda binders that we have +-- setup as part of a lambda group, assuming they will be applied all at once, +-- but turn out to be part of an unsaturated lambda as in e.g: +-- +-- > (\x1. \x2. e) arg1 +zapLamInfo :: IdInfo -> Maybe IdInfo +zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) + | is_safe_occ occ && is_safe_dmd demand + = Nothing + | otherwise + = Just (info {occInfo = safe_occ, demandInfo = topDmd}) + where + -- The "unsafe" occ info is the ones that say I'm not in a lambda + -- because that might not be true for an unsaturated lambda + is_safe_occ occ | isAlwaysTailCalled occ = False + is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False + is_safe_occ _other = True + + safe_occ = case occ of + OneOcc{} -> occ { occ_in_lam = IsInsideLam + , occ_tail = NoTailCallInfo } + IAmALoopBreaker{} + -> occ { occ_tail = NoTailCallInfo } + _other -> occ + + is_safe_dmd dmd = not (isStrictDmd dmd) + +-- | Remove all demand info on the 'IdInfo' +zapDemandInfo :: IdInfo -> Maybe IdInfo +zapDemandInfo info = Just (info {demandInfo = topDmd}) + +-- | Remove usage (but not strictness) info on the 'IdInfo' +zapUsageInfo :: IdInfo -> Maybe IdInfo +zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) + +-- | Remove usage environment info from the strictness signature on the 'IdInfo' +zapUsageEnvInfo :: IdInfo -> Maybe IdInfo +zapUsageEnvInfo info + | hasDemandEnvSig (strictnessInfo info) + = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) + | otherwise + = Nothing + +zapUsedOnceInfo :: IdInfo -> Maybe IdInfo +zapUsedOnceInfo info + = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) + , demandInfo = zapUsedOnceDemand (demandInfo info) } + +zapFragileInfo :: IdInfo -> Maybe IdInfo +-- ^ Zap info that depends on free variables +zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) + = new_unf `seq` -- The unfolding field is not (currently) strict, so we + -- force it here to avoid a (zapFragileUnfolding unf) thunk + -- which might leak space + Just (info `setRuleInfo` emptyRuleInfo + `setUnfoldingInfo` new_unf + `setOccInfo` zapFragileOcc occ) + where + new_unf = zapFragileUnfolding unf + +zapFragileUnfolding :: Unfolding -> Unfolding +zapFragileUnfolding unf + | isFragileUnfolding unf = noUnfolding + | otherwise = unf + +zapUnfolding :: Unfolding -> Unfolding +-- Squash all unfolding info, preserving only evaluated-ness +zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding + | otherwise = noUnfolding + +zapTailCallInfo :: IdInfo -> Maybe IdInfo +zapTailCallInfo info + = case occInfo info of + occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) + | otherwise -> Nothing + where + safe_occ = occ { occ_tail = NoTailCallInfo } + +zapCallArityInfo :: IdInfo -> IdInfo +zapCallArityInfo info = setCallArityInfo info 0 + +{- +************************************************************************ +* * +\subsection{TickBoxOp} +* * +************************************************************************ +-} + +type TickBoxId = Int + +-- | Tick box for Hpc-style coverage +data TickBoxOp + = TickBox Module {-# UNPACK #-} !TickBoxId + +instance Outputable TickBoxOp where + ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) + +{- +************************************************************************ +* * + Levity +* * +************************************************************************ + +Note [Levity info] +~~~~~~~~~~~~~~~~~~ + +Ids store whether or not they can be levity-polymorphic at any amount +of saturation. This is helpful in optimizing the levity-polymorphism check +done in the desugarer, where we can usually learn that something is not +levity-polymorphic without actually figuring out its type. See +isExprLevPoly in GHC.Core.Utils for where this info is used. Storing +this is required to prevent perf/compiler/T5631 from blowing up. + +-} + +-- See Note [Levity info] +data LevityInfo = NoLevityInfo -- always safe + | NeverLevityPolymorphic + deriving Eq + +instance Outputable LevityInfo where + ppr NoLevityInfo = text "NoLevityInfo" + ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" + +-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when +-- applied). The Type is only there for checking that it's really never levity +-- polymorphic +setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo +setNeverLevPoly info ty + = ASSERT2( not (resultIsLevPoly ty), ppr ty ) + info { levityInfo = NeverLevityPolymorphic } + +setLevityInfoWithType :: IdInfo -> Type -> IdInfo +setLevityInfoWithType info ty + | not (resultIsLevPoly ty) + = info { levityInfo = NeverLevityPolymorphic } + | otherwise + = info + +isNeverLevPolyIdInfo :: IdInfo -> Bool +isNeverLevPolyIdInfo info + | NeverLevityPolymorphic <- levityInfo info = True + | otherwise = False diff --git a/compiler/GHC/Types/Id/Info.hs-boot b/compiler/GHC/Types/Id/Info.hs-boot new file mode 100644 index 0000000000..c6912344aa --- /dev/null +++ b/compiler/GHC/Types/Id/Info.hs-boot @@ -0,0 +1,11 @@ +module GHC.Types.Id.Info where +import GhcPrelude +import Outputable +data IdInfo +data IdDetails + +vanillaIdInfo :: IdInfo +coVarDetails :: IdDetails +isCoVarDetails :: IdDetails -> Bool +pprIdDetails :: IdDetails -> SDoc + diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs new file mode 100644 index 0000000000..43b7aae72d --- /dev/null +++ b/compiler/GHC/Types/Id/Make.hs @@ -0,0 +1,1708 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + + +This module contains definitions for the IdInfo for things that +have a standard form, namely: + +- data constructors +- record selectors +- method and superclass selectors +- primitive operations +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Types.Id.Make ( + mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, + + mkPrimOpId, mkFCallId, + + unwrapNewTypeBody, wrapFamInstBody, + DataConBoxer(..), vanillaDataConBoxer, + mkDataConRep, mkDataConWorkId, + + -- And some particular Ids; see below for why they are wired in + wiredInIds, ghcPrimIds, + realWorldPrimId, + voidPrimId, voidArgId, + nullAddrId, seqId, lazyId, lazyIdKey, + coercionTokenId, magicDictId, coerceId, + proxyHashId, noinlineId, noinlineIdName, + coerceName, + + -- Re-export error Ids + module GHC.Core.Op.ConstantFold + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core.Rules +import TysPrim +import TysWiredIn +import GHC.Core.Op.ConstantFold +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import TcType +import GHC.Core.Make +import GHC.Core.Utils ( mkCast, mkDefaultCase ) +import GHC.Core.Unfold +import GHC.Types.Literal +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Types.Name.Set +import GHC.Types.Name +import PrimOp +import GHC.Types.ForeignCall +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Demand +import GHC.Types.Cpr +import GHC.Core +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import PrelNames +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import Util +import GHC.Driver.Session +import Outputable +import FastString +import ListSetOps +import GHC.Types.Var (VarBndr(Bndr)) +import qualified GHC.LanguageExtensions as LangExt + +import Data.Maybe ( maybeToList ) + +{- +************************************************************************ +* * +\subsection{Wired in Ids} +* * +************************************************************************ + +Note [Wired-in Ids] +~~~~~~~~~~~~~~~~~~~ +A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') +rather than by looking it up its name in some environment or fetching +it from an interface file. + +There are several reasons why an Id might appear in the wiredInIds: + +* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] + +* magicIds: see Note [magicIds] + +* errorIds, defined in GHC.Core.Make. + These error functions (e.g. rUNTIME_ERROR_ID) are wired in + because the desugarer generates code that mentions them directly + +In all cases except ghcPrimIds, there is a definition site in a +library module, which may be called (e.g. in higher order situations); +but the wired-in version means that the details are never read from +that module's interface file; instead, the full definition is right +here. + +Note [ghcPrimIds (aka pseudoops)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ghcPrimIds + + * Are exported from GHC.Prim + + * Can't be defined in Haskell, and hence no Haskell binding site, + but have perfectly reasonable unfoldings in Core + + * Either have a CompulsoryUnfolding (hence always inlined), or + of an EvaldUnfolding and void representation (e.g. void#) + + * Are (or should be) defined in primops.txt.pp as 'pseudoop' + Reason: that's how we generate documentation for them + +Note [magicIds] +~~~~~~~~~~~~~~~ +The magicIds + + * Are exported from GHC.Magic + + * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). + This definition at least generates Haddock documentation for them. + + * May or may not have a CompulsoryUnfolding. + + * But have some special behaviour that can't be done via an + unfolding from an interface file +-} + +wiredInIds :: [Id] +wiredInIds + = magicIds + ++ ghcPrimIds + ++ errorIds -- Defined in GHC.Core.Make + +magicIds :: [Id] -- See Note [magicIds] +magicIds = [lazyId, oneShotId, noinlineId] + +ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] +ghcPrimIds + = [ realWorldPrimId + , voidPrimId + , nullAddrId + , seqId + , magicDictId + , coerceId + , proxyHashId + ] + +{- +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ + +The wrapper for a constructor is an ordinary top-level binding that evaluates +any strict args, unboxes any args that are going to be flattened, and calls +the worker. + +We're going to build a constructor that looks like: + + data (Data a, C b) => T a b = T1 !a !Int b + + T1 = /\ a b -> + \d1::Data a, d2::C b -> + \p q r -> case p of { p -> + case q of { q -> + Con T1 [a,b] [p,q,r]}} + +Notice that + +* d2 is thrown away --- a context in a data decl is used to make sure + one *could* construct dictionaries at the site the constructor + is used, but the dictionary isn't actually used. + +* We have to check that we can construct Data dictionaries for + the types a and Int. Once we've done that we can throw d1 away too. + +* We use (case p of q -> ...) to evaluate p, rather than "seq" because + all that matters is that the arguments are evaluated. "seq" is + very careful to preserve evaluation order, which we don't need + to be here. + + You might think that we could simply give constructors some strictness + info, like PrimOps, and let CoreToStg do the let-to-case transformation. + But we don't do that because in the case of primops and functions strictness + is a *property* not a *requirement*. In the case of constructors we need to + do something active to evaluate the argument. + + Making an explicit case expression allows the simplifier to eliminate + it in the (common) case where the constructor arg is already evaluated. + +Note [Wrappers for data instance tycons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of data instances, the wrapper also applies the coercion turning +the representation type into the family instance type to cast the result of +the wrapper. For example, consider the declarations + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +The tycon to which the datacon MapPair belongs gets a unique internal +name of the form :R123Map, and we call it the representation tycon. +In contrast, Map is the family tycon (accessible via +tyConFamInst_maybe). A coercion allows you to move between +representation and family type. It is accessible from :R123Map via +tyConFamilyCoercion_maybe and has kind + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +The wrapper and worker of MapPair get the types + + -- Wrapper + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) + + -- Worker + MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +This coercion is conditionally applied by wrapFamInstBody. + +It's a bit more complicated if the data instance is a GADT as well! + + data instance T [a] where + T1 :: forall b. b -> T [Maybe b] + +Hence we translate to + + -- Wrapper + $WT1 :: forall b. b -> T [Maybe b] + $WT1 b v = T1 (Maybe b) b (Maybe b) v + `cast` sym (Co7T (Maybe b)) + + -- Worker + T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c + + -- Coercion from family type to representation type + Co7T a :: T [a] ~ :R7T a + +Newtype instances through an additional wrinkle into the mix. Consider the +following example (adapted from #15318, comment:2): + + data family T a + newtype instance T [a] = MkT [a] + +Within the newtype instance, there are three distinct types at play: + +1. The newtype's underlying type, [a]. +2. The instance's representation type, TList a (where TList is the + representation tycon). +3. The family type, T [a]. + +We need two coercions in order to cast from (1) to (3): + +(a) A newtype coercion axiom: + + axiom coTList a :: TList a ~ [a] + + (Where TList is the representation tycon of the newtype instance.) + +(b) A data family instance coercion axiom: + + axiom coT a :: T [a] ~ TList a + +When we translate the newtype instance to Core, we obtain: + + -- Wrapper + $WMkT :: forall a. [a] -> T [a] + $WMkT a x = MkT a x |> Sym (coT a) + + -- Worker + MkT :: forall a. [a] -> TList [a] + MkT a x = x |> Sym (coTList a) + +Unlike for data instances, the worker for a newtype instance is actually an +executable function which expands to a cast, but otherwise, the general +strategy is essentially the same as for data instances. Also note that we have +a wrapper, which is unusual for a newtype, but we make GHC produce one anyway +for symmetry with the way data instances are handled. + +Note [Newtype datacons] +~~~~~~~~~~~~~~~~~~~~~~~ +The "data constructor" for a newtype should always be vanilla. At one +point this wasn't true, because the newtype arising from + class C a => D a +looked like + newtype T:D a = D:D (C a) +so the data constructor for T:C had a single argument, namely the +predicate (C a). But now we treat that as an ordinary argument, not +part of the theta-type, so all is well. + +Note [Newtype workers] +~~~~~~~~~~~~~~~~~~~~~~ +A newtype does not really have a worker. Instead, newtype constructors +just unfold into a cast. But we need *something* for, say, MkAge to refer +to. So, we do this: + +* The Id used as the newtype worker will have a compulsory unfolding to + a cast. See Note [Compulsory newtype unfolding] + +* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId, + as those have special treatment in the back end. + +* There is no top-level binding, because the compulsory unfolding + means that it will be inlined (to a cast) at every call site. + +We probably should have a NewtypeWorkId, but these Ids disappear as soon as +we desugar anyway, so it seems a step too far. + +Note [Compulsory newtype unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtype wrappers, just like workers, have compulsory unfoldings. +This is needed so that two optimizations involving newtypes have the same +effect whether a wrapper is present or not: + +(1) Case-of-known constructor. + See Note [beta-reduction in exprIsConApp_maybe]. + +(2) Matching against the map/coerce RULE. Suppose we have the RULE + + {-# RULE "map/coerce" map coerce = ... #-} + + As described in Note [Getting the map/coerce RULE to work], + the occurrence of 'coerce' is transformed into: + + {-# RULE "map/coerce" forall (c :: T1 ~R# T2). + map ((\v -> v) `cast` c) = ... #-} + + We'd like 'map Age' to match the LHS. For this to happen, Age + must be unfolded, otherwise we'll be stuck. This is tested in T16208. + +It also allows for the posssibility of levity polymorphic newtypes +with wrappers (with -XUnliftedNewtypes): + + newtype N (a :: TYPE r) = MkN a + +With -XUnliftedNewtypes, this is allowed -- even though MkN is levity- +polymorphic. It's OK because MkN evaporates in the compiled code, becoming +just a cast. That is, it has a compulsory unfolding. As long as its +argument is not levity-polymorphic (which it can't be, according to +Note [Levity polymorphism invariants] in GHC.Core), and it's saturated, +no levity-polymorphic code ends up in the code generator. The saturation +condition is effectively checked by Note [Detecting forced eta expansion] +in GHC.HsToCore.Expr. + +However, if we make a *wrapper* for a newtype, we get into trouble. +The saturation condition is no longer checked (because hasNoBinding +returns False) and indeed we generate a forbidden levity-polymorphic +binding. + +The solution is simple, though: just make the newtype wrappers +as ephemeral as the newtype workers. In other words, give the wrappers +compulsory unfoldings and no bindings. The compulsory unfolding is given +in wrap_unf in mkDataConRep, and the lack of a binding happens in +GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no +implicit bindings. + +************************************************************************ +* * +\subsection{Dictionary selectors} +* * +************************************************************************ + +Selecting a field for a dictionary. If there is just one field, then +there's nothing to do. + +Dictionary selectors may get nested forall-types. Thus: + + class Foo a where + op :: forall b. Ord b => a -> b -> b + +Then the top-level type for op is + + op :: forall a. Foo a => + forall b. Ord b => + a -> b -> b + +-} + +mkDictSelId :: Name -- Name of one of the *value* selectors + -- (dictionary superclass or method) + -> Class -> Id +mkDictSelId name clas + = mkGlobalId (ClassOpId clas) name sel_ty info + where + tycon = classTyCon clas + sel_names = map idName (classAllSelIds clas) + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUserTyVarBinders data_con + n_ty_args = length tyvars + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name + + sel_ty = mkForAllTys tyvars $ + mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ + getNth arg_tys val_index + + base_info = noCafIdInfo + `setArityInfo` 1 + `setStrictnessInfo` strict_sig + `setCprInfo` topCprSig + `setLevityInfoWithType` sel_ty + + info | new_tycon + = base_info `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 + (mkDictSelRhs clas val_index) + -- See Note [Single-method classes] in TcInstDcls + -- for why alwaysInlinePragma + + | otherwise + = base_info `setRuleInfo` mkRuleInfo [rule] + -- Add a magic BuiltinRule, but no unfolding + -- so that the rule is always available to fire. + -- See Note [ClassOp/DFun selection] in TcInstDcls + + -- This is the built-in rule that goes + -- op (dfT d1 d2) ---> opT d1 d2 + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = dictSelRule val_index n_ty_args } + + -- The strictness signature is of the form U(AAAVAAAA) -> T + -- where the V depends on which item we are selecting + -- It's worth giving one, so that absence info etc is generated + -- even if the selector isn't inlined + + strict_sig = mkClosedStrictSig [arg_dmd] topDiv + arg_dmd | new_tycon = evalDmd + | otherwise = mkManyUsedDmd $ + mkProdDmd [ if name == sel_name then evalDmd else absDmd + | sel_name <- sel_names ] + +mkDictSelRhs :: Class + -> Int -- 0-indexed selector among (superclasses ++ methods) + -> CoreExpr +mkDictSelRhs clas val_index + = mkLams tyvars (Lam dict_id rhs_body) + where + tycon = classTyCon clas + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + + the_arg_id = getNth arg_ids val_index + pred = mkClassPred clas (mkTyVarTys tyvars) + dict_id = mkTemplateLocal 1 pred + arg_ids = mkTemplateLocalsNum 2 arg_tys + + rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) + (Var dict_id) + | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) + arg_ids (varToCoreExpr the_arg_id) + -- varToCoreExpr needed for equality superclass selectors + -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } + +dictSelRule :: Int -> Arity -> RuleFun +-- Tries to persuade the argument to look like a constructor +-- application, using exprIsConApp_maybe, and then selects +-- from it +-- sel_i t1..tk (D t1..tk op1 ... opm) = opi +-- +dictSelRule val_index n_ty_args _ id_unf _ args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg + = Just (wrapFloats floats $ getNth con_args val_index) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Data constructors +* * +************************************************************************ +-} + +mkDataConWorkId :: Name -> DataCon -> Id +mkDataConWorkId wkr_name data_con + | isNewTyCon tycon + = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info + -- See Note [Newtype workers] + + | otherwise + = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info + + where + tycon = dataConTyCon data_con -- The representation TyCon + wkr_ty = dataConRepType data_con + + ----------- Workers for data types -------------- + alg_wkr_info = noCafIdInfo + `setArityInfo` wkr_arity + `setStrictnessInfo` wkr_sig + `setCprInfo` mkCprSig wkr_arity (dataConCPR data_con) + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + -- even if arity = 0 + `setLevityInfoWithType` wkr_ty + -- NB: unboxed tuples have workers, so we can't use + -- setNeverLevPoly + + wkr_arity = dataConRepArity data_con + wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) topDiv + -- Note [Data-con worker strictness] + -- Notice that we do *not* say the worker Id is strict + -- even if the data constructor is declared strict + -- e.g. data T = MkT !(Int,Int) + -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has + -- case expressions that do the evals) but the *worker* MkT itself is + -- not. If we pretend it is strict then when we see + -- case x of y -> MkT y + -- the simplifier thinks that y is "sure to be evaluated" (because + -- the worker MkT is strict) and drops the case. No, the workerId + -- MkT is not strict. + -- + -- However, the worker does have StrictnessMarks. When the simplifier + -- sees a pattern + -- case e of MkT x -> ... + -- it uses the dataConRepStrictness of MkT to mark x as evaluated; + -- but that's fine... dataConRepStrictness comes from the data con + -- not from the worker Id. + + ----------- Workers for newtypes -------------- + univ_tvs = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys + nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` newtype_unf + `setLevityInfoWithType` wkr_ty + id_arg1 = mkTemplateLocal 1 (head arg_tys) + res_ty_args = mkTyCoVarTys univ_tvs + newtype_unf = ASSERT2( isVanillaDataCon data_con && + isSingleton arg_tys + , ppr data_con ) + -- Note [Newtype datacons] + mkCompulsoryUnfolding $ + mkLams univ_tvs $ Lam id_arg1 $ + wrapNewTypeBody tycon res_ty_args (Var id_arg1) + +dataConCPR :: DataCon -> CprResult +dataConCPR con + | isDataTyCon tycon -- Real data types only; that is, + -- not unboxed tuples or newtypes + , null (dataConExTyCoVars con) -- No existentials + , wkr_arity > 0 + , wkr_arity <= mAX_CPR_SIZE + = conCpr (dataConTag con) + | otherwise + = topCpr + where + tycon = dataConTyCon con + wkr_arity = dataConRepArity con + + mAX_CPR_SIZE :: Arity + mAX_CPR_SIZE = 10 + -- We do not treat very big tuples as CPR-ish: + -- a) for a start we get into trouble because there aren't + -- "enough" unboxed tuple types (a tiresome restriction, + -- but hard to fix), + -- b) more importantly, big unboxed tuples get returned mainly + -- on the stack, and are often then allocated in the heap + -- by the caller. So doing CPR for them may in fact make + -- things worse. + +{- +------------------------------------------------- +-- Data constructor representation +-- +-- This is where we decide how to wrap/unwrap the +-- constructor fields +-- +-------------------------------------------------- +-} + +type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) + -- Unbox: bind rep vars by decomposing src var + +data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) + -- Box: build src arg using these rep vars + +-- | Data Constructor Boxer +newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) + -- Bind these src-level vars, returning the + -- rep-level vars to bind in the pattern + +vanillaDataConBoxer :: DataConBoxer +-- No transformation on arguments needed +vanillaDataConBoxer = DCB (\_tys args -> return (args, [])) + +{- +Note [Inline partially-applied constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We allow the wrapper to inline when partially applied to avoid +boxing values unnecessarily. For example, consider + + data Foo a = Foo !Int a + + instance Traversable Foo where + traverse f (Foo i a) = Foo i <$> f a + +This desugars to + + traverse f foo = case foo of + Foo i# a -> let i = I# i# + in map ($WFoo i) (f a) + +If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. +But if we inline the wrapper, we get + + map (\a. case i of I# i# a -> Foo i# a) (f a) + +and now case-of-known-constructor eliminates the redundant allocation. + +-} + +mkDataConRep :: DynFlags + -> FamInstEnvs + -> Name + -> Maybe [HsImplBang] + -- See Note [Bangs on imported data constructors] + -> DataCon + -> UniqSM DataConRep +mkDataConRep dflags fam_envs wrap_name mb_bangs data_con + | not wrapper_reqd + = return NoDataConRep + + | otherwise + = do { wrap_args <- mapM newLocal wrap_arg_tys + ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) + initial_wrap_app + + ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info + wrap_info = noCafIdInfo + `setArityInfo` wrap_arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setInlinePragInfo` wrap_prag + `setUnfoldingInfo` wrap_unf + `setStrictnessInfo` wrap_sig + `setCprInfo` mkCprSig wrap_arity (dataConCPR data_con) + -- We need to get the CAF info right here because GHC.Iface.Tidy + -- does not tidy the IdInfo of implicit bindings (like the wrapper) + -- so it not make sure that the CAF info is sane + `setLevityInfoWithType` wrap_ty + + wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv + + wrap_arg_dmds = + replicate (length theta) topDmd ++ map mk_dmd arg_ibangs + -- Don't forget the dictionary arguments when building + -- the strictness signature (#14290). + + mk_dmd str | isBanged str = evalDmd + | otherwise = topDmd + + wrap_prag = alwaysInlinePragma `setInlinePragmaActivation` + activeDuringFinal + -- See Note [Activation for data constructor wrappers] + + -- The wrapper will usually be inlined (see wrap_unf), so its + -- strictness and CPR info is usually irrelevant. But this is + -- not always the case; GHC may choose not to inline it. In + -- particular, the wrapper constructor is not inlined inside + -- an INLINE rhs or when it is not applied to any arguments. + -- See Note [Inline partially-applied constructor wrappers] + -- Passing Nothing here allows the wrapper to inline when + -- unsaturated. + wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs + -- See Note [Compulsory newtype unfolding] + | otherwise = mkInlineUnfolding wrap_rhs + wrap_rhs = mkLams wrap_tvs $ + mkLams wrap_args $ + wrapFamInstBody tycon res_ty_args $ + wrap_body + + ; return (DCR { dcr_wrap_id = wrap_id + , dcr_boxer = mk_boxer boxers + , dcr_arg_tys = rep_tys + , dcr_stricts = rep_strs + -- For newtypes, dcr_bangs is always [HsLazy]. + -- See Note [HsImplBangs for newtypes]. + , dcr_bangs = arg_ibangs }) } + + where + (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) + = dataConFullSig data_con + wrap_tvs = dataConUserTyVars data_con + res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs + + tycon = dataConTyCon data_con -- The representation TyCon (not family) + wrap_ty = dataConUserType data_con + ev_tys = eqSpecPreds eq_spec ++ theta + all_arg_tys = ev_tys ++ orig_arg_tys + ev_ibangs = map (const HsLazy) ev_tys + orig_bangs = dataConSrcBangs data_con + + wrap_arg_tys = theta ++ orig_arg_tys + wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys + -- The wrap_args are the arguments *other than* the eq_spec + -- Because we are going to apply the eq_spec args manually in the + -- wrapper + + new_tycon = isNewTyCon tycon + arg_ibangs + | new_tycon + = ASSERT( isSingleton orig_arg_tys ) + [HsLazy] -- See Note [HsImplBangs for newtypes] + | otherwise + = case mb_bangs of + Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) + orig_arg_tys orig_bangs + Just bangs -> bangs + + (rep_tys_w_strs, wrappers) + = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) + + (unboxers, boxers) = unzip wrappers + (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) + + wrapper_reqd = + (not new_tycon + -- (Most) newtypes have only a worker, with the exception + -- of some newtypes written with GADT syntax. See below. + && (any isBanged (ev_ibangs ++ arg_ibangs) + -- Some forcing/unboxing (includes eq_spec) + || (not $ null eq_spec))) -- GADT + || isFamInstTyCon tycon -- Cast result + || dataConUserTyVarsArePermuted data_con + -- If the data type was written with GADT syntax and + -- orders the type variables differently from what the + -- worker expects, it needs a data con wrapper to reorder + -- the type variables. + -- See Note [Data con wrappers and GADT syntax]. + + initial_wrap_app = Var (dataConWorkId data_con) + `mkTyApps` res_ty_args + `mkVarApps` ex_tvs + `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec + + mk_boxer :: [Boxer] -> DataConBoxer + mk_boxer boxers = DCB (\ ty_args src_vars -> + do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars + subst1 = zipTvSubst univ_tvs ty_args + subst2 = extendTCvSubstList subst1 ex_tvs + (mkTyCoVarTys ex_vars) + ; (rep_ids, binds) <- go subst2 boxers term_vars + ; return (ex_vars ++ rep_ids, binds) } ) + + go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) + go subst (UnitBox : boxers) (src_var : src_vars) + = do { (rep_ids2, binds) <- go subst boxers src_vars + ; return (src_var : rep_ids2, binds) } + go subst (Boxer boxer : boxers) (src_var : src_vars) + = do { (rep_ids1, arg) <- boxer subst + ; (rep_ids2, binds) <- go subst boxers src_vars + ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } + go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) + + mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr + mk_rep_app [] con_app + = return con_app + mk_rep_app ((wrap_arg, unboxer) : prs) con_app + = do { (rep_ids, unbox_fn) <- unboxer wrap_arg + ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) + ; return (unbox_fn expr) } + +{- Note [Activation for data constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Activation on a data constructor wrapper allows it to inline only in Phase +0. This way rules have a chance to fire if they mention a data constructor on +the left + RULE "foo" f (K a b) = ... +Since the LHS of rules are simplified with InitialPhase, we won't +inline the wrapper on the LHS either. + +On the other hand, this means that exprIsConApp_maybe must be able to deal +with wrappers so that case-of-constructor is not delayed; see +Note [exprIsConApp_maybe on data constructors with wrappers] for details. + +It used to activate in phases 2 (afterInitial) and later, but it makes it +awkward to write a RULE[1] with a constructor on the left: it would work if a +constructor has no wrapper, but whether a constructor has a wrapper depends, for +instance, on the order of type argument of that constructors. Therefore changing +the order of type argument could make previously working RULEs fail. + +See also https://gitlab.haskell.org/ghc/ghc/issues/15840 . + + +Note [Bangs on imported data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs +from imported modules. + +- Nothing <=> use HsSrcBangs +- Just bangs <=> use HsImplBangs + +For imported types we can't work it all out from the HsSrcBangs, +because we want to be very sure to follow what the original module +(where the data type was declared) decided, and that depends on what +flags were enabled when it was compiled. So we record the decisions in +the interface file. + +The HsImplBangs passed are in 1-1 correspondence with the +dataConOrigArgTys of the DataCon. + +Note [Data con wrappers and unlifted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int# + +We certainly do not want to make a wrapper + $WMkT x = case x of y { DEFAULT -> MkT y } + +For a start, it's still to generate a no-op. But worse, since wrappers +are currently injected at TidyCore, we don't even optimise it away! +So the stupid case expression stays there. This actually happened for +the Integer data type (see #1600 comment:66)! + +Note [Data con wrappers and GADT syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two very similar data types: + + data T1 a b = MkT1 b + + data T2 a b where + MkT2 :: forall b a. b -> T2 a b + +Despite their similar appearance, T2 will have a data con wrapper but T1 will +not. What sets them apart? The types of their constructors, which are: + + MkT1 :: forall a b. b -> T1 a b + MkT2 :: forall b a. b -> T2 a b + +MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` +would normally appear. See Note [DataCon user type variable binders] in GHC.Core.DataCon +for further discussion on this topic. + +The worker data cons for T1 and T2, however, both have types such that `a` is +expected to come before `b` as arguments. Because MkT2 permutes this order, it +needs a data con wrapper to swizzle around the type variables to be in the +order the worker expects. + +A somewhat surprising consequence of this is that *newtypes* can have data con +wrappers! After all, a newtype can also be written with GADT syntax: + + newtype T3 a b where + MkT3 :: forall b a. b -> T3 a b + +Again, this needs a wrapper data con to reorder the type variables. It does +mean that this newtype constructor requires another level of indirection when +being called, but the inliner should make swift work of that. + +Note [HsImplBangs for newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the time, we use the dataConSrctoImplBang function to decide what +strictness/unpackedness to use for the fields of a data type constructor. But +there is an exception to this rule: newtype constructors. You might not think +that newtypes would pose a challenge, since newtypes are seemingly forbidden +from having strictness annotations in the first place. But consider this +(from #16141): + + {-# LANGUAGE StrictData #-} + {-# OPTIONS_GHC -O #-} + newtype T a b where + MkT :: forall b a. Int -> T a b + +Because StrictData (plus optimization) is enabled, invoking +dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#! +This would be disastrous, since the wrapper for `MkT` uses a coercion involving +Int, not Int#. + +Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the +case of a newtype constructor, we simply hardcode its dcr_bangs field to +[HsLazy]. +-} + +------------------------- +newLocal :: Type -> UniqSM Var +newLocal ty = do { uniq <- getUniqueM + ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } + -- We should not have "OrCoVar" here, this is a bug (#17545) + + +-- | Unpack/Strictness decisions from source module. +-- +-- This function should only ever be invoked for data constructor fields, and +-- never on the field of a newtype constructor. +-- See @Note [HsImplBangs for newtypes]@. +dataConSrcToImplBang + :: DynFlags + -> FamInstEnvs + -> Type + -> HsSrcBang + -> HsImplBang + +dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang ann unpk NoSrcStrict) + | xopt LangExt.StrictData dflags -- StrictData => strict field + = dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang ann unpk SrcStrict) + | otherwise -- no StrictData => lazy field + = HsLazy + +dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) + = HsLazy + +dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang _ unpk_prag SrcStrict) + | isUnliftedType arg_ty + = HsLazy -- For !Int#, say, use HsLazy + -- See Note [Data con wrappers and unlifted types] + + | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas + -- Don't unpack if we aren't optimising; rather arbitrarily, + -- we use -fomit-iface-pragmas as the indication + , let mb_co = topNormaliseType_maybe fam_envs arg_ty + -- Unwrap type families and newtypes + arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } + , isUnpackableType dflags fam_envs arg_ty' + , (rep_tys, _) <- dataConArgUnpack arg_ty' + , case unpk_prag of + NoSrcUnpack -> + gopt Opt_UnboxStrictFields dflags + || (gopt Opt_UnboxSmallStrictFields dflags + && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] + srcUnpack -> isSrcUnpacked srcUnpack + = case mb_co of + Nothing -> HsUnpack Nothing + Just (co,_) -> HsUnpack (Just co) + + | otherwise -- Record the strict-but-no-unpack decision + = HsStrict + + +-- | Wrappers/Workers and representation following Unpack/Strictness +-- decisions +dataConArgRep + :: Type + -> HsImplBang + -> ([(Type,StrictnessMark)] -- Rep types + ,(Unboxer,Boxer)) + +dataConArgRep arg_ty HsLazy + = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) + +dataConArgRep arg_ty HsStrict + = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) + +dataConArgRep arg_ty (HsUnpack Nothing) + | (rep_tys, wrappers) <- dataConArgUnpack arg_ty + = (rep_tys, wrappers) + +dataConArgRep _ (HsUnpack (Just co)) + | let co_rep_ty = coercionRKind co + , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty + = (rep_tys, wrapCo co co_rep_ty wrappers) + + +------------------------- +wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) +wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty + = (unboxer, boxer) + where + unboxer arg_id = do { rep_id <- newLocal rep_ty + ; (rep_ids, rep_fn) <- unbox_rep rep_id + ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) + ; return (rep_ids, Let co_bind . rep_fn) } + boxer = Boxer $ \ subst -> + do { (rep_ids, rep_expr) + <- case box_rep of + UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) + ; return ([rep_id], Var rep_id) } + Boxer boxer -> boxer subst + ; let sco = substCoUnchecked subst co + ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } + +------------------------ +seqUnboxer :: Unboxer +seqUnboxer v = return ([v], mkDefaultCase (Var v) v) + +unitUnboxer :: Unboxer +unitUnboxer v = return ([v], \e -> e) + +unitBoxer :: Boxer +unitBoxer = UnitBox + +------------------------- +dataConArgUnpack + :: Type + -> ( [(Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) + +dataConArgUnpack arg_ty + | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty + , Just con <- tyConSingleAlgDataCon_maybe tc + -- NB: check for an *algebraic* data type + -- A recursive newtype might mean that + -- 'arg_ty' is a newtype + , let rep_tys = dataConInstArgTys con tc_args + = ASSERT( null (dataConExTyCoVars con) ) + -- Note [Unpacking GADTs and existentials] + ( rep_tys `zip` dataConRepStrictness con + ,( \ arg_id -> + do { rep_ids <- mapM newLocal rep_tys + ; let unbox_fn body + = mkSingleAltCase (Var arg_id) arg_id + (DataAlt con) rep_ids body + ; return (rep_ids, unbox_fn) } + , Boxer $ \ subst -> + do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys + ; return (rep_ids, Var (dataConWorkId con) + `mkTyApps` (substTysUnchecked subst tc_args) + `mkVarApps` rep_ids ) } ) ) + | otherwise + = pprPanic "dataConArgUnpack" (ppr arg_ty) + -- An interface file specified Unpacked, but we couldn't unpack it + +isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool +-- True if we can unpack the UNPACK the argument type +-- See Note [Recursive unboxing] +-- We look "deeply" inside rather than relying on the DataCons +-- we encounter on the way, because otherwise we might well +-- end up relying on ourselves! +isUnpackableType dflags fam_envs ty + | Just data_con <- unpackable_type ty + = ok_con_args emptyNameSet data_con + | otherwise + = False + where + ok_con_args dcs con + | dc_name `elemNameSet` dcs + = False + | otherwise + = all (ok_arg dcs') + (dataConOrigArgTys con `zip` dataConSrcBangs con) + -- NB: dataConSrcBangs gives the *user* request; + -- We'd get a black hole if we used dataConImplBangs + where + dc_name = getName con + dcs' = dcs `extendNameSet` dc_name + + ok_arg dcs (ty, bang) + = not (attempt_unpack bang) || ok_ty dcs norm_ty + where + norm_ty = topNormaliseType fam_envs ty + + ok_ty dcs ty + | Just data_con <- unpackable_type ty + = ok_con_args dcs data_con + | otherwise + = True -- NB True here, in contrast to False at top level + + attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) + = xopt LangExt.StrictData dflags + attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) + = True + attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) + = True -- Be conservative + attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) + = xopt LangExt.StrictData dflags -- Be conservative + attempt_unpack _ = False + + unpackable_type :: Type -> Maybe DataCon + -- Works just on a single level + unpackable_type ty + | Just (tc, _) <- splitTyConApp_maybe ty + , Just data_con <- tyConSingleAlgDataCon_maybe tc + , null (dataConExTyCoVars data_con) + -- See Note [Unpacking GADTs and existentials] + = Just data_con + | otherwise + = Nothing + +{- +Note [Unpacking GADTs and existentials] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is nothing stopping us unpacking a data type with equality +components, like + data Equal a b where + Equal :: Equal a a + +And it'd be fine to unpack a product type with existential components +too, but that would require a bit more plumbing, so currently we don't. + +So for now we require: null (dataConExTyCoVars data_con) +See #14978 + +Note [Unpack one-wide fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flag UnboxSmallStrictFields ensures that any field that can +(safely) be unboxed to a word-sized unboxed field, should be so unboxed. +For example: + + data A = A Int# + newtype B = B A + data C = C !B + data D = D !C + data E = E !() + data F = F !D + data G = G !F !F + +All of these should have an Int# as their representation, except +G which should have two Int#s. + +However + + data T = T !(S Int) + data S = S !a + +Here we can represent T with an Int#. + +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data R = MkR {-# UNPACK #-} !S Int + data S = MkS {-# UNPACK #-} !Int +The representation arguments of MkR are the *representation* arguments +of S (plus Int); the rep args of MkS are Int#. This is all fine. + +But be careful not to try to unbox this! + data T = MkT {-# UNPACK #-} !T Int +Because then we'd get an infinite number of arguments. + +Here is a more complicated case: + data S = MkS {-# UNPACK #-} !T Int + data T = MkT {-# UNPACK #-} !S Int +Each of S and T must decide independently whether to unpack +and they had better not both say yes. So they must both say no. + +Also behave conservatively when there is no UNPACK pragma + data T = MkS !T Int +with -funbox-strict-fields or -funbox-small-strict-fields +we need to behave as if there was an UNPACK pragma there. + +But it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + +************************************************************************ +* * + Wrapping and unwrapping newtypes and type families +* * +************************************************************************ +-} + +wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +-- The wrapper for the data constructor for a newtype looks like this: +-- newtype T a = MkT (a,Int) +-- MkT :: forall a. (a,Int) -> T a +-- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) +-- where CoT is the coercion TyCon associated with the newtype +-- +-- The call (wrapNewTypeBody T [a] e) returns the +-- body of the wrapper, namely +-- e `cast` (CoT [a]) +-- +-- If a coercion constructor is provided in the newtype, then we use +-- it, otherwise the wrap/unwrap are both no-ops + +wrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + mkCast result_expr (mkSymCo co) + where + co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] + +-- When unwrapping, we do *not* apply any family coercion, because this will +-- be done via a CoPat by the type checker. We have to do it this way as +-- computing the right type arguments for the coercion requires more than just +-- a splitting operation (cf, TcPat.tcConPat). + +unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +unwrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) + +-- If the type constructor is a representation type of a data instance, wrap +-- the expression into a cast adjusting the expression type, which is an +-- instance of the representation type, to the corresponding instance of the +-- family instance type. +-- See Note [Wrappers for data instance tycons] +wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +wrapFamInstBody tycon args body + | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) + | otherwise + = body + +{- +************************************************************************ +* * +\subsection{Primitive operations} +* * +************************************************************************ +-} + +mkPrimOpId :: PrimOp -> Id +mkPrimOpId prim_op + = id + where + (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op + ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) + name = mkWiredInName gHC_PRIM (primOpOcc prim_op) + (mkPrimOpIdUnique (primOpTag prim_op)) + (AnId id) UserSyntax + id = mkGlobalId (PrimOpId prim_op) name ty info + + -- PrimOps don't ever construct a product, but we want to preserve bottoms + cpr + | isBotDiv (snd (splitStrictSig strict_sig)) = botCpr + | otherwise = topCpr + + info = noCafIdInfo + `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setCprInfo` mkCprSig arity cpr + `setInlinePragInfo` neverInlinePragma + `setLevityInfoWithType` res_ty + -- We give PrimOps a NOINLINE pragma so that we don't + -- get silly warnings from Desugar.dsRule (the inline_shadows_rule + -- test) about a RULE conflicting with a possible inlining + -- cf #7287 + +-- For each ccall we manufacture a separate CCallOpId, giving it +-- a fresh unique, a type that is correct for this particular ccall, +-- and a CCall structure that gives the correct details about calling +-- convention etc. +-- +-- The *name* of this Id is a local name whose OccName gives the full +-- details of the ccall, type and all. This means that the interface +-- file reader can reconstruct a suitable Id + +mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id +mkFCallId dflags uniq fcall ty + = ASSERT( noFreeVarsOfType ty ) + -- A CCallOpId should have no free type variables; + -- when doing substitutions won't substitute over it + mkGlobalId (FCallId fcall) name ty info + where + occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) + -- The "occurrence name" of a ccall is the full info about the + -- ccall; it is encoded, but may have embedded spaces etc! + + name = mkFCallName uniq occ_str + + info = noCafIdInfo + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setCprInfo` topCprSig + `setLevityInfoWithType` ty + + (bndrs, _) = tcSplitPiTys ty + arity = count isAnonTyCoBinder bndrs + strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv + -- the call does not claim to be strict in its arguments, since they + -- may be lifted (foreign import prim) and the called code doesn't + -- necessarily force them. See #11076. +{- +************************************************************************ +* * +\subsection{DictFuns and default methods} +* * +************************************************************************ + +Note [Dict funs and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dict funs and default methods are *not* ImplicitIds. Their definition +involves user-written code, so we can't figure out their strictness etc +based on fixed info, as we can for constructors and record selectors (say). + +NB: See also Note [Exported LocalIds] in GHC.Types.Id +-} + +mkDictFunId :: Name -- Name to use for the dict fun; + -> [TyVar] + -> ThetaType + -> Class + -> [Type] + -> Id +-- Implements the DFun Superclass Invariant (see TcInstDcls) +-- See Note [Dict funs and default methods] + +mkDictFunId dfun_name tvs theta clas tys + = mkExportedLocalId (DFunId is_nt) + dfun_name + dfun_ty + where + is_nt = isNewTyCon (classTyCon clas) + dfun_ty = mkDictFunTy tvs theta clas tys + +mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type +mkDictFunTy tvs theta clas tys + = mkSpecSigmaTy tvs theta (mkClassPred clas tys) + +{- +************************************************************************ +* * +\subsection{Un-definable} +* * +************************************************************************ + +These Ids can't be defined in Haskell. They could be defined in +unfoldings in the wired-in GHC.Prim interface file, but we'd have to +ensure that they were definitely, definitely inlined, because there is +no curried identifier for them. That's what mkCompulsoryUnfolding +does. If we had a way to get a compulsory unfolding from an interface +file, we could do that, but we don't right now. + +The type variables we use here are "open" type variables: this means +they can unify with both unlifted and lifted types. Hence we provide +another gun with which to shoot yourself in the foot. +-} + +nullAddrName, seqName, + realWorldName, voidPrimIdName, coercionTokenName, + magicDictName, coerceName, proxyName :: Name +nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId +voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId +magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId +coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId +proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId + +lazyIdName, oneShotName, noinlineIdName :: Name +lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId +oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId +noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId + +------------------------------------------------ +proxyHashId :: Id +proxyHashId + = pcMiscPrelId proxyName ty + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` ty ) + where + -- proxy# :: forall {k} (a:k). Proxy# k a + -- + -- The visibility of the `k` binder is Inferred to match the type of the + -- Proxy data constructor (#16293). + [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id + kv_ty = mkTyVarTy kv + tv_ty = mkTyVarTy tv + ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty + +------------------------------------------------ +nullAddrId :: Id +-- nullAddr# :: Addr# +-- The reason it is here is because we don't provide +-- a way to write this literal in Haskell. +nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) + `setNeverLevPoly` addrPrimTy + +------------------------------------------------ +seqId :: Id -- See Note [seqId magic] +seqId = pcMiscPrelId seqName ty info + where + info = noCafIdInfo `setInlinePragInfo` inline_prag + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + + inline_prag + = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter + NoSourceText 0 + -- Make 'seq' not inline-always, so that simpleOptExpr + -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the + -- LHS of rules. That way we can have rules for 'seq'; + -- see Note [seqId magic] + + -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b + ty = + mkInvForAllTy runtimeRep2TyVar + $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] + $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy) + + [x,y] = mkTemplateLocals [alphaTy, openBetaTy] + rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ + Case (Var x) x openBetaTy [(DEFAULT, [], Var y)] + +------------------------------------------------ +lazyId :: Id -- See Note [lazyId magic] +lazyId = pcMiscPrelId lazyIdName ty info + where + info = noCafIdInfo `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) + +noinlineId :: Id -- See Note [noinlineId magic] +noinlineId = pcMiscPrelId noinlineIdName ty info + where + info = noCafIdInfo `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) + +oneShotId :: Id -- See Note [The oneShot function] +oneShotId = pcMiscPrelId oneShotName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar ] + (mkVisFunTy fun_ty fun_ty) + fun_ty = mkVisFunTy openAlphaTy openBetaTy + [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] + x' = setOneShotLambda x -- Here is the magic bit! + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar + , body, x'] $ + Var body `App` Var x + +-------------------------------------------------------------------------------- +magicDictId :: Id -- See Note [magicDictId magic] +magicDictId = pcMiscPrelId magicDictName ty info + where + info = noCafIdInfo `setInlinePragInfo` neverInlinePragma + `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] alphaTy + +-------------------------------------------------------------------------------- + +coerceId :: Id +coerceId = pcMiscPrelId coerceName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] + ty = mkForAllTys [ Bndr rv Inferred + , Bndr av Specified + , Bndr bv Specified + ] $ + mkInvisFunTy eqRTy $ + mkVisFunTy a b + + bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy + (\r -> [tYPE r, tYPE r]) + + [r, a, b] = mkTyVarTys bndrs + + [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] + rhs = mkLams (bndrs ++ [eqR, x]) $ + mkWildCase (Var eqR) eqRTy b $ + [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] + +{- +Note [seqId magic] +~~~~~~~~~~~~~~~~~~ +'GHC.Prim.seq' is special in several ways. + +a) Its fixity is set in GHC.Iface.Load.ghcPrimIface + +b) It has quite a bit of desugaring magic. + See GHC.HsToCore.Utils.hs Note [Desugaring seq (1)] and (2) and (3) + +c) There is some special rule handing: Note [User-defined RULES for seq] + +Historical note: + In TcExpr we used to need a special typing rule for 'seq', to handle calls + whose second argument had an unboxed type, e.g. x `seq` 3# + + However, with levity polymorphism we can now give seq the type seq :: + forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this + case without special treatment in the typechecker. + +Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Roman found situations where he had + case (f n) of _ -> e +where he knew that f (which was strict in n) would terminate if n did. +Notice that the result of (f n) is discarded. So it makes sense to +transform to + case n of _ -> e + +Rather than attempt some general analysis to support this, I've added +enough support that you can do this using a rewrite rule: + + RULE "f/seq" forall n. seq (f n) = seq n + +You write that rule. When GHC sees a case expression that discards +its result, it mentally transforms it to a call to 'seq' and looks for +a RULE. (This is done in GHC.Core.Op.Simplify.trySeqRules.) As usual, the +correctness of the rule is up to you. + +VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. +If we wrote + RULE "f/seq" forall n e. seq (f n) e = seq n e +with rule arity 2, then two bad things would happen: + + - The magical desugaring done in Note [seqId magic] item (b) + for saturated application of 'seq' would turn the LHS into + a case expression! + + - The code in GHC.Core.Op.Simplify.rebuildCase would need to actually supply + the value argument, which turns out to be awkward. + +See also: Note [User-defined RULES for seq] in GHC.Core.Op.Simplify. + + +Note [lazyId magic] +~~~~~~~~~~~~~~~~~~~ +lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) + +'lazy' is used to make sure that a sub-expression, and its free variables, +are truly used call-by-need, with no code motion. Key examples: + +* pseq: pseq a b = a `seq` lazy b + We want to make sure that the free vars of 'b' are not evaluated + before 'a', even though the expression is plainly strict in 'b'. + +* catch: catch a b = catch# (lazy a) b + Again, it's clear that 'a' will be evaluated strictly (and indeed + applied to a state token) but we want to make sure that any exceptions + arising from the evaluation of 'a' are caught by the catch (see + #11555). + +Implementing 'lazy' is a bit tricky: + +* It must not have a strictness signature: by being a built-in Id, + all the info about lazyId comes from here, not from GHC.Base.hi. + This is important, because the strictness analyser will spot it as + strict! + +* It must not have an unfolding: it gets "inlined" by a HACK in + CorePrep. It's very important to do this inlining *after* unfoldings + are exposed in the interface file. Otherwise, the unfolding for + (say) pseq in the interface file will not mention 'lazy', so if we + inline 'pseq' we'll totally miss the very thing that 'lazy' was + there for in the first place. See #3259 for a real world + example. + +* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must + avoid using call by value here: + case e of r -> catch# r b + Avoiding that is the whole point of 'lazy'. So in CorePrep (which + generate the 'case' expression for a call-by-value call) we must + spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' + instead. + +* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it + appears un-applied, we'll end up just calling it. + +Note [noinlineId magic] +~~~~~~~~~~~~~~~~~~~~~~~ +noinline :: forall a. a -> a + +'noinline' is used to make sure that a function f is never inlined, +e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE +could be used to achieve this effect; however, this has the unfortunate +result of leaving a (useless) call to noinline at runtime. So we have +a little bit of magic to optimize away 'noinline' after we are done +running the simplifier. + +'noinline' needs to be wired-in because it gets inserted automatically +when we serialize an expression to the interface format. See +Note [Inlining and hs-boot files] in GHC.CoreToIface + +Note that noinline as currently implemented can hide some simplifications since +it hides strictness from the demand analyser. Specifically, the demand analyser +will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f' +specifies that it is strict in its argument. We considered fixing this this by adding a +special case to the demand analyser to address #16588. However, the special +case seemed like a large and expensive hammer to address a rare case and +consequently we rather opted to use a more minimal solution. + +Note [The oneShot function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the context of making left-folds fuse somewhat okish (see ticket #7994 +and Note [Left folds via right fold]) it was determined that it would be useful +if library authors could explicitly tell the compiler that a certain lambda is +called at most once. The oneShot function allows that. + +'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted +types as well (#10744); e.g. + oneShot (\x:Int# -> x +# 1#) + +Like most magic functions it has a compulsory unfolding, so there is no need +for a real definition somewhere. We have one in GHC.Magic for the convenience +of putting the documentation there. + +It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: + +A typical call looks like + oneShot (\y. e) +after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get + (\f \x[oneshot]. f x) (\y. e) + --> \x[oneshot]. ((\y.e) x) + --> \x[oneshot] e[x/y] +which is what we want. + +It is only effective if the one-shot info survives as long as possible; in +particular it must make it into the interface in unfoldings. See Note [Preserve +OneShotInfo] in GHC.Core.Op.Tidy. + +Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. + + +Note [magicDictId magic] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The identifier `magicDict` is just a place-holder, which is used to +implement a primitive that we cannot define in Haskell but we can write +in Core. It is declared with a place-holder type: + + magicDict :: forall a. a + +The intention is that the identifier will be used in a very specific way, +to create dictionaries for classes with a single method. Consider a class +like this: + + class C a where + f :: T a + +We are going to use `magicDict`, in conjunction with a built-in Prelude +rule, to cast values of type `T a` into dictionaries for `C a`. To do +this, we define a function like this in the library: + + data WrapC a b = WrapC (C a => Proxy a -> b) + + withT :: (C a => Proxy a -> b) + -> T a -> Proxy a -> b + withT f x y = magicDict (WrapC f) x y + +The purpose of `WrapC` is to avoid having `f` instantiated. +Also, it avoids impredicativity, because `magicDict`'s type +cannot be instantiated with a forall. The field of `WrapC` contains +a `Proxy` parameter which is used to link the type of the constraint, +`C a`, with the type of the `Wrap` value being made. + +Next, we add a built-in Prelude rule (see GHC.Core.Op.ConstantFold), +which will replace the RHS of this definition with the appropriate +definition in Core. The rewrite rule works as follows: + + magicDict @t (wrap @a @b f) x y +----> + f (x `cast` co a) y + +The `co` coercion is the newtype-coercion extracted from the type-class. +The type class is obtain by looking at the type of wrap. + + +------------------------------------------------------------- +@realWorld#@ used to be a magic literal, \tr{void#}. If things get +nasty as-is, change it back to a literal (@Literal@). + +voidArgId is a Local Id used simply as an argument in functions +where we just want an arg to avoid having a thunk of unlifted type. +E.g. + x = \ void :: Void# -> (# p, q #) + +This comes up in strictness analysis + +Note [evaldUnfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The evaldUnfolding makes it look that some primitive value is +evaluated, which in turn makes Simplify.interestingArg return True, +which in turn makes INLINE things applied to said value likely to be +inlined. +-} + +realWorldPrimId :: Id -- :: State# RealWorld +realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setOneShotInfo` stateHackOneShot + `setNeverLevPoly` realWorldStatePrimTy) + +voidPrimId :: Id -- Global constant :: Void# +voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` voidPrimTy) + +voidArgId :: Id -- Local lambda-bound :: Void# +voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy + +coercionTokenId :: Id -- :: () ~ () +coercionTokenId -- See Note [Coercion tokens] in CoreToStg.hs + = pcMiscPrelId coercionTokenName + (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) + noCafIdInfo + +pcMiscPrelId :: Name -> Type -> IdInfo -> Id +pcMiscPrelId name ty info + = mkVanillaGlobalWithInfo name ty info + -- We lie and say the thing is imported; otherwise, we get into + -- a mess with dependency analysis; e.g., core2stg may heave in + -- random calls to GHCbase.unpackPS__. If GHCbase is the module + -- being compiled, then it's just a matter of luck if the definition + -- will be in "the right place" to be in scope. diff --git a/compiler/GHC/Types/Id/Make.hs-boot b/compiler/GHC/Types/Id/Make.hs-boot new file mode 100644 index 0000000000..25ae32207e --- /dev/null +++ b/compiler/GHC/Types/Id/Make.hs-boot @@ -0,0 +1,15 @@ +module GHC.Types.Id.Make where +import GHC.Types.Name( Name ) +import GHC.Types.Var( Id ) +import GHC.Core.Class( Class ) +import {-# SOURCE #-} GHC.Core.DataCon( DataCon ) +import {-# SOURCE #-} PrimOp( PrimOp ) + +data DataConBoxer + +mkDataConWorkId :: Name -> DataCon -> Id +mkDictSelId :: Name -> Class -> Id + +mkPrimOpId :: PrimOp -> Id + +magicDictId :: Id diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs new file mode 100644 index 0000000000..9e6a8e4ede --- /dev/null +++ b/compiler/GHC/Types/Literal.hs @@ -0,0 +1,847 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[Literal]{@Literal@: literals} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Types.Literal + ( + -- * Main data type + Literal(..) -- Exported to ParseIface + , LitNumType(..) + + -- ** Creating Literals + , mkLitInt, mkLitIntWrap, mkLitIntWrapC + , mkLitWord, mkLitWordWrap, mkLitWordWrapC + , mkLitInt64, mkLitInt64Wrap + , mkLitWord64, mkLitWord64Wrap + , mkLitFloat, mkLitDouble + , mkLitChar, mkLitString + , mkLitInteger, mkLitNatural + , mkLitNumber, mkLitNumberWrap + + -- ** Operations on Literals + , literalType + , absentLiteralOf + , pprLiteral + , litNumIsSigned + , litNumCheckRange + + -- ** Predicates on Literals and their contents + , litIsDupable, litIsTrivial, litIsLifted + , inCharRange + , isZeroLit + , litFitsInChar + , litValue, isLitValue, isLitValue_maybe, mapLitValue + + -- ** Coercions + , word2IntLit, int2WordLit + , narrowLit + , narrow8IntLit, narrow16IntLit, narrow32IntLit + , narrow8WordLit, narrow16WordLit, narrow32WordLit + , char2IntLit, int2CharLit + , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit + , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TysPrim +import PrelNames +import GHC.Core.Type +import GHC.Core.TyCon +import Outputable +import FastString +import GHC.Types.Basic +import Binary +import Constants +import GHC.Platform +import GHC.Types.Unique.FM +import Util + +import Data.ByteString (ByteString) +import Data.Int +import Data.Word +import Data.Char +import Data.Maybe ( isJust ) +import Data.Data ( Data ) +import Data.Proxy +import Numeric ( fromRat ) + +{- +************************************************************************ +* * +\subsection{Literals} +* * +************************************************************************ +-} + +-- | So-called 'Literal's are one of: +-- +-- * An unboxed numeric literal or floating-point literal which is presumed +-- to be surrounded by appropriate constructors (@Int#@, etc.), so that +-- the overall thing makes sense. +-- +-- We maintain the invariant that the 'Integer' in the 'LitNumber' +-- constructor is actually in the (possibly target-dependent) range. +-- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying +-- the target machine's wrapping semantics. Use these in situations +-- where you know the wrapping semantics are correct. +-- +-- * The literal derived from the label mentioned in a \"foreign label\" +-- declaration ('LitLabel') +-- +-- * A 'LitRubbish' to be used in place of values of 'UnliftedRep' +-- (i.e. 'MutVar#') when the the value is never used. +-- +-- * A character +-- * A string +-- * The NULL pointer +-- +data Literal + = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with + -- 'mkLitChar' + + | LitNumber !LitNumType !Integer Type + -- ^ Any numeric literal that can be + -- internally represented with an Integer. + -- See Note [Types of LitNumbers] below for the + -- Type field. + + | LitString ByteString -- ^ A string-literal: stored and emitted + -- UTF-8 encoded, we'll arrange to decode it + -- at runtime. Also emitted with a @\'\\0\'@ + -- terminator. Create with 'mkLitString' + + | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value + -- that can be represented as a Literal. Create + -- with 'nullAddrLit' + + | LitRubbish -- ^ A nonsense value, used when an unlifted + -- binding is absent and has type + -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. + -- May be lowered by code-gen to any possible + -- value. Also see Note [Rubbish literals] + + | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' + | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' + + | LitLabel FastString (Maybe Int) FunctionOrData + -- ^ A label literal. Parameters: + -- + -- 1) The name of the symbol mentioned in the + -- declaration + -- + -- 2) The size (in bytes) of the arguments + -- the label expects. Only applicable with + -- @stdcall@ labels. @Just x@ => @\@ will + -- be appended to label name when emitting + -- assembly. + -- + -- 3) Flag indicating whether the symbol + -- references a function or a data + deriving Data + +-- | Numeric literal type +data LitNumType + = LitNumInteger -- ^ @Integer@ (see Note [Integer literals]) + | LitNumNatural -- ^ @Natural@ (see Note [Natural literals]) + | LitNumInt -- ^ @Int#@ - according to target machine + | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits + | LitNumWord -- ^ @Word#@ - according to target machine + | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits + deriving (Data,Enum,Eq,Ord) + +-- | Indicate if a numeric literal type supports negative numbers +litNumIsSigned :: LitNumType -> Bool +litNumIsSigned nt = case nt of + LitNumInteger -> True + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> False + LitNumWord64 -> False + +{- +Note [Integer literals] +~~~~~~~~~~~~~~~~~~~~~~~ +An Integer literal is represented using, well, an Integer, to make it +easier to write RULEs for them. They also contain the Integer type, so +that e.g. literalType can return the right Type for them. + +They only get converted into real Core, + mkInteger [c1, c2, .., cn] +during the CorePrep phase, although GHC.Iface.Tidy looks ahead at what the +core will be, so that it can see whether it involves CAFs. + +When we initially build an Integer literal, notably when +deserialising it from an interface file (see the Binary instance +below), we don't have convenient access to the mkInteger Id. So we +just use an error thunk, and fill in the real Id when we do tcIfaceLit +in GHC.IfaceToCore. + +Note [Natural literals] +~~~~~~~~~~~~~~~~~~~~~~~ +Similar to Integer literals. + +Note [String literals] +~~~~~~~~~~~~~~~~~~~~~~ + +String literals are UTF-8 encoded and stored into ByteStrings in the following +ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals +with the BytesPrimL constructor (see #14741). + +It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite +bad for performance with large strings (see #16198 and #14741). + +To include string literals into output objects, the assembler code generator has +to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs] +for more details. + +-} + +instance Binary LitNumType where + put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) + get bh = do + h <- getByte bh + return (toEnum (fromIntegral h)) + +instance Binary Literal where + put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa + put_ bh (LitString ab) = do putByte bh 1; put_ bh ab + put_ bh (LitNullAddr) = do putByte bh 2 + put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah + put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai + put_ bh (LitLabel aj mb fod) + = do putByte bh 5 + put_ bh aj + put_ bh mb + put_ bh fod + put_ bh (LitNumber nt i _) + = do putByte bh 6 + put_ bh nt + put_ bh i + put_ bh (LitRubbish) = do putByte bh 7 + get bh = do + h <- getByte bh + case h of + 0 -> do + aa <- get bh + return (LitChar aa) + 1 -> do + ab <- get bh + return (LitString ab) + 2 -> do + return (LitNullAddr) + 3 -> do + ah <- get bh + return (LitFloat ah) + 4 -> do + ai <- get bh + return (LitDouble ai) + 5 -> do + aj <- get bh + mb <- get bh + fod <- get bh + return (LitLabel aj mb fod) + 6 -> do + nt <- get bh + i <- get bh + -- Note [Types of LitNumbers] + let t = case nt of + LitNumInt -> intPrimTy + LitNumInt64 -> int64PrimTy + LitNumWord -> wordPrimTy + LitNumWord64 -> word64PrimTy + -- See Note [Integer literals] + LitNumInteger -> + panic "Evaluated the place holder for mkInteger" + -- and Note [Natural literals] + LitNumNatural -> + panic "Evaluated the place holder for mkNatural" + return (LitNumber nt i t) + _ -> do + return (LitRubbish) + +instance Outputable Literal where + ppr = pprLiteral id + +instance Eq Literal where + a == b = compare a b == EQ + +-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in +-- 'TrieMap.CoreMap'. +instance Ord Literal where + compare = cmpLit + +{- + Construction + ~~~~~~~~~~~~ +-} + +{- Note [Word/Int underflow/overflow] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and +unsigned integral types): "All arithmetic is performed modulo 2^n, where n is +the number of bits in the type." + +GHC stores Word# and Int# constant values as Integer. Core optimizations such +as constant folding must ensure that the Integer value remains in the valid +target Word/Int range (see #13172). The following functions are used to +ensure this. + +Note that we *don't* warn the user about overflow. It's not done at runtime +either, and compilation of completely harmless things like + ((124076834 :: Word32) + (2147483647 :: Word32)) +doesn't yield a warning. Instead we simply squash the value into the *target* +Int/Word range. +-} + +-- | Wrap a literal number according to its type +wrapLitNumber :: Platform -> Literal -> Literal +wrapLitNumber platform v@(LitNumber nt i t) = case nt of + LitNumInt -> case platformWordSize platform of + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t + LitNumWord -> case platformWordSize platform of + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t + LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t + LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t + LitNumInteger -> v + LitNumNatural -> v +wrapLitNumber _ x = x + +-- | Create a numeric 'Literal' of the given type +mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Type -> Literal +mkLitNumberWrap platform nt i t = wrapLitNumber platform (LitNumber nt i t) + +-- | Check that a given number is in the range of a numeric literal +litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool +litNumCheckRange platform nt i = case nt of + LitNumInt -> platformInIntRange platform i + LitNumWord -> platformInWordRange platform i + LitNumInt64 -> inInt64Range i + LitNumWord64 -> inWord64Range i + LitNumNatural -> i >= 0 + LitNumInteger -> True + +-- | Create a numeric 'Literal' of the given type +mkLitNumber :: Platform -> LitNumType -> Integer -> Type -> Literal +mkLitNumber platform nt i t = + ASSERT2(litNumCheckRange platform nt i, integer i) + (LitNumber nt i t) + +-- | Creates a 'Literal' of type @Int#@ +mkLitInt :: Platform -> Integer -> Literal +mkLitInt platform x = ASSERT2( platformInIntRange platform x, integer x ) + (mkLitIntUnchecked x) + +-- | Creates a 'Literal' of type @Int#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrap :: Platform -> Integer -> Literal +mkLitIntWrap platform i = wrapLitNumber platform $ mkLitIntUnchecked i + +-- | Creates a 'Literal' of type @Int#@ without checking its range. +mkLitIntUnchecked :: Integer -> Literal +mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy + +-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating +-- overflow. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the overflow flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitIntWrapC platform i = (n, i /= i') + where + n@(LitNumber _ i' _) = mkLitIntWrap platform i + +-- | Creates a 'Literal' of type @Word#@ +mkLitWord :: Platform -> Integer -> Literal +mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x ) + (mkLitWordUnchecked x) + +-- | Creates a 'Literal' of type @Word#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrap :: Platform -> Integer -> Literal +mkLitWordWrap platform i = wrapLitNumber platform $ mkLitWordUnchecked i + +-- | Creates a 'Literal' of type @Word#@ without checking its range. +mkLitWordUnchecked :: Integer -> Literal +mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy + +-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating +-- carry. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the carry flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitWordWrapC platform i = (n, i /= i') + where + n@(LitNumber _ i' _) = mkLitWordWrap platform i + +-- | Creates a 'Literal' of type @Int64#@ +mkLitInt64 :: Integer -> Literal +mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) + +-- | Creates a 'Literal' of type @Int64#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt64Wrap :: Platform -> Integer -> Literal +mkLitInt64Wrap platform i = wrapLitNumber platform $ mkLitInt64Unchecked i + +-- | Creates a 'Literal' of type @Int64#@ without checking its range. +mkLitInt64Unchecked :: Integer -> Literal +mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy + +-- | Creates a 'Literal' of type @Word64#@ +mkLitWord64 :: Integer -> Literal +mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) + +-- | Creates a 'Literal' of type @Word64#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord64Wrap :: Platform -> Integer -> Literal +mkLitWord64Wrap platform i = wrapLitNumber platform $ mkLitWord64Unchecked i + +-- | Creates a 'Literal' of type @Word64#@ without checking its range. +mkLitWord64Unchecked :: Integer -> Literal +mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy + +-- | Creates a 'Literal' of type @Float#@ +mkLitFloat :: Rational -> Literal +mkLitFloat = LitFloat + +-- | Creates a 'Literal' of type @Double#@ +mkLitDouble :: Rational -> Literal +mkLitDouble = LitDouble + +-- | Creates a 'Literal' of type @Char#@ +mkLitChar :: Char -> Literal +mkLitChar = LitChar + +-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to +-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ +mkLitString :: String -> Literal +-- stored UTF-8 encoded +mkLitString s = LitString (bytesFS $ mkFastString s) + +mkLitInteger :: Integer -> Type -> Literal +mkLitInteger x ty = LitNumber LitNumInteger x ty + +mkLitNatural :: Integer -> Type -> Literal +mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) + (LitNumber LitNumNatural x ty) + +inNaturalRange :: Integer -> Bool +inNaturalRange x = x >= 0 + +inInt64Range, inWord64Range :: Integer -> Bool +inInt64Range x = x >= toInteger (minBound :: Int64) && + x <= toInteger (maxBound :: Int64) +inWord64Range x = x >= toInteger (minBound :: Word64) && + x <= toInteger (maxBound :: Word64) + +inCharRange :: Char -> Bool +inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR + +-- | Tests whether the literal represents a zero of whatever type it is +isZeroLit :: Literal -> Bool +isZeroLit (LitNumber _ 0 _) = True +isZeroLit (LitFloat 0) = True +isZeroLit (LitDouble 0) = True +isZeroLit _ = False + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. +litValue :: Literal -> Integer +litValue l = case isLitValue_maybe l of + Just x -> x + Nothing -> pprPanic "litValue" (ppr l) + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char' and numbers. +isLitValue_maybe :: Literal -> Maybe Integer +isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c +isLitValue_maybe (LitNumber _ i _) = Just i +isLitValue_maybe _ = Nothing + +-- | Apply a function to the 'Integer' contained in the 'Literal', for when that +-- makes sense, e.g. for 'Char' and numbers. +-- For fixed-size integral literals, the result will be wrapped in accordance +-- with the semantics of the target type. +-- See Note [Word/Int underflow/overflow] +mapLitValue :: Platform -> (Integer -> Integer) -> Literal -> Literal +mapLitValue _ f (LitChar c) = mkLitChar (fchar c) + where fchar = chr . fromInteger . f . toInteger . ord +mapLitValue platform f (LitNumber nt i t) = wrapLitNumber platform + (LitNumber nt (f i) t) +mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) + +-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', +-- 'Int', 'Word', 'LitInteger' and 'LitNatural'. +isLitValue :: Literal -> Bool +isLitValue = isJust . isLitValue_maybe + +{- + Coercions + ~~~~~~~~~ +-} + +narrow8IntLit, narrow16IntLit, narrow32IntLit, + narrow8WordLit, narrow16WordLit, narrow32WordLit, + char2IntLit, int2CharLit, + float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, + float2DoubleLit, double2FloatLit + :: Literal -> Literal + +word2IntLit, int2WordLit :: Platform -> Literal -> Literal +word2IntLit platform (LitNumber LitNumWord w _) + -- Map Word range [max_int+1, max_word] + -- to Int range [min_int , -1] + -- Range [0,max_int] has the same representation with both Int and Word + | w > platformMaxInt platform = mkLitInt platform (w - platformMaxWord platform - 1) + | otherwise = mkLitInt platform w +word2IntLit _ l = pprPanic "word2IntLit" (ppr l) + +int2WordLit platform (LitNumber LitNumInt i _) + -- Map Int range [min_int , -1] + -- to Word range [max_int+1, max_word] + -- Range [0,max_int] has the same representation with both Int and Word + | i < 0 = mkLitWord platform (1 + platformMaxWord platform + i) + | otherwise = mkLitWord platform i +int2WordLit _ l = pprPanic "int2WordLit" (ppr l) + +-- | Narrow a literal number (unchecked result range) +narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal +narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t +narrowLit _ l = pprPanic "narrowLit" (ppr l) + +narrow8IntLit = narrowLit (Proxy :: Proxy Int8) +narrow16IntLit = narrowLit (Proxy :: Proxy Int16) +narrow32IntLit = narrowLit (Proxy :: Proxy Int32) +narrow8WordLit = narrowLit (Proxy :: Proxy Word8) +narrow16WordLit = narrowLit (Proxy :: Proxy Word16) +narrow32WordLit = narrowLit (Proxy :: Proxy Word32) + +char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) +char2IntLit l = pprPanic "char2IntLit" (ppr l) +int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i)) +int2CharLit l = pprPanic "int2CharLit" (ppr l) + +float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) +float2IntLit l = pprPanic "float2IntLit" (ppr l) +int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i) +int2FloatLit l = pprPanic "int2FloatLit" (ppr l) + +double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) +double2IntLit l = pprPanic "double2IntLit" (ppr l) +int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i) +int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) + +float2DoubleLit (LitFloat f) = LitDouble f +float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) +double2FloatLit (LitDouble d) = LitFloat d +double2FloatLit l = pprPanic "double2FloatLit" (ppr l) + +nullAddrLit :: Literal +nullAddrLit = LitNullAddr + +-- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. +rubbishLit :: Literal +rubbishLit = LitRubbish + +{- + Predicates + ~~~~~~~~~~ +-} + +-- | True if there is absolutely no penalty to duplicating the literal. +-- False principally of strings. +-- +-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would +-- blow up code sizes. Not only this, it's also unsafe. +-- +-- Consider a program that wants to traverse a string. One way it might do this +-- is to first compute the Addr# pointing to the end of the string, and then, +-- starting from the beginning, bump a pointer using eqAddr# to determine the +-- end. For instance, +-- +-- @ +-- -- Given pointers to the start and end of a string, count how many zeros +-- -- the string contains. +-- countZeros :: Addr# -> Addr# -> -> Int +-- countZeros start end = go start 0 +-- where +-- go off n +-- | off `addrEq#` end = n +-- | otherwise = go (off `plusAddr#` 1) n' +-- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 +-- | otherwise = n +-- @ +-- +-- Consider what happens if we considered strings to be trivial (and therefore +-- duplicable) and emitted a call like @countZeros "hello"# ("hello"# +-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same +-- string, meaning that an iteration like the above would blow up terribly. +-- This is what happened in #12757. +-- +-- Ultimately the solution here is to make primitive strings a bit more +-- structured, ensuring that the compiler can't inline in ways that will break +-- user code. One approach to this is described in #8472. +litIsTrivial :: Literal -> Bool +-- c.f. GHC.Core.Utils.exprIsTrivial +litIsTrivial (LitString _) = False +litIsTrivial (LitNumber nt _ _) = case nt of + LitNumInteger -> False + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True +litIsTrivial _ = True + +-- | True if code space does not go bad if we duplicate this literal +litIsDupable :: Platform -> Literal -> Bool +-- c.f. GHC.Core.Utils.exprIsDupable +litIsDupable platform x = case x of + (LitNumber nt i _) -> case nt of + LitNumInteger -> platformInIntRange platform i + LitNumNatural -> platformInWordRange platform i + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True + (LitString _) -> False + _ -> True + +litFitsInChar :: Literal -> Bool +litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) + && i <= toInteger (ord maxBound) +litFitsInChar _ = False + +litIsLifted :: Literal -> Bool +litIsLifted (LitNumber nt _ _) = case nt of + LitNumInteger -> True + LitNumNatural -> True + LitNumInt -> False + LitNumInt64 -> False + LitNumWord -> False + LitNumWord64 -> False +litIsLifted _ = False + +{- + Types + ~~~~~ + +Note [Types of LitNumbers] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A LitNumber's type is always known from its LitNumType: + + LitNumInteger -> Integer + LitNumNatural -> Natural + LitNumInt -> Int# (intPrimTy) + LitNumInt64 -> Int64# (int64PrimTy) + LitNumWord -> Word# (wordPrimTy) + LitNumWord64 -> Word64# (word64PrimTy) + +The reason why we have a Type field is because Integer and Natural types live +outside of GHC (in the libraries), so we have to get the actual Type via +lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites +of literalType, so we do that when creating these literals, and literalType +simply reads the field. + +(But see also Note [Integer literals] and Note [Natural literals]) +-} + +-- | Find the Haskell 'Type' the literal occupies +literalType :: Literal -> Type +literalType LitNullAddr = addrPrimTy +literalType (LitChar _) = charPrimTy +literalType (LitString _) = addrPrimTy +literalType (LitFloat _) = floatPrimTy +literalType (LitDouble _) = doublePrimTy +literalType (LitLabel _ _ _) = addrPrimTy +literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers] +literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) + where + a = alphaTyVarUnliftedRep + +absentLiteralOf :: TyCon -> Maybe Literal +-- Return a literal of the appropriate primitive +-- TyCon, to use as a placeholder when it doesn't matter +-- Rubbish literals are handled in GHC.Core.Op.WorkWrap.Lib, because +-- 1. Looking at the TyCon is not enough, we need the actual type +-- 2. This would need to return a type application to a literal +absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) + +absent_lits :: UniqFM Literal +absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr) + , (charPrimTyConKey, LitChar 'x') + , (intPrimTyConKey, mkLitIntUnchecked 0) + , (int64PrimTyConKey, mkLitInt64Unchecked 0) + , (wordPrimTyConKey, mkLitWordUnchecked 0) + , (word64PrimTyConKey, mkLitWord64Unchecked 0) + , (floatPrimTyConKey, LitFloat 0) + , (doublePrimTyConKey, LitDouble 0) + ] + +{- + Comparison + ~~~~~~~~~~ +-} + +cmpLit :: Literal -> Literal -> Ordering +cmpLit (LitChar a) (LitChar b) = a `compare` b +cmpLit (LitString a) (LitString b) = a `compare` b +cmpLit (LitNullAddr) (LitNullAddr) = EQ +cmpLit (LitFloat a) (LitFloat b) = a `compare` b +cmpLit (LitDouble a) (LitDouble b) = a `compare` b +cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b +cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) + | nt1 == nt2 = a `compare` b + | otherwise = nt1 `compare` nt2 +cmpLit (LitRubbish) (LitRubbish) = EQ +cmpLit lit1 lit2 + | litTag lit1 < litTag lit2 = LT + | otherwise = GT + +litTag :: Literal -> Int +litTag (LitChar _) = 1 +litTag (LitString _) = 2 +litTag (LitNullAddr) = 3 +litTag (LitFloat _) = 4 +litTag (LitDouble _) = 5 +litTag (LitLabel _ _ _) = 6 +litTag (LitNumber {}) = 7 +litTag (LitRubbish) = 8 + +{- + Printing + ~~~~~~~~ +* See Note [Printing of literals in Core] +-} + +pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc +pprLiteral _ (LitChar c) = pprPrimChar c +pprLiteral _ (LitString s) = pprHsBytes s +pprLiteral _ (LitNullAddr) = text "__NULL" +pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix +pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix +pprLiteral add_par (LitNumber nt i _) + = case nt of + LitNumInteger -> pprIntegerVal add_par i + LitNumNatural -> pprIntegerVal add_par i + LitNumInt -> pprPrimInt i + LitNumInt64 -> pprPrimInt64 i + LitNumWord -> pprPrimWord i + LitNumWord64 -> pprPrimWord64 i +pprLiteral add_par (LitLabel l mb fod) = + add_par (text "__label" <+> b <+> ppr fod) + where b = case mb of + Nothing -> pprHsString l + Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) +pprLiteral _ (LitRubbish) = text "__RUBBISH" + +pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc +-- See Note [Printing of literals in Core]. +pprIntegerVal add_par i | i < 0 = add_par (integer i) + | otherwise = integer i + +{- +Note [Printing of literals in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function `add_par` is used to wrap parenthesis around negative integers +(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring +an atomic thing (for example function application). + +Although not all Core literals would be valid Haskell, we are trying to stay +as close as possible to Haskell syntax in the printing of Core, to make it +easier for a Haskell user to read Core. + +To that end: + * We do print parenthesis around negative `LitInteger`, because we print + `LitInteger` using plain number literals (no prefix or suffix), and plain + number literals in Haskell require parenthesis in contexts like function + application (i.e. `1 - -1` is not valid Haskell). + + * We don't print parenthesis around other (negative) literals, because they + aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's + parser). + +Literal Output Output if context requires + an atom (if different) +------- ------- ---------------------- +LitChar 'a'# +LitString "aaa"# +LitNullAddr "__NULL" +LitInt -1# +LitInt64 -1L# +LitWord 1## +LitWord64 1L## +LitFloat -1.0# +LitDouble -1.0## +LitInteger -1 (-1) +LitLabel "__label" ... ("__label" ...) +LitRubbish "__RUBBISH" + +Note [Rubbish literals] +~~~~~~~~~~~~~~~~~~~~~~~ +During worker/wrapper after demand analysis, where an argument +is unused (absent) we do the following w/w split (supposing that +y is absent): + + f x y z = e +===> + f x y z = $wf x z + $wf x z = let y = + in e + +Usually the binding for y is ultimately optimised away, and +even if not it should never be evaluated -- but that's the +way the w/w split starts off. + +What is ? +* For lifted values can be a call to 'error'. +* For primitive types like Int# or Word# we can use any random + value of that type. +* But what about /unlifted/ but /boxed/ types like MutVar# or + Array#? We need a literal value of that type. + +That is 'LitRubbish'. Since we need a rubbish literal for +many boxed, unlifted types, we say that LitRubbish has type + LitRubbish :: forall (a :: TYPE UnliftedRep). a + +So we might see a w/w split like + $wf x z = let y :: Array# Int = LitRubbish @(Array# Int) + in e + +Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted +heap pointers. + +Here are the moving parts: + +* We define LitRubbish as a constructor in GHC.Types.Literal.Literal + +* It is given its polymorphic type by Literal.literalType + +* GHC.Core.Op.WorkWrap.Lib.mk_absent_let introduces a LitRubbish for absent + arguments of boxed, unlifted type. + +* In CoreToSTG we convert (RubishLit @t) to just (). STG is + untyped, so it doesn't matter that it points to a lifted + value. The important thing is that it is a heap pointer, + which the garbage collector can follow if it encounters it. + + We considered maintaining LitRubbish in STG, and lowering + it in the code generators, but it seems simpler to do it + once and for all in CoreToSTG. + + In GHC.ByteCode.Asm we just lower it as a 0 literal, because + it's all boxed and lifted to the host GC anyway. +-} diff --git a/compiler/GHC/Types/Module.hs b/compiler/GHC/Types/Module.hs new file mode 100644 index 0000000000..a73df28a9e --- /dev/null +++ b/compiler/GHC/Types/Module.hs @@ -0,0 +1,1303 @@ +{- +(c) The University of Glasgow, 2004-2006 + + +Module +~~~~~~~~~~ +Simply the name of a module, represented as a FastString. +These are Uniquable, hence we can build Maps with Modules as +the keys. +-} + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module GHC.Types.Module + ( + -- * The ModuleName type + ModuleName, + pprModuleName, + moduleNameFS, + moduleNameString, + moduleNameSlashes, moduleNameColons, + moduleStableString, + moduleFreeHoles, + moduleIsDefinite, + mkModuleName, + mkModuleNameFS, + stableModuleNameCmp, + + -- * The UnitId type + ComponentId(..), + UnitId(..), + unitIdFS, + unitIdKey, + IndefUnitId(..), + IndefModule(..), + indefUnitIdToUnitId, + indefModuleToModule, + InstalledUnitId(..), + toInstalledUnitId, + ShHoleSubst, + + unitIdIsDefinite, + unitIdString, + unitIdFreeHoles, + + newUnitId, + newIndefUnitId, + newSimpleUnitId, + hashUnitId, + fsToUnitId, + stringToUnitId, + stableUnitIdCmp, + + -- * HOLE renaming + renameHoleUnitId, + renameHoleModule, + renameHoleUnitId', + renameHoleModule', + + -- * Generalization + splitModuleInsts, + splitUnitIdInsts, + generalizeIndefUnitId, + generalizeIndefModule, + + -- * Parsers + parseModuleName, + parseUnitId, + parseComponentId, + parseModuleId, + parseModSubst, + + -- * Wired-in UnitIds + -- $wired_in_packages + primUnitId, + integerUnitId, + baseUnitId, + rtsUnitId, + thUnitId, + mainUnitId, + thisGhcUnitId, + isHoleModule, + interactiveUnitId, isInteractiveModule, + wiredInUnitIds, + + -- * The Module type + Module(Module), + moduleUnitId, moduleName, + pprModule, + mkModule, + mkHoleModule, + stableModuleCmp, + HasModule(..), + ContainsModule(..), + + -- * Installed unit ids and modules + InstalledModule(..), + InstalledModuleEnv, + installedModuleEq, + installedUnitIdEq, + installedUnitIdString, + fsToInstalledUnitId, + componentIdToInstalledUnitId, + stringToInstalledUnitId, + emptyInstalledModuleEnv, + lookupInstalledModuleEnv, + extendInstalledModuleEnv, + filterInstalledModuleEnv, + delInstalledModuleEnv, + DefUnitId(..), + + -- * The ModuleLocation type + ModLocation(..), + addBootSuffix, addBootSuffix_maybe, + addBootSuffixLocn, addBootSuffixLocnOut, + + -- * Module mappings + ModuleEnv, + elemModuleEnv, extendModuleEnv, extendModuleEnvList, + extendModuleEnvList_C, plusModuleEnv_C, + delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, + lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, + moduleEnvKeys, moduleEnvElts, moduleEnvToList, + unitModuleEnv, isEmptyModuleEnv, + extendModuleEnvWith, filterModuleEnv, + + -- * ModuleName mappings + ModuleNameEnv, DModuleNameEnv, + + -- * Sets of Modules + ModuleSet, + emptyModuleSet, mkModuleSet, moduleSetElts, + extendModuleSet, extendModuleSetList, delModuleSet, + elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet, + unitModuleSet + ) where + +import GhcPrelude + +import 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 Data.List (sortBy, sort) +import Data.Ord +import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) +import Fingerprint + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.Char8 +import Encoding + +import qualified Text.ParserCombinators.ReadP as Parse +import Text.ParserCombinators.ReadP (ReadP, (<++)) +import Data.Char (isAlphaNum) +import Control.DeepSeq +import Data.Coerce +import Data.Data +import Data.Function +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 System.FilePath + +import {-# SOURCE #-} GHC.Driver.Session (DynFlags) +import {-# SOURCE #-} GHC.Driver.Packages (componentIdString, improveUnitId, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId) + +-- Note [The identifier lexicon] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Unit IDs, installed package IDs, ABI hashes, package names, +-- versions, there are a *lot* of different identifiers for closely +-- related things. What do they all mean? Here's what. (See also +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts ) +-- +-- THE IMPORTANT ONES +-- +-- ComponentId: An opaque identifier provided by Cabal, which should +-- uniquely identify such things as the package name, the package +-- version, the name of the component, the hash of the source code +-- tarball, the selected Cabal flags, GHC flags, direct dependencies of +-- the component. These are very similar to InstalledPackageId, but +-- an 'InstalledPackageId' implies that it identifies a package, while +-- a package may install multiple components with different +-- 'ComponentId's. +-- - Same as Distribution.Package.ComponentId +-- +-- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names +-- (ModuleName) to Modules. This is how the compiler identifies instantiated +-- components, and also is the main identifier by which GHC identifies things. +-- - When Backpack is not being used, UnitId = ComponentId. +-- this means a useful fiction for end-users is that there are +-- only ever ComponentIds, and some ComponentIds happen to have +-- more information (UnitIds). +-- - Same as Language.Haskell.TH.Syntax:PkgName, see +-- https://gitlab.haskell.org/ghc/ghc/issues/10279 +-- - The same as PackageKey in GHC 7.10 (we renamed it because +-- they don't necessarily identify packages anymore.) +-- - Same as -this-package-key/-package-name flags +-- - An InstalledUnitId corresponds to an actual package which +-- we have installed on disk. It could be definite or indefinite, +-- but if it's indefinite, it has nothing instantiated (we +-- never install partially instantiated units.) +-- +-- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how +-- the compiler identifies modules (e.g. a Name is a Module + OccName) +-- - Same as Language.Haskell.TH.Syntax:Module +-- +-- THE LESS IMPORTANT ONES +-- +-- PackageName: The "name" field in a Cabal file, something like "lens". +-- - Same as Distribution.Package.PackageName +-- - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see +-- https://gitlab.haskell.org/ghc/ghc/issues/10279 +-- - DIFFERENT FROM -package-name flag +-- - DIFFERENT FROM the 'name' field in an installed package +-- information. This field could more accurately be described +-- as a munged package name: when it's for the main library +-- it is the same as the package name, but if it's an internal +-- library it's a munged combination of the package name and +-- the component name. +-- +-- LEGACY ONES +-- +-- InstalledPackageId: This is what we used to call ComponentId. +-- It's a still pretty useful concept for packages that have only +-- one library; in that case the logical InstalledPackageId = +-- ComponentId. Also, the Cabal nix-local-build continues to +-- compute an InstalledPackageId which is then forcibly used +-- for all components in a package. This means that if a dependency +-- from one component in a package changes, the InstalledPackageId +-- changes: you don't get as fine-grained dependency tracking, +-- but it means your builds are hermetic. Eventually, Cabal will +-- deal completely in components and we can get rid of this. +-- +-- PackageKey: This is what we used to call UnitId. We ditched +-- "Package" from the name when we realized that you might want to +-- assign different "PackageKeys" to components from the same package. +-- (For a brief, non-released period of time, we also called these +-- UnitKeys). + +{- +************************************************************************ +* * +\subsection{Module locations} +* * +************************************************************************ +-} + +-- | Module Location +-- +-- Where a module lives on the file system: the actual locations +-- of the .hs, .hi and .o files, if we have them +data ModLocation + = ModLocation { + ml_hs_file :: Maybe FilePath, + -- The source file, if we have one. Package modules + -- probably don't have source files. + + ml_hi_file :: FilePath, + -- Where the .hi file is, whether or not it exists + -- yet. Always of form foo.hi, even if there is an + -- hi-boot file (we add the -boot suffix later) + + ml_obj_file :: FilePath, + -- Where the .o file is, whether or not it exists yet. + -- (might not exist either because the module hasn't + -- been compiled yet, or because it is part of a + -- package with a .a file) + ml_hie_file :: FilePath + } deriving Show + +instance Outputable ModLocation where + ppr = text . show + +{- +For a module in another package, the hs_file and obj_file +components of ModLocation are undefined. + +The locations specified by a ModLocation may or may not +correspond to actual files yet: for example, even if the object +file doesn't exist, the ModLocation still contains the path to +where the object file will reside if/when it is created. +-} + +addBootSuffix :: FilePath -> FilePath +-- ^ Add the @-boot@ suffix to .hs, .hi and .o files +addBootSuffix path = path ++ "-boot" + +addBootSuffix_maybe :: Bool -> FilePath -> FilePath +-- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ +addBootSuffix_maybe is_boot path + | is_boot = addBootSuffix path + | otherwise = path + +addBootSuffixLocn :: ModLocation -> ModLocation +-- ^ Add the @-boot@ suffix to all file paths associated with the module +addBootSuffixLocn locn + = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) + , ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) + , ml_hie_file = addBootSuffix (ml_hie_file locn) } + +addBootSuffixLocnOut :: ModLocation -> ModLocation +-- ^ Add the @-boot@ suffix to all output file paths associated with the +-- module, not including the input file itself +addBootSuffixLocnOut locn + = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) + , ml_hie_file = addBootSuffix (ml_hie_file locn) } + +{- +************************************************************************ +* * +\subsection{The name of a module} +* * +************************************************************************ +-} + +-- | A ModuleName is essentially a simple string, e.g. @Data.List@. +newtype ModuleName = ModuleName FastString + +instance Uniquable ModuleName where + getUnique (ModuleName nm) = getUnique nm + +instance Eq ModuleName where + nm1 == nm2 = getUnique nm1 == getUnique nm2 + +instance Ord ModuleName where + nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 + +instance Outputable ModuleName where + ppr = pprModuleName + +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + +instance BinaryStringRep ModuleName where + fromStringRep = mkModuleNameFS . mkFastStringByteString + toStringRep = bytesFS . moduleNameFS + +instance Data ModuleName where + -- don't traverse? + toConstr _ = abstractConstr "ModuleName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ModuleName" + +instance NFData ModuleName where + rnf x = x `seq` () + +stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering +-- ^ Compares module names lexically, rather than by their 'Unique's +stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 + +pprModuleName :: ModuleName -> SDoc +pprModuleName (ModuleName nm) = + getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS nm) + else ftext nm + +moduleNameFS :: ModuleName -> FastString +moduleNameFS (ModuleName mod) = mod + +moduleNameString :: ModuleName -> String +moduleNameString (ModuleName mod) = unpackFS mod + +-- | Get a string representation of a 'Module' that's unique and stable +-- across recompilations. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" +moduleStableString :: Module -> String +moduleStableString Module{..} = + "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName + +mkModuleName :: String -> ModuleName +mkModuleName s = ModuleName (mkFastString s) + +mkModuleNameFS :: FastString -> ModuleName +mkModuleNameFS s = ModuleName s + +-- |Returns the string version of the module name, with dots replaced by slashes. +-- +moduleNameSlashes :: ModuleName -> String +moduleNameSlashes = dots_to_slashes . moduleNameString + where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) + +-- |Returns the string version of the module name, with dots replaced by colons. +-- +moduleNameColons :: ModuleName -> String +moduleNameColons = dots_to_colons . moduleNameString + where dots_to_colons = map (\c -> if c == '.' then ':' else c) + +{- +************************************************************************ +* * +\subsection{A fully qualified module} +* * +************************************************************************ +-} + +-- | A Module is a pair of a 'UnitId' and a 'ModuleName'. +-- +-- Module variables (i.e. @@) which can be instantiated to a +-- specific module at some later point in time are represented +-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to +-- avoid having to make 'moduleUnitId' a partial operation.) +-- +data Module = Module { + moduleUnitId :: !UnitId, -- pkg-1.0 + moduleName :: !ModuleName -- A.B.C + } + deriving (Eq, Ord) + +-- | Calculate the free holes of a 'Module'. If this set is non-empty, +-- this module was defined in an indefinite library that had required +-- signatures. +-- +-- If a module has free holes, that means that substitutions can operate on it; +-- if it has no free holes, substituting over a module has no effect. +moduleFreeHoles :: Module -> UniqDSet ModuleName +moduleFreeHoles m + | isHoleModule m = unitUniqDSet (moduleName m) + | otherwise = unitIdFreeHoles (moduleUnitId m) + +-- | A 'Module' is definite if it has no free holes. +moduleIsDefinite :: Module -> Bool +moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles + +-- | Create a module variable at some 'ModuleName'. +-- See Note [Representation of module/name variables] +mkHoleModule :: ModuleName -> Module +mkHoleModule = mkModule holeUnitId + +instance Uniquable Module where + getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) + +instance Outputable Module where + ppr = pprModule + +instance Binary Module where + put_ bh (Module p n) = put_ bh p >> put_ bh n + get bh = do p <- get bh; n <- get bh; return (Module p n) + +instance Data Module where + -- don't traverse? + toConstr _ = abstractConstr "Module" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Module" + +instance NFData Module where + rnf x = x `seq` () + +-- | This gives a stable ordering, as opposed to the Ord instance which +-- gives an ordering based on the 'Unique's of the components, which may +-- not be stable from run to run of the compiler. +stableModuleCmp :: Module -> Module -> Ordering +stableModuleCmp (Module p1 n1) (Module p2 n2) + = (p1 `stableUnitIdCmp` p2) `thenCmp` + (n1 `stableModuleNameCmp` n2) + +mkModule :: UnitId -> ModuleName -> Module +mkModule = Module + +pprModule :: Module -> SDoc +pprModule mod@(Module p n) = getPprStyle doc + where + doc sty + | codeStyle sty = + (if p == mainUnitId + then empty -- never qualify the main package in code + else ztext (zEncodeFS (unitIdFS p)) <> char '_') + <> pprModuleName n + | qualModule sty mod = + if isHoleModule mod + then angleBrackets (pprModuleName n) + else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n + | otherwise = + pprModuleName n + +class ContainsModule t where + extractModule :: t -> Module + +class HasModule m where + getModule :: m Module + +instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where + fromDbModule (DbModule uid mod_name) = mkModule uid mod_name + fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name + fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts + fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid) + -- GHC never writes to the database, so it's not needed + toDbModule = error "toDbModule: not implemented" + toDbUnitId = error "toDbUnitId: not implemented" + +{- +************************************************************************ +* * +\subsection{ComponentId} +* * +************************************************************************ +-} + +-- | A 'ComponentId' consists of the package name, package version, component +-- ID, the transitive dependencies of the component, and other information to +-- uniquely identify the source code and build configuration of a component. +-- +-- This used to be known as an 'InstalledPackageId', but a package can contain +-- multiple components and a 'ComponentId' uniquely identifies a component +-- within a package. When a package only has one component, the 'ComponentId' +-- coincides with the 'InstalledPackageId' +newtype ComponentId = ComponentId FastString deriving (Eq, Ord) + +instance BinaryStringRep ComponentId where + fromStringRep = ComponentId . mkFastStringByteString + toStringRep (ComponentId s) = bytesFS s + +instance Uniquable ComponentId where + getUnique (ComponentId n) = getUnique n + +instance Outputable ComponentId where + ppr cid@(ComponentId fs) = + getPprStyle $ \sty -> + sdocWithDynFlags $ \dflags -> + case componentIdString dflags cid of + Just str | not (debugStyle sty) -> text str + _ -> ftext fs + +{- +************************************************************************ +* * +\subsection{UnitId} +* * +************************************************************************ +-} + +-- | A unit identifier identifies a (possibly partially) instantiated +-- library. It is primarily used as part of 'Module', which in turn +-- is used in 'Name', which is used to give names to entities when +-- typechecking. +-- +-- There are two possible forms for a 'UnitId'. It can be a +-- 'DefiniteUnitId', in which case we just have a string that uniquely +-- identifies some fully compiled, installed library we have on disk. +-- However, when we are typechecking a library with missing holes, +-- we may need to instantiate a library on the fly (in which case +-- we don't have any on-disk representation.) In that case, you +-- have an 'IndefiniteUnitId', which explicitly records the +-- instantiation, so that we can substitute over it. +data UnitId + = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId + | DefiniteUnitId {-# UNPACK #-} !DefUnitId + +unitIdFS :: UnitId -> FastString +unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x +unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x + +unitIdKey :: UnitId -> Unique +unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x +unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x + +-- | A unit identifier which identifies an indefinite +-- library (with holes) that has been *on-the-fly* instantiated +-- with a substitution 'indefUnitIdInsts'. In fact, an indefinite +-- unit identifier could have no holes, but we haven't gotten +-- around to compiling the actual library yet. +-- +-- An indefinite unit identifier pretty-prints to something like +-- @p[H=,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the +-- brackets enclose the module substitution). +data IndefUnitId + = IndefUnitId { + -- | A private, uniquely identifying representation of + -- a UnitId. This string is completely private to GHC + -- and is just used to get a unique; in particular, we don't use it for + -- symbols (indefinite libraries are not compiled). + indefUnitIdFS :: FastString, + -- | Cached unique of 'unitIdFS'. + indefUnitIdKey :: Unique, + -- | The component identity of the indefinite library that + -- is being instantiated. + indefUnitIdComponentId :: !ComponentId, + -- | The sorted (by 'ModuleName') instantiations of this library. + indefUnitIdInsts :: ![(ModuleName, Module)], + -- | A cache of the free module variables of 'unitIdInsts'. + -- This lets us efficiently tell if a 'UnitId' has been + -- fully instantiated (free module variables are empty) + -- and whether or not a substitution can have any effect. + indefUnitIdFreeHoles :: UniqDSet ModuleName + } + +instance Eq IndefUnitId where + u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 + +instance Ord IndefUnitId where + u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 + +instance Binary IndefUnitId where + put_ bh indef = do + put_ bh (indefUnitIdComponentId indef) + put_ bh (indefUnitIdInsts indef) + get bh = do + cid <- get bh + insts <- get bh + let fs = hashUnitId cid insts + return IndefUnitId { + indefUnitIdComponentId = cid, + indefUnitIdInsts = insts, + indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + indefUnitIdFS = fs, + indefUnitIdKey = getUnique fs + } + +-- | Create a new 'IndefUnitId' given an explicit module substitution. +newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId +newIndefUnitId cid insts = + IndefUnitId { + indefUnitIdComponentId = cid, + indefUnitIdInsts = sorted_insts, + indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + indefUnitIdFS = fs, + indefUnitIdKey = getUnique fs + } + where + fs = hashUnitId cid sorted_insts + sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts + +-- | Injects an 'IndefUnitId' (indefinite library which +-- was on-the-fly instantiated) to a 'UnitId' (either +-- an indefinite or definite library). +indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId +indefUnitIdToUnitId dflags iuid = + -- NB: suppose that we want to compare the indefinite + -- unit id p[H=impl:H] against p+abcd (where p+abcd + -- happens to be the existing, installed version of + -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] + -- IndefiniteUnitId, they won't compare equal; only + -- after improvement will the equality hold. + improveUnitId (getUnitInfoMap dflags) $ + IndefiniteUnitId iuid + +data IndefModule = IndefModule { + indefModuleUnitId :: IndefUnitId, + indefModuleName :: ModuleName + } deriving (Eq, Ord) + +instance Outputable IndefModule where + ppr (IndefModule uid m) = + ppr uid <> char ':' <> ppr m + +-- | Injects an 'IndefModule' to 'Module' (see also +-- 'indefUnitIdToUnitId'. +indefModuleToModule :: DynFlags -> IndefModule -> Module +indefModuleToModule dflags (IndefModule iuid mod_name) = + mkModule (indefUnitIdToUnitId dflags iuid) mod_name + +-- | An installed unit identifier identifies a library which has +-- been installed to the package database. These strings are +-- provided to us via the @-this-unit-id@ flag. The library +-- in question may be definite or indefinite; if it is indefinite, +-- none of the holes have been filled (we never install partially +-- instantiated libraries.) Put another way, an installed unit id +-- is either fully instantiated, or not instantiated at all. +-- +-- Installed unit identifiers look something like @p+af23SAj2dZ219@, +-- or maybe just @p@ if they don't use Backpack. +newtype InstalledUnitId = + InstalledUnitId { + -- | The full hashed unit identifier, including the component id + -- and the hash. + installedUnitIdFS :: FastString + } + +instance Binary InstalledUnitId where + put_ bh (InstalledUnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (InstalledUnitId fs) + +instance BinaryStringRep InstalledUnitId where + fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) + -- GHC doesn't write to database + toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" + +instance Eq InstalledUnitId where + uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 + +instance Ord InstalledUnitId where + u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 + +instance Uniquable InstalledUnitId where + getUnique = installedUnitIdKey + +instance Outputable InstalledUnitId where + ppr uid@(InstalledUnitId fs) = + getPprStyle $ \sty -> + sdocWithDynFlags $ \dflags -> + case displayInstalledUnitId dflags uid of + Just str | not (debugStyle sty) -> text str + _ -> ftext fs + +installedUnitIdKey :: InstalledUnitId -> Unique +installedUnitIdKey = getUnique . installedUnitIdFS + +-- | Lossy conversion to the on-disk 'InstalledUnitId' for a component. +toInstalledUnitId :: UnitId -> InstalledUnitId +toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid +toInstalledUnitId (IndefiniteUnitId indef) = + componentIdToInstalledUnitId (indefUnitIdComponentId indef) + +installedUnitIdString :: InstalledUnitId -> String +installedUnitIdString = unpackFS . installedUnitIdFS + +instance Outputable IndefUnitId where + ppr uid = + -- getPprStyle $ \sty -> + ppr cid <> + (if not (null insts) -- pprIf + then + brackets (hcat + (punctuate comma $ + [ ppr modname <> text "=" <> ppr m + | (modname, m) <- insts])) + else empty) + where + cid = indefUnitIdComponentId uid + insts = indefUnitIdInsts uid + +-- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. +data InstalledModule = InstalledModule { + installedModuleUnitId :: !InstalledUnitId, + installedModuleName :: !ModuleName + } + deriving (Eq, Ord) + +instance Outputable InstalledModule where + ppr (InstalledModule p n) = + ppr p <> char ':' <> pprModuleName n + +fsToInstalledUnitId :: FastString -> InstalledUnitId +fsToInstalledUnitId fs = InstalledUnitId fs + +componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId +componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs + +stringToInstalledUnitId :: String -> InstalledUnitId +stringToInstalledUnitId = fsToInstalledUnitId . mkFastString + +-- | Test if a 'Module' corresponds to a given 'InstalledModule', +-- modulo instantiation. +installedModuleEq :: InstalledModule -> Module -> Bool +installedModuleEq imod mod = + fst (splitModuleInsts mod) == imod + +-- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', +-- modulo instantiation. +installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool +installedUnitIdEq iuid uid = + fst (splitUnitIdInsts uid) == iuid + +-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that +-- it only refers to a definite library; i.e., one we have generated +-- code for. +newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } + deriving (Eq, Ord) + +instance Outputable DefUnitId where + ppr (DefUnitId uid) = ppr uid + +instance Binary DefUnitId where + put_ bh (DefUnitId uid) = put_ bh uid + get bh = do uid <- get bh; return (DefUnitId uid) + +-- | A map keyed off of 'InstalledModule' +newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) + +emptyInstalledModuleEnv :: InstalledModuleEnv a +emptyInstalledModuleEnv = InstalledModuleEnv Map.empty + +lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a +lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e + +extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a +extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) + +filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a +filterInstalledModuleEnv f (InstalledModuleEnv e) = + InstalledModuleEnv (Map.filterWithKey f e) + +delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a +delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) + +-- Note [UnitId to InstalledUnitId improvement] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Just because a UnitId is definite (has no holes) doesn't +-- mean it's necessarily a InstalledUnitId; it could just be +-- that over the course of renaming UnitIds on the fly +-- while typechecking an indefinite library, we +-- ended up with a fully instantiated unit id with no hash, +-- since we haven't built it yet. This is fine. +-- +-- However, if there is a hashed unit id for this instantiation +-- in the package database, we *better use it*, because +-- that hashed unit id may be lurking in another interface, +-- and chaos will ensue if we attempt to compare the two +-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided +-- hash of a compiled instantiated library). +-- +-- There is one last niggle: improvement based on the package database means +-- that we might end up developing on a package that is not transitively +-- depended upon by the packages the user specified directly via command line +-- flags. This could lead to strange and difficult to understand bugs if those +-- instantiations are out of date. The solution is to only improve a +-- unit id if the new unit id is part of the 'preloadClosure'; i.e., the +-- closure of all the packages which were explicitly specified. + +-- | Retrieve the set of free holes of a 'UnitId'. +unitIdFreeHoles :: UnitId -> UniqDSet ModuleName +unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x +-- Hashed unit ids are always fully instantiated +unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet + +instance Show UnitId where + show = unitIdString + +-- | A 'UnitId' is definite if it has no free holes. +unitIdIsDefinite :: UnitId -> Bool +unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles + +-- | Generate a uniquely identifying 'FastString' for a unit +-- identifier. This is a one-way function. You can rely on one special +-- property: if a unit identifier is in most general form, its 'FastString' +-- coincides with its 'ComponentId'. This hash is completely internal +-- to GHC and is not used for symbol names or file paths. +hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString +hashUnitId cid sorted_holes = + mkFastStringByteString + . fingerprintUnitId (toStringRep cid) + $ rawHashUnitId sorted_holes + +-- | Generate a hash for a sorted module substitution. +rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint +rawHashUnitId sorted_holes = + fingerprintByteString + . BS.concat $ do + (m, b) <- sorted_holes + [ toStringRep m, BS.Char8.singleton ' ', + bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', + toStringRep (moduleName b), BS.Char8.singleton '\n'] + +fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString +fingerprintUnitId prefix (Fingerprint a b) + = BS.concat + $ [ prefix + , BS.Char8.singleton '-' + , BS.Char8.pack (toBase62Padded a) + , BS.Char8.pack (toBase62Padded b) ] + +-- | Create a new, un-hashed unit identifier. +newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId +newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... +newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts + +pprUnitId :: UnitId -> SDoc +pprUnitId (DefiniteUnitId uid) = ppr uid +pprUnitId (IndefiniteUnitId uid) = ppr uid + +instance Eq UnitId where + uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 + +instance Uniquable UnitId where + getUnique = unitIdKey + +instance Ord UnitId where + nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 + +instance Data UnitId where + -- don't traverse? + toConstr _ = abstractConstr "UnitId" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "UnitId" + +instance NFData UnitId where + rnf x = x `seq` () + +stableUnitIdCmp :: UnitId -> UnitId -> Ordering +-- ^ Compares package ids lexically, rather than by their 'Unique's +stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 + +instance Outputable UnitId where + ppr pk = pprUnitId pk + +-- Performance: would prefer to have a NameCache like thing +instance Binary UnitId where + put_ bh (DefiniteUnitId def_uid) = do + putByte bh 0 + put_ bh def_uid + put_ bh (IndefiniteUnitId indef_uid) = do + putByte bh 1 + put_ bh indef_uid + get bh = do b <- getByte bh + case b of + 0 -> fmap DefiniteUnitId (get bh) + _ -> fmap IndefiniteUnitId (get bh) + +instance Binary ComponentId where + put_ bh (ComponentId fs) = put_ bh fs + get bh = do { fs <- get bh; return (ComponentId fs) } + +-- | Create a new simple unit identifier (no holes) from a 'ComponentId'. +newSimpleUnitId :: ComponentId -> UnitId +newSimpleUnitId (ComponentId fs) = fsToUnitId fs + +-- | Create a new simple unit identifier from a 'FastString'. Internally, +-- this is primarily used to specify wired-in unit identifiers. +fsToUnitId :: FastString -> UnitId +fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId + +stringToUnitId :: String -> UnitId +stringToUnitId = fsToUnitId . mkFastString + +unitIdString :: UnitId -> String +unitIdString = unpackFS . unitIdFS + +{- +************************************************************************ +* * + Hole substitutions +* * +************************************************************************ +-} + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Substitutes holes in a 'Module'. NOT suitable for being called +-- directly on a 'nameModule', see Note [Representation of module/name variable]. +-- @p[A=]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; +-- similarly, @@ maps to @q():A@. +renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module +renameHoleModule dflags = renameHoleModule' (getUnitInfoMap dflags) + +-- | Substitutes holes in a 'UnitId', suitable for renaming when +-- an include occurs; see Note [Representation of module/name variable]. +-- +-- @p[A=]@ maps to @p[A=]@ with @A=@. +renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId dflags = renameHoleUnitId' (getUnitInfoMap dflags) + +-- | Like 'renameHoleModule', but requires only 'UnitInfoMap' +-- so it can be used by "Packages". +renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m + | not (isHoleModule m) = + let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = , that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnitId, but requires only 'UnitInfoMap' +-- so it can be used by "Packages". +renameHoleUnitId' :: UnitInfoMap -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId' pkg_map env uid = + case uid of + (IndefiniteUnitId + IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts + , indefUnitIdFreeHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) + then uid + -- Functorially apply the substitution to the instantiation, + -- then check the 'UnitInfoMap' to see if there is + -- a compiled version of this 'UnitId' we can improve to. + -- See Note [UnitId to InstalledUnitId] improvement + else improveUnitId pkg_map $ + newUnitId cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) + _ -> uid + +-- | Given a possibly on-the-fly instantiated module, split it into +-- a 'Module' that we definitely can find on-disk, as well as an +-- instantiation if we need to instantiate it on the fly. If the +-- instantiation is @Nothing@ no on-the-fly renaming is needed. +splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule) +splitModuleInsts m = + let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m) + in (InstalledModule uid (moduleName m), + fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid) + +-- | See 'splitModuleInsts'. +splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId) +splitUnitIdInsts (IndefiniteUnitId iuid) = + (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid) +splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) + +generalizeIndefUnitId :: IndefUnitId -> IndefUnitId +generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts } = + newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) + +generalizeIndefModule :: IndefModule -> IndefModule +generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n + +parseModuleName :: ReadP ModuleName +parseModuleName = fmap mkModuleName + $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") + +parseUnitId :: ReadP UnitId +parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId + where + parseFullUnitId = do + cid <- parseComponentId + insts <- parseModSubst + return (newUnitId cid insts) + parseDefiniteUnitId = do + s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + return (stringToUnitId s) + parseSimpleUnitId = do + cid <- parseComponentId + return (newSimpleUnitId cid) + +parseComponentId :: ReadP ComponentId +parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." + +parseModuleId :: ReadP Module +parseModuleId = parseModuleVar <++ parseModule + where + parseModuleVar = do + _ <- Parse.char '<' + modname <- parseModuleName + _ <- Parse.char '>' + return (mkHoleModule modname) + parseModule = do + uid <- parseUnitId + _ <- Parse.char ':' + modname <- parseModuleName + return (mkModule uid modname) + +parseModSubst :: ReadP [(ModuleName, Module)] +parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') + . flip Parse.sepBy (Parse.char ',') + $ do k <- parseModuleName + _ <- Parse.char '=' + v <- parseModuleId + return (k, v) + + +{- +Note [Wired-in packages] +~~~~~~~~~~~~~~~~~~~~~~~~ + +Certain packages are known to the compiler, in that we know about certain +entities that reside in these packages, and the compiler needs to +declare static Modules and Names that refer to these packages. Hence +the wired-in packages can't include version numbers in their package UnitId, +since we don't want to bake the version numbers of these packages into GHC. + +So here's the plan. Wired-in packages are still versioned as +normal in the packages database, and you can still have multiple +versions of them installed. To the user, everything looks normal. + +However, for each invocation of GHC, only a single instance of each wired-in +package will be recognised (the desired one is selected via +@-package@\/@-hide-package@), and GHC will internally pretend that it has the +*unversioned* 'UnitId', including in .hi files and object file symbols. + +Unselected versions of wired-in packages will be ignored, as will any other +package that depends directly or indirectly on it (much as if you +had used @-ignore-package@). + +The affected packages are compiled with, e.g., @-this-unit-id base@, so that +the symbols in the object files have the unversioned unit id in their name. + +Make sure you change 'Packages.findWiredInPackages' if you add an entry here. + +For `integer-gmp`/`integer-simple` we also change the base name to +`integer-wired-in`, but this is fundamentally no different. +See Note [The integer library] in PrelNames. +-} + +integerUnitId, primUnitId, + baseUnitId, rtsUnitId, + thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId +primUnitId = fsToUnitId (fsLit "ghc-prim") +integerUnitId = fsToUnitId (fsLit "integer-wired-in") + -- See Note [The integer library] in PrelNames +baseUnitId = fsToUnitId (fsLit "base") +rtsUnitId = fsToUnitId (fsLit "rts") +thUnitId = fsToUnitId (fsLit "template-haskell") +thisGhcUnitId = fsToUnitId (fsLit "ghc") +interactiveUnitId = fsToUnitId (fsLit "interactive") + +-- | This is the package Id for the current program. It is the default +-- package Id if you don't specify a package name. We don't add this prefix +-- to symbol names, since there can be only one main package per program. +mainUnitId = fsToUnitId (fsLit "main") + +-- | This is a fake package id used to provide identities to any un-implemented +-- signatures. The set of hole identities is global over an entire compilation. +-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. +-- See Note [Representation of module/name variables] +holeUnitId :: UnitId +holeUnitId = fsToUnitId (fsLit "hole") + +isInteractiveModule :: Module -> Bool +isInteractiveModule mod = moduleUnitId mod == interactiveUnitId + +-- Note [Representation of module/name variables] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In our ICFP'16, we use to represent module holes, and {A.T} to represent +-- name holes. This could have been represented by adding some new cases +-- to the core data types, but this would have made the existing 'nameModule' +-- and 'moduleUnitId' partial, which would have required a lot of modifications +-- to existing code. +-- +-- Instead, we adopted the following encoding scheme: +-- +-- ===> hole:A +-- {A.T} ===> hole:A.T +-- +-- This encoding is quite convenient, but it is also a bit dangerous too, +-- because if you have a 'hole:A' you need to know if it's actually a +-- 'Module' or just a module stored in a 'Name'; these two cases must be +-- treated differently when doing substitutions. 'renameHoleModule' +-- and 'renameHoleUnitId' assume they are NOT operating on a +-- 'Name'; 'NameShape' handles name substitutions exclusively. + +isHoleModule :: Module -> Bool +isHoleModule mod = moduleUnitId mod == holeUnitId + +wiredInUnitIds :: [UnitId] +wiredInUnitIds = [ primUnitId, + integerUnitId, + baseUnitId, + rtsUnitId, + thUnitId, + thisGhcUnitId ] + +{- +************************************************************************ +* * +\subsection{@ModuleEnv@s} +* * +************************************************************************ +-} + +-- | A map keyed off of 'Module's +newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) + +{- +Note [ModuleEnv performance and determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To prevent accidental reintroduction of nondeterminism the Ord instance +for Module was changed to not depend on Unique ordering and to use the +lexicographic order. This is potentially expensive, but when measured +there was no difference in performance. + +To be on the safe side and not pessimize ModuleEnv uses nondeterministic +ordering on Module and normalizes by doing the lexicographic sort when +turning the env to a list. +See Note [Unique Determinism] for more information about the source of +nondeterminismand and Note [Deterministic UniqFM] for explanation of why +it matters for maps. +-} + +newtype NDModule = NDModule { unNDModule :: Module } + deriving Eq + -- A wrapper for Module with faster nondeterministic Ord. + -- Don't export, See [ModuleEnv performance and determinism] + +instance Ord NDModule where + compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = + (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` + (getUnique n1 `nonDetCmpUnique` getUnique n2) + +filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a +filterModuleEnv f (ModuleEnv e) = + ModuleEnv (Map.filterWithKey (f . unNDModule) e) + +elemModuleEnv :: Module -> ModuleEnv a -> Bool +elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e + +extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) + +extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a + -> ModuleEnv a +extendModuleEnvWith f (ModuleEnv e) m x = + ModuleEnv (Map.insertWith f (NDModule m) x e) + +extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a +extendModuleEnvList (ModuleEnv e) xs = + ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) + +extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] + -> ModuleEnv a +extendModuleEnvList_C f (ModuleEnv e) xs = + ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) + +plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = + ModuleEnv (Map.unionWith f e1 e2) + +delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a +delModuleEnvList (ModuleEnv e) ms = + ModuleEnv (Map.deleteList (map NDModule ms) e) + +delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a +delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) + +plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) + +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e + +lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a +lookupWithDefaultModuleEnv (ModuleEnv e) x m = + Map.findWithDefault x (NDModule m) e + +mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) + +mkModuleEnv :: [(Module, a)] -> ModuleEnv a +mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) + +emptyModuleEnv :: ModuleEnv a +emptyModuleEnv = ModuleEnv Map.empty + +moduleEnvKeys :: ModuleEnv a -> [Module] +moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvElts :: ModuleEnv a -> [a] +moduleEnvElts e = map snd $ moduleEnvToList e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvToList :: ModuleEnv a -> [(Module, a)] +moduleEnvToList (ModuleEnv e) = + sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] + -- See Note [ModuleEnv performance and determinism] + +unitModuleEnv :: Module -> a -> ModuleEnv a +unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) + +isEmptyModuleEnv :: ModuleEnv a -> Bool +isEmptyModuleEnv (ModuleEnv e) = Map.null e + +-- | A set of 'Module's +type ModuleSet = Set NDModule + +mkModuleSet :: [Module] -> ModuleSet +mkModuleSet = Set.fromList . coerce + +extendModuleSet :: ModuleSet -> Module -> ModuleSet +extendModuleSet s m = Set.insert (NDModule m) s + +extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet +extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms + +emptyModuleSet :: ModuleSet +emptyModuleSet = Set.empty + +moduleSetElts :: ModuleSet -> [Module] +moduleSetElts = sort . coerce . Set.toList + +elemModuleSet :: Module -> ModuleSet -> Bool +elemModuleSet = Set.member . coerce + +intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +intersectModuleSet = coerce Set.intersection + +minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +minusModuleSet = coerce Set.difference + +delModuleSet :: ModuleSet -> Module -> ModuleSet +delModuleSet = coerce (flip Set.delete) + +unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +unionModuleSet = coerce Set.union + +unitModuleSet :: Module -> ModuleSet +unitModuleSet = coerce Set.singleton + +{- +A ModuleName has a Unique, so we can build mappings of these using +UniqFM. +-} + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +type ModuleNameEnv elt = UniqFM elt + + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +-- Has deterministic folds and can be deterministically converted to a list +type DModuleNameEnv elt = UniqDFM elt diff --git a/compiler/GHC/Types/Module.hs-boot b/compiler/GHC/Types/Module.hs-boot new file mode 100644 index 0000000000..1f2fec56d7 --- /dev/null +++ b/compiler/GHC/Types/Module.hs-boot @@ -0,0 +1,14 @@ +module GHC.Types.Module where + +import GhcPrelude +import FastString + +data Module +data ModuleName +data UnitId +data InstalledUnitId +newtype ComponentId = ComponentId FastString + +moduleName :: Module -> ModuleName +moduleUnitId :: Module -> UnitId +unitIdString :: UnitId -> String diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs new file mode 100644 index 0000000000..60aee23af8 --- /dev/null +++ b/compiler/GHC/Types/Name.hs @@ -0,0 +1,693 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Name]{@Name@: to transmit name info from renamer to typechecker} +-} + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They +-- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have +-- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names +-- also contain information about where they originated from, see "Name#name_sorts" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" +-- +-- #name_sorts# +-- Names are one of: +-- +-- * External, if they name things declared in other modules. Some external +-- Names are wired in, i.e. they name primitives defined in the compiler itself +-- +-- * Internal, if they name things in the module being compiled. Some internal +-- Names are system names, if they are names manufactured by the compiler + +module GHC.Types.Name ( + -- * The main types + Name, -- Abstract + BuiltInSyntax(..), + + -- ** Creating 'Name's + mkSystemName, mkSystemNameAt, + mkInternalName, mkClonedInternalName, mkDerivedInternalName, + mkSystemVarName, mkSysTvName, + mkFCallName, + mkExternalName, mkWiredInName, + + -- ** Manipulating and deconstructing 'Name's + nameUnique, setNameUnique, + nameOccName, nameNameSpace, nameModule, nameModule_maybe, + setNameLoc, + tidyNameOcc, + localiseName, + + nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, + + -- ** Predicates on 'Name's + isSystemName, isInternalName, isExternalName, + isTyVarName, isTyConName, isDataConName, + isValName, isVarName, + isWiredInName, isWiredIn, isBuiltInSyntax, + isHoleName, + wiredInNameTyThing_maybe, + nameIsLocalOrFrom, nameIsHomePackage, + nameIsHomePackageImport, nameIsFromExternalPackage, + stableNameCmp, + + -- * Class 'NamedThing' and overloaded friends + NamedThing(..), + getSrcLoc, getSrcSpan, getOccString, getOccFS, + + pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, + nameStableString, + + -- Re-export the OccName stuff + module GHC.Types.Name.Occurrence + ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing ) + +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 Control.DeepSeq +import Data.Data + +{- +************************************************************************ +* * +\subsection[Name-datatype]{The @Name@ datatype, and name construction} +* * +************************************************************************ +-} + +-- | A unique, unambiguous name for something, containing information about where +-- that thing originated. +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_occ :: !OccName, -- Its occurrence name + n_uniq :: {-# UNPACK #-} !Unique, + n_loc :: !SrcSpan -- Definition site + } + +-- NOTE: we make the n_loc field strict to eliminate some potential +-- (and real!) space leaks, due to the fact that we don't look at +-- the SrcLoc in a Name all that often. + +-- See Note [About the NameSorts] +data NameSort + = External Module + + | WiredIn Module TyThing BuiltInSyntax + -- A variant of External, for wired-in things + + | Internal -- A user-defined Id or TyVar + -- defined in the module being compiled + + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') + +instance Outputable NameSort where + ppr (External _) = text "external" + ppr (WiredIn _ _ _) = text "wired-in" + ppr Internal = text "internal" + ppr System = text "system" + +instance NFData Name where + rnf Name{..} = rnf n_sort + +instance NFData NameSort where + rnf (External m) = rnf m + rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () + -- XXX this is a *lie*, we're not going to rnf the TyThing, but + -- since the TyThings for WiredIn Names are all static they can't + -- be hiding space leaks or errors. + rnf Internal = () + rnf System = () + +-- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, +-- which have special syntactic forms. They aren't in scope +-- as such. +data BuiltInSyntax = BuiltInSyntax | UserSyntax + +{- +Note [About the NameSorts] + +1. Initially, top-level Ids (including locally-defined ones) get External names, + and all other local Ids get Internal names + +2. In any invocation of GHC, an External Name for "M.x" has one and only one + unique. This unique association is ensured via the Name Cache; + see Note [The Name Cache] in GHC.Iface.Env. + +3. Things with a External name are given C static labels, so they finally + appear in the .o file's symbol table. They appear in the symbol table + in the form M.n. If originally-local things have this property they + must be made @External@ first. + +4. In the tidy-core phase, a External that is not visible to an importer + is changed to Internal, and a Internal that is visible is changed to External + +5. A System Name differs in the following ways: + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + + Before anything gets printed in interface files or output code, it's + fed through a 'tidy' processor, which zaps the OccNames to have + unique names; and converts all sys-locals to user locals + If any desugarer sys-locals have survived that far, they get changed to + "ds1", "ds2", etc. + +Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) + +Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, + not read from an interface file. + E.g. Bool, True, Int, Float, and many others + +All built-in syntax is for wired-in things. +-} + +instance HasOccName Name where + occName = nameOccName + +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameNameSpace :: Name -> NameSpace +nameModule :: HasDebugCallStack => Name -> Module +nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan + +nameUnique name = n_uniq name +nameOccName name = n_occ name +nameNameSpace name = occNameSpace (n_occ name) +nameSrcLoc name = srcSpanStart (n_loc name) +nameSrcSpan name = n_loc name + +{- +************************************************************************ +* * +\subsection{Predicates on names} +* * +************************************************************************ +-} + +isInternalName :: Name -> Bool +isExternalName :: Name -> Bool +isSystemName :: Name -> Bool +isWiredInName :: Name -> Bool + +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName _ = False + +isWiredIn :: NamedThing thing => thing -> Bool +isWiredIn = isWiredInName . getName + +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing +wiredInNameTyThing_maybe _ = Nothing + +isBuiltInSyntax :: Name -> Bool +isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True +isBuiltInSyntax _ = False + +isExternalName (Name {n_sort = External _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName _ = False + +isInternalName name = not (isExternalName name) + +isHoleName :: Name -> Bool +isHoleName = isHoleModule . nameModule + +nameModule name = + nameModule_maybe name `orElse` + pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) + +nameModule_maybe :: Name -> Maybe Module +nameModule_maybe (Name { n_sort = External mod}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe _ = Nothing + +nameIsLocalOrFrom :: Module -> Name -> Bool +-- ^ Returns True if the name is +-- (a) Internal +-- (b) External but from the specified module +-- (c) External but from the 'interactive' package +-- +-- The key idea is that +-- False means: the entity is defined in some other module +-- you can find the details (type, fixity, instances) +-- in some interface file +-- those details will be stored in the EPT or HPT +-- +-- True means: the entity is defined in this module or earlier in +-- the GHCi session +-- you can find details (type, fixity, instances) in the +-- TcGblEnv or TcLclEnv +-- +-- The isInteractiveModule part is because successive interactions of a GHCi session +-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come +-- from the magic 'interactive' package; and all the details are kept in the +-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. +-- See Note [The interactive package] in GHC.Driver.Types + +nameIsLocalOrFrom from name + | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod + | otherwise = True + +nameIsHomePackage :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +nameIsHomePackage this_mod + = \nm -> case n_sort nm of + External nm_mod -> moduleUnitId nm_mod == this_pkg + WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg + Internal -> True + System -> False + where + this_pkg = moduleUnitId this_mod + +nameIsHomePackageImport :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +-- /other than/ the this_mod +nameIsHomePackageImport this_mod + = \nm -> case nameModule_maybe nm of + Nothing -> False + Just nm_mod -> nm_mod /= this_mod + && moduleUnitId nm_mod == this_pkg + where + this_pkg = moduleUnitId this_mod + +-- | Returns True if the Name comes from some other package: neither this +-- package nor the interactive package. +nameIsFromExternalPackage :: UnitId -> Name -> Bool +nameIsFromExternalPackage this_pkg name + | Just mod <- nameModule_maybe name + , moduleUnitId mod /= this_pkg -- Not this package + , not (isInteractiveModule mod) -- Not the 'interactive' package + = True + | otherwise + = False + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + +isTyConName :: Name -> Bool +isTyConName name = isTcOcc (nameOccName name) + +isDataConName :: Name -> Bool +isDataConName name = isDataOcc (nameOccName name) + +isValName :: Name -> Bool +isValName name = isValOcc (nameOccName name) + +isVarName :: Name -> Bool +isVarName = isVarOcc . nameOccName + +isSystemName (Name {n_sort = System}) = True +isSystemName _ = False + +{- +************************************************************************ +* * +\subsection{Making names} +* * +************************************************************************ +-} + +-- | Create a name which is (for now at least) local to the current module and hence +-- does not need a 'Module' to disambiguate it from other 'Name's +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName uniq occ loc = Name { n_uniq = uniq + , n_sort = Internal + , n_occ = occ + , n_loc = loc } + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which makes + -- the OccNames distinct when they need to be + +mkClonedInternalName :: Unique -> Name -> Name +mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = occ, n_loc = loc } + +mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name +mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = derive_occ occ, n_loc = loc } + +-- | Create a name which definitely originates in the given module +mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name +-- WATCH OUT! External Names should be in the Name Cache +-- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName +-- with some fresh unique without populating the Name Cache +mkExternalName uniq mod occ loc + = Name { n_uniq = uniq, n_sort = External mod, + n_occ = occ, n_loc = loc } + +-- | Create a name which is actually defined by the compiler itself +mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name +mkWiredInName mod occ uniq thing built_in + = Name { n_uniq = uniq, + n_sort = WiredIn mod thing built_in, + n_occ = occ, n_loc = wiredInSrcSpan } + +-- | Create a name brought into being by the compiler +mkSystemName :: Unique -> OccName -> Name +mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan + +mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name +mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System + , n_occ = occ, n_loc = loc } + +mkSystemVarName :: Unique -> FastString -> Name +mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) + +mkSysTvName :: Unique -> FastString -> Name +mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) + +-- | Make a name for a foreign call +mkFCallName :: Unique -> String -> Name +mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan + -- The encoded string completely describes the ccall + +-- When we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +setNameUnique :: Name -> Unique -> Name +setNameUnique name uniq = name {n_uniq = uniq} + +-- This is used for hsigs: we want to use the name of the originally exported +-- entity, but edit the location to refer to the reexport site +setNameLoc :: Name -> SrcSpan -> Name +setNameLoc name loc = name {n_loc = loc} + +tidyNameOcc :: Name -> OccName -> Name +-- We set the OccName of a Name when tidying +-- In doing so, we change System --> Internal, so that when we print +-- it we don't get the unique by default. It's tidy now! +tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} +tidyNameOcc name occ = name { n_occ = occ } + +-- | Make the 'Name' into an internal name, regardless of what it was to begin with +localiseName :: Name -> Name +localiseName n = n { n_sort = Internal } + +{- +************************************************************************ +* * +\subsection{Hashing and comparison} +* * +************************************************************************ +-} + +cmpName :: Name -> Name -> Ordering +cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 + +-- | Compare Names lexicographically +-- This only works for Names that originate in the source code or have been +-- tidied. +stableNameCmp :: Name -> Name -> Ordering +stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) + (Name { n_sort = s2, n_occ = occ2 }) + = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + -- The ordinary compare on OccNames is lexicographic + where + -- Later constructors are bigger + sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 + sort_cmp (External {}) _ = LT + sort_cmp (WiredIn {}) (External {}) = GT + sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 + sort_cmp (WiredIn {}) _ = LT + sort_cmp Internal (External {}) = GT + sort_cmp Internal (WiredIn {}) = GT + sort_cmp Internal Internal = EQ + sort_cmp Internal System = LT + sort_cmp System System = EQ + sort_cmp System _ = GT + +{- +************************************************************************ +* * +\subsection[Name-instances]{Instance declarations} +* * +************************************************************************ +-} + +-- | The same comments as for `Name`'s `Ord` instance apply. +instance Eq Name where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +-- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which +-- means that the ordering is not stable across deserialization or rebuilds. +-- +-- See `nonDetCmpUnique` for further information, and trac #15240 for a bug +-- caused by improper use of this instance. + +-- For a deterministic lexicographic ordering, use `stableNameCmp`. +instance Ord Name where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpName a b + +instance Uniquable Name where + getUnique = nameUnique + +instance NamedThing Name where + getName n = n + +instance Data Name where + -- don't traverse? + toConstr _ = abstractConstr "Name" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Name" + +{- +************************************************************************ +* * +\subsection{Binary} +* * +************************************************************************ +-} + +-- | Assumes that the 'Name' is a non-binding one. See +-- 'GHC.Iface.Syntax.putIfaceTopBndr' and 'GHC.Iface.Syntax.getIfaceTopBndr' for +-- serializing binding 'Name's. See 'UserData' for the rationale for this +-- distinction. +instance Binary Name where + put_ bh name = + case getUserData bh of + UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name + + get bh = + case getUserData bh of + UserData { ud_get_name = get_name } -> get_name bh + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance Outputable Name where + ppr name = pprName name + +instance OutputableBndr Name where + pprBndr _ name = pprName name + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + +pprName :: Name -> SDoc +pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) + = getPprStyle $ \ sty -> + case sort of + WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin + External mod -> pprExternal sty uniq mod occ False UserSyntax + System -> pprSystem sty uniq occ + Internal -> pprInternal sty uniq occ + +-- | Print the string of Name unqualifiedly directly. +pprNameUnqualified :: Name -> SDoc +pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ + +pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal sty uniq mod occ is_wired is_builtin + | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? + | debugStyle sty = pp_mod <> ppr_occ_name occ + <> braces (hsep [if is_wired then text "(w)" else empty, + pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax + | otherwise = + if isHoleModule mod + then case qualName sty mod occ of + NameUnqual -> ppr_occ_name occ + _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) + else pprModulePrefix sty mod occ <> ppr_occ_name occ + where + pp_mod = ppUnlessOption sdocSuppressModulePrefixes + (ppr mod <> dot) + +pprInternal :: PprStyle -> Unique -> OccName -> SDoc +pprInternal sty uniq occ + | codeStyle sty = pprUniqueAlways uniq + | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + -- For debug dumps, we're not necessarily dumping + -- tidied code, so we need to print the uniques. + | otherwise = ppr_occ_name occ -- User style + +-- Like Internal, except that we only omit the unique in Iface style +pprSystem :: PprStyle -> Unique -> OccName -> SDoc +pprSystem sty uniq occ + | codeStyle sty = pprUniqueAlways uniq + | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + <> braces (pprNameSpaceBrief (occNameSpace occ)) + | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq + -- If the tidy phase hasn't run, the OccName + -- is unlikely to be informative (like 's'), + -- so print the unique + + +pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +-- Print the "M." part of a name, based on whether it's in scope or not +-- See Note [Printing original names] in GHC.Driver.Types +pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ + case qualName sty mod occ of -- See Outputable.QualifyName: + NameQual modname -> ppr modname <> dot -- Name is in scope + NameNotInScope1 -> ppr mod <> dot -- Not in scope + NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in + <> ppr (moduleName mod) <> dot -- scope either + NameUnqual -> empty -- In scope unqualified + +pprUnique :: Unique -> SDoc +-- Print a unique unless we are suppressing them +pprUnique uniq + = ppUnlessOption sdocSuppressUniques $ + pprUniqueAlways uniq + +ppr_underscore_unique :: Unique -> SDoc +-- Print an underscore separating the name from its unique +-- But suppress it if we aren't printing the uniques anyway +ppr_underscore_unique uniq + = ppUnlessOption sdocSuppressUniques $ + char '_' <> pprUniqueAlways uniq + +ppr_occ_name :: OccName -> SDoc +ppr_occ_name occ = ftext (occNameFS occ) + -- Don't use pprOccName; instead, just print the string of the OccName; + -- we print the namespace in the debug stuff above + +-- In code style, we Z-encode the strings. The results of Z-encoding each FastString are +-- cached behind the scenes in the FastString implementation. +ppr_z_occ_name :: OccName -> SDoc +ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) + +-- Prints (if mod information is available) "Defined at " or +-- "Defined in " information for a Name. +pprDefinedAt :: Name -> SDoc +pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name + +pprNameDefnLoc :: Name -> SDoc +-- Prints "at " or +-- or "in " depending on what info is available +pprNameDefnLoc name + = case nameSrcLoc name of + -- nameSrcLoc rather than nameSrcSpan + -- It seems less cluttered to show a location + -- rather than a span for the definition point + RealSrcLoc s _ -> text "at" <+> ppr s + UnhelpfulLoc s + | isInternalName name || isSystemName name + -> text "at" <+> ftext s + | otherwise + -> text "in" <+> quotes (ppr (nameModule name)) + + +-- | Get a string representation of a 'Name' that's unique and stable +-- across recompilations. Used for deterministic generation of binds for +-- derived instances. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" +nameStableString :: Name -> String +nameStableString Name{..} = + nameSortStableString n_sort ++ "$" ++ occNameString n_occ + +nameSortStableString :: NameSort -> String +nameSortStableString System = "$_sys" +nameSortStableString Internal = "$_in" +nameSortStableString (External mod) = moduleStableString mod +nameSortStableString (WiredIn mod _ _) = moduleStableString mod + +{- +************************************************************************ +* * +\subsection{Overloaded functions related to Names} +* * +************************************************************************ +-} + +-- | A class allowing convenient access to the 'Name' of various datatypes +class NamedThing a where + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method + +instance NamedThing e => NamedThing (Located e) where + getName = getName . unLoc + +getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan +getOccString :: NamedThing a => a -> String +getOccFS :: NamedThing a => a -> FastString + +getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName +getOccString = occNameString . getOccName +getOccFS = occNameFS . getOccName + +pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc +-- See Outputable.pprPrefixVar, pprInfixVar; +-- add parens or back-quotes as appropriate +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) + +pprPrefixName :: NamedThing a => a -> SDoc +pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) + where + name = getName thing diff --git a/compiler/GHC/Types/Name.hs-boot b/compiler/GHC/Types/Name.hs-boot new file mode 100644 index 0000000000..fdd2f62b8d --- /dev/null +++ b/compiler/GHC/Types/Name.hs-boot @@ -0,0 +1,5 @@ +module GHC.Types.Name where + +import GhcPrelude () + +data Name diff --git a/compiler/GHC/Types/Name/Cache.hs b/compiler/GHC/Types/Name/Cache.hs new file mode 100644 index 0000000000..abf7bc89b5 --- /dev/null +++ b/compiler/GHC/Types/Name/Cache.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +-- | The Name Cache +module GHC.Types.Name.Cache + ( lookupOrigNameCache + , extendOrigNameCache + , extendNameCache + , initNameCache + , NameCache(..), OrigNameCache + ) where + +import GhcPrelude + +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Unique.Supply +import TysWiredIn +import Util +import Outputable +import PrelNames + +#include "HsVersions.h" + +{- + +Note [The Name Cache] +~~~~~~~~~~~~~~~~~~~~~ +The Name Cache makes sure that, during any invocation of GHC, each +External Name "M.x" has one, and only one globally-agreed Unique. + +* The first time we come across M.x we make up a Unique and record that + association in the Name Cache. + +* When we come across "M.x" again, we look it up in the Name Cache, + and get a hit. + +The functions newGlobalBinder, allocateGlobalBinder do the main work. +When you make an External name, you should probably be calling one +of them. + + +Note [Built-in syntax and the OrigNameCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower +their cost we use two tricks, + + a. We specially encode tuple and sum Names in interface files' symbol tables + to avoid having to look up their names while loading interface files. + Namely these names are encoded as by their Uniques. We know how to get from + a Unique back to the Name which it represents via the mapping defined in + the SumTupleUniques module. See Note [Symbol table representation of names] + in GHC.Iface.Binary and for details. + + b. We don't include them in the Orig name cache but instead parse their + OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with + them. + +Why is the second measure necessary? Good question; afterall, 1) the parser +emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never +needs to looked-up during interface loading due to (a). It turns out that there +are two reasons why we might look up an Orig RdrName for built-in syntax, + + * If you use setRdrNameSpace on an Exact RdrName it may be + turned into an Orig RdrName. + + * Template Haskell turns a BuiltInSyntax Name into a TH.NameG + (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName + (GHC.ThToHs.thRdrName). So, e.g. $(do { reify '(,); ... }) will + go this route (#8954). + +-} + +-- | Per-module cache of original 'OccName's given 'Name's +type OrigNameCache = ModuleEnv (OccEnv Name) + +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ + | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE + , Just name <- isBuiltInOcc_maybe occ + = -- See Note [Known-key names], 3(c) in PrelNames + -- Special case for tuples; there are too many + -- of them to pre-populate the original-name cache + Just name + + | otherwise + = case lookupModuleEnv nc mod of + Nothing -> Nothing + Just occ_env -> lookupOccEnv occ_env occ + +extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache +extendOrigNameCache nc name + = ASSERT2( isExternalName name, ppr name ) + extendNameCache nc (nameModule name) (nameOccName name) name + +extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extendNameCache nc mod occ name + = extendModuleEnvWith combine nc mod (unitOccEnv occ name) + where + combine _ occ_env = extendOccEnv occ_env occ name + +-- | The NameCache makes sure that there is just one Unique assigned for +-- each original name; i.e. (module-name, occ-name) pair and provides +-- something of a lookup mechanism for those names. +data NameCache + = NameCache { nsUniqs :: !UniqSupply, + -- ^ Supply of uniques + nsNames :: !OrigNameCache + -- ^ Ensures that one original name gets one unique + } + +-- | Return a function to atomically update the name cache. +initNameCache :: UniqSupply -> [Name] -> NameCache +initNameCache us names + = NameCache { nsUniqs = us, + nsNames = initOrigNames names } + +initOrigNames :: [Name] -> OrigNameCache +initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs new file mode 100644 index 0000000000..25842ab3f1 --- /dev/null +++ b/compiler/GHC/Types/Name/Env.hs @@ -0,0 +1,175 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[NameEnv]{@NameEnv@: name environments} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Types.Name.Env ( + -- * Var, Id and TyVar environments (maps) + NameEnv, + + -- ** Manipulating these environments + mkNameEnv, mkNameEnvWith, + emptyNameEnv, isEmptyNameEnv, + unitNameEnv, nameEnvElts, + extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, + extendNameEnvList, extendNameEnvList_C, + filterNameEnv, anyNameEnv, + plusNameEnv, plusNameEnv_C, alterNameEnv, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, + elemNameEnv, mapNameEnv, disjointNameEnv, + + DNameEnv, + + emptyDNameEnv, + lookupDNameEnv, + delFromDNameEnv, filterDNameEnv, + mapDNameEnv, + adjustDNameEnv, alterDNameEnv, extendDNameEnv, + -- ** Dependency analysis + depAnal + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Digraph +import GHC.Types.Name +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import Maybes + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +{- +Note [depAnal determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. +-} + +depAnal :: forall node. + (node -> [Name]) -- Defs + -> (node -> [Name]) -- Uses + -> [node] + -> [SCC node] +-- Perform dependency analysis on a group of definitions, +-- where each definition may define more than one Name +-- +-- The get_defs and get_uses functions are called only once per node +depAnal get_defs get_uses nodes + = stronglyConnCompFromEdgedVerticesUniq graph_nodes + where + graph_nodes = (map mk_node keyed_nodes) :: [Node Int node] + keyed_nodes = nodes `zip` [(1::Int)..] + mk_node (node, key) = + let !edges = (mapMaybe (lookupNameEnv key_map) (get_uses node)) + in DigraphNode node key edges + + key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it + key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +-- | Name Environment +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +isEmptyNameEnv :: NameEnv a -> Bool +mkNameEnv :: [(Name,a)] -> NameEnv a +mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a +nameEnvElts :: NameEnv a -> [a] +alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a +extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b +extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a +extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +lookupNameEnv_NF :: NameEnv a -> Name -> a +filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool +mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 +disjointNameEnv :: NameEnv a -> NameEnv a -> Bool + +nameEnvElts x = eltsUFM x +emptyNameEnv = emptyUFM +isEmptyNameEnv = isNullUFM +unitNameEnv x y = unitUFM x y +extendNameEnv x y z = addToUFM x y z +extendNameEnvList x l = addListToUFM x l +lookupNameEnv x y = lookupUFM x y +alterNameEnv = alterUFM +mkNameEnv l = listToUFM l +mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) +elemNameEnv x y = elemUFM x y +plusNameEnv x y = plusUFM x y +plusNameEnv_C f x y = plusUFM_C f x y +extendNameEnv_C f x y z = addToUFM_C f x y z +mapNameEnv f x = mapUFM f x +extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendNameEnvList_C x y z = addListToUFM_C x y z +delFromNameEnv x y = delFromUFM x y +delListFromNameEnv x y = delListFromUFM x y +filterNameEnv x y = filterUFM x y +anyNameEnv f x = foldUFM ((||) . f) False x +disjointNameEnv x y = isNullUFM (intersectUFM x y) + +lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) + +-- | Deterministic Name Environment +-- +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why +-- we need DNameEnv. +type DNameEnv a = UniqDFM a + +emptyDNameEnv :: DNameEnv a +emptyDNameEnv = emptyUDFM + +lookupDNameEnv :: DNameEnv a -> Name -> Maybe a +lookupDNameEnv = lookupUDFM + +delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a +delFromDNameEnv = delFromUDFM + +filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a +filterDNameEnv = filterUDFM + +mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b +mapDNameEnv = mapUDFM + +adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a +adjustDNameEnv = adjustUDFM + +alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a +alterDNameEnv = alterUDFM + +extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a +extendDNameEnv = addToUDFM diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs new file mode 100644 index 0000000000..d57924e121 --- /dev/null +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -0,0 +1,927 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName' represents names as strings with just a little more information: +-- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or +-- data constructors +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" + +module GHC.Types.Name.Occurrence ( + -- * The 'NameSpace' type + NameSpace, -- Abstract + + nameSpacesRelated, + + -- ** Construction + -- $real_vs_source_data_constructors + tcName, clsName, tcClsName, dataName, varName, + tvName, srcDataName, + + -- ** Pretty Printing + pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, + + -- * The 'OccName' type + OccName, -- Abstract, instance of Outputable + pprOccName, + + -- ** Construction + mkOccName, mkOccNameFS, + mkVarOcc, mkVarOccFS, + mkDataOcc, mkDataOccFS, + mkTyVarOcc, mkTyVarOccFS, + mkTcOcc, mkTcOccFS, + mkClsOcc, mkClsOccFS, + mkDFunOcc, + setOccNameSpace, + demoteOccName, + HasOccName(..), + + -- ** Derived 'OccName's + isDerivedOccName, + mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, + mkNewTyCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, + mkSuperDictSelOcc, mkSuperDictAuxOcc, + mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, + mkInstTyCoOcc, mkEqPredCoOcc, + mkRecFldSelOcc, + mkTyConRepOcc, + + -- ** Deconstruction + occNameFS, occNameString, occNameSpace, + + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, startsWithUnderscore, + + isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, + + -- * The 'OccEnv' type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, + lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, + occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, + alterOccEnv, pprOccEnv, + + -- * The 'OccSet' type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, + extendOccSetList, + unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, + isEmptyOccSet, intersectOccSet, intersectsOccSet, + filterOccSet, + + -- * Tidying up + TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, + tidyOccName, avoidClashesOccEnv, delTidyOccEnvList, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv + ) where + +import GhcPrelude + +import Util +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import FastString +import FastStringEnv +import Outputable +import GHC.Utils.Lexeme +import Binary +import Control.DeepSeq +import Data.Char +import Data.Data + +{- +************************************************************************ +* * +\subsection{Name space} +* * +************************************************************************ +-} + +data NameSpace = VarName -- Variables, including "real" data constructors + | DataName -- "Source" data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. + deriving( Eq, Ord ) + +-- Note [Data Constructors] +-- see also: Note [Data Constructor Naming] in GHC.Core.DataCon +-- +-- $real_vs_source_data_constructors +-- There are two forms of data constructor: +-- +-- [Source data constructors] The data constructors mentioned in Haskell source code +-- +-- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type +-- +-- For example: +-- +-- > data T = T !(Int, Int) +-- +-- The source datacon has type @(Int, Int) -> T@ +-- The real datacon has type @Int -> Int -> T@ +-- +-- GHC chooses a representation based on the strictness etc. + +tcName, clsName, tcClsName :: NameSpace +dataName, srcDataName :: NameSpace +tvName, varName :: NameSpace + +-- Though type constructors and classes are in the same name space now, +-- the NameSpace type is abstract, so we can easily separate them later +tcName = TcClsName -- Type constructors +clsName = TcClsName -- Classes +tcClsName = TcClsName -- Not sure which! + +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space + +tvName = TvName +varName = VarName + +isDataConNameSpace :: NameSpace -> Bool +isDataConNameSpace DataName = True +isDataConNameSpace _ = False + +isTcClsNameSpace :: NameSpace -> Bool +isTcClsNameSpace TcClsName = True +isTcClsNameSpace _ = False + +isTvNameSpace :: NameSpace -> Bool +isTvNameSpace TvName = True +isTvNameSpace _ = False + +isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors +isVarNameSpace TvName = True +isVarNameSpace VarName = True +isVarNameSpace _ = False + +isValNameSpace :: NameSpace -> Bool +isValNameSpace DataName = True +isValNameSpace VarName = True +isValNameSpace _ = False + +pprNameSpace :: NameSpace -> SDoc +pprNameSpace DataName = text "data constructor" +pprNameSpace VarName = text "variable" +pprNameSpace TvName = text "type variable" +pprNameSpace TcClsName = text "type constructor or class" + +pprNonVarNameSpace :: NameSpace -> SDoc +pprNonVarNameSpace VarName = empty +pprNonVarNameSpace ns = pprNameSpace ns + +pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = text "tv" +pprNameSpaceBrief TcClsName = text "tc" + +-- demoteNameSpace lowers the NameSpace if possible. We can not know +-- in advance, since a TvName can appear in an HsTyVar. +-- See Note [Demotion] in GHC.Rename.Env +demoteNameSpace :: NameSpace -> Maybe NameSpace +demoteNameSpace VarName = Nothing +demoteNameSpace DataName = Nothing +demoteNameSpace TvName = Nothing +demoteNameSpace TcClsName = Just DataName + +{- +************************************************************************ +* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +* * +************************************************************************ +-} + +-- | Occurrence Name +-- +-- In this context that means: +-- "classified (i.e. as a type name, value name, etc) but not qualified +-- and not yet resolved" +data OccName = OccName + { occNameSpace :: !NameSpace + , occNameFS :: !FastString + } + +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +instance Ord OccName where + -- Compares lexicographically, *not* by Unique of the string + compare (OccName sp1 s1) (OccName sp2 s2) + = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) + +instance Data OccName where + -- don't traverse? + toConstr _ = abstractConstr "OccName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "OccName" + +instance HasOccName OccName where + occName = id + +instance NFData OccName where + rnf x = x `seq` () + +{- +************************************************************************ +* * +\subsection{Printing} +* * +************************************************************************ +-} + +instance Outputable OccName where + ppr = pprOccName + +instance OutputableBndr OccName where + pprBndr _ = ppr + pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) + pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) + +pprOccName :: OccName -> SDoc +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS occ) + else pp_occ <> pp_debug sty + where + pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) + | otherwise = empty + + pp_occ = sdocOption sdocSuppressUniques $ \case + True -> text (strip_th_unique (unpackFS occ)) + False -> ftext occ + + -- See Note [Suppressing uniques in OccNames] + strip_th_unique ('[' : c : _) | isAlphaNum c = [] + strip_th_unique (c : cs) = c : strip_th_unique cs + strip_th_unique [] = [] + +{- +Note [Suppressing uniques in OccNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is a hack to de-wobblify the OccNames that contain uniques from +Template Haskell that have been turned into a string in the OccName. +See Note [Unique OccNames from Template Haskell] in Convert.hs + +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +mkOccName :: NameSpace -> String -> OccName +mkOccName occ_sp str = OccName occ_sp (mkFastString str) + +mkOccNameFS :: NameSpace -> FastString -> OccName +mkOccNameFS occ_sp fs = OccName occ_sp fs + +mkVarOcc :: String -> OccName +mkVarOcc s = mkOccName varName s + +mkVarOccFS :: FastString -> OccName +mkVarOccFS fs = mkOccNameFS varName fs + +mkDataOcc :: String -> OccName +mkDataOcc = mkOccName dataName + +mkDataOccFS :: FastString -> OccName +mkDataOccFS = mkOccNameFS dataName + +mkTyVarOcc :: String -> OccName +mkTyVarOcc = mkOccName tvName + +mkTyVarOccFS :: FastString -> OccName +mkTyVarOccFS fs = mkOccNameFS tvName fs + +mkTcOcc :: String -> OccName +mkTcOcc = mkOccName tcName + +mkTcOccFS :: FastString -> OccName +mkTcOccFS = mkOccNameFS tcName + +mkClsOcc :: String -> OccName +mkClsOcc = mkOccName clsName + +mkClsOccFS :: FastString -> OccName +mkClsOccFS = mkOccNameFS clsName + +-- demoteOccName lowers the Namespace of OccName. +-- see Note [Demotion] +demoteOccName :: OccName -> Maybe OccName +demoteOccName (OccName space name) = do + space' <- demoteNameSpace space + return $ OccName space' name + +-- Name spaces are related if there is a chance to mean the one when one writes +-- the other, i.e. variables <-> data constructors and type variables <-> type constructors +nameSpacesRelated :: NameSpace -> NameSpace -> Bool +nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 + +otherNameSpace :: NameSpace -> NameSpace +otherNameSpace VarName = DataName +otherNameSpace DataName = VarName +otherNameSpace TvName = TcClsName +otherNameSpace TcClsName = TvName + + + +{- | Other names in the compiler add additional information to an OccName. +This class provides a consistent way to access the underlying OccName. -} +class HasOccName name where + occName :: name -> OccName + +{- +************************************************************************ +* * + Environments +* * +************************************************************************ + +OccEnvs are used mainly for the envts in ModIfaces. + +Note [The Unique of an OccName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +They are efficient, because FastStrings have unique Int# keys. We assume +this key is less than 2^24, and indeed FastStrings are allocated keys +sequentially starting at 0. + +So we can make a Unique using + mkUnique ns key :: Unique +where 'ns' is a Char representing the name space. This in turn makes it +easy to build an OccEnv. +-} + +instance Uniquable OccName where + -- See Note [The Unique of an OccName] + getUnique (OccName VarName fs) = mkVarOccUnique fs + getUnique (OccName DataName fs) = mkDataOccUnique fs + getUnique (OccName TvName fs) = mkTvOccUnique fs + getUnique (OccName TcClsName fs) = mkTcOccUnique fs + +newtype OccEnv a = A (UniqFM a) + deriving Data + +emptyOccEnv :: OccEnv a +unitOccEnv :: OccName -> a -> OccEnv a +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +mkOccEnv :: [(OccName,a)] -> OccEnv a +mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a +elemOccEnv :: OccName -> OccEnv a -> Bool +foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +occEnvElts :: OccEnv a -> [a] +extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b +delFromOccEnv :: OccEnv a -> OccName -> OccEnv a +delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a +filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt +alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt + +emptyOccEnv = A emptyUFM +unitOccEnv x y = A $ unitUFM x y +extendOccEnv (A x) y z = A $ addToUFM x y z +extendOccEnvList (A x) l = A $ addListToUFM x l +lookupOccEnv (A x) y = lookupUFM x y +mkOccEnv l = A $ listToUFM l +elemOccEnv x (A y) = elemUFM x y +foldOccEnv a b (A c) = foldUFM a b c +occEnvElts (A x) = eltsUFM x +plusOccEnv (A x) (A y) = A $ plusUFM x y +plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y +extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z +mapOccEnv f (A x) = A $ mapUFM f x +mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l +delFromOccEnv (A x) y = A $ delFromUFM x y +delListFromOccEnv (A x) y = A $ delListFromUFM x y +filterOccEnv x (A y) = A $ filterUFM x y +alterOccEnv fn (A y) k = A $ alterUFM fn y k + +instance Outputable a => Outputable (OccEnv a) where + ppr x = pprOccEnv ppr x + +pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc +pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env + +type OccSet = UniqSet OccName + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +minusOccSet :: OccSet -> OccSet -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +isEmptyOccSet :: OccSet -> Bool +intersectOccSet :: OccSet -> OccSet -> OccSet +intersectsOccSet :: OccSet -> OccSet -> Bool +filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet + +emptyOccSet = emptyUniqSet +unitOccSet = unitUniqSet +mkOccSet = mkUniqSet +extendOccSet = addOneToUniqSet +extendOccSetList = addListToUniqSet +unionOccSets = unionUniqSets +unionManyOccSets = unionManyUniqSets +minusOccSet = minusUniqSet +elemOccSet = elementOfUniqSet +isEmptyOccSet = isEmptyUniqSet +intersectOccSet = intersectUniqSets +intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) +filterOccSet = filterUniqSet + +{- +************************************************************************ +* * +\subsection{Predicates and taking them apart} +* * +************************************************************************ +-} + +occNameString :: OccName -> String +occNameString (OccName _ s) = unpackFS s + +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ + +isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc _ = False + +isTvOcc (OccName TvName _) = True +isTvOcc _ = False + +isTcOcc (OccName TcClsName _) = True +isTcOcc _ = False + +-- | /Value/ 'OccNames's are those that are either in +-- the variable or data constructor namespaces +isValOcc :: OccName -> Bool +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc _ = False + +isDataOcc (OccName DataName _) = True +isDataOcc _ = False + +-- | Test if the 'OccName' is a data constructor that starts with +-- a symbol (e.g. @:@, or @[]@) +isDataSymOcc :: OccName -> Bool +isDataSymOcc (OccName DataName s) = isLexConSym s +isDataSymOcc _ = False +-- Pretty inefficient! + +-- | Test if the 'OccName' is that for any operator (whether +-- it is a data constructor or variable or whatever) +isSymOcc :: OccName -> Bool +isSymOcc (OccName DataName s) = isLexConSym s +isSymOcc (OccName TcClsName s) = isLexSym s +isSymOcc (OccName VarName s) = isLexSym s +isSymOcc (OccName TvName s) = isLexSym s +-- Pretty inefficient! + +parenSymOcc :: OccName -> SDoc -> SDoc +-- ^ Wrap parens around an operator +parenSymOcc occ doc | isSymOcc occ = parens doc + | otherwise = doc + +startsWithUnderscore :: OccName -> Bool +-- ^ Haskell 98 encourages compilers to suppress warnings about unused +-- names in a pattern if they start with @_@: this implements that test +startsWithUnderscore occ = headFS (occNameFS occ) == '_' + +{- +************************************************************************ +* * +\subsection{Making system names} +* * +************************************************************************ + +Here's our convention for splitting up the interface file name space: + + d... dictionary identifiers + (local variables, so no name-clash worries) + +All of these other OccNames contain a mixture of alphabetic +and symbolic characters, and hence cannot possibly clash with +a user-written type or function name + + $f... Dict-fun identifiers (from inst decls) + $dmop Default method for 'op' + $pnC n'th superclass selector for class C + $wf Worker for function 'f' + $sf.. Specialised version of f + D:C Data constructor for dictionary for class C + NTCo:T Coercion connecting newtype T with its representation type + TFCo:R Coercion connecting a data family to its representation type R + +In encoded form these appear as Zdfxxx etc + + :... keywords (export:, letrec: etc.) +--- I THINK THIS IS WRONG! + +This knowledge is encoded in the following functions. + +@mk_deriv@ generates an @OccName@ from the prefix and a string. +NB: The string must already be encoded! +-} + +-- | Build an 'OccName' derived from another 'OccName'. +-- +-- Note that the pieces of the name are passed in as a @[FastString]@ so that +-- the whole name can be constructed with a single 'concatFS', minimizing +-- unnecessary intermediate allocations. +mk_deriv :: NameSpace + -> FastString -- ^ A prefix which distinguishes one sort of + -- derived name from another + -> [FastString] -- ^ The name we are deriving from in pieces which + -- will be concatenated. + -> OccName +mk_deriv occ_sp sys_prefix str = + mkOccNameFS occ_sp (concatFS $ sys_prefix : str) + +isDerivedOccName :: OccName -> Bool +-- ^ Test for definitions internally generated by GHC. This predicate +-- is used to suppress printing of internal definitions in some debug prints +isDerivedOccName occ = + case occNameString occ of + '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo + c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions + _other -> False + +isDefaultMethodOcc :: OccName -> Bool +isDefaultMethodOcc occ = + case occNameString occ of + '$':'d':'m':_ -> True + _ -> False + +-- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? +-- This is needed as these bindings are renamed differently. +-- See Note [Grand plan for Typeable] in TcTypeable. +isTypeableBindOcc :: OccName -> Bool +isTypeableBindOcc occ = + case occNameString occ of + '$':'t':'c':_ -> True -- mkTyConRepOcc + '$':'t':'r':_ -> True -- Module binding + _ -> False + +mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, + mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataConWorkerOcc, mkNewTyCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkTyConRepOcc + :: OccName -> OccName + +-- These derived variables have a prefix that no Haskell value could have +mkDataConWrapperOcc = mk_simple_deriv varName "$W" +mkWorkerOcc = mk_simple_deriv varName "$w" +mkMatcherOcc = mk_simple_deriv varName "$m" +mkBuilderOcc = mk_simple_deriv varName "$b" +mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkClassOpAuxOcc = mk_simple_deriv varName "$c" +mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" +mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible +mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class +mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes +mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions +mkEqPredCoOcc = mk_simple_deriv tcName "$co" + +-- Used in derived instances +mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" +mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" +mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" + +-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable +mkTyConRepOcc occ = mk_simple_deriv varName prefix occ + where + prefix | isDataOcc occ = "$tc'" + | otherwise = "$tc" + +-- Generic deriving mechanism +mkGenR = mk_simple_deriv tcName "Rep_" +mkGen1R = mk_simple_deriv tcName "Rep1_" + +-- Overloaded record field selectors +mkRecFldSelOcc :: String -> OccName +mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] + +mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName +mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] + +-- Data constructor workers are made by setting the name space +-- of the data constructor OccName (which should be a DataName) +-- to VarName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ + +mkSuperDictAuxOcc :: Int -> OccName -> OccName +mkSuperDictAuxOcc index cls_tc_occ + = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] + +mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 + -> OccName -- ^ Class, e.g. @Ord@ + -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ +mkSuperDictSelOcc index cls_tc_occ + = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] + +mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' + -> OccName -- ^ Local name, e.g. @sat@ + -> OccName -- ^ Nice unique version, e.g. @$L23sat@ +mkLocalOcc uniq occ + = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] + -- The Unique might print with characters + -- that need encoding (e.g. 'z'!) + +-- | Derive a name for the representation type constructor of a +-- @data@\/@newtype@ instance. +mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ @R:Map@ +mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) + +mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. + -- Only used in debug mode, for extra clarity + -> Bool -- ^ Is this a hs-boot instance DFun? + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ E.g. @$f3OrdMaybe@ + +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot set + = chooseUniqueOcc VarName (prefix ++ info_str) set + where + prefix | is_boot = "$fx" + | otherwise = "$f" + +mkDataTOcc, mkDataCOcc + :: OccName -- ^ TyCon or data con string + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ E.g. @$f3OrdMaybe@ +-- data T = MkT ... deriving( Data ) needs definitions for +-- $tT :: Data.Generics.Basics.DataType +-- $cMkT :: Data.Generics.Basics.Constr +mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ) +mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ) + +{- +Sometimes we need to pick an OccName that has not already been used, +given a set of in-use OccNames. +-} + +chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName +chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) + where + loop occ n + | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) + | otherwise = occ + +{- +We used to add a '$m' to indicate a method, but that gives rise to bad +error messages from the type checker when we print the function name or pattern +of an instance-decl binding. Why? Because the binding is zapped +to use the method name in place of the selector name. +(See TcClassDcl.tcMethodBind) + +The way it is now, -ddump-xx output may look confusing, but +you can always say -dppr-debug to get the uniques. + +However, we *do* have to zap the first character to be lower case, +because overloaded constructors (blarg) generate methods too. +And convert to VarName space + +e.g. a call to constructor MkFoo where + data (Ord a) => Foo a = MkFoo a + +If this is necessary, we do it by prefixing '$m'. These +guys never show up in error messages. What a hack. +-} + +mkMethodOcc :: OccName -> OccName +mkMethodOcc occ@(OccName VarName _) = occ +mkMethodOcc occ = mk_simple_deriv varName "$m" occ + +{- +************************************************************************ +* * +\subsection{Tidying them up} +* * +************************************************************************ + +Before we print chunks of code we like to rename it so that +we don't have to print lots of silly uniques in it. But we mustn't +accidentally introduce name clashes! So the idea is that we leave the +OccName alone unless it accidentally clashes with one that is already +in scope; if so, we tack on '1' at the end and try again, then '2', and +so on till we find a unique one. + +There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' +because that isn't a single lexeme. So we encode it to 'lle' and *then* +tack on the '1', if necessary. + +Note [TidyOccEnv] +~~~~~~~~~~~~~~~~~ +type TidyOccEnv = UniqFM Int + +* Domain = The OccName's FastString. These FastStrings are "taken"; + make sure that we don't re-use + +* Int, n = A plausible starting point for new guesses + There is no guarantee that "FSn" is available; + you must look that up in the TidyOccEnv. But + it's a good place to start looking. + +* When looking for a renaming for "foo2" we strip off the "2" and start + with "foo". Otherwise if we tidy twice we get silly names like foo23. + + However, if it started with digits at the end, we always make a name + with digits at the end, rather than shortening "foo2" to just "foo", + even if "foo" is unused. Reasons: + - Plain "foo" might be used later + - We use trailing digits to subtly indicate a unification variable + in typechecker error message; see TypeRep.tidyTyVarBndr + +We have to take care though! Consider a machine-generated module (#10370) + module Foo where + a1 = e1 + a2 = e2 + ... + a2000 = e2000 +Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, +we have to do a linear search to find a free one, "a2001". That might just be +acceptable once. But if we now come across "a8" again, we don't want to repeat +that search. + +So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for +starting the search; and we make sure to update the starting point for "a" +after we allocate a new one. + + +Note [Tidying multiple names at once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider + + > :t (id,id,id) + +Every id contributes a type variable to the type signature, and all of them are +"a". If we tidy them one by one, we get + + (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) + +which is a bit unfortunate, as it unfairly renames only two of them. What we +would like to see is + + (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) + +To achieve this, the function avoidClashesOccEnv can be used to prepare the +TidyEnv, by “blocking” every name that occurs twice in the map. This way, none +of the "a"s will get the privilege of keeping this name, and all of them will +get a suitable number by tidyOccName. + +This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs +for an example where this is used. + +This is #12382. + +-} + +type TidyOccEnv = UniqFM Int -- The in-scope OccNames + -- See Note [TidyOccEnv] + +emptyTidyOccEnv :: TidyOccEnv +emptyTidyOccEnv = emptyUFM + +initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! +initTidyOccEnv = foldl' add emptyUFM + where + add env (OccName _ fs) = addToUFM env fs 1 + +delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv +delTidyOccEnvList = delListFromUFM + +-- see Note [Tidying multiple names at once] +avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv +avoidClashesOccEnv env occs = go env emptyUFM occs + where + go env _ [] = env + go env seenOnce ((OccName _ fs):occs) + | fs `elemUFM` env = go env seenOnce occs + | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs + | otherwise = go env (addToUFM seenOnce fs ()) occs + +tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) +tidyOccName env occ@(OccName occ_sp fs) + | not (fs `elemUFM` env) + = -- Desired OccName is free, so use it, + -- and record in 'env' that it's no longer available + (addToUFM env fs 1, occ) + + | otherwise + = case lookupUFM env base1 of + Nothing -> (addToUFM env base1 2, OccName occ_sp base1) + Just n -> find 1 n + where + base :: String -- Drop trailing digits (see Note [TidyOccEnv]) + base = dropWhileEndLE isDigit (unpackFS fs) + base1 = mkFastString (base ++ "1") + + find !k !n + = case lookupUFM env new_fs of + Just {} -> find (k+1 :: Int) (n+k) + -- By using n+k, the n argument to find goes + -- 1, add 1, add 2, add 3, etc which + -- moves at quadratic speed through a dense patch + + Nothing -> (new_env, OccName occ_sp new_fs) + where + new_fs = mkFastString (base ++ show n) + new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) + -- Update: base1, so that next time we'll start where we left off + -- new_fs, so that we know it is taken + -- If they are the same (n==1), the former wins + -- See Note [TidyOccEnv] + + +{- +************************************************************************ +* * + Binary instance + Here rather than in GHC.Iface.Binary because OccName is abstract +* * +************************************************************************ +-} + +instance Binary NameSpace where + put_ bh VarName = do + putByte bh 0 + put_ bh DataName = do + putByte bh 1 + put_ bh TvName = do + putByte bh 2 + put_ bh TcClsName = do + putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> do return VarName + 1 -> do return DataName + 2 -> do return TvName + _ -> do return TcClsName + +instance Binary OccName where + put_ bh (OccName aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (OccName aa ab) diff --git a/compiler/GHC/Types/Name/Occurrence.hs-boot b/compiler/GHC/Types/Name/Occurrence.hs-boot new file mode 100644 index 0000000000..212b58b8e6 --- /dev/null +++ b/compiler/GHC/Types/Name/Occurrence.hs-boot @@ -0,0 +1,5 @@ +module GHC.Types.Name.Occurrence where + +import GhcPrelude () + +data OccName diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs new file mode 100644 index 0000000000..d183979372 --- /dev/null +++ b/compiler/GHC/Types/Name/Reader.hs @@ -0,0 +1,1387 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName' is the type of names that come directly from the parser. They +-- have not yet had their scoping and binding resolved by the renamer and can be +-- thought of to a first approximation as an 'OccName.OccName' with an optional module +-- qualifier +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" + +module GHC.Types.Name.Reader ( + -- * The main type + RdrName(..), -- Constructors exported only to GHC.Iface.Binary + + -- ** Construction + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, + + -- ** Destruction + rdrNameOcc, rdrNameSpace, demoteRdrName, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + + -- * Local mapping of 'RdrName' to 'Name.Name' + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, + lookupLocalRdrEnv, lookupLocalRdrOcc, + elemLocalRdrEnv, inLocalRdrEnvScope, + localRdrEnvElts, delLocalRdrEnvList, + + -- * Global mapping of 'RdrName' to 'GlobalRdrElt's + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, + pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, + lookupGRE_Name_OccName, + getGRE_NameQualifier_maybes, + transformGREs, pickGREs, pickGREsModExp, + + -- * GlobalRdrElts + gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, + greRdrNames, greSrcSpan, greQualModName, + gresToAvailInfo, + + -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' + GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel, + unQualOK, qualSpecOK, unQualSpecOK, + pprNameProvenance, + Parent(..), greParent_maybe, + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule, isExplicitItem, bestImport, + + -- * Utils for StarIsType + starInfo + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Avail +import GHC.Types.Name.Set +import Maybes +import GHC.Types.SrcLoc as SrcLoc +import FastString +import GHC.Types.FieldLabel +import Outputable +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import Util +import GHC.Types.Name.Env + +import Data.Data +import Data.List( sortBy ) + +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Reader Name +-- +-- Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', +-- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, +-- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, +-- 'ApiAnnotation.AnnBackquote' @'`'@, +-- 'ApiAnnotation.AnnVal' +-- 'ApiAnnotation.AnnTilde', + +-- For details on above see note [Api annotations] in ApiAnnotation +data RdrName + = Unqual OccName + -- ^ Unqualified name + -- + -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ Qualified name + -- + -- A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ Original name + -- + -- An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ Exact name + -- + -- We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving Data + +{- +************************************************************************ +* * +\subsection{Simple functions} +* * +************************************************************************ +-} + +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +rdrNameSpace :: RdrName -> NameSpace +rdrNameSpace = occNameSpace . rdrNameOcc + +-- demoteRdrName lowers the NameSpace of RdrName. +-- see Note [Demotion] in GHC.Types.Name.Occurrence +demoteRdrName :: RdrName -> Maybe RdrName +demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) +demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) +demoteRdrName (Orig _ _) = panic "demoteRdrName" +demoteRdrName (Exact _) = panic "demoteRdrName" + + -- These two are the basic constructors +mkRdrUnqual :: OccName -> RdrName +mkRdrUnqual occ = Unqual occ + +mkRdrQual :: ModuleName -> OccName -> RdrName +mkRdrQual mod occ = Qual mod occ + +mkOrig :: Module -> OccName -> RdrName +mkOrig mod occ = Orig mod occ + +--------------- + -- These two are used when parsing source files + -- They do encode the module and occurrence names +mkUnqual :: NameSpace -> FastString -> RdrName +mkUnqual sp n = Unqual (mkOccNameFS sp n) + +mkVarUnqual :: FastString -> RdrName +mkVarUnqual n = Unqual (mkVarOccFS n) + +-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and +-- the 'OccName' are taken from the first and second elements of the tuple respectively +mkQual :: NameSpace -> (FastString, FastString) -> RdrName +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) + +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = nameRdrName (getName name) + +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) + +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + +isRdrDataCon :: RdrName -> Bool +isRdrTyVar :: RdrName -> Bool +isRdrTc :: RdrName -> Bool + +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) + +isSrcRdrName :: RdrName -> Bool +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + +isUnqual :: RdrName -> Bool +isUnqual (Unqual _) = True +isUnqual _ = False + +isQual :: RdrName -> Bool +isQual (Qual _ _) = True +isQual _ = False + +isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) +isQual_maybe (Qual m n) = Just (m,n) +isQual_maybe _ = Nothing + +isOrig :: RdrName -> Bool +isOrig (Orig _ _) = True +isOrig _ = False + +isOrig_maybe :: RdrName -> Maybe (Module, OccName) +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + +isExact :: RdrName -> Bool +isExact (Exact _) = True +isExact _ = False + +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig _ _) _ = GT + +{- +************************************************************************ +* * + LocalRdrEnv +* * +************************************************************************ +-} + +-- | Local Reader Environment +-- +-- This environment is used to store local bindings +-- (@let@, @where@, lambda, @case@). +-- It is keyed by OccName, because we never use it for qualified names +-- We keep the current mapping, *and* the set of all Names in scope +-- Reason: see Note [Splicing Exact names] in GHC.Rename.Env +data LocalRdrEnv = LRE { lre_env :: OccEnv Name + , lre_in_scope :: NameSet } + +instance Outputable LocalRdrEnv where + ppr (LRE {lre_env = env, lre_in_scope = ns}) + = hang (text "LocalRdrEnv {") + 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env + , text "in_scope =" + <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) + ] <+> char '}') + where + ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name + -- So we can see if the keys line up correctly + +emptyLocalRdrEnv :: LocalRdrEnv +emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv + , lre_in_scope = emptyNameSet } + +extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv +-- The Name should be a non-top-level thing +extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name + = WARN( isExternalName name, ppr name ) + lre { lre_env = extendOccEnv env (nameOccName name) name + , lre_in_scope = extendNameSet ns name } + +extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names + = WARN( any isExternalName names, ppr names ) + lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] + , lre_in_scope = extendNameSetList ns names } + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr + | Unqual occ <- rdr + = lookupOccEnv env occ + + -- See Note [Local bindings with Exact Names] + | Exact name <- rdr + , name `elemNameSet` ns + = Just name + + | otherwise + = Nothing + +lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name +lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) + = case rdr_name of + Unqual occ -> occ `elemOccEnv` env + Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Qual {} -> False + Orig {} -> False + +localRdrEnvElts :: LocalRdrEnv -> [Name] +localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env + +inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool +-- This is the point of the NameSet +inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns + +delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv +delLocalRdrEnvList lre@(LRE { lre_env = env }) occs + = lre { lre_env = delListFromOccEnv env occs } + +{- +Note [Local bindings with Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Template Haskell we can make local bindings that have Exact Names. +Computing shadowing etc may use elemLocalRdrEnv (at least it certainly +does so in GHC.Rename.Types.bindHsQTyVars), so for an Exact Name we must consult +the in-scope-name-set. + + +************************************************************************ +* * + GlobalRdrEnv +* * +************************************************************************ +-} + +-- | Global Reader Environment +type GlobalRdrEnv = OccEnv [GlobalRdrElt] +-- ^ Keyed by 'OccName'; when looking up a qualified name +-- we look up the 'OccName' part, and then check the 'Provenance' +-- to see if the appropriate qualification is valid. This +-- saves routinely doubling the size of the env by adding both +-- qualified and unqualified names to the domain. +-- +-- The list in the codomain is required because there may be name clashes +-- These only get reported on lookup, not on construction +-- +-- INVARIANT 1: All the members of the list have distinct +-- 'gre_name' fields; that is, no duplicate Names +-- +-- INVARIANT 2: Imported provenance => Name is an ExternalName +-- However LocalDefs can have an InternalName. This +-- happens only when type-checking a [d| ... |] Template +-- Haskell quotation; see this note in GHC.Rename.Names +-- Note [Top-level Names in Template Haskell decl quotes] +-- +-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then +-- greOccName gre = occ +-- +-- NB: greOccName gre is usually the same as +-- nameOccName (gre_name gre), but not always in the +-- case of record selectors; see greOccName + +-- | Global Reader Element +-- +-- An element of the 'GlobalRdrEnv' +data GlobalRdrElt + = GRE { gre_name :: Name + , gre_par :: Parent + , gre_lcl :: Bool -- ^ True <=> the thing was defined locally + , gre_imp :: [ImportSpec] -- ^ In scope through these imports + } deriving (Data, Eq) + -- INVARIANT: either gre_lcl = True or gre_imp is non-empty + -- See Note [GlobalRdrElt provenance] + +-- | The children of a Name are the things that are abbreviated by the ".." +-- notation in export lists. See Note [Parents] +data Parent = NoParent + | ParentIs { par_is :: Name } + | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } + -- ^ See Note [Parents for record fields] + deriving (Eq, Data) + +instance Outputable Parent where + ppr NoParent = empty + ppr (ParentIs n) = text "parent:" <> ppr n + ppr (FldParent n f) = text "fldparent:" + <> ppr n <> colon <> ppr f + +plusParent :: Parent -> Parent -> Parent +-- See Note [Combining parents] +plusParent p1@(ParentIs _) p2 = hasParent p1 p2 +plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 +plusParent p1 p2@(ParentIs _) = hasParent p2 p1 +plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 +plusParent _ _ = NoParent + +hasParent :: Parent -> Parent -> Parent +#if defined(DEBUG) +hasParent p NoParent = p +hasParent p p' + | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree +#endif +hasParent p _ = p + + +{- Note [GlobalRdrElt provenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", +i.e. how the Name came to be in scope. It can be in scope two ways: + - gre_lcl = True: it is bound in this module + - gre_imp: a list of all the imports that brought it into scope + +It's an INVARIANT that you have one or the other; that is, either +gre_lcl is True, or gre_imp is non-empty. + +It is just possible to have *both* if there is a module loop: a Name +is defined locally in A, and also brought into scope by importing a +module that SOURCE-imported A. Example (#7672): + + A.hs-boot module A where + data T + + B.hs module B(Decl.T) where + import {-# SOURCE #-} qualified A as Decl + + A.hs module A where + import qualified B + data T = Z | S B.T + +In A.hs, 'T' is locally bound, *and* imported as B.T. + +Note [Parents] +~~~~~~~~~~~~~~~~~ + Parent Children +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + data T Data constructors + Record-field ids + + data family T Data constructors and record-field ids + of all visible data instances of T + + class C Class operations + Associated type constructors + +~~~~~~~~~~~~~~~~~~~~~~~~~ + Constructor Meaning + ~~~~~~~~~~~~~~~~~~~~~~~~ + NoParent Can not be bundled with a type constructor. + ParentIs n Can be bundled with the type constructor corresponding to + n. + FldParent See Note [Parents for record fields] + + + + +Note [Parents for record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record fields, in addition to the Name of the type constructor +(stored in par_is), we use FldParent to store the field label. This +extra information is used for identifying overloaded record fields +during renaming. + +In a definition arising from a normal module (without +-XDuplicateRecordFields), par_lbl will be Nothing, meaning that the +field's label is the same as the OccName of the selector's Name. The +GlobalRdrEnv will contain an entry like this: + + "x" |-> GRE x (FldParent T Nothing) LocalDef + +When -XDuplicateRecordFields is enabled for the module that contains +T, the selector's Name will be mangled (see comments in GHC.Types.FieldLabel). +Thus we store the actual field label in par_lbl, and the GlobalRdrEnv +entry looks like this: + + "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef + +Note that the OccName used when adding a GRE to the environment +(greOccName) now depends on the parent field: for FldParent it is the +field label, if present, rather than the selector name. + +~~ + +Record pattern synonym selectors are treated differently. Their parent +information is `NoParent` in the module in which they are defined. This is because +a pattern synonym `P` has no parent constructor either. + +However, if `f` is bundled with a type constructor `T` then whenever `f` is +imported the parent will use the `Parent` constructor so the parent of `f` is +now `T`. + + +Note [Combining parents] +~~~~~~~~~~~~~~~~~~~~~~~~ +With an associated type we might have + module M where + class C a where + data T a + op :: T a -> a + instance C Int where + data T Int = TInt + instance C Bool where + data T Bool = TBool + +Then: C is the parent of T + T is the parent of TInt and TBool +So: in an export list + C(..) is short for C( op, T ) + T(..) is short for T( TInt, TBool ) + +Module M exports everything, so its exports will be + AvailTC C [C,T,op] + AvailTC T [T,TInt,TBool] +On import we convert to GlobalRdrElt and then combine +those. For T that will mean we have + one GRE with Parent C + one GRE with NoParent +That's why plusParent picks the "best" case. +-} + +-- | make a 'GlobalRdrEnv' where all the elements point to the same +-- Provenance (useful for "hiding" imports, or imports with no details). +gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] +-- prov = Nothing => locally bound +-- Just spec => imported as described by spec +gresFromAvails prov avails + = concatMap (gresFromAvail (const prov)) avails + +localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] +-- Turn an Avail into a list of LocalDef GlobalRdrElts +localGREsFromAvail = gresFromAvail (const Nothing) + +gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] +gresFromAvail prov_fn avail + = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) + where + mk_gre n + = case prov_fn n of -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = True, gre_imp = [] } + Just is -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = False, gre_imp = [is] } + + mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded + , flSelector = n }) + = case prov_fn n of -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + , gre_lcl = True, gre_imp = [] } + Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + , gre_lcl = False, gre_imp = [is] } + where + mb_lbl | is_overloaded = Just lbl + | otherwise = Nothing + + +greQualModName :: GlobalRdrElt -> ModuleName +-- Get a suitable module qualifier for the GRE +-- (used in mkPrintUnqualified) +-- Prerecondition: the gre_name is always External +greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + | lcl, Just mod <- nameModule_maybe name = moduleName mod + | (is:_) <- iss = is_as (is_decl is) + | otherwise = pprPanic "greQualModName" (ppr gre) + +greRdrNames :: GlobalRdrElt -> [RdrName] +greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } + = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) + where + occ = greOccName gre + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ + +-- the SrcSpan that pprNameProvenance prints out depends on whether +-- the Name is defined locally or not: for a local definition the +-- definition site is used, otherwise the location of the import +-- declaration. We want to sort the export locations in +-- exportClashErr by this SrcSpan, we need to extract it: +greSrcSpan :: GlobalRdrElt -> SrcSpan +greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) + | lcl = nameSrcSpan name + | (is:_) <- iss = is_dloc (is_decl is) + | otherwise = pprPanic "greSrcSpan" (ppr gre) + +mkParent :: Name -> AvailInfo -> Parent +mkParent _ (Avail _) = NoParent +mkParent n (AvailTC m _ _) | n == m = NoParent + | otherwise = ParentIs m + +greParent_maybe :: GlobalRdrElt -> Maybe Name +greParent_maybe gre = case gre_par gre of + NoParent -> Nothing + ParentIs n -> Just n + FldParent n _ -> Just n + +-- | Takes a list of distinct GREs and folds them +-- into AvailInfos. This is more efficient than mapping each individual +-- GRE to an AvailInfo and the folding using `plusAvail` but needs the +-- uniqueness assumption. +gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] +gresToAvailInfo gres + = nameEnvElts avail_env + where + avail_env :: NameEnv AvailInfo -- Keyed by the parent + (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres + + add :: (NameEnv AvailInfo, NameSet) + -> GlobalRdrElt + -> (NameEnv AvailInfo, NameSet) + add (env, done) gre + | name `elemNameSet` done + = (env, done) -- Don't insert twice into the AvailInfo + | otherwise + = ( extendNameEnv_Acc comb availFromGRE env key gre + , done `extendNameSet` name ) + where + name = gre_name gre + key = case greParent_maybe gre of + Just parent -> parent + Nothing -> gre_name gre + + -- We want to insert the child `k` into a list of children but + -- need to maintain the invariant that the parent is first. + -- + -- We also use the invariant that `k` is not already in `ns`. + insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] + insertChildIntoChildren _ [] k = [k] + insertChildIntoChildren p (n:ns) k + | p == k = k:n:ns + | otherwise = n:k:ns + + comb :: GlobalRdrElt -> AvailInfo -> AvailInfo + comb _ (Avail n) = Avail n -- Duplicated name, should not happen + comb gre (AvailTC m ns fls) + = case gre_par gre of + NoParent -> AvailTC m (name:ns) fls -- Not sure this ever happens + ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls + FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls) + +availFromGRE :: GlobalRdrElt -> AvailInfo +availFromGRE (GRE { gre_name = me, gre_par = parent }) + = case parent of + ParentIs p -> AvailTC p [me] [] + NoParent | isTyConName me -> AvailTC me [me] [] + | otherwise -> avail me + FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] + +mkFieldLabel :: Name -> Maybe FastString -> FieldLabel +mkFieldLabel me mb_lbl = + case mb_lbl of + Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) + , flIsOverloaded = False + , flSelector = me } + Just lbl -> FieldLabel { flLabel = lbl + , flIsOverloaded = True + , flSelector = me } + +emptyGlobalRdrEnv :: GlobalRdrEnv +emptyGlobalRdrEnv = emptyOccEnv + +globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] +globalRdrEnvElts env = foldOccEnv (++) [] env + +instance Outputable GlobalRdrElt where + ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) + 2 (pprNameProvenance gre) + +pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc +pprGlobalRdrEnv locals_only env + = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) + <+> lbrace + , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] + <+> rbrace) ] + where + remove_locals gres | locals_only = filter isLocalGRE gres + | otherwise = gres + pp [] = empty + pp gres = hang (ppr occ + <+> parens (text "unique" <+> ppr (getUnique occ)) + <> colon) + 2 (vcat (map ppr gres)) + where + occ = nameOccName (gre_name (head gres)) + +lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] +lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of + Nothing -> [] + Just gres -> gres + +greOccName :: GlobalRdrElt -> OccName +greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl +greOccName gre = nameOccName (gre_name gre) + +lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] +lookupGRE_RdrName rdr_name env + = case lookupOccEnv env (rdrNameOcc rdr_name) of + Nothing -> [] + Just gres -> pickGREs rdr_name gres + +lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt +-- ^ Look for precisely this 'Name' in the environment. This tests +-- whether it is in scope, ignoring anything else that might be in +-- scope with the same 'OccName'. +lookupGRE_Name env name + = lookupGRE_Name_OccName env name (nameOccName name) + +lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt +-- ^ Look for a particular record field selector in the environment, where the +-- selector name and field label may be different: the GlobalRdrEnv is keyed on +-- the label. See Note [Parents for record fields] for why this happens. +lookupGRE_FieldLabel env fl + = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) + +lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt +-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' +-- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and +-- Note [Parents for record fields]. +lookupGRE_Name_OccName env name occ + = case [ gre | gre <- lookupGlobalRdrEnv env occ + , gre_name gre == name ] of + [] -> Nothing + [gre] -> Just gre + gres -> pprPanic "lookupGRE_Name_OccName" + (ppr name $$ ppr occ $$ ppr gres) + -- See INVARIANT 1 on GlobalRdrEnv + + +getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] +-- Returns all the qualifiers by which 'x' is in scope +-- Nothing means "the unqualified version is in scope" +-- [] means the thing is not in scope at all +getGRE_NameQualifier_maybes env name + = case lookupGRE_Name env name of + Just gre -> [qualifier_maybe gre] + Nothing -> [] + where + qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) + | lcl = Nothing + | otherwise = Just $ map (is_as . is_decl) iss + +isLocalGRE :: GlobalRdrElt -> Bool +isLocalGRE (GRE {gre_lcl = lcl }) = lcl + +isRecFldGRE :: GlobalRdrElt -> Bool +isRecFldGRE (GRE {gre_par = FldParent{}}) = True +isRecFldGRE _ = False + +-- Returns the field label of this GRE, if it has one +greLabel :: GlobalRdrElt -> Maybe FieldLabelString +greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl +greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) +greLabel _ = Nothing + +unQualOK :: GlobalRdrElt -> Bool +-- ^ Test if an unqualified version of this thing would be in scope +unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) + | lcl = True + | otherwise = any unQualSpecOK iss + +{- Note [GRE filtering] +~~~~~~~~~~~~~~~~~~~~~~~ +(pickGREs rdr gres) takes a list of GREs which have the same OccName +as 'rdr', say "x". It does two things: + +(a) filters the GREs to a subset that are in scope + * Qualified, as 'M.x' if want_qual is Qual M _ + * Unqualified, as 'x' if want_unqual is Unqual _ + +(b) for that subset, filter the provenance field (gre_lcl and gre_imp) + to ones that brought it into scope qualified or unqualified resp. + +Example: + module A ( f ) where + import qualified Foo( f ) + import Baz( f ) + f = undefined + +Let's suppose that Foo.f and Baz.f are the same entity really, but the local +'f' is different, so there will be two GREs matching "f": + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] + +The use of "f" in the export list is ambiguous because it's in scope +from the local def and the import Baz(f); but *not* the import qualified Foo. +pickGREs returns two GRE + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Bar ] + +Now the "ambiguous occurrence" message can correctly report how the +ambiguity arises. +-} + +pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] +-- ^ Takes a list of GREs which have the right OccName 'x' +-- Pick those GREs that are in scope +-- * Qualified, as 'M.x' if want_qual is Qual M _ +-- * Unqualified, as 'x' if want_unqual is Unqual _ +-- +-- Return each such GRE, with its ImportSpecs filtered, to reflect +-- how it is in scope qualified or unqualified respectively. +-- See Note [GRE filtering] +pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres +pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres +pickGREs _ _ = [] -- I don't think this actually happens + +pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt +pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | not lcl, null iss' = Nothing + | otherwise = Just (gre { gre_imp = iss' }) + where + iss' = filter unQualSpecOK iss + +pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt +pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) + | not lcl', null iss' = Nothing + | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) + where + iss' = filter (qualSpecOK mod) iss + lcl' = lcl && name_is_from mod n + + name_is_from :: ModuleName -> Name -> Bool + name_is_from mod name = case nameModule_maybe name of + Just n_mod -> moduleName n_mod == mod + Nothing -> False + +pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] +-- ^ Pick GREs that are in scope *both* qualified *and* unqualified +-- Return each GRE that is, as a pair +-- (qual_gre, unqual_gre) +-- These two GREs are the original GRE with imports filtered to express how +-- it is in scope qualified an unqualified respectively +-- +-- Used only for the 'module M' item in export list; +-- see GHC.Rename.Names.exports_from_avail +pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres + +pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) +pickBothGRE mod gre@(GRE { gre_name = n }) + | isBuiltInSyntax n = Nothing + | Just gre1 <- pickQualGRE mod gre + , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) + | otherwise = Nothing + where + -- isBuiltInSyntax filter out names for built-in syntax They + -- just clutter up the environment (esp tuples), and the + -- parser will generate Exact RdrNames for them, so the + -- cluttered envt is no use. Really, it's only useful for + -- GHC.Base and GHC.Tuple. + +-- Building GlobalRdrEnvs + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_Acc insertGRE singleton env + (greOccName gre) + gre + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | gre_name new_g == gre_name old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1 + , gre_lcl = gre_lcl g1 || gre_lcl g2 + , gre_imp = gre_imp g1 ++ gre_imp g2 + , gre_par = gre_par g1 `plusParent` gre_par g2 } + +transformGREs :: (GlobalRdrElt -> GlobalRdrElt) + -> [OccName] + -> GlobalRdrEnv -> GlobalRdrEnv +-- ^ Apply a transformation function to the GREs for these OccNames +transformGREs trans_gre occs rdr_env + = foldr trans rdr_env occs + where + trans occ env + = case lookupOccEnv env occ of + Just gres -> extendOccEnv env occ (map trans_gre gres) + Nothing -> env + +extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv +extendGlobalRdrEnv env gre + = extendOccEnv_Acc insertGRE singleton env + (greOccName gre) gre + +shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv +shadowNames = foldl' shadowName + +{- Note [GlobalRdrEnv shadowing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before adding new names to the GlobalRdrEnv we nuke some existing entries; +this is "shadowing". The actual work is done by RdrEnv.shadowName. +Suppose + env' = shadowName env M.f + +Then: + * Looking up (Unqual f) in env' should succeed, returning M.f, + even if env contains existing unqualified bindings for f. + They are shadowed + + * Looking up (Qual M.f) in env' should succeed, returning M.f + + * Looking up (Qual X.f) in env', where X /= M, should be the same as + looking up (Qual X.f) in env. + That is, shadowName does /not/ delete earlier qualified bindings + +There are two reasons for shadowing: + +* The GHCi REPL + + - Ids bought into scope on the command line (eg let x = True) have + External Names, like Ghci4.x. We want a new binding for 'x' (say) + to override the existing binding for 'x'. Example: + + ghci> :load M -- Brings `x` and `M.x` into scope + ghci> x + ghci> "Hello" + ghci> M.x + ghci> "hello" + ghci> let x = True -- Shadows `x` + ghci> x -- The locally bound `x` + -- NOT an ambiguous reference + ghci> True + ghci> M.x -- M.x is still in scope! + ghci> "Hello" + So when we add `x = True` we must not delete the `M.x` from the + `GlobalRdrEnv`; rather we just want to make it "qualified only"; + hence the `mk_fake-imp_spec` in `shadowName`. See also Note + [Interactively-bound Ids in GHCi] in GHC.Driver.Types + + - Data types also have External Names, like Ghci4.T; but we still want + 'T' to mean the newly-declared 'T', not an old one. + +* Nested Template Haskell declaration brackets + See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names + + Consider a TH decl quote: + module M where + f x = h [d| f = ...f...M.f... |] + We must shadow the outer unqualified binding of 'f', else we'll get + a complaint when extending the GlobalRdrEnv, saying that there are + two bindings for 'f'. There are several tricky points: + + - This shadowing applies even if the binding for 'f' is in a + where-clause, and hence is in the *local* RdrEnv not the *global* + RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. + + - The External Name M.f from the enclosing module must certainly + still be available. So we don't nuke it entirely; we just make + it seem like qualified import. + + - We only shadow *External* names (which come from the main module), + or from earlier GHCi commands. Do not shadow *Internal* names + because in the bracket + [d| class C a where f :: a + f = 4 |] + rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the + class decl, and *separately* extend the envt with the value binding. + At that stage, the class op 'f' will have an Internal name. +-} + +shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv +-- Remove certain old GREs that share the same OccName as this new Name. +-- See Note [GlobalRdrEnv shadowing] for details +shadowName env name + = alterOccEnv (fmap alter_fn) env (nameOccName name) + where + alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] + alter_fn gres = mapMaybe (shadow_with name) gres + + shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt + shadow_with new_name + old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) + = case nameModule_maybe old_name of + Nothing -> Just old_gre -- Old name is Internal; do not shadow + Just old_mod + | Just new_mod <- nameModule_maybe new_name + , new_mod == old_mod -- Old name same as new name; shadow completely + -> Nothing + + | null iss' -- Nothing remains + -> Nothing + + | otherwise + -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) + + where + iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss + lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] + | otherwise = [] + + mk_fake_imp_spec old_name old_mod -- Urgh! + = ImpSpec id_spec ImpAll + where + old_mod_name = moduleName old_mod + id_spec = ImpDeclSpec { is_mod = old_mod_name + , is_as = old_mod_name + , is_qual = True + , is_dloc = nameSrcSpan old_name } + + shadow_is :: Name -> ImportSpec -> Maybe ImportSpec + shadow_is new_name is@(ImpSpec { is_decl = id_spec }) + | Just new_mod <- nameModule_maybe new_name + , is_as id_spec == moduleName new_mod + = Nothing -- Shadow both qualified and unqualified + | otherwise -- Shadow unqualified only + = Just (is { is_decl = id_spec { is_qual = True } }) + + +{- +************************************************************************ +* * + ImportSpec +* * +************************************************************************ +-} + +-- | Import Specification +-- +-- The 'ImportSpec' of something says how it came to be imported +-- It's quite elaborate so that we can give accurate unused-name warnings. +data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, + is_item :: ImpItemSpec } + deriving( Eq, Data ) + +-- | Import Declaration Specification +-- +-- Describes a particular import declaration and is +-- shared among all the 'Provenance's for that decl +data ImpDeclSpec + = ImpDeclSpec { + is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ + -- Note the @Muggle@ may well not be + -- the defining module for this thing! + + -- TODO: either should be Module, or there + -- should be a Maybe UnitId here too. + is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: Bool, -- ^ Was this import qualified? + is_dloc :: SrcSpan -- ^ The location of the entire import declaration + } deriving (Eq, Data) + +-- | Import Item Specification +-- +-- Describes import info a particular Name +data ImpItemSpec + = ImpAll -- ^ The import had no import list, + -- or had a hiding list + + | ImpSome { + is_explicit :: Bool, + is_iloc :: SrcSpan -- Location of the import item + } -- ^ The import had an import list. + -- The 'is_explicit' field is @True@ iff the thing was named + -- /explicitly/ in the import specs rather + -- than being imported as part of a "..." group. Consider: + -- + -- > import C( T(..) ) + -- + -- Here the constructors of @T@ are not named explicitly; + -- only @T@ is named explicitly. + deriving (Eq, Data) + +bestImport :: [ImportSpec] -> ImportSpec +-- See Note [Choosing the best import declaration] +bestImport iss + = case sortBy best iss of + (is:_) -> is + [] -> pprPanic "bestImport" (ppr iss) + where + best :: ImportSpec -> ImportSpec -> Ordering + -- Less means better + -- Unqualified always wins over qualified; then + -- import-all wins over import-some; then + -- earlier declaration wins over later + best (ImpSpec { is_item = item1, is_decl = d1 }) + (ImpSpec { is_item = item2, is_decl = d2 }) + = (is_qual d1 `compare` is_qual d2) `thenCmp` + (best_item item1 item2) `thenCmp` + SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) + + best_item :: ImpItemSpec -> ImpItemSpec -> Ordering + best_item ImpAll ImpAll = EQ + best_item ImpAll (ImpSome {}) = LT + best_item (ImpSome {}) ImpAll = GT + best_item (ImpSome { is_explicit = e1 }) + (ImpSome { is_explicit = e2 }) = e1 `compare` e2 + -- False < True, so if e1 is explicit and e2 is not, we get GT + +{- Note [Choosing the best import declaration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reporting unused import declarations we use the following rules. + (see [wiki:commentary/compiler/unused-imports]) + +Say that an import-item is either + * an entire import-all decl (eg import Foo), or + * a particular item in an import list (eg import Foo( ..., x, ...)). +The general idea is that for each /occurrence/ of an imported name, we will +attribute that use to one import-item. Once we have processed all the +occurrences, any import items with no uses attributed to them are unused, +and are warned about. More precisely: + +1. For every RdrName in the program text, find its GlobalRdrElt. + +2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one + the "chosen import-item", and mark it "used". This is done + by 'bestImport' + +3. After processing all the RdrNames, bleat about any + import-items that are unused. + This is done in GHC.Rename.Names.warnUnusedImportDecls. + +The function 'bestImport' returns the dominant import among the +ImportSpecs it is given, implementing Step 2. We say import-item A +dominates import-item B if we choose A over B. In general, we try to +choose the import that is most likely to render other imports +unnecessary. Here is the dominance relationship we choose: + + a) import Foo dominates import qualified Foo. + + b) import Foo dominates import Foo(x). + + c) Otherwise choose the textually first one. + +Rationale for (a). Consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + x + +The unqualified 'x' can only come from import #2. The qualified 'M.x' +could come from either, but bestImport picks import #2, because it is +more likely to be useful in other imports, as indeed it is in this +case (see #5211 for a concrete example). + +But the rules are not perfect; consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + M.y + +The M.x will use import #2, but M.y can only use import #1. +-} + + +unQualSpecOK :: ImportSpec -> Bool +-- ^ Is in scope unqualified? +unQualSpecOK is = not (is_qual (is_decl is)) + +qualSpecOK :: ModuleName -> ImportSpec -> Bool +-- ^ Is in scope qualified with the given module? +qualSpecOK mod is = mod == is_as (is_decl is) + +importSpecLoc :: ImportSpec -> SrcSpan +importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl +importSpecLoc (ImpSpec _ item) = is_iloc item + +importSpecModule :: ImportSpec -> ModuleName +importSpecModule is = is_mod (is_decl is) + +isExplicitItem :: ImpItemSpec -> Bool +isExplicitItem ImpAll = False +isExplicitItem (ImpSome {is_explicit = exp}) = exp + +pprNameProvenance :: GlobalRdrElt -> SDoc +-- ^ Print out one place where the name was define/imported +-- (With -dppr-debug, print them all) +pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + = ifPprDebug (vcat pp_provs) + (head pp_provs) + where + pp_provs = pp_lcl ++ map pp_is iss + pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] + else [] + pp_is is = sep [ppr is, ppr_defn_site is name] + +-- If we know the exact definition point (which we may do with GHCi) +-- then show that too. But not if it's just "imported from X". +ppr_defn_site :: ImportSpec -> Name -> SDoc +ppr_defn_site imp_spec name + | same_module && not (isGoodSrcSpan loc) + = empty -- Nothing interesting to say + | otherwise + = parens $ hang (text "and originally defined" <+> pp_mod) + 2 (pprLoc loc) + where + loc = nameSrcSpan name + defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + same_module = importSpecModule imp_spec == moduleName defining_mod + pp_mod | same_module = empty + | otherwise = text "in" <+> quotes (ppr defining_mod) + + +instance Outputable ImportSpec where + ppr imp_spec + = text "imported" <+> qual + <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) + <+> pprLoc (importSpecLoc imp_spec) + where + qual | is_qual (is_decl imp_spec) = text "qualified" + | otherwise = empty + +pprLoc :: SrcSpan -> SDoc +pprLoc (RealSrcSpan s _) = text "at" <+> ppr s +pprLoc (UnhelpfulSpan {}) = empty + +-- | Display info about the treatment of '*' under NoStarIsType. +-- +-- With StarIsType, three properties of '*' hold: +-- +-- (a) it is not an infix operator +-- (b) it is always in scope +-- (c) it is a synonym for Data.Kind.Type +-- +-- However, the user might not know that he's working on a module with +-- NoStarIsType and write code that still assumes (a), (b), and (c), which +-- actually do not hold in that module. +-- +-- Violation of (a) shows up in the parser. For instance, in the following +-- examples, we have '*' not applied to enough arguments: +-- +-- data A :: * +-- data F :: * -> * +-- +-- Violation of (b) or (c) show up in the renamer and the typechecker +-- respectively. For instance: +-- +-- type K = Either * Bool +-- +-- This will parse differently depending on whether StarIsType is enabled, +-- but it will parse nonetheless. With NoStarIsType it is parsed as a type +-- operator, thus we have ((*) Either Bool). Now there are two cases to +-- consider: +-- +-- 1. There is no definition of (*) in scope. In this case the renamer will +-- fail to look it up. This is a violation of assumption (b). +-- +-- 2. There is a definition of the (*) type operator in scope (for example +-- coming from GHC.TypeNats). In this case the user will get a kind +-- mismatch error. This is a violation of assumption (c). +-- +-- The user might unknowingly be working on a module with NoStarIsType +-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a +-- hint whenever an assumption about '*' is violated. Unfortunately, it is +-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). +-- +-- 'starInfo' generates an appropriate hint to the user depending on the +-- extensions enabled in the module and the name that triggered the error. +-- That is, if we have NoStarIsType and the error is related to '*' or its +-- Unicode variant, the resulting SDoc will contain a helpful suggestion. +-- Otherwise it is empty. +-- +starInfo :: Bool -> RdrName -> SDoc +starInfo star_is_type rdr_name = + -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to + -- take star_is_type as input? Why not refactor? + -- + -- The reason is that `sdocOption sdocStarIsType` would indicate that + -- StarIsType is enabled in the module that tries to load the problematic + -- definition, not in the module that is being loaded. + -- + -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint + -- must be displayed even if we load this definition from a module (or GHCi) + -- with StarIsType enabled! + -- + if isUnqualStar && not star_is_type + then text "With NoStarIsType, " <> + quotes (ppr rdr_name) <> + text " is treated as a regular type operator. " + $$ + text "Did you mean to use " <> quotes (text "Type") <> + text " from Data.Kind instead?" + else empty + where + -- Does rdr_name look like the user might have meant the '*' kind by it? + -- We focus on unqualified stars specifically, because qualified stars are + -- treated as type operators even under StarIsType. + isUnqualStar + | Unqual occName <- rdr_name + = let fs = occNameFS occName + in fs == fsLit "*" || fs == fsLit "★" + | otherwise = False diff --git a/compiler/GHC/Types/Name/Set.hs b/compiler/GHC/Types/Name/Set.hs new file mode 100644 index 0000000000..04a8f1effa --- /dev/null +++ b/compiler/GHC/Types/Name/Set.hs @@ -0,0 +1,215 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +-} + +{-# LANGUAGE CPP #-} +module GHC.Types.Name.Set ( + -- * Names set type + NameSet, + + -- ** Manipulating these sets + emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, + minusNameSet, elemNameSet, extendNameSet, extendNameSetList, + delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, + intersectsNameSet, intersectNameSet, + nameSetAny, nameSetAll, nameSetElemsStable, + + -- * Free variables + FreeVars, + + -- ** Manipulating sets of free variables + isEmptyFVs, emptyFVs, plusFVs, plusFV, + mkFVs, addOneFV, unitFV, delFV, delFVs, + intersectFVs, + + -- * Defs and uses + Defs, Uses, DefUse, DefUses, + + -- ** Manipulating defs and uses + emptyDUs, usesOnly, mkDUs, plusDU, + findUses, duDefs, duUses, allUses + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Types.Name +import OrdList +import GHC.Types.Unique.Set +import Data.List (sortBy) + +{- +************************************************************************ +* * +\subsection[Sets of names} +* * +************************************************************************ +-} + +type NameSet = UniqSet Name + +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +extendNameSetList :: NameSet -> [Name] -> NameSet +extendNameSet :: NameSet -> Name -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSet :: NameSet -> NameSet -> NameSet +unionNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +isEmptyNameSet :: NameSet -> Bool +delFromNameSet :: NameSet -> Name -> NameSet +delListFromNameSet :: NameSet -> [Name] -> NameSet +filterNameSet :: (Name -> Bool) -> NameSet -> NameSet +intersectNameSet :: NameSet -> NameSet -> NameSet +intersectsNameSet :: NameSet -> NameSet -> Bool +-- ^ True if there is a non-empty intersection. +-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty + +isEmptyNameSet = isEmptyUniqSet +emptyNameSet = emptyUniqSet +unitNameSet = unitUniqSet +mkNameSet = mkUniqSet +extendNameSetList = addListToUniqSet +extendNameSet = addOneToUniqSet +unionNameSet = unionUniqSets +unionNameSets = unionManyUniqSets +minusNameSet = minusUniqSet +elemNameSet = elementOfUniqSet +delFromNameSet = delOneFromUniqSet +filterNameSet = filterUniqSet +intersectNameSet = intersectUniqSets + +delListFromNameSet set ns = foldl' delFromNameSet set ns + +intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) + +nameSetAny :: (Name -> Bool) -> NameSet -> Bool +nameSetAny = uniqSetAny + +nameSetAll :: (Name -> Bool) -> NameSet -> Bool +nameSetAll = uniqSetAll + +-- | Get the elements of a NameSet with some stable ordering. +-- This only works for Names that originate in the source code or have been +-- tidied. +-- See Note [Deterministic UniqFM] to learn about nondeterminism +nameSetElemsStable :: NameSet -> [Name] +nameSetElemsStable ns = + sortBy stableNameCmp $ nonDetEltsUniqSet ns + -- It's OK to use nonDetEltsUniqSet here because we immediately sort + -- with stableNameCmp + +{- +************************************************************************ +* * +\subsection{Free variables} +* * +************************************************************************ + +These synonyms are useful when we are thinking of free variables +-} + +type FreeVars = NameSet + +plusFV :: FreeVars -> FreeVars -> FreeVars +addOneFV :: FreeVars -> Name -> FreeVars +unitFV :: Name -> FreeVars +emptyFVs :: FreeVars +plusFVs :: [FreeVars] -> FreeVars +mkFVs :: [Name] -> FreeVars +delFV :: Name -> FreeVars -> FreeVars +delFVs :: [Name] -> FreeVars -> FreeVars +intersectFVs :: FreeVars -> FreeVars -> FreeVars + +isEmptyFVs :: NameSet -> Bool +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionNameSets +plusFV = unionNameSet +mkFVs = mkNameSet +addOneFV = extendNameSet +unitFV = unitNameSet +delFV n s = delFromNameSet s n +delFVs ns s = delListFromNameSet s ns +intersectFVs = intersectNameSet + +{- +************************************************************************ +* * + Defs and uses +* * +************************************************************************ +-} + +-- | A set of names that are defined somewhere +type Defs = NameSet + +-- | A set of names that are used somewhere +type Uses = NameSet + +-- | @(Just ds, us) =>@ The use of any member of the @ds@ +-- implies that all the @us@ are used too. +-- Also, @us@ may mention @ds@. +-- +-- @Nothing =>@ Nothing is defined in this group, but +-- nevertheless all the uses are essential. +-- Used for instance declarations, for example +type DefUse = (Maybe Defs, Uses) + +-- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' +-- In a single (def, use) pair, the defs also scope over the uses +type DefUses = OrdList DefUse + +emptyDUs :: DefUses +emptyDUs = nilOL + +usesOnly :: Uses -> DefUses +usesOnly uses = unitOL (Nothing, uses) + +mkDUs :: [(Defs,Uses)] -> DefUses +mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs] + +plusDU :: DefUses -> DefUses -> DefUses +plusDU = appOL + +duDefs :: DefUses -> Defs +duDefs dus = foldr get emptyNameSet dus + where + get (Nothing, _u1) d2 = d2 + get (Just d1, _u1) d2 = d1 `unionNameSet` d2 + +allUses :: DefUses -> Uses +-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned +allUses dus = foldr get emptyNameSet dus + where + get (_d1, u1) u2 = u1 `unionNameSet` u2 + +duUses :: DefUses -> Uses +-- ^ Collect all 'Uses', regardless of whether the group is itself used, +-- but remove 'Defs' on the way +duUses dus = foldr get emptyNameSet dus + where + get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) + `minusNameSet` defs + +findUses :: DefUses -> Uses -> Uses +-- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. +-- The result is a superset of the input 'Uses'; and includes things defined +-- in the input 'DefUses' (but only if they are used) +findUses dus uses + = foldr get uses dus + where + get (Nothing, rhs_uses) uses + = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses + | defs `intersectsNameSet` uses -- Used + || nameSetAny (startsWithUnderscore . nameOccName) defs + -- At least one starts with an "_", + -- so treat the group as used + = rhs_uses `unionNameSet` uses + | otherwise -- No def is used + = uses diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs index aa1879220f..39a25c1ad6 100644 --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} -module GHC.Types.Name.Shape( - NameShape(..), - emptyNameShape, - mkNameShape, - extendNameShape, - nameShapeExports, - substNameShape, - maybeSubstNameShape, - ) where +module GHC.Types.Name.Shape + ( NameShape(..) + , emptyNameShape + , mkNameShape + , extendNameShape + , nameShapeExports + , substNameShape + , maybeSubstNameShape + ) +where #include "HsVersions.h" @@ -16,13 +17,13 @@ import GhcPrelude import Outputable import GHC.Driver.Types -import Module -import UniqFM -import Avail -import FieldLabel +import GHC.Types.Module +import GHC.Types.Unique.FM +import GHC.Types.Avail +import GHC.Types.FieldLabel -import Name -import NameEnv +import GHC.Types.Name +import GHC.Types.Name.Env import TcRnMonad import Util import GHC.Iface.Env diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index 3a76dde256..645d2af7c8 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -25,7 +25,7 @@ module GHC.Types.RepType import GhcPrelude -import BasicTypes (Arity, RepArity) +import GHC.Types.Basic (Arity, RepArity) import GHC.Core.DataCon import Outputable import PrelNames diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs new file mode 100644 index 0000000000..0488d4d882 --- /dev/null +++ b/compiler/GHC/Types/SrcLoc.hs @@ -0,0 +1,741 @@ +-- (c) The University of Glasgow, 1992-2006 + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} + + +-- | This module contains types that relate to the positions of things +-- in source files, and allow tagging of those things with locations +module GHC.Types.SrcLoc ( + -- * SrcLoc + RealSrcLoc, -- Abstract + SrcLoc(..), + + -- ** Constructing SrcLoc + mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + + noSrcLoc, -- "I'm sorry, I haven't a clue" + generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session + + advanceSrcLoc, + advanceBufPos, + + -- ** Unsafely deconstructing SrcLoc + -- These are dubious exports, because they crash on some inputs + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part + + -- * SrcSpan + RealSrcSpan, -- Abstract + SrcSpan(..), + + -- ** Constructing SrcSpan + mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, + noSrcSpan, + wiredInSrcSpan, -- Something wired into the compiler + interactiveSrcSpan, + srcLocSpan, realSrcLocSpan, + combineSrcSpans, + srcSpanFirstCharacter, + + -- ** Deconstructing SrcSpan + srcSpanStart, srcSpanEnd, + realSrcSpanStart, realSrcSpanEnd, + srcSpanFileName_maybe, + pprUserRealSpan, + + -- ** Unsafely deconstructing SrcSpan + -- These are dubious exports, because they crash on some inputs + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Predicates on SrcSpan + isGoodSrcSpan, isOneLineSpan, + containsSpan, + + -- * StringBuffer locations + BufPos(..), + BufSpan(..), + + -- * Located + Located, + RealLocated, + GenLocated(..), + + -- ** Constructing Located + noLoc, + mkGeneralLocated, + + -- ** Deconstructing Located + getLoc, unLoc, + unRealSrcSpan, getRealSrcSpan, + + -- ** Modifying Located + mapLoc, + + -- ** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost_smallest, + spans, isSubspanOf, isRealSubspanOf, sortLocated, + sortRealLocated, + lookupSrcLoc, lookupSrcSpan, + + liftL, + + -- * Parser locations + PsLoc(..), + PsSpan(..), + PsLocated, + advancePsLoc, + mkPsSpan, + psSpanStart, + psSpanEnd, + mkSrcSpanPs, + + ) where + +import GhcPrelude + +import Util +import Json +import Outputable +import FastString + +import Control.DeepSeq +import Control.Applicative (liftA2) +import Data.Bits +import Data.Data +import Data.List (sortBy, intercalate) +import Data.Function (on) +import qualified Data.Map as Map + +{- +************************************************************************ +* * +\subsection[SrcLoc-SrcLocations]{Source-location information} +* * +************************************************************************ + +We keep information about the {\em definition} point for each entity; +this is the obvious stuff: +-} + +-- | Real Source Location +-- +-- Represents a single point within a file +data RealSrcLoc + = SrcLoc FastString -- A precise location (file name) + {-# UNPACK #-} !Int -- line number, begins at 1 + {-# UNPACK #-} !Int -- column number, begins at 1 + deriving (Eq, Ord) + +-- | 0-based index identifying the raw location in the StringBuffer. +-- +-- Unlike 'RealSrcLoc', it is not affected by #line and {-# LINE ... #-} +-- pragmas. In particular, notice how 'setSrcLoc' and 'resetAlrLastLoc' in +-- Lexer.x update 'PsLoc' preserving 'BufPos'. +-- +-- The parser guarantees that 'BufPos' are monotonic. See #17632. +newtype BufPos = BufPos { bufPos :: Int } + deriving (Eq, Ord, Show) + +-- | Source Location +data SrcLoc + = RealSrcLoc !RealSrcLoc !(Maybe BufPos) -- See Note [Why Maybe BufPos] + | UnhelpfulLoc FastString -- Just a general indication + deriving (Eq, Show) + +{- +************************************************************************ +* * +\subsection[SrcLoc-access-fns]{Access functions} +* * +************************************************************************ +-} + +mkSrcLoc :: FastString -> Int -> Int -> SrcLoc +mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing + +mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc +mkRealSrcLoc x line col = SrcLoc x line col + +-- | Built-in "bad" 'SrcLoc' values for particular locations +noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc +noSrcLoc = UnhelpfulLoc (fsLit "") +generatedSrcLoc = UnhelpfulLoc (fsLit "") +interactiveSrcLoc = UnhelpfulLoc (fsLit "") + +-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc + +-- | Gives the filename of the 'RealSrcLoc' +srcLocFile :: RealSrcLoc -> FastString +srcLocFile (SrcLoc fname _ _) = fname + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocLine :: RealSrcLoc -> Int +srcLocLine (SrcLoc _ l _) = l + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocCol :: RealSrcLoc -> Int +srcLocCol (SrcLoc _ _ c) = c + +-- | Move the 'SrcLoc' down by one line if the character is a newline, +-- to the next 8-char tabstop if it is a tab, and across by one +-- character in any other case +advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc +advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (advance_tabstop c) +advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) + +advance_tabstop :: Int -> Int +advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1 + +advanceBufPos :: BufPos -> BufPos +advanceBufPos (BufPos i) = BufPos (i+1) + +{- +************************************************************************ +* * +\subsection[SrcLoc-instances]{Instance declarations for various names} +* * +************************************************************************ +-} + +sortLocated :: [Located a] -> [Located a] +sortLocated = sortBy (leftmost_smallest `on` getLoc) + +sortRealLocated :: [RealLocated a] -> [RealLocated a] +sortRealLocated = sortBy (compare `on` getLoc) + +lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a +lookupSrcLoc (RealSrcLoc l _) = Map.lookup l +lookupSrcLoc (UnhelpfulLoc _) = const Nothing + +lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a +lookupSrcSpan (RealSrcSpan l _) = Map.lookup l +lookupSrcSpan (UnhelpfulSpan _) = const Nothing + +instance Outputable RealSrcLoc where + ppr (SrcLoc src_path src_line src_col) + = hcat [ pprFastFilePath src_path <> colon + , int src_line <> colon + , int src_col ] + +-- I don't know why there is this style-based difference +-- if userStyle sty || debugStyle sty then +-- hcat [ pprFastFilePath src_path, char ':', +-- int src_line, +-- char ':', int src_col +-- ] +-- else +-- hcat [text "{-# LINE ", int src_line, space, +-- char '\"', pprFastFilePath src_path, text " #-}"] + +instance Outputable SrcLoc where + ppr (RealSrcLoc l _) = ppr l + ppr (UnhelpfulLoc s) = ftext s + +instance Data RealSrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "RealSrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "RealSrcSpan" + +instance Data SrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "SrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "SrcSpan" + +{- +************************************************************************ +* * +\subsection[SrcSpan]{Source Spans} +* * +************************************************************************ +-} + +{- | +A 'RealSrcSpan' delimits a portion of a text file. It could be represented +by a pair of (line,column) coordinates, but in fact we optimise +slightly by using more compact representations for single-line and +zero-length spans, both of which are quite common. + +The end position is defined to be the column /after/ the end of the +span. That is, a span of (1,1)-(1,2) is one character long, and a +span of (1,1)-(1,1) is zero characters long. +-} + +-- | Real Source Span +data RealSrcSpan + = RealSrcSpan' + { srcSpanFile :: !FastString, + srcSpanSLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanELine :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int + } + deriving Eq + +-- | StringBuffer Source Span +data BufSpan = + BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } + deriving (Eq, Ord, Show) + +-- | Source Span +-- +-- A 'SrcSpan' identifies either a specific portion of a text file +-- or a human-readable description of a location. +data SrcSpan = + RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos] + | UnhelpfulSpan !FastString -- Just a general indication + -- also used to indicate an empty span + + deriving (Eq, Show) -- Show is used by Lexer.x, because we + -- derive Show for Token + +{- Note [Why Maybe BufPos] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan). +Why the Maybe? + +Surely, the lexer can always fill in the buffer position, and it guarantees to do so. +However, sometimes the SrcLoc/SrcSpan is constructed in a different context +where the buffer location is not available, and then we use Nothing instead of +a fake value like BufPos (-1). + +Perhaps the compiler could be re-engineered to pass around BufPos more +carefully and never discard it, and this 'Maybe' could be removed. If you're +interested in doing so, you may find this ripgrep query useful: + + rg "RealSrc(Loc|Span).*?Nothing" + +For example, it is not uncommon to whip up source locations for e.g. error +messages, constructing a SrcSpan without a BufSpan. +-} + +instance ToJson SrcSpan where + json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] + json (RealSrcSpan rss _) = json rss + +instance ToJson RealSrcSpan where + json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) + , ("startLine", JSInt srcSpanSLine) + , ("startCol", JSInt srcSpanSCol) + , ("endLine", JSInt srcSpanELine) + , ("endCol", JSInt srcSpanECol) + ] + +instance NFData SrcSpan where + rnf x = x `seq` () + +-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty +noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan (fsLit "") +wiredInSrcSpan = UnhelpfulSpan (fsLit "") +interactiveSrcSpan = UnhelpfulSpan (fsLit "") + +-- | Create a "bad" 'SrcSpan' that has not location information +mkGeneralSrcSpan :: FastString -> SrcSpan +mkGeneralSrcSpan = UnhelpfulSpan + +-- | Create a 'SrcSpan' corresponding to a single point +srcLocSpan :: SrcLoc -> SrcSpan +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str +srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb) + +realSrcLocSpan :: RealSrcLoc -> RealSrcSpan +realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col + +-- | Create a 'SrcSpan' between two points in a file +mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan +mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 + where + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol loc1 + col2 = srcLocCol loc2 + file = srcLocFile loc1 + +-- | 'True' if the span is known to straddle only one line. +isOneLineRealSpan :: RealSrcSpan -> Bool +isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) + = line1 == line2 + +-- | 'True' if the span is a single point +isPointRealSpan :: RealSrcSpan -> Bool +isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) + = line1 == line2 && col1 == col2 + +-- | Create a 'SrcSpan' between two points in a file +mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str +mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) + = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2) + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Returns UnhelpfulSpan if the files differ. +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful +combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) + | srcSpanFile span1 == srcSpanFile span2 + = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) + | otherwise = UnhelpfulSpan (fsLit "") + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Assumes the "file" part is the same in both inputs +combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +combineRealSrcSpans span1 span2 + = RealSrcSpan' file line_start col_start line_end col_end + where + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 + +combineBufSpans :: BufSpan -> BufSpan -> BufSpan +combineBufSpans span1 span2 = BufSpan start end + where + start = min (bufSpanStart span1) (bufSpanStart span2) + end = max (bufSpanEnd span1) (bufSpanEnd span2) + + +-- | Convert a SrcSpan into one that represents only its first character +srcSpanFirstCharacter :: SrcSpan -> SrcSpan +srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l +srcSpanFirstCharacter (RealSrcSpan span mbspan) = + RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) + where + loc1@(SrcLoc f l c) = realSrcSpanStart span + loc2 = SrcLoc f l (c+1) + mkBufSpan bspan = + let bpos1@(BufPos i) = bufSpanStart bspan + bpos2 = BufPos (i+1) + in BufSpan bpos1 bpos2 + +{- +************************************************************************ +* * +\subsection[SrcSpan-predicates]{Predicates} +* * +************************************************************************ +-} + +-- | Test if a 'SrcSpan' is "good", i.e. has precise location information +isGoodSrcSpan :: SrcSpan -> Bool +isGoodSrcSpan (RealSrcSpan _ _) = True +isGoodSrcSpan (UnhelpfulSpan _) = False + +isOneLineSpan :: SrcSpan -> Bool +-- ^ True if the span is known to straddle only one line. +-- For "bad" 'SrcSpan', it returns False +isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s +isOneLineSpan (UnhelpfulSpan _) = False + +-- | Tests whether the first span "contains" the other span, meaning +-- that it covers at least as much source code. True where spans are equal. +containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool +containsSpan s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanEndLine s1, srcSpanEndCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + -- We check file equality last because it is (presumably?) least + -- likely to fail. +{- +%************************************************************************ +%* * +\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} +* * +************************************************************************ +-} + +srcSpanStartLine :: RealSrcSpan -> Int +srcSpanEndLine :: RealSrcSpan -> Int +srcSpanStartCol :: RealSrcSpan -> Int +srcSpanEndCol :: RealSrcSpan -> Int + +srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l +srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l +srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l +srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c + +{- +************************************************************************ +* * +\subsection[SrcSpan-access-fns]{Access functions} +* * +************************************************************************ +-} + +-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanStart :: SrcSpan -> SrcLoc +srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) + +-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanEnd :: SrcSpan -> SrcLoc +srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) + +realSrcSpanStart :: RealSrcSpan -> RealSrcLoc +realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) + +realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc +realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) + +-- | Obtains the filename for a 'SrcSpan' if it is "good" +srcSpanFileName_maybe :: SrcSpan -> Maybe FastString +srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) +srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing + +{- +************************************************************************ +* * +\subsection[SrcSpan-instances]{Instances} +* * +************************************************************************ +-} + +-- We want to order RealSrcSpans first by the start point, then by the +-- end point. +instance Ord RealSrcSpan where + a `compare` b = + (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` + (realSrcSpanEnd a `compare` realSrcSpanEnd b) + +instance Show RealSrcLoc where + show (SrcLoc filename row col) + = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col + +-- Show is used by Lexer.x, because we derive Show for Token +instance Show RealSrcSpan where + show span@(RealSrcSpan' file sl sc el ec) + | isPointRealSpan span + = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) + + | isOneLineRealSpan span + = "SrcSpanOneLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,ec]) + + | otherwise + = "SrcSpanMultiLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,el,ec]) + + +instance Outputable RealSrcSpan where + ppr span = pprUserRealSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- text (showUserRealSpan True span) +-- else +-- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, +-- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] + +instance Outputable SrcSpan where + ppr span = pprUserSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- pprUserSpan True span +-- else +-- case span of +-- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" +-- RealSrcSpan s -> ppr s + +pprUserSpan :: Bool -> SrcSpan -> SDoc +pprUserSpan _ (UnhelpfulSpan s) = ftext s +pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s + +pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc +pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) + | isPointRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int col ] + +pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) + | isOneLineRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int scol + , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] + -- For single-character or point spans, we just + -- output the starting column number + +pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , parens (int sline <> comma <> int scol) + , char '-' + , parens (int eline <> comma <> int ecol') ] + where + ecol' = if ecol == 0 then ecol else ecol - 1 + +{- +************************************************************************ +* * +\subsection[Located]{Attaching SrcSpans to things} +* * +************************************************************************ +-} + +-- | We attach SrcSpans to lots of things, so let's have a datatype for it. +data GenLocated l e = L l e + deriving (Eq, Ord, Data, Functor, Foldable, Traversable) + +type Located = GenLocated SrcSpan +type RealLocated = GenLocated RealSrcSpan + +mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b +mapLoc = fmap + +unLoc :: GenLocated l e -> e +unLoc (L _ e) = e + +getLoc :: GenLocated l e -> l +getLoc (L l _) = l + +noLoc :: e -> Located e +noLoc e = L noSrcSpan e + +mkGeneralLocated :: String -> e -> Located e +mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e + +combineLocs :: Located a -> Located b -> SrcSpan +combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) + +-- | Combine locations from two 'Located' things and add them to a third thing +addCLoc :: Located a -> Located b -> c -> Located c +addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c + +-- not clear whether to add a general Eq instance, but this is useful sometimes: + +-- | Tests whether the two located things are equal +eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool +eqLocated a b = unLoc a == unLoc b + +-- not clear whether to add a general Ord instance, but this is useful sometimes: + +-- | Tests the ordering of the two located things +cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering +cmpLocated a b = unLoc a `compare` unLoc b + +instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where + ppr (L l e) = -- TODO: We can't do this since Located was refactored into + -- GenLocated: + -- Print spans without the file name etc + -- ifPprDebug (braces (pprUserSpan False l)) + whenPprDebug (braces (ppr l)) + $$ ppr e + +{- +************************************************************************ +* * +\subsection{Ordering SrcSpans for InteractiveUI} +* * +************************************************************************ +-} + +-- | Strategies for ordering 'SrcSpan's +leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering +rightmost_smallest = compareSrcSpanBy (flip compare) +leftmost_smallest = compareSrcSpanBy compare +leftmost_largest = compareSrcSpanBy $ \a b -> + (realSrcSpanStart a `compare` realSrcSpanStart b) + `thenCmp` + (realSrcSpanEnd b `compare` realSrcSpanEnd a) + +compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering +compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b +compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT +compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT +compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ + +-- | Determines whether a span encloses a given line and column index +spans :: SrcSpan -> (Int, Int) -> Bool +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span + where loc = mkRealSrcLoc (srcSpanFile span) l c + +-- | Determines whether a span is enclosed by another one +isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other + -> SrcSpan -- ^ The span it may be enclosed by + -> Bool +isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent +isSubspanOf _ _ = False + +-- | Determines whether a span is enclosed by another one +isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other + -> RealSrcSpan -- ^ The span it may be enclosed by + -> Bool +isRealSubspanOf src parent + | srcSpanFile parent /= srcSpanFile src = False + | otherwise = realSrcSpanStart parent <= realSrcSpanStart src && + realSrcSpanEnd parent >= realSrcSpanEnd src + +liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) +liftL f (L loc a) = do + a' <- f a + return $ L loc a' + +getRealSrcSpan :: RealLocated a -> RealSrcSpan +getRealSrcSpan (L l _) = l + +unRealSrcSpan :: RealLocated a -> a +unRealSrcSpan (L _ e) = e + + +-- | A location as produced by the parser. Consists of two components: +-- +-- * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc) +-- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632) +data PsLoc + = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos } + deriving (Eq, Ord, Show) + +data PsSpan + = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } + deriving (Eq, Ord, Show) + +type PsLocated = GenLocated PsSpan + +advancePsLoc :: PsLoc -> Char -> PsLoc +advancePsLoc (PsLoc real_loc buf_loc) c = + PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc) + +mkPsSpan :: PsLoc -> PsLoc -> PsSpan +mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2) + +psSpanStart :: PsSpan -> PsLoc +psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b) + +psSpanEnd :: PsSpan -> PsLoc +psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) + +mkSrcSpanPs :: PsSpan -> SrcSpan +mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b) diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs new file mode 100644 index 0000000000..d031f70072 --- /dev/null +++ b/compiler/GHC/Types/Unique.hs @@ -0,0 +1,448 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +@Uniques@ are used to distinguish entities in the compiler (@Ids@, +@Classes@, etc.) from each other. Thus, @Uniques@ are the basic +comparison key in the compiler. + +If there is any single operation that needs to be fast, it is @Unique@ + +comparison. Unsurprisingly, there is quite a bit of huff-and-puff +directed to that end. + +Some of the other hair in this code is to be able to use a +``splittable @UniqueSupply@'' if requested/possible (not standard +Haskell). +-} + +{-# LANGUAGE CPP, BangPatterns, MagicHash #-} + +module GHC.Types.Unique ( + -- * Main data types + Unique, Uniquable(..), + uNIQUE_BITS, + + -- ** Constructors, destructors and operations on 'Unique's + hasKey, + + pprUniqueAlways, + + mkUniqueGrimily, + getKey, + mkUnique, unpkUnique, + eqUnique, ltUnique, + incrUnique, + + newTagUnique, + initTyVarUnique, + initExitJoinUnique, + nonDetCmpUnique, + isValidKnownKeyUnique, + + -- ** Making built-in uniques + + -- now all the built-in GHC.Types.Uniques (and functions to make them) + -- [the Oh-So-Wonderful Haskell module system wins again...] + mkAlphaTyVarUnique, + mkPrimOpIdUnique, mkPrimOpWrapperUnique, + mkPreludeMiscIdUnique, mkPreludeDataConUnique, + mkPreludeTyConUnique, mkPreludeClassUnique, + mkCoVarUnique, + + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, + mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, + mkCostCentreUnique, + + mkBuiltinUnique, + mkPseudoUniqueD, + mkPseudoUniqueE, + mkPseudoUniqueH, + + -- ** Deriving uniques + -- *** From TyCon name uniques + tyConRepNameUnique, + -- *** From DataCon name uniques + dataConWorkerUnique, dataConTyRepNameUnique, + + -- ** Local uniques + -- | These are exposed exclusively for use by 'VarEnv.uniqAway', which + -- has rather peculiar needs. See Note [Local uniques]. + mkLocalUnique, minLocalUnique, maxLocalUnique + ) where + +#include "HsVersions.h" +#include "Unique.h" + +import GhcPrelude + +import GHC.Types.Basic +import FastString +import Outputable +import Util + +-- just for implementing a fast [0,61) -> Char function +import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) + +import Data.Char ( chr, ord ) +import Data.Bits + +{- +************************************************************************ +* * +\subsection[Unique-type]{@Unique@ type and operations} +* * +************************************************************************ + +The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. +Fast comparison is everything on @Uniques@: +-} + +-- | Unique identifier. +-- +-- The type of unique identifiers that are used in many places in GHC +-- for fast ordering and equality tests. You should generate these with +-- the functions from the 'UniqSupply' module +-- +-- These are sometimes also referred to as \"keys\" in comments in GHC. +newtype Unique = MkUnique Int + +{-# INLINE uNIQUE_BITS #-} +uNIQUE_BITS :: Int +uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS + +{- +Now come the functions which construct uniques from their pieces, and vice versa. +The stuff about unique *supplies* is handled further down this module. +-} + +unpkUnique :: Unique -> (Char, Int) -- The reverse + +mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply +getKey :: Unique -> Int -- for Var + +incrUnique :: Unique -> Unique +stepUnique :: Unique -> Int -> Unique +newTagUnique :: Unique -> Char -> Unique + +mkUniqueGrimily = MkUnique + +{-# INLINE getKey #-} +getKey (MkUnique x) = x + +incrUnique (MkUnique i) = MkUnique (i + 1) +stepUnique (MkUnique i) n = MkUnique (i + n) + +mkLocalUnique :: Int -> Unique +mkLocalUnique i = mkUnique 'X' i + +minLocalUnique :: Unique +minLocalUnique = mkLocalUnique 0 + +maxLocalUnique :: Unique +maxLocalUnique = mkLocalUnique uniqueMask + +-- newTagUnique changes the "domain" of a unique to a different char +newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u + +-- | How many bits are devoted to the unique index (as opposed to the class +-- character). +uniqueMask :: Int +uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 + +-- pop the Char in the top 8 bits of the Unique(Supply) + +-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM + +-- and as long as the Char fits in 8 bits, which we assume anyway! + +mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces +-- NOT EXPORTED, so that we can see all the Chars that +-- are used in this one module +mkUnique c i + = MkUnique (tag .|. bits) + where + tag = ord c `shiftL` uNIQUE_BITS + bits = i .&. uniqueMask + +unpkUnique (MkUnique u) + = let + -- as long as the Char may have its eighth bit set, we + -- really do need the logical right-shift here! + tag = chr (u `shiftR` uNIQUE_BITS) + i = u .&. uniqueMask + in + (tag, i) + +-- | The interface file symbol-table encoding assumes that known-key uniques fit +-- in 30-bits; verify this. +-- +-- See Note [Symbol table representation of names] in GHC.Iface.Binary for details. +isValidKnownKeyUnique :: Unique -> Bool +isValidKnownKeyUnique u = + case unpkUnique u of + (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) + +{- +************************************************************************ +* * +\subsection[Uniquable-class]{The @Uniquable@ class} +* * +************************************************************************ +-} + +-- | Class of things that we can obtain a 'Unique' from +class Uniquable a where + getUnique :: a -> Unique + +hasKey :: Uniquable a => a -> Unique -> Bool +x `hasKey` k = getUnique x == k + +instance Uniquable FastString where + getUnique fs = mkUniqueGrimily (uniqueOfFS fs) + +instance Uniquable Int where + getUnique i = mkUniqueGrimily i + +{- +************************************************************************ +* * +\subsection[Unique-instances]{Instance declarations for @Unique@} +* * +************************************************************************ + +And the whole point (besides uniqueness) is fast equality. We don't +use `deriving' because we want {\em precise} control of ordering +(equality on @Uniques@ is v common). +-} + +-- Note [Unique Determinism] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The order of allocated @Uniques@ is not stable across rebuilds. +-- The main reason for that is that typechecking interface files pulls +-- @Uniques@ from @UniqSupply@ and the interface file for the module being +-- currently compiled can, but doesn't have to exist. +-- +-- It gets more complicated if you take into account that the interface +-- files are loaded lazily and that building multiple files at once has to +-- work for any subset of interface files present. When you add parallelism +-- this makes @Uniques@ hopelessly random. +-- +-- As such, to get deterministic builds, the order of the allocated +-- @Uniques@ should not affect the final result. +-- see also wiki/deterministic-builds +-- +-- Note [Unique Determinism and code generation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The goal of the deterministic builds (wiki/deterministic-builds, #4012) +-- is to get ABI compatible binaries given the same inputs and environment. +-- The motivation behind that is that if the ABI doesn't change the +-- binaries can be safely reused. +-- Note that this is weaker than bit-for-bit identical binaries and getting +-- bit-for-bit identical binaries is not a goal for now. +-- This means that we don't care about nondeterminism that happens after +-- the interface files are created, in particular we don't care about +-- register allocation and code generation. +-- To track progress on bit-for-bit determinism see #12262. + +eqUnique :: Unique -> Unique -> Bool +eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 + +ltUnique :: Unique -> Unique -> Bool +ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 + +-- Provided here to make it explicit at the call-site that it can +-- introduce non-determinism. +-- See Note [Unique Determinism] +-- See Note [No Ord for Unique] +nonDetCmpUnique :: Unique -> Unique -> Ordering +nonDetCmpUnique (MkUnique u1) (MkUnique u2) + = if u1 == u2 then EQ else if u1 < u2 then LT else GT + +{- +Note [No Ord for Unique] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Unique Determinism] the relative order of Uniques +is nondeterministic. To prevent from accidental use the Ord Unique +instance has been removed. +This makes it easier to maintain deterministic builds, but comes with some +drawbacks. +The biggest drawback is that Maps keyed by Uniques can't directly be used. +The alternatives are: + + 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which + 2) Create a newtype wrapper based on Unique ordering where nondeterminism + is controlled. See Module.ModuleEnv + 3) Change the algorithm to use nonDetCmpUnique and document why it's still + deterministic + 4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel +-} + +instance Eq Unique where + a == b = eqUnique a b + a /= b = not (eqUnique a b) + +instance Uniquable Unique where + getUnique u = u + +-- We do sometimes make strings with @Uniques@ in them: + +showUnique :: Unique -> String +showUnique uniq + = case unpkUnique uniq of + (tag, u) -> finish_show tag u (iToBase62 u) + +finish_show :: Char -> Int -> String -> String +finish_show 't' u _pp_u | u < 26 + = -- Special case to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + [chr (ord 'a' + u)] +finish_show tag _ pp_u = tag : pp_u + +pprUniqueAlways :: Unique -> SDoc +-- The "always" means regardless of -dsuppress-uniques +-- It replaces the old pprUnique to remind callers that +-- they should consider whether they want to consult +-- Opt_SuppressUniques +pprUniqueAlways u + = text (showUnique u) + +instance Outputable Unique where + ppr = pprUniqueAlways + +instance Show Unique where + show uniq = showUnique uniq + +{- +************************************************************************ +* * +\subsection[Utils-base62]{Base-62 numbers} +* * +************************************************************************ + +A character-stingy way to read/write numbers (notably Uniques). +The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. +Code stolen from Lennart. +-} + +iToBase62 :: Int -> String +iToBase62 n_ + = ASSERT(n_ >= 0) go n_ "" + where + go n cs | n < 62 + = let !c = chooseChar62 n in c : cs + | otherwise + = go q (c : cs) where (!q, r) = quotRem n 62 + !c = chooseChar62 r + + chooseChar62 :: Int -> Char + {-# INLINE chooseChar62 #-} + chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) + chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# + +{- +************************************************************************ +* * +\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} +* * +************************************************************************ + +Allocation of unique supply characters: + v,t,u : for renumbering value-, type- and usage- vars. + B: builtin + C-E: pseudo uniques (used in native-code generator) + X: uniques from mkLocalUnique + _: unifiable tyvars (above) + 0-9: prelude things below + (no numbers left any more..) + :: (prelude) parallel array data constructors + + other a-z: lower case chars for unique supplies. Used so far: + + d desugarer + f AbsC flattener + g SimplStg + k constraint tuple tycons + m constraint tuple datacons + n Native codegen + r Hsc name cache + s simplifier + z anonymous sums +-} + +mkAlphaTyVarUnique :: Int -> Unique +mkPreludeClassUnique :: Int -> Unique +mkPreludeTyConUnique :: Int -> Unique +mkPreludeDataConUnique :: Arity -> Unique +mkPrimOpIdUnique :: Int -> Unique +-- See Note [Primop wrappers] in PrimOp.hs. +mkPrimOpWrapperUnique :: Int -> Unique +mkPreludeMiscIdUnique :: Int -> Unique +mkCoVarUnique :: Int -> Unique + +mkAlphaTyVarUnique i = mkUnique '1' i +mkCoVarUnique i = mkUnique 'g' i +mkPreludeClassUnique i = mkUnique '2' i + +-------------------------------------------------- +-- Wired-in type constructor keys occupy *two* slots: +-- * u: the TyCon itself +-- * u+1: the TyConRepName of the TyCon +mkPreludeTyConUnique i = mkUnique '3' (2*i) + +tyConRepNameUnique :: Unique -> Unique +tyConRepNameUnique u = incrUnique u + +-------------------------------------------------- +-- Wired-in data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon +-- Prelude data constructors are too simple to need wrappers. + +mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic + +-------------------------------------------------- +dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique +dataConWorkerUnique u = incrUnique u +dataConTyRepNameUnique u = stepUnique u 2 + +-------------------------------------------------- +mkPrimOpIdUnique op = mkUnique '9' (2*op) +mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1) +mkPreludeMiscIdUnique i = mkUnique '0' i + +-- The "tyvar uniques" print specially nicely: a, b, c, etc. +-- See pprUnique for details + +initTyVarUnique :: Unique +initTyVarUnique = mkUnique 't' 0 + +mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, + mkBuiltinUnique :: Int -> Unique + +mkBuiltinUnique i = mkUnique 'B' i +mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs +mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs +mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs + +mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique +mkRegSingleUnique = mkUnique 'R' +mkRegSubUnique = mkUnique 'S' +mkRegPairUnique = mkUnique 'P' +mkRegClassUnique = mkUnique 'L' + +mkCostCentreUnique :: Int -> Unique +mkCostCentreUnique = mkUnique 'C' + +mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique +-- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence +mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) +mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) +mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) +mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) + +initExitJoinUnique :: Unique +initExitJoinUnique = mkUnique 's' 0 + diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs new file mode 100644 index 0000000000..21e2f8249b --- /dev/null +++ b/compiler/GHC/Types/Unique/DFM.hs @@ -0,0 +1,420 @@ +{- +(c) Bartosz Nitka, Facebook, 2015 + +UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +This is very similar to @UniqFM@, the major difference being that the order of +folding is not dependent on @Unique@ ordering, giving determinism. +Currently the ordering is determined by insertion order. + +See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ ordering +is not deterministic. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wall #-} + +module GHC.Types.Unique.DFM ( + -- * Unique-keyed deterministic mappings + UniqDFM, -- abstract type + + -- ** Manipulating those mappings + emptyUDFM, + unitUDFM, + addToUDFM, + addToUDFM_C, + addListToUDFM, + delFromUDFM, + delListFromUDFM, + adjustUDFM, + alterUDFM, + mapUDFM, + plusUDFM, + plusUDFM_C, + lookupUDFM, lookupUDFM_Directly, + elemUDFM, + foldUDFM, + eltsUDFM, + filterUDFM, filterUDFM_Directly, + isNullUDFM, + sizeUDFM, + intersectUDFM, udfmIntersectUFM, + intersectsUDFM, + disjointUDFM, disjointUdfmUfm, + equalKeysUDFM, + minusUDFM, + listToUDFM, + udfmMinusUFM, + partitionUDFM, + anyUDFM, allUDFM, + pprUniqDFM, pprUDFM, + + udfmToList, + udfmToUfm, + nonDetFoldUDFM, + alwaysUnsafeUfmToUdfm, + ) where + +import GhcPrelude + +import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) +import Outputable + +import qualified Data.IntMap as M +import Data.Data +import Data.Functor.Classes (Eq1 (..)) +import Data.List (sortBy) +import Data.Function (on) +import qualified Data.Semigroup as Semi +import GHC.Types.Unique.FM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap) + +-- Note [Deterministic UniqFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A @UniqDFM@ is just like @UniqFM@ with the following additional +-- property: the function `udfmToList` returns the elements in some +-- deterministic order not depending on the Unique key for those elements. +-- +-- If the client of the map performs operations on the map in deterministic +-- order then `udfmToList` returns them in deterministic order. +-- +-- There is an implementation cost: each element is given a serial number +-- as it is added, and `udfmToList` sorts it's result by this serial +-- number. So you should only use `UniqDFM` if you need the deterministic +-- property. +-- +-- `foldUDFM` also preserves determinism. +-- +-- Normal @UniqFM@ when you turn it into a list will use +-- Data.IntMap.toList function that returns the elements in the order of +-- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with +-- with a list ordered by @Uniques@. +-- The order of @Uniques@ is known to be not stable across rebuilds. +-- See Note [Unique Determinism] in GHC.Types.Unique. +-- +-- +-- There's more than one way to implement this. The implementation here tags +-- every value with the insertion time that can later be used to sort the +-- values when asked to convert to a list. +-- +-- An alternative would be to have +-- +-- data UniqDFM ele = UDFM (M.IntMap ele) [ele] +-- +-- where the list determines the order. This makes deletion tricky as we'd +-- only accumulate elements in that list, but makes merging easier as you +-- can just merge both structures independently. +-- Deletion can probably be done in amortized fashion when the size of the +-- list is twice the size of the set. + +-- | A type of values tagged with insertion time +data TaggedVal val = + TaggedVal + val + {-# UNPACK #-} !Int -- ^ insertion time + deriving (Data, Functor) + +taggedFst :: TaggedVal val -> val +taggedFst (TaggedVal v _) = v + +taggedSnd :: TaggedVal val -> Int +taggedSnd (TaggedVal _ i) = i + +instance Eq val => Eq (TaggedVal val) where + (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 + +-- | Type of unique deterministic finite maps +data UniqDFM ele = + UDFM + !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and + -- values are tagged with insertion time. + -- The invariant is that all the tags will + -- be distinct within a single map + {-# UNPACK #-} !Int -- Upper bound on the values' insertion + -- time. See Note [Overflow on plusUDFM] + deriving (Data, Functor) + +-- | Deterministic, in O(n log n). +instance Foldable UniqDFM where + foldr = foldUDFM + +-- | Deterministic, in O(n log n). +instance Traversable UniqDFM where + traverse f = fmap listToUDFM_Directly + . traverse (\(u,a) -> (u,) <$> f a) + . udfmToList + +emptyUDFM :: UniqDFM elt +emptyUDFM = UDFM M.empty 0 + +unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt +unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 + +-- The new binding always goes to the right of existing ones +addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt +addToUDFM m k v = addToUDFM_Directly m (getUnique k) v + +-- The new binding always goes to the right of existing ones +addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt +addToUDFM_Directly (UDFM m i) u v + = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i + -- Keep the old tag, but insert the new value + -- This means that udfmToList typically returns elements + -- in the order of insertion, rather than the reverse + +addToUDFM_Directly_C + :: (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM elt + -> Unique -> elt + -> UniqDFM elt +addToUDFM_Directly_C f (UDFM m i) u v + = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal old_v old_i) + = TaggedVal (f old_v new_v) old_i + -- Flip the arguments, because M.insertWith uses (new->old->result) + -- but f needs (old->new->result) + -- Like addToUDFM_Directly, keep the old tag + +addToUDFM_C + :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM elt -- old + -> key -> elt -- new + -> UniqDFM elt -- result +addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v + +addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt +addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) + +addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt +addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) + +addListToUDFM_Directly_C + :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt +addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v) + +delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt +delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i + +plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt +plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft_C f udfml udfmr + | otherwise = insertUDFMIntoLeft_C f udfmr udfml + +-- Note [Overflow on plusUDFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- There are multiple ways of implementing plusUDFM. +-- The main problem that needs to be solved is overlap on times of +-- insertion between different keys in two maps. +-- Consider: +-- +-- A = fromList [(a, (x, 1))] +-- B = fromList [(b, (y, 1))] +-- +-- If you merge them naively you end up with: +-- +-- C = fromList [(a, (x, 1)), (b, (y, 1))] +-- +-- Which loses information about ordering and brings us back into +-- non-deterministic world. +-- +-- The solution I considered before would increment the tags on one of the +-- sets by the upper bound of the other set. The problem with this approach +-- is that you'll run out of tags for some merge patterns. +-- Say you start with A with upper bound 1, you merge A with A to get A' and +-- the upper bound becomes 2. You merge A' with A' and the upper bound +-- doubles again. After 64 merges you overflow. +-- This solution would have the same time complexity as plusUFM, namely O(n+m). +-- +-- The solution I ended up with has time complexity of +-- O(m log m + m * min (n+m, W)) where m is the smaller set. +-- It simply inserts the elements of the smaller set into the larger +-- set in the order that they were inserted into the smaller set. That's +-- O(m log m) for extracting the elements from the smaller set in the +-- insertion order and O(m * min(n+m, W)) to insert them into the bigger +-- set. + +plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt +plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft udfml udfmr + | otherwise = insertUDFMIntoLeft udfmr udfml + +insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt +insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr + +insertUDFMIntoLeft_C + :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt +insertUDFMIntoLeft_C f udfml udfmr = + addListToUDFM_Directly_C f udfml $ udfmToList udfmr + +lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt +lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m + +lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt +lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m + +elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool +elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m + +-- | Performs a deterministic fold over the UniqDFM. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a +foldUDFM k z m = foldr k z (eltsUDFM m) + +-- | Performs a nondeterministic fold over the UniqDFM. +-- It's O(n), same as the corresponding function on `UniqFM`. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a +nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m + +eltsUDFM :: UniqDFM elt -> [elt] +eltsUDFM (UDFM m _i) = + map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m + +filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt +filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i + +filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt +filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i + where + p' k (TaggedVal v _) = p (getUnique k) v + +-- | Converts `UniqDFM` to a list, with elements in deterministic order. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +udfmToList :: UniqDFM elt -> [(Unique, elt)] +udfmToList (UDFM m _i) = + [ (getUnique k, taggedFst v) + | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] + +-- Determines whether two 'UniqDFM's contain the same keys. +equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool +equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2 + +isNullUDFM :: UniqDFM elt -> Bool +isNullUDFM (UDFM m _) = M.null m + +sizeUDFM :: UniqDFM elt -> Int +sizeUDFM (UDFM m _i) = M.size m + +intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt +intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 +udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool +intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) + +disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool +disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) + +disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool +disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y)) + +minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1 +minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 +udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +-- | Partition UniqDFM into two UniqDFMs according to the predicate +partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) +partitionUDFM p (UDFM m i) = + case M.partition (p . taggedFst) m of + (left, right) -> (UDFM left i, UDFM right i) + +-- | Delete a list of elements from a UniqDFM +delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt +delListFromUDFM = foldl' delFromUDFM + +-- | This allows for lossy conversion from UniqDFM to UniqFM +udfmToUfm :: UniqDFM elt -> UniqFM elt +udfmToUfm (UDFM m _i) = + listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m] + +listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt +listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM + +listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt +listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM + +-- | Apply a function to a particular element +adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt +adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i + +-- | The expression (alterUDFM f k map) alters value x at k, or absence +-- thereof. alterUDFM can be used to insert, delete, or update a value in +-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are +-- more efficient. +alterUDFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqDFM elt -- old + -> key -- new + -> UniqDFM elt -- result +alterUDFM f (UDFM m i) k = + UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) + where + alterf Nothing = inject $ f Nothing + alterf (Just (TaggedVal v _)) = inject $ f (Just v) + inject Nothing = Nothing + inject (Just v) = Just $ TaggedVal v i + +-- | Map a function over every value in a UniqDFM +mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 +mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i + +anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool +anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m + +allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool +allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m + +instance Semi.Semigroup (UniqDFM a) where + (<>) = plusUDFM + +instance Monoid (UniqDFM a) where + mempty = emptyUDFM + mappend = (Semi.<>) + +-- This should not be used in committed code, provided for convenience to +-- make ad-hoc conversions when developing +alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt +alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList + +-- Output-ery + +instance Outputable a => Outputable (UniqDFM a) where + ppr ufm = pprUniqDFM ppr ufm + +pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc +pprUniqDFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- udfmToList ufm ] + +pprUDFM :: UniqDFM a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUDFM ufm pp = pp (eltsUDFM ufm) diff --git a/compiler/GHC/Types/Unique/DSet.hs b/compiler/GHC/Types/Unique/DSet.hs new file mode 100644 index 0000000000..32d32536df --- /dev/null +++ b/compiler/GHC/Types/Unique/DSet.hs @@ -0,0 +1,141 @@ +-- (c) Bartosz Nitka, Facebook, 2015 + +-- | +-- Specialised deterministic sets, for things with @Uniques@ +-- +-- Based on 'UniqDFM's (as you would expect). +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need it. +-- +-- Basically, the things need to be in class 'Uniquable'. + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.Unique.DSet ( + -- * Unique set type + UniqDSet, -- type synonym for UniqFM a + getUniqDSet, + pprUniqDSet, + + -- ** Manipulating these sets + delOneFromUniqDSet, delListFromUniqDSet, + emptyUniqDSet, + unitUniqDSet, + mkUniqDSet, + addOneToUniqDSet, addListToUniqDSet, + unionUniqDSets, unionManyUniqDSets, + minusUniqDSet, uniqDSetMinusUniqSet, + intersectUniqDSets, uniqDSetIntersectUniqSet, + foldUniqDSet, + elementOfUniqDSet, + filterUniqDSet, + sizeUniqDSet, + isEmptyUniqDSet, + lookupUniqDSet, + uniqDSetToList, + partitionUniqDSet, + mapUniqDSet + ) where + +import GhcPrelude + +import Outputable +import GHC.Types.Unique.DFM +import GHC.Types.Unique.Set +import GHC.Types.Unique + +import Data.Coerce +import Data.Data +import qualified Data.Semigroup as Semi + +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. +-- Beyond preserving invariants, we may also want to 'override' typeclass +-- instances. + +newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a} + deriving (Data, Semi.Semigroup, Monoid) + +emptyUniqDSet :: UniqDSet a +emptyUniqDSet = UniqDSet emptyUDFM + +unitUniqDSet :: Uniquable a => a -> UniqDSet a +unitUniqDSet x = UniqDSet (unitUDFM x x) + +mkUniqDSet :: Uniquable a => [a] -> UniqDSet a +mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet + +-- The new element always goes to the right of existing ones. +addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x) + +addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +addListToUniqDSet = foldl' addOneToUniqDSet + +delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s + +delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s + +unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t) + +unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a +unionManyUniqDSets [] = emptyUniqDSet +unionManyUniqDSets sets = foldr1 unionUniqDSets sets + +minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a +minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t) + +uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a +uniqDSetMinusUniqSet xs ys + = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys)) + +intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t) + +uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a +uniqDSetIntersectUniqSet xs ys + = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys)) + +foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b +foldUniqDSet c n (UniqDSet s) = foldUDFM c n s + +elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool +elementOfUniqDSet k = elemUDFM k . getUniqDSet + +filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a +filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s) + +sizeUniqDSet :: UniqDSet a -> Int +sizeUniqDSet = sizeUDFM . getUniqDSet + +isEmptyUniqDSet :: UniqDSet a -> Bool +isEmptyUniqDSet = isNullUDFM . getUniqDSet + +lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a +lookupUniqDSet = lookupUDFM . getUniqDSet + +uniqDSetToList :: UniqDSet a -> [a] +uniqDSetToList = eltsUDFM . getUniqDSet + +partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) +partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet + +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set +mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList + +-- Two 'UniqDSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqDSet a) where + UniqDSet a == UniqDSet b = equalKeysUDFM a b + +getUniqDSet :: UniqDSet a -> UniqDFM a +getUniqDSet = getUniqDSet' + +instance Outputable a => Outputable (UniqDSet a) where + ppr = pprUniqDSet ppr + +pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc +pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs new file mode 100644 index 0000000000..01ab645783 --- /dev/null +++ b/compiler/GHC/Types/Unique/FM.hs @@ -0,0 +1,416 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +UniqFM: Specialised finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +(A similar thing to @UniqSet@, as opposed to @Set@.) + +The interface is based on @FiniteMap@s, but the implementation uses +@Data.IntMap@, which is both maintained and faster than the past +implementation (see commit log). + +The @UniqFM@ interface maps directly to Data.IntMap, only +``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased +and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order +of arguments of combining function. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wall #-} + +module GHC.Types.Unique.FM ( + -- * Unique-keyed mappings + UniqFM, -- abstract type + NonDetUniqFM(..), -- wrapper for opting into nondeterminism + + -- ** Manipulating those mappings + emptyUFM, + unitUFM, + unitDirectlyUFM, + listToUFM, + listToUFM_Directly, + listToUFM_C, + addToUFM,addToUFM_C,addToUFM_Acc, + addListToUFM,addListToUFM_C, + addToUFM_Directly, + addListToUFM_Directly, + adjustUFM, alterUFM, + adjustUFM_Directly, + delFromUFM, + delFromUFM_Directly, + delListFromUFM, + delListFromUFM_Directly, + plusUFM, + plusUFM_C, + plusUFM_CD, + plusMaybeUFM_C, + plusUFMList, + minusUFM, + intersectUFM, + intersectUFM_C, + disjointUFM, + equalKeysUFM, + nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly, + anyUFM, allUFM, seqEltsUFM, + mapUFM, mapUFM_Directly, + elemUFM, elemUFM_Directly, + filterUFM, filterUFM_Directly, partitionUFM, + sizeUFM, + isNullUFM, + lookupUFM, lookupUFM_Directly, + lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, + nonDetEltsUFM, eltsUFM, nonDetKeysUFM, + ufmToSet_Directly, + nonDetUFMToList, ufmToIntMap, + pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM + ) where + +import GhcPrelude + +import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) +import Outputable + +import qualified Data.IntMap as M +import qualified Data.IntSet as S +import Data.Data +import qualified Data.Semigroup as Semi +import Data.Functor.Classes (Eq1 (..)) + + +newtype UniqFM ele = UFM (M.IntMap ele) + deriving (Data, Eq, Functor) + -- Nondeterministic Foldable and Traversable instances are accessible through + -- use of the 'NonDetUniqFM' wrapper. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. + +emptyUFM :: UniqFM elt +emptyUFM = UFM M.empty + +isNullUFM :: UniqFM elt -> Bool +isNullUFM (UFM m) = M.null m + +unitUFM :: Uniquable key => key -> elt -> UniqFM elt +unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) + +-- when you've got the Unique already +unitDirectlyUFM :: Unique -> elt -> UniqFM elt +unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) + +listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt +listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM + +listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt +listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM + +listToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> [(key, elt)] + -> UniqFM elt +listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM + +addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt +addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) + +addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt +addListToUFM = foldl' (\m (k, v) -> addToUFM m k v) + +addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt +addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v) + +addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt +addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) + +addToUFM_C + :: Uniquable key + => (elt -> elt -> elt) -- old -> new -> result + -> UniqFM elt -- old + -> key -> elt -- new + -> UniqFM elt -- result +-- Arguments of combining function of M.insertWith and addToUFM_C are flipped. +addToUFM_C f (UFM m) k v = + UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) + +addToUFM_Acc + :: Uniquable key + => (elt -> elts -> elts) -- Add to existing + -> (elt -> elts) -- New element + -> UniqFM elts -- old + -> key -> elt -- new + -> UniqFM elts -- result +addToUFM_Acc exi new (UFM m) k v = + UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) + +alterUFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqFM elt -- old + -> key -- new + -> UniqFM elt -- result +alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) + +addListToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> UniqFM elt -> [(key,elt)] + -> UniqFM elt +addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) + +adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt +adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) + +adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt +adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) + +delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt +delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) + +delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt +delListFromUFM = foldl' delFromUFM + +delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt +delListFromUFM_Directly = foldl' delFromUFM_Directly + +delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt +delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) + +-- Bindings in right argument shadow those in the left +plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt +-- M.union is left-biased, plusUFM should be right-biased. +plusUFM (UFM x) (UFM y) = UFM (M.union y x) + -- Note (M.union y x), with arguments flipped + -- M.union is left-biased, plusUFM should be right-biased. + +plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt +plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) + +-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the +-- combinding function and `d1` resp. `d2` as the default value if +-- there is no entry in `m1` reps. `m2`. The domain is the union of +-- the domains of `m1` and `m2`. +-- +-- Representative example: +-- +-- @ +-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 +-- == {A: f 1 42, B: f 2 3, C: f 23 4 } +-- @ +plusUFM_CD + :: (elt -> elt -> elt) + -> UniqFM elt -- map X + -> elt -- default for X + -> UniqFM elt -- map Y + -> elt -- default for Y + -> UniqFM elt +plusUFM_CD f (UFM xm) dx (UFM ym) dy + = UFM $ M.mergeWithKey + (\_ x y -> Just (x `f` y)) + (M.map (\x -> x `f` dy)) + (M.map (\y -> dx `f` y)) + xm ym + +plusMaybeUFM_C :: (elt -> elt -> Maybe elt) + -> UniqFM elt -> UniqFM elt -> UniqFM elt +plusMaybeUFM_C f (UFM xm) (UFM ym) + = UFM $ M.mergeWithKey + (\_ x y -> x `f` y) + id + id + xm ym + +plusUFMList :: [UniqFM elt] -> UniqFM elt +plusUFMList = foldl' plusUFM emptyUFM + +minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 +minusUFM (UFM x) (UFM y) = UFM (M.difference x y) + +intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 +intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) + +intersectUFM_C + :: (elt1 -> elt2 -> elt3) + -> UniqFM elt1 + -> UniqFM elt2 + -> UniqFM elt3 +intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) + +disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool +disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y) + +foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +foldUFM k z (UFM m) = M.foldr k z m + +mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM f (UFM m) = UFM (M.map f m) + +mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) + +filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt +filterUFM p (UFM m) = UFM (M.filter p m) + +filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt +filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) + +partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) +partitionUFM p (UFM m) = + case M.partition p m of + (left, right) -> (UFM left, UFM right) + +sizeUFM :: UniqFM elt -> Int +sizeUFM (UFM m) = M.size m + +elemUFM :: Uniquable key => key -> UniqFM elt -> Bool +elemUFM k (UFM m) = M.member (getKey $ getUnique k) m + +elemUFM_Directly :: Unique -> UniqFM elt -> Bool +elemUFM_Directly u (UFM m) = M.member (getKey u) m + +lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt +lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m + +-- when you've got the Unique already +lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt +lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m + +lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt +lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m + +lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt +lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m + +eltsUFM :: UniqFM elt -> [elt] +eltsUFM (UFM m) = M.elems m + +ufmToSet_Directly :: UniqFM elt -> S.IntSet +ufmToSet_Directly (UFM m) = M.keysSet m + +anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool +anyUFM p (UFM m) = M.foldr ((||) . p) False m + +allUFM :: (elt -> Bool) -> UniqFM elt -> Bool +allUFM p (UFM m) = M.foldr ((&&) . p) True m + +seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> () +seqEltsUFM seqList = seqList . nonDetEltsUFM + -- It's OK to use nonDetEltsUFM here because the type guarantees that + -- the only interesting thing this function can do is to force the + -- elements. + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUFM :: UniqFM elt -> [elt] +nonDetEltsUFM (UFM m) = M.elems m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUFM :: UniqFM elt -> [Unique] +nonDetKeysUFM (UFM m) = map getUnique $ M.keys m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +nonDetFoldUFM k z (UFM m) = M.foldr k z m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a +nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] +nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m + +-- | A wrapper around 'UniqFM' with the sole purpose of informing call sites +-- that the provided 'Foldable' and 'Traversable' instances are +-- nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. +newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele } + deriving (Functor) + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. +instance Foldable NonDetUniqFM where + foldr f z (NonDetUniqFM (UFM m)) = foldr f z m + +-- | Inherently nondeterministic. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM to learn about determinism. +instance Traversable NonDetUniqFM where + traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m + +ufmToIntMap :: UniqFM elt -> M.IntMap elt +ufmToIntMap (UFM m) = m + +-- Determines whether two 'UniqFM's contain the same keys. +equalKeysUFM :: UniqFM a -> UniqFM b -> Bool +equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 + +-- Instances + +instance Semi.Semigroup (UniqFM a) where + (<>) = plusUFM + +instance Monoid (UniqFM a) where + mempty = emptyUFM + mappend = (Semi.<>) + +-- Output-ery + +instance Outputable a => Outputable (UniqFM a) where + ppr ufm = pprUniqFM ppr ufm + +pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc +pprUniqFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- nonDetUFMToList ufm ] + -- It's OK to use nonDetUFMToList here because we only use it for + -- pretty-printing. + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +pprUFM :: UniqFM a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFM ufm pp = pp (nonDetEltsUFM ufm) + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetUFMToList. +pprUFMWithKeys + :: UniqFM a -- ^ The things to be pretty printed + -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralUFM :: UniqFM a -> SDoc +pluralUFM ufm + | sizeUFM ufm == 1 = empty + | otherwise = char 's' diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs new file mode 100644 index 0000000000..5b06864629 --- /dev/null +++ b/compiler/GHC/Types/Unique/Map.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -Wall #-} + +-- Like 'UniqFM', these are maps for keys which are Uniquable. +-- Unlike 'UniqFM', these maps also remember their keys, which +-- makes them a much better drop in replacement for 'Data.Map.Map'. +-- +-- Key preservation is right-biased. +module GHC.Types.Unique.Map ( + UniqMap, + emptyUniqMap, + isNullUniqMap, + unitUniqMap, + listToUniqMap, + listToUniqMap_C, + addToUniqMap, + addListToUniqMap, + addToUniqMap_C, + addToUniqMap_Acc, + alterUniqMap, + addListToUniqMap_C, + adjustUniqMap, + delFromUniqMap, + delListFromUniqMap, + plusUniqMap, + plusUniqMap_C, + plusMaybeUniqMap_C, + plusUniqMapList, + minusUniqMap, + intersectUniqMap, + disjointUniqMap, + mapUniqMap, + filterUniqMap, + partitionUniqMap, + sizeUniqMap, + elemUniqMap, + lookupUniqMap, + lookupWithDefaultUniqMap, + anyUniqMap, + allUniqMap, + -- Non-deterministic functions omitted +) where + +import GhcPrelude + +import GHC.Types.Unique.FM + +import GHC.Types.Unique +import Outputable + +import Data.Semigroup as Semi ( Semigroup(..) ) +import Data.Coerce +import Data.Maybe +import Data.Data + +-- | Maps indexed by 'Uniquable' keys +newtype UniqMap k a = UniqMap (UniqFM (k, a)) + deriving (Data, Eq, Functor) +type role UniqMap nominal representational + +instance Semigroup (UniqMap k a) where + (<>) = plusUniqMap + +instance Monoid (UniqMap k a) where + mempty = emptyUniqMap + mappend = (Semi.<>) + +instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where + ppr (UniqMap m) = + brackets $ fsep $ punctuate comma $ + [ ppr k <+> text "->" <+> ppr v + | (k, v) <- eltsUFM m ] + +liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a) +liftC f (_, v) (k', v') = (k', f v v') + +emptyUniqMap :: UniqMap k a +emptyUniqMap = UniqMap emptyUFM + +isNullUniqMap :: UniqMap k a -> Bool +isNullUniqMap (UniqMap m) = isNullUFM m + +unitUniqMap :: Uniquable k => k -> a -> UniqMap k a +unitUniqMap k v = UniqMap (unitUFM k (k, v)) + +listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a +listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs]) + +listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a +listToUniqMap_C f kvs = UniqMap $ + listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs] + +addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a +addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v) + +addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a +addListToUniqMap (UniqMap m) kvs = UniqMap $ + addListToUFM m [(k,(k,v)) | (k,v) <- kvs] + +addToUniqMap_C :: Uniquable k + => (a -> a -> a) + -> UniqMap k a + -> k + -> a + -> UniqMap k a +addToUniqMap_C f (UniqMap m) k v = UniqMap $ + addToUFM_C (liftC f) m k (k, v) + +addToUniqMap_Acc :: Uniquable k + => (b -> a -> a) + -> (b -> a) + -> UniqMap k a + -> k + -> b + -> UniqMap k a +addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $ + addToUFM_Acc (\b (k, v) -> (k, exi b v)) + (\b -> (k0, new b)) + m k0 v0 + +alterUniqMap :: Uniquable k + => (Maybe a -> Maybe a) + -> UniqMap k a + -> k + -> UniqMap k a +alterUniqMap f (UniqMap m) k = UniqMap $ + alterUFM (fmap (k,) . f . fmap snd) m k + +addListToUniqMap_C + :: Uniquable k + => (a -> a -> a) + -> UniqMap k a + -> [(k, a)] + -> UniqMap k a +addListToUniqMap_C f (UniqMap m) kvs = UniqMap $ + addListToUFM_C (liftC f) m + [(k,(k,v)) | (k,v) <- kvs] + +adjustUniqMap + :: Uniquable k + => (a -> a) + -> UniqMap k a + -> k + -> UniqMap k a +adjustUniqMap f (UniqMap m) k = UniqMap $ + adjustUFM (\(_,v) -> (k,f v)) m k + +delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a +delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k + +delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a +delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks + +plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a +plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2 + +plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a +plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ + plusUFM_C (liftC f) m1 m2 + +plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a +plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ + plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2 + +plusUniqMapList :: [UniqMap k a] -> UniqMap k a +plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs) + +minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a +minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2 + +intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a +intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2 + +disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool +disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2 + +mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b +mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance + +filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a +filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m + +partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a) +partitionUniqMap f (UniqMap m) = + coerce $ partitionUFM (f . snd) m + +sizeUniqMap :: UniqMap k a -> Int +sizeUniqMap (UniqMap m) = sizeUFM m + +elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool +elemUniqMap k (UniqMap m) = elemUFM k m + +lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a +lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k) + +lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a +lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k)) + +anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool +anyUniqMap f (UniqMap m) = anyUFM (f . snd) m + +allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool +allUniqMap f (UniqMap m) = allUFM (f . snd) m diff --git a/compiler/GHC/Types/Unique/Set.hs b/compiler/GHC/Types/Unique/Set.hs new file mode 100644 index 0000000000..1c52a66732 --- /dev/null +++ b/compiler/GHC/Types/Unique/Set.hs @@ -0,0 +1,195 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[UniqSet]{Specialised sets, for things with @Uniques@} + +Based on @UniqFMs@ (as you would expect). + +Basically, the things need to be in class @Uniquable@. +-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Types.Unique.Set ( + -- * Unique set type + UniqSet, -- type synonym for UniqFM a + getUniqSet, + pprUniqSet, + + -- ** Manipulating these sets + emptyUniqSet, + unitUniqSet, + mkUniqSet, + addOneToUniqSet, addListToUniqSet, + delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, + delListFromUniqSet_Directly, + unionUniqSets, unionManyUniqSets, + minusUniqSet, uniqSetMinusUFM, + intersectUniqSets, + restrictUniqSetToUFM, + uniqSetAny, uniqSetAll, + elementOfUniqSet, + elemUniqSet_Directly, + filterUniqSet, + filterUniqSet_Directly, + sizeUniqSet, + isEmptyUniqSet, + lookupUniqSet, + lookupUniqSet_Directly, + partitionUniqSet, + mapUniqSet, + unsafeUFMToUniqSet, + nonDetEltsUniqSet, + nonDetKeysUniqSet, + nonDetFoldUniqSet, + nonDetFoldUniqSet_Directly + ) where + +import GhcPrelude + +import GHC.Types.Unique.FM +import GHC.Types.Unique +import Data.Coerce +import Outputable +import Data.Data +import qualified Data.Semigroup as Semi + +-- Note [UniqSet invariant] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- UniqSet has the following invariant: +-- The keys in the map are the uniques of the values +-- It means that to implement mapUniqSet you have to update +-- both the keys and the values. + +newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} + deriving (Data, Semi.Semigroup, Monoid) + +emptyUniqSet :: UniqSet a +emptyUniqSet = UniqSet emptyUFM + +unitUniqSet :: Uniquable a => a -> UniqSet a +unitUniqSet x = UniqSet $ unitUFM x x + +mkUniqSet :: Uniquable a => [a] -> UniqSet a +mkUniqSet = foldl' addOneToUniqSet emptyUniqSet + +addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) + +addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +addListToUniqSet = foldl' addOneToUniqSet + +delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) + +delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a +delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) + +delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) + +delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a +delListFromUniqSet_Directly (UniqSet s) l = + UniqSet (delListFromUFM_Directly s l) + +unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) + +unionManyUniqSets :: [UniqSet a] -> UniqSet a +unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet + +minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a +minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) + +intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) + +restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a +restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) + +uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a +uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) + +elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool +elementOfUniqSet a (UniqSet s) = elemUFM a s + +elemUniqSet_Directly :: Unique -> UniqSet a -> Bool +elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s + +filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a +filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) + +filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt +filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) + +partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) +partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) + +uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAny p (UniqSet s) = anyUFM p s + +uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAll p (UniqSet s) = allUFM p s + +sizeUniqSet :: UniqSet a -> Int +sizeUniqSet (UniqSet s) = sizeUFM s + +isEmptyUniqSet :: UniqSet a -> Bool +isEmptyUniqSet (UniqSet s) = isNullUFM s + +lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b +lookupUniqSet (UniqSet s) k = lookupUFM s k + +lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a +lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUniqSet :: UniqSet elt -> [elt] +nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUniqSet :: UniqSet elt -> [Unique] +nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a +nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a +nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s + +-- See Note [UniqSet invariant] +mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet + +-- Two 'UniqSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqSet a) where + UniqSet a == UniqSet b = equalKeysUFM a b + +getUniqSet :: UniqSet a -> UniqFM a +getUniqSet = getUniqSet' + +-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ +-- assuming, without checking, that it maps each 'Unique' to a value +-- that has that 'Unique'. See Note [UniqSet invariant]. +unsafeUFMToUniqSet :: UniqFM a -> UniqSet a +unsafeUFMToUniqSet = UniqSet + +instance Outputable a => Outputable (UniqSet a) where + ppr = pprUniqSet ppr + +pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc +-- It's OK to use nonDetUFMToList here because we only use it for +-- pretty-printing. +pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs new file mode 100644 index 0000000000..56c85efcce --- /dev/null +++ b/compiler/GHC/Types/Unique/Supply.hs @@ -0,0 +1,224 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} + +#if !defined(GHC_LOADED_INTO_GHCI) +{-# LANGUAGE UnboxedTuples #-} +#endif + +module GHC.Types.Unique.Supply ( + -- * Main data type + UniqSupply, -- Abstractly + + -- ** Operations on supplies + uniqFromSupply, uniqsFromSupply, -- basic ops + takeUniqFromSupply, uniqFromMask, + + mkSplitUniqSupply, + splitUniqSupply, listSplitUniqSupply, + + -- * Unique supply monad and its abstraction + UniqSM, MonadUnique(..), + + -- ** Operations on the monad + initUs, initUs_, + + -- * Set supply strategy + initUniqSupply + ) where + +import GhcPrelude + +import GHC.Types.Unique +import PlainPanic (panic) + +import GHC.IO + +import MonadUtils +import Control.Monad +import Data.Bits +import Data.Char +import Control.Monad.Fail as Fail + +#include "Unique.h" + +{- +************************************************************************ +* * +\subsection{Splittable Unique supply: @UniqSupply@} +* * +************************************************************************ +-} + +-- | Unique Supply +-- +-- A value of type 'UniqSupply' is unique, and it can +-- supply /one/ distinct 'Unique'. Also, from the supply, one can +-- also manufacture an arbitrary number of further 'UniqueSupply' values, +-- which will be distinct from the first and from all others. +data UniqSupply + = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this + UniqSupply UniqSupply + -- when split => these two supplies + +mkSplitUniqSupply :: Char -> IO UniqSupply +-- ^ Create a unique supply out of thin air. The character given must +-- be distinct from those of all calls to this function in the compiler +-- for the values generated to be truly unique. + +splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) +-- ^ Build two 'UniqSupply' from a single one, each of which +-- can supply its own 'Unique'. +listSplitUniqSupply :: UniqSupply -> [UniqSupply] +-- ^ Create an infinite list of 'UniqSupply' from a single one +uniqFromSupply :: UniqSupply -> Unique +-- ^ Obtain the 'Unique' from this particular 'UniqSupply' +uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite +-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply +takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) +-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply + +uniqFromMask :: Char -> IO Unique +uniqFromMask mask + = do { uqNum <- genSym + ; return $! mkUnique mask uqNum } + +mkSplitUniqSupply c + = case ord c `shiftL` uNIQUE_BITS of + !mask -> let + -- here comes THE MAGIC: + + -- This is one of the most hammered bits in the whole compiler + mk_supply + -- NB: Use unsafeInterleaveIO for thread-safety. + = unsafeInterleaveIO ( + genSym >>= \ u -> + mk_supply >>= \ s1 -> + mk_supply >>= \ s2 -> + return (MkSplitUniqSupply (mask .|. u) s1 s2) + ) + in + mk_supply + +foreign import ccall unsafe "genSym" genSym :: IO Int +foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO () + +splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) +listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 + +uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n +uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 +takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) + +{- +************************************************************************ +* * +\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} +* * +************************************************************************ +-} + +-- Avoids using unboxed tuples when loading into GHCi +#if !defined(GHC_LOADED_INTO_GHCI) + +type UniqResult result = (# result, UniqSupply #) + +pattern UniqResult :: a -> b -> (# a, b #) +pattern UniqResult x y = (# x, y #) +{-# COMPLETE UniqResult #-} + +#else + +data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply + deriving (Functor) + +#endif + +-- | A monad which just gives the ability to obtain 'Unique's +newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } + deriving (Functor) + +instance Monad UniqSM where + (>>=) = thenUs + (>>) = (*>) + +instance Applicative UniqSM where + pure = returnUs + (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of + UniqResult ff us1 -> case x us1 of + UniqResult xx us2 -> UniqResult (ff xx) us2 + (*>) = thenUs_ + +-- TODO: try to get rid of this instance +instance Fail.MonadFail UniqSM where + fail = panic + +-- | Run the 'UniqSM' action, returning the final 'UniqSupply' +initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) +initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) } + +-- | Run the 'UniqSM' action, discarding the final 'UniqSupply' +initUs_ :: UniqSupply -> UniqSM a -> a +initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } + +{-# INLINE thenUs #-} +{-# INLINE returnUs #-} +{-# INLINE splitUniqSupply #-} + +-- @thenUs@ is where we split the @UniqSupply@. + +liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) +liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) + +instance MonadFix UniqSM where + mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) + +thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b +thenUs (USM expr) cont + = USM (\us0 -> case (expr us0) of + UniqResult result us1 -> unUSM (cont result) us1) + +thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b +thenUs_ (USM expr) (USM cont) + = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 }) + +returnUs :: a -> UniqSM a +returnUs result = USM (\us -> UniqResult result us) + +getUs :: UniqSM UniqSupply +getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) + +-- | A monad for generating unique identifiers +class Monad m => MonadUnique m where + -- | Get a new UniqueSupply + getUniqueSupplyM :: m UniqSupply + -- | Get a new unique identifier + getUniqueM :: m Unique + -- | Get an infinite list of new unique identifiers + getUniquesM :: m [Unique] + + -- This default definition of getUniqueM, while correct, is not as + -- efficient as it could be since it needlessly generates and throws away + -- an extra Unique. For your instances consider providing an explicit + -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. + getUniqueM = liftM uniqFromSupply getUniqueSupplyM + getUniquesM = liftM uniqsFromSupply getUniqueSupplyM + +instance MonadUnique UniqSM where + getUniqueSupplyM = getUs + getUniqueM = getUniqueUs + getUniquesM = getUniquesUs + +getUniqueUs :: UniqSM Unique +getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of + (u,us1) -> UniqResult u us1) + +getUniquesUs :: UniqSM [Unique] +getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of + (us1,us2) -> UniqResult (uniqsFromSupply us1) us2) diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs new file mode 100644 index 0000000000..267d0fc786 --- /dev/null +++ b/compiler/GHC/Types/Var.hs @@ -0,0 +1,763 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{@Vars@: Variables} +-} + +{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally +-- potentially contain type variables, which have a 'GHC.Core.TyCo.Rep.Kind' +-- rather than a 'GHC.Core.TyCo.Rep.Type' and only contain some extra +-- details during typechecking. +-- +-- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" +-- +-- #globalvslocal# +-- Global 'Id's and 'Var's are those that are imported or correspond +-- to a data constructor, primitive operation, or record selectors. +-- Local 'Id's and 'Var's are those bound within an expression +-- (e.g. by a lambda) or at the top level of the module being compiled. + +module GHC.Types.Var ( + -- * The main data type and synonyms + Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, + TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, + + -- * In and Out variants + InVar, InCoVar, InId, InTyVar, + OutVar, OutCoVar, OutId, OutTyVar, + + -- ** Taking 'Var's apart + varName, varUnique, varType, + + -- ** Modifying 'Var's + setVarName, setVarUnique, setVarType, updateVarType, + updateVarTypeM, + + -- ** Constructing, taking apart, modifying 'Id's + mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, + idInfo, idDetails, + lazySetIdInfo, setIdDetails, globaliseId, + setIdExported, setIdNotExported, + + -- ** Predicates + isId, isTyVar, isTcTyVar, + isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, + isGlobalId, isExportedId, + mustHaveLocalBinding, + + -- * ArgFlags + ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis, + AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag, + + -- * TyVar's + VarBndr(..), TyCoVarBinder, TyVarBinder, + binderVar, binderVars, binderArgFlag, binderType, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinder, mkTyVarBinders, + isTyVarBinder, + + -- ** Constructing TyVar's + mkTyVar, mkTcTyVar, + + -- ** Taking 'TyVar's apart + tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, + + -- ** Modifying 'TyVar's + setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, + updateTyVarKindM, + + nonDetCmpVar + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) +import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) +import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails, + vanillaIdInfo, pprIdDetails ) + +import GHC.Types.Name hiding (varName) +import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique + , mkUniqueGrimily, nonDetCmpUnique ) +import Util +import Binary +import Outputable + +import Data.Data + +{- +************************************************************************ +* * + Synonyms +* * +************************************************************************ +-- These synonyms are here and not in Id because otherwise we need a very +-- large number of SOURCE imports of Id.hs :-( +-} + +-- | Identifier +type Id = Var -- A term-level identifier + -- predicate: isId + +-- | Coercion Variable +type CoVar = Id -- See Note [Evidence: EvIds and CoVars] + -- predicate: isCoVar + +-- | +type NcId = Id -- A term-level (value) variable that is + -- /not/ an (unlifted) coercion + -- predicate: isNonCoVarId + +-- | Type or kind Variable +type TyVar = Var -- Type *or* kind variable (historical) + +-- | Type or Kind Variable +type TKVar = Var -- Type *or* kind variable (historical) + +-- | Type variable that might be a metavariable +type TcTyVar = Var + +-- | Type Variable +type TypeVar = Var -- Definitely a type variable + +-- | Kind Variable +type KindVar = Var -- Definitely a kind variable + -- See Note [Kind and type variables] + +-- See Note [Evidence: EvIds and CoVars] +-- | Evidence Identifier +type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar + +-- | Evidence Variable +type EvVar = EvId -- ...historical name for EvId + +-- | Dictionary Function Identifier +type DFunId = Id -- A dictionary function + +-- | Dictionary Identifier +type DictId = EvId -- A dictionary variable + +-- | Implicit parameter Identifier +type IpId = EvId -- A term-level implicit parameter + +-- | Equality Variable +type EqVar = EvId -- Boxed equality evidence +type JoinId = Id -- A join variable + +-- | Type or Coercion Variable +type TyCoVar = Id -- Type, *or* coercion variable + -- predicate: isTyCoVar + + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied -} + +type InVar = Var +type InTyVar = TyVar +type InCoVar = CoVar +type InId = Id +type OutVar = Var +type OutTyVar = TyVar +type OutCoVar = CoVar +type OutId = Id + + + +{- Note [Evidence: EvIds and CoVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* An EvId (evidence Id) is a term-level evidence variable + (dictionary, implicit parameter, or equality). Could be boxed or unboxed. + +* DictId, IpId, and EqVar are synonyms when we know what kind of + evidence we are talking about. For example, an EqVar has type (t1 ~ t2). + +* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) + +Note [Kind and type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before kind polymorphism, TyVar were used to mean type variables. Now +they are used to mean kind *or* type variables. KindVar is used when we +know for sure that it is a kind variable. In future, we might want to +go over the whole compiler code to use: + - TKVar to mean kind or type variables + - TypeVar to mean type variables only + - KindVar to mean kind variables + + +************************************************************************ +* * +\subsection{The main data type declarations} +* * +************************************************************************ + + +Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a +@Type@, and an @IdInfo@ (non-essential info about it, e.g., +strictness). The essential info about different kinds of @Vars@ is +in its @VarDetails@. +-} + +-- | Variable +-- +-- Essentially a typed 'Name', that may also contain some additional information +-- about the 'Var' and its use sites. +data Var + = TyVar { -- Type and kind variables + -- see Note [Kind and type variables] + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + -- ^ Key for fast comparison + -- Identical to the Unique in the name, + -- cached here for speed + varType :: Kind -- ^ The type or kind of the 'Var' in question + } + + | TcTyVar { -- Used only during type inference + -- Used for kind variables during + -- inference, as well + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + varType :: Kind, + tc_tv_details :: TcTyVarDetails + } + + | Id { + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + varType :: Type, + idScope :: IdScope, + id_details :: IdDetails, -- Stable, doesn't change + id_info :: IdInfo } -- Unstable, updated by simplifier + +-- | Identifier Scope +data IdScope -- See Note [GlobalId/LocalId] + = GlobalId + | LocalId ExportFlag + +data ExportFlag -- See Note [ExportFlag on binders] + = NotExported -- ^ Not exported: may be discarded as dead code. + | Exported -- ^ Exported: kept alive + +{- Note [ExportFlag on binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An ExportFlag of "Exported" on a top-level binder says "keep this +binding alive; do not drop it as dead code". This transitively +keeps alive all the other top-level bindings that this binding refers +to. This property is persisted all the way down the pipeline, so that +the binding will be compiled all the way to object code, and its +symbols will appear in the linker symbol table. + +However, note that this use of "exported" is quite different to the +export list on a Haskell module. Setting the ExportFlag on an Id does +/not/ mean that if you import the module (in Haskell source code) you +will see this Id. Of course, things that appear in the export list +of the source Haskell module do indeed have their ExportFlag set. +But many other things, such as dictionary functions, are kept alive +by having their ExportFlag set, even though they are not exported +in the source-code sense. + +We should probably use a different term for ExportFlag, like +KeepAlive. + +Note [GlobalId/LocalId] +~~~~~~~~~~~~~~~~~~~~~~~ +A GlobalId is + * always a constant (top-level) + * imported, or data constructor, or primop, or record selector + * has a Unique that is globally unique across the whole + GHC invocation (a single invocation may compile multiple modules) + * never treated as a candidate by the free-variable finder; + it's a constant! + +A LocalId is + * bound within an expression (lambda, case, local let(rec)) + * or defined at top level in the module being compiled + * always treated as a candidate by the free-variable finder + +After CoreTidy, top-level LocalIds are turned into GlobalIds +-} + +instance Outputable Var where + ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds -> + getPprStyle $ \ppr_style -> + if | debugStyle ppr_style && (not supp_var_kinds) + -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> + dcolon <+> pprKind (tyVarKind var)) + | otherwise + -> ppr (varName var) <> ppr_debug var ppr_style + +ppr_debug :: Var -> PprStyle -> SDoc +ppr_debug (TyVar {}) sty + | debugStyle sty = brackets (text "tv") +ppr_debug (TcTyVar {tc_tv_details = d}) sty + | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) +ppr_debug (Id { idScope = s, id_details = d }) sty + | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) +ppr_debug _ _ = empty + +ppr_id_scope :: IdScope -> SDoc +ppr_id_scope GlobalId = text "gid" +ppr_id_scope (LocalId Exported) = text "lidx" +ppr_id_scope (LocalId NotExported) = text "lid" + +instance NamedThing Var where + getName = varName + +instance Uniquable Var where + getUnique = varUnique + +instance Eq Var where + a == b = realUnique a == realUnique b + +instance Ord Var where + a <= b = realUnique a <= realUnique b + a < b = realUnique a < realUnique b + a >= b = realUnique a >= realUnique b + a > b = realUnique a > realUnique b + a `compare` b = a `nonDetCmpVar` b + +-- | Compare Vars by their Uniques. +-- This is what Ord Var does, provided here to make it explicit at the +-- call-site that it can introduce non-determinism. +-- See Note [Unique Determinism] +nonDetCmpVar :: Var -> Var -> Ordering +nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b + +instance Data Var where + -- don't traverse? + toConstr _ = abstractConstr "Var" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Var" + +instance HasOccName Var where + occName = nameOccName . varName + +varUnique :: Var -> Unique +varUnique var = mkUniqueGrimily (realUnique var) + +setVarUnique :: Var -> Unique -> Var +setVarUnique var uniq + = var { realUnique = getKey uniq, + varName = setNameUnique (varName var) uniq } + +setVarName :: Var -> Name -> Var +setVarName var new_name + = var { realUnique = getKey (getUnique new_name), + varName = new_name } + +setVarType :: Id -> Type -> Id +setVarType id ty = id { varType = ty } + +updateVarType :: (Type -> Type) -> Id -> Id +updateVarType f id = id { varType = f (varType id) } + +updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id +updateVarTypeM f id = do { ty' <- f (varType id) + ; return (id { varType = ty' }) } + +{- ********************************************************************* +* * +* ArgFlag +* * +********************************************************************* -} + +-- | Argument Flag +-- +-- Is something required to appear in source Haskell ('Required'), +-- permitted by request ('Specified') (visible type application), or +-- prohibited entirely from appearing in source Haskell ('Inferred')? +-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep +data ArgFlag = Inferred | Specified | Required + deriving (Eq, Ord, Data) + -- (<) on ArgFlag means "is less visible than" + +-- | Does this 'ArgFlag' classify an argument that is written in Haskell? +isVisibleArgFlag :: ArgFlag -> Bool +isVisibleArgFlag Required = True +isVisibleArgFlag _ = False + +-- | Does this 'ArgFlag' classify an argument that is not written in Haskell? +isInvisibleArgFlag :: ArgFlag -> Bool +isInvisibleArgFlag = not . isVisibleArgFlag + +-- | Do these denote the same level of visibility? 'Required' +-- arguments are visible, others are not. So this function +-- equates 'Specified' and 'Inferred'. Used for printing. +sameVis :: ArgFlag -> ArgFlag -> Bool +sameVis Required Required = True +sameVis Required _ = False +sameVis _ Required = False +sameVis _ _ = True + +instance Outputable ArgFlag where + ppr Required = text "[req]" + ppr Specified = text "[spec]" + ppr Inferred = text "[infrd]" + +instance Binary ArgFlag where + put_ bh Required = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Inferred = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Required + 1 -> return Specified + _ -> return Inferred + +-- | The non-dependent version of 'ArgFlag'. + +-- Appears here partly so that it's together with its friend ArgFlag, +-- but also because it is used in IfaceType, rather early in the +-- compilation chain +-- See Note [AnonArgFlag vs. ForallVisFlag] +data AnonArgFlag + = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. + -- The argument is visible in source code. + | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. + -- The argument is invisible in source code. + deriving (Eq, Ord, Data) + +instance Outputable AnonArgFlag where + ppr VisArg = text "[vis]" + ppr InvisArg = text "[invis]" + +instance Binary AnonArgFlag where + put_ bh VisArg = putByte bh 0 + put_ bh InvisArg = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return VisArg + _ -> return InvisArg + +-- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible +-- (e.g., @forall a b -> {...}@, with an arrow)? + +-- See Note [AnonArgFlag vs. ForallVisFlag] +data ForallVisFlag + = ForallVis -- ^ A visible @forall@ (with an arrow) + | ForallInvis -- ^ An invisible @forall@ (with a dot) + deriving (Eq, Ord, Data) + +instance Outputable ForallVisFlag where + ppr f = text $ case f of + ForallVis -> "ForallVis" + ForallInvis -> "ForallInvis" + +-- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'. +argToForallVisFlag :: ArgFlag -> ForallVisFlag +argToForallVisFlag Required = ForallVis +argToForallVisFlag Specified = ForallInvis +argToForallVisFlag Inferred = ForallInvis + +{- +Note [AnonArgFlag vs. ForallVisFlag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The AnonArgFlag and ForallVisFlag data types are quite similar at a first +glance: + + data AnonArgFlag = VisArg | InvisArg + data ForallVisFlag = ForallVis | ForallInvis + +Both data types keep track of visibility of some sort. AnonArgFlag tracks +whether a FunTy has a visible argument (->) or an invisible predicate argument +(=>). ForallVisFlag tracks whether a `forall` quantifier is visible +(forall a -> {...}) or invisible (forall a. {...}). + +Given their similarities, it's tempting to want to combine these two data types +into one, but they actually represent distinct concepts. AnonArgFlag reflects a +property of *Core* types, whereas ForallVisFlag reflects a property of the GHC +AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag +is all about surface syntax. Therefore, they are kept as separate data types. +-} + +{- ********************************************************************* +* * +* VarBndr, TyCoVarBinder +* * +********************************************************************* -} + +-- Variable Binder +-- +-- VarBndr is polymorphic in both var and visibility fields. +-- Currently there are six different uses of 'VarBndr': +-- * Var.TyVarBinder = VarBndr TyVar ArgFlag +-- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag +-- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis +-- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis +-- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +-- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +data VarBndr var argf = Bndr var argf + deriving( Data ) + +-- | Variable Binder +-- +-- A 'TyCoVarBinder' is the binder of a ForAllTy +-- It's convenient to define this synonym here rather its natural +-- home in GHC.Core.TyCo.Rep, because it's used in GHC.Core.DataCon.hs-boot +-- +-- A 'TyVarBinder' is a binder with only TyVar +type TyCoVarBinder = VarBndr TyCoVar ArgFlag +type TyVarBinder = VarBndr TyVar ArgFlag + +binderVar :: VarBndr tv argf -> tv +binderVar (Bndr v _) = v + +binderVars :: [VarBndr tv argf] -> [tv] +binderVars tvbs = map binderVar tvbs + +binderArgFlag :: VarBndr tv argf -> argf +binderArgFlag (Bndr _ argf) = argf + +binderType :: VarBndr TyCoVar argf -> Type +binderType (Bndr tv _) = varType tv + +-- | Make a named binder +mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder +mkTyCoVarBinder vis var = Bndr var vis + +-- | Make a named binder +-- 'var' should be a type variable +mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder +mkTyVarBinder vis var + = ASSERT( isTyVar var ) + Bndr var vis + +-- | Make many named binders +mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] +mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) + +-- | Make many named binders +-- Input vars should be type variables +mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] +mkTyVarBinders vis = map (mkTyVarBinder vis) + +isTyVarBinder :: TyCoVarBinder -> Bool +isTyVarBinder (Bndr v _) = isTyVar v + +instance Outputable tv => Outputable (VarBndr tv ArgFlag) where + ppr (Bndr v Required) = ppr v + ppr (Bndr v Specified) = char '@' <> ppr v + ppr (Bndr v Inferred) = braces (ppr v) + +instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where + put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } + + get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } + +instance NamedThing tv => NamedThing (VarBndr tv flag) where + getName (Bndr tv _) = getName tv + +{- +************************************************************************ +* * +* Type and kind variables * +* * +************************************************************************ +-} + +tyVarName :: TyVar -> Name +tyVarName = varName + +tyVarKind :: TyVar -> Kind +tyVarKind = varType + +setTyVarUnique :: TyVar -> Unique -> TyVar +setTyVarUnique = setVarUnique + +setTyVarName :: TyVar -> Name -> TyVar +setTyVarName = setVarName + +setTyVarKind :: TyVar -> Kind -> TyVar +setTyVarKind tv k = tv {varType = k} + +updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar +updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} + +updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar +updateTyVarKindM update tv + = do { k' <- update (tyVarKind tv) + ; return $ tv {varType = k'} } + +mkTyVar :: Name -> Kind -> TyVar +mkTyVar name kind = TyVar { varName = name + , realUnique = getKey (nameUnique name) + , varType = kind + } + +mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar +mkTcTyVar name kind details + = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' + TcTyVar { varName = name, + realUnique = getKey (nameUnique name), + varType = kind, + tc_tv_details = details + } + +tcTyVarDetails :: TyVar -> TcTyVarDetails +-- See Note [TcTyVars in the typechecker] in TcType +tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details +tcTyVarDetails (TyVar {}) = vanillaSkolemTv +tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) + +setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar +setTcTyVarDetails tv details = tv { tc_tv_details = details } + +{- +%************************************************************************ +%* * +\subsection{Ids} +* * +************************************************************************ +-} + +idInfo :: HasDebugCallStack => Id -> IdInfo +idInfo (Id { id_info = info }) = info +idInfo other = pprPanic "idInfo" (ppr other) + +idDetails :: Id -> IdDetails +idDetails (Id { id_details = details }) = details +idDetails other = pprPanic "idDetails" (ppr other) + +-- The next three have a 'Var' suffix even though they always build +-- Ids, because Id.hs uses 'mkGlobalId' etc with different types +mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalVar details name ty info + = mk_id name ty GlobalId details info + +mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkLocalVar details name ty info + = mk_id name ty (LocalId NotExported) details info + +mkCoVar :: Name -> Type -> CoVar +-- Coercion variables have no IdInfo +mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo + +-- | Exported 'Var's will not be removed as dead code +mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkExportedLocalVar details name ty info + = mk_id name ty (LocalId Exported) details info + +mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id +mk_id name ty scope details info + = Id { varName = name, + realUnique = getKey (nameUnique name), + varType = ty, + idScope = scope, + id_details = details, + id_info = info } + +------------------- +lazySetIdInfo :: Id -> IdInfo -> Var +lazySetIdInfo id info = id { id_info = info } + +setIdDetails :: Id -> IdDetails -> Id +setIdDetails id details = id { id_details = details } + +globaliseId :: Id -> Id +-- ^ If it's a local, make it global +globaliseId id = id { idScope = GlobalId } + +setIdExported :: Id -> Id +-- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors +-- and class operations, which are born as global 'Id's and automatically exported +setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } +setIdExported id@(Id { idScope = GlobalId }) = id +setIdExported tv = pprPanic "setIdExported" (ppr tv) + +setIdNotExported :: Id -> Id +-- ^ We can only do this to LocalIds +setIdNotExported id = ASSERT( isLocalId id ) + id { idScope = LocalId NotExported } + +{- +************************************************************************ +* * +\subsection{Predicates over variables} +* * +************************************************************************ +-} + +-- | Is this a type-level (i.e., computationally irrelevant, thus erasable) +-- variable? Satisfies @isTyVar = not . isId@. +isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar +isTyVar (TyVar {}) = True +isTyVar (TcTyVar {}) = True +isTyVar _ = False + +isTcTyVar :: Var -> Bool -- True of TcTyVar only +isTcTyVar (TcTyVar {}) = True +isTcTyVar _ = False + +isTyCoVar :: Var -> Bool +isTyCoVar v = isTyVar v || isCoVar v + +-- | Is this a value-level (i.e., computationally relevant) 'Id'entifier? +-- Satisfies @isId = not . isTyVar@. +isId :: Var -> Bool +isId (Id {}) = True +isId _ = False + +-- | Is this a coercion variable? +-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. +isCoVar :: Var -> Bool +isCoVar (Id { id_details = details }) = isCoVarDetails details +isCoVar _ = False + +-- | Is this a term variable ('Id') that is /not/ a coercion variable? +-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. +isNonCoVarId :: Var -> Bool +isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) +isNonCoVarId _ = False + +isLocalId :: Var -> Bool +isLocalId (Id { idScope = LocalId _ }) = True +isLocalId _ = False + +-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's +-- These are the variables that we need to pay attention to when finding free +-- variables, or doing dependency analysis. +isLocalVar :: Var -> Bool +isLocalVar v = not (isGlobalId v) + +isGlobalId :: Var -> Bool +isGlobalId (Id { idScope = GlobalId }) = True +isGlobalId _ = False + +-- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's +-- that must have a binding in this module. The converse +-- is not quite right: there are some global 'Id's that must have +-- bindings, such as record selectors. But that doesn't matter, +-- because it's only used for assertions +mustHaveLocalBinding :: Var -> Bool +mustHaveLocalBinding var = isLocalVar var + +-- | 'isExportedIdVar' means \"don't throw this away\" +isExportedId :: Var -> Bool +isExportedId (Id { idScope = GlobalId }) = True +isExportedId (Id { idScope = LocalId Exported}) = True +isExportedId _ = False diff --git a/compiler/GHC/Types/Var.hs-boot b/compiler/GHC/Types/Var.hs-boot new file mode 100644 index 0000000000..bf83f8cda6 --- /dev/null +++ b/compiler/GHC/Types/Var.hs-boot @@ -0,0 +1,14 @@ +module GHC.Types.Var where + +import GhcPrelude () + -- 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 GHC.Type is built first. + +data ArgFlag +data AnonArgFlag +data Var diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs new file mode 100644 index 0000000000..fff3dc897d --- /dev/null +++ b/compiler/GHC/Types/Var/Env.hs @@ -0,0 +1,632 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Types.Var.Env ( + -- * Var, Id and TyVar environments (maps) + VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, + + -- ** Manipulating these environments + emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, + elemVarEnv, disjointVarEnv, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, + extendVarEnvList, + plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + plusVarEnvList, alterVarEnv, + delVarEnvList, delVarEnv, delVarEnv_Directly, + minusVarEnv, intersectsVarEnv, + lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, + mapVarEnv, zipVarEnv, + modifyVarEnv, modifyVarEnv_Directly, + isEmptyVarEnv, + elemVarEnvByKey, lookupVarEnv_Directly, + filterVarEnv, filterVarEnv_Directly, restrictVarEnv, + partitionVarEnv, + + -- * Deterministic Var environments (maps) + DVarEnv, DIdEnv, DTyVarEnv, + + -- ** Manipulating these environments + emptyDVarEnv, mkDVarEnv, + dVarEnvElts, + extendDVarEnv, extendDVarEnv_C, + extendDVarEnvList, + lookupDVarEnv, elemDVarEnv, + isEmptyDVarEnv, foldDVarEnv, + mapDVarEnv, filterDVarEnv, + modifyDVarEnv, + alterDVarEnv, + plusDVarEnv, plusDVarEnv_C, + unitDVarEnv, + delDVarEnv, + delDVarEnvList, + minusDVarEnv, + partitionDVarEnv, + anyDVarEnv, + + -- * The InScopeSet type + InScopeSet, + + -- ** Operations on InScopeSets + emptyInScopeSet, mkInScopeSet, delInScopeSet, + extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, + getInScopeVars, lookupInScope, lookupInScope_Directly, + unionInScope, elemInScopeSet, uniqAway, + varSetInScope, + unsafeGetFreshLocalUnique, + + -- * The RnEnv2 type + RnEnv2, + + -- ** Operations on RnEnv2s + mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, + delBndrL, delBndrR, delBndrsL, delBndrsR, + addRnInScopeSet, + rnEtaL, rnEtaR, + rnInScope, rnInScopeSet, lookupRnInScope, + rnEnvL, rnEnvR, + + -- * TidyEnv and its operation + TidyEnv, + emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList + ) where + +import GhcPrelude +import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM + +import GHC.Types.Name.Occurrence +import GHC.Types.Name +import GHC.Types.Var as Var +import GHC.Types.Var.Set +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 + +{- +************************************************************************ +* * + In-scope sets +* * +************************************************************************ +-} + +-- | A set of variables that are in scope at some point +-- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides +-- the motivation for this abstraction. +newtype InScopeSet = InScope VarSet + -- Note [Lookups in in-scope set] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We store a VarSet here, but we use this for lookups rather than just + -- membership tests. Typically the InScopeSet contains the canonical + -- version of the variable (e.g. with an informative unfolding), so this + -- lookup is useful (see, for instance, Note [In-scope set as a + -- substitution]). + +instance Outputable InScopeSet where + ppr (InScope s) = + text "InScope" <+> + braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) + -- It's OK to use nonDetEltsUniqSet here because it's + -- only for pretty printing + -- In-scope sets get big, and with -dppr-debug + -- the output is overwhelming + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet + +getInScopeVars :: InScopeSet -> VarSet +getInScopeVars (InScope vs) = vs + +mkInScopeSet :: VarSet -> InScopeSet +mkInScopeSet in_scope = InScope in_scope + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope) v + = InScope (extendVarSet in_scope v) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope) vs + = InScope $ foldl' extendVarSet in_scope vs + +extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet +extendInScopeSetSet (InScope in_scope) vs + = InScope (in_scope `unionVarSet` vs) + +delInScopeSet :: InScopeSet -> Var -> InScopeSet +delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v) + +elemInScopeSet :: Var -> InScopeSet -> Bool +elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope + +-- | Look up a variable the 'InScopeSet'. This lets you map from +-- the variable's identity (unique) to its full value. +lookupInScope :: InScopeSet -> Var -> Maybe Var +lookupInScope (InScope in_scope) v = lookupVarSet in_scope v + +lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var +lookupInScope_Directly (InScope in_scope) uniq + = lookupVarSet_Directly in_scope uniq + +unionInScope :: InScopeSet -> InScopeSet -> InScopeSet +unionInScope (InScope s1) (InScope s2) + = InScope (s1 `unionVarSet` s2) + +varSetInScope :: VarSet -> InScopeSet -> Bool +varSetInScope vars (InScope s1) = vars `subVarSet` s1 + +{- +Note [Local uniques] +~~~~~~~~~~~~~~~~~~~~ +Sometimes one must create conjure up a unique which is unique in a particular +context (but not necessarily globally unique). For instance, one might need to +create a fresh local identifier which does not shadow any of the locally +in-scope variables. For this we purpose we provide 'uniqAway'. + +'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique' +operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To +ensure that we do not conflict with uniques allocated by future allocations +from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are +allocated into a dedicated region of the unique space (namely the X tag). + +Note that one must be quite carefully when using uniques generated in this way +since they are only locally unique. In particular, two successive calls to +'uniqAway' on the same 'InScopeSet' will produce the same unique. + -} + +-- | @uniqAway in_scope v@ finds a unique that is not used in the +-- in-scope set, and gives that to v. See Note [Local uniques]. +uniqAway :: InScopeSet -> Var -> Var +-- It starts with v's current unique, of course, in the hope that it won't +-- have to change, and thereafter uses the successor to the last derived unique +-- found in the in-scope set. +uniqAway in_scope var + | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one + | otherwise = var -- Nothing to do + +uniqAway' :: InScopeSet -> Var -> Var +-- This one *always* makes up a new variable +uniqAway' in_scope var + = setVarUnique var (unsafeGetFreshLocalUnique in_scope) + +-- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the +-- given 'InScopeSet'. This must be used very carefully since one can very easily +-- introduce non-unique 'Unique's this way. See Note [Local uniques]. +unsafeGetFreshLocalUnique :: InScopeSet -> Unique +unsafeGetFreshLocalUnique (InScope set) + | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set) + , let uniq' = mkLocalUnique uniq + , not $ uniq' `ltUnique` minLocalUnique + = incrUnique uniq' + + | otherwise + = minLocalUnique + +{- +************************************************************************ +* * + Dual renaming +* * +************************************************************************ +-} + +-- | Rename Environment 2 +-- +-- When we are comparing (or matching) types or terms, we are faced with +-- \"going under\" corresponding binders. E.g. when comparing: +-- +-- > \x. e1 ~ \y. e2 +-- +-- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of +-- things we must be careful of. In particular, @x@ might be free in @e2@, or +-- y in @e1@. So the idea is that we come up with a fresh binder that is free +-- in neither, and rename @x@ and @y@ respectively. That means we must maintain: +-- +-- 1. A renaming for the left-hand expression +-- +-- 2. A renaming for the right-hand expressions +-- +-- 3. An in-scope set +-- +-- Furthermore, when matching, we want to be able to have an 'occurs check', +-- to prevent: +-- +-- > \x. f ~ \y. y +-- +-- matching with [@f@ -> @y@]. So for each expression we want to know that set of +-- locally-bound variables. That is precisely the domain of the mappings 1. +-- and 2., but we must ensure that we always extend the mappings as we go in. +-- +-- All of this information is bundled up in the 'RnEnv2' +data RnEnv2 + = RV2 { envL :: VarEnv Var -- Renaming for Left term + , envR :: VarEnv Var -- Renaming for Right term + , in_scope :: InScopeSet } -- In scope in left or right terms + +-- The renamings envL and envR are *guaranteed* to contain a binding +-- for every variable bound as we go into the term, even if it is not +-- renamed. That way we can ask what variables are locally bound +-- (inRnEnvL, inRnEnvR) + +mkRnEnv2 :: InScopeSet -> RnEnv2 +mkRnEnv2 vars = RV2 { envL = emptyVarEnv + , envR = emptyVarEnv + , in_scope = vars } + +addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 +addRnInScopeSet env vs + | isEmptyVarSet vs = env + | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } + +rnInScope :: Var -> RnEnv2 -> Bool +rnInScope x env = x `elemInScopeSet` in_scope env + +rnInScopeSet :: RnEnv2 -> InScopeSet +rnInScopeSet = in_scope + +-- | Retrieve the left mapping +rnEnvL :: RnEnv2 -> VarEnv Var +rnEnvL = envL + +-- | Retrieve the right mapping +rnEnvR :: RnEnv2 -> VarEnv Var +rnEnvR = envR + +rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 +-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length +rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR + +rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 +-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, +-- and binder @bR@ in the Right term. +-- It finds a new binder, @new_b@, +-- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ +rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR + +rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but returns the new variable as well as the +-- new environment +rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR + = (RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + -- Find a new binder not in scope in either term + new_b | not (bL `elemInScopeSet` in_scope) = bL + | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bL + + -- Note [Rebinding] + -- If the new var is the same as the old one, note that + -- the extendVarEnv *deletes* any current renaming + -- E.g. (\x. \x. ...) ~ (\y. \z. ...) + -- + -- Inside \x \y { [x->y], [y->y], {y} } + -- \x \z { [x->x], [y->y, z->x], {y,x} } + +rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the left +-- side only. +rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = envR + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the right +-- side only. +rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envR = extendVarEnv envR bR new_b + , envL = envL + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndrL' but used for eta expansion +-- See Note [Eta expansion] +rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used for eta expansion +-- See Note [Eta expansion] +rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 +delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } + +delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 +delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } + +rnOccL, rnOccR :: RnEnv2 -> Var -> Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v +rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v + +rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v +rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v + +inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool +-- ^ Tells whether a variable is locally bound +inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env +inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env + +lookupRnInScope :: RnEnv2 -> Var -> Var +lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v + +nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +-- ^ Wipe the left or right side renaming +nukeRnEnvL env = env { envL = emptyVarEnv } +nukeRnEnvR env = env { envR = emptyVarEnv } + +rnSwap :: RnEnv2 -> RnEnv2 +-- ^ swap the meaning of left and right +rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) + = RV2 { envL = envR, envR = envL, in_scope = in_scope } + +{- +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~ +When matching + (\x.M) ~ N +we rename x to x' with, where x' is not in scope in +either term. Then we want to behave as if we'd seen + (\x'.M) ~ (\x'.N x') +Since x' isn't in scope in N, the form (\x'. N x') doesn't +capture any variables in N. But we must nevertheless extend +the envR with a binding [x' -> x'], to support the occurs check. +For example, if we don't do this, we can get silly matches like + forall a. (\y.a) ~ v +succeeding with [a -> v y], which is bogus of course. + + +************************************************************************ +* * + Tidying +* * +************************************************************************ +-} + +-- | Tidy Environment +-- +-- When tidying up print names, we keep a mapping of in-scope occ-names +-- (the 'TidyOccEnv') and a Var-to-Var of the current renamings +type TidyEnv = (TidyOccEnv, VarEnv Var) + +emptyTidyEnv :: TidyEnv +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) + +mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv +mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) + +delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv +delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env') + where + occ_env' = occ_env `delTidyOccEnvList` map (occNameFS . getOccName) vs + var_env' = var_env `delVarEnvList` vs + +{- +************************************************************************ +* * +\subsection{@VarEnv@s} +* * +************************************************************************ +-} + +-- | Variable Environment +type VarEnv elt = UniqFM elt + +-- | Identifier Environment +type IdEnv elt = VarEnv elt + +-- | Type Variable Environment +type TyVarEnv elt = VarEnv elt + +-- | Type or Coercion Variable Environment +type TyCoVarEnv elt = VarEnv elt + +-- | Coercion Variable Environment +type CoVarEnv elt = VarEnv elt + +emptyVarEnv :: VarEnv a +mkVarEnv :: [(Var, a)] -> VarEnv a +mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a +zipVarEnv :: [Var] -> [a] -> VarEnv a +unitVarEnv :: Var -> a -> VarEnv a +alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a +extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b +extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a +plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +plusVarEnvList :: [VarEnv a] -> VarEnv a +extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a + +lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a +filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a +delVarEnv_Directly :: VarEnv a -> Unique -> VarEnv a +partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) +restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a +delVarEnvList :: VarEnv a -> [Var] -> VarEnv a +delVarEnv :: VarEnv a -> Var -> VarEnv a +minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a +intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool +plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a +plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a +mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b +modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a + +isEmptyVarEnv :: VarEnv a -> Bool +lookupVarEnv :: VarEnv a -> Var -> Maybe a +filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a +lookupVarEnv_NF :: VarEnv a -> Var -> a +lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a +elemVarEnv :: Var -> VarEnv a -> Bool +elemVarEnvByKey :: Unique -> VarEnv a -> Bool +disjointVarEnv :: VarEnv a -> VarEnv a -> Bool + +elemVarEnv = elemUFM +elemVarEnvByKey = elemUFM_Directly +disjointVarEnv = disjointUFM +alterVarEnv = alterUFM +extendVarEnv = addToUFM +extendVarEnv_C = addToUFM_C +extendVarEnv_Acc = addToUFM_Acc +extendVarEnv_Directly = addToUFM_Directly +extendVarEnvList = addListToUFM +plusVarEnv_C = plusUFM_C +plusVarEnv_CD = plusUFM_CD +plusMaybeVarEnv_C = plusMaybeUFM_C +delVarEnvList = delListFromUFM +delVarEnv = delFromUFM +minusVarEnv = minusUFM +intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) +plusVarEnv = plusUFM +plusVarEnvList = plusUFMList +lookupVarEnv = lookupUFM +filterVarEnv = filterUFM +lookupWithDefaultVarEnv = lookupWithDefaultUFM +mapVarEnv = mapUFM +mkVarEnv = listToUFM +mkVarEnv_Directly= listToUFM_Directly +emptyVarEnv = emptyUFM +unitVarEnv = unitUFM +isEmptyVarEnv = isNullUFM +lookupVarEnv_Directly = lookupUFM_Directly +filterVarEnv_Directly = filterUFM_Directly +delVarEnv_Directly = delFromUFM_Directly +partitionVarEnv = partitionUFM + +restrictVarEnv env vs = filterVarEnv_Directly keep env + where + keep u _ = u `elemVarSetByKey` vs + +zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) +lookupVarEnv_NF env id = case lookupVarEnv env id of + Just xx -> xx + Nothing -> panic "lookupVarEnv_NF: Nothing" + +{- +@modifyVarEnv@: Look up a thing in the VarEnv, +then mash it with the modify function, and put it back. +-} + +modifyVarEnv mangle_fn env key + = case (lookupVarEnv env key) of + Nothing -> env + Just xx -> extendVarEnv env key (mangle_fn xx) + +modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a +modifyVarEnv_Directly mangle_fn env key + = case (lookupUFM_Directly env key) of + Nothing -> env + Just xx -> addToUFM_Directly env key (mangle_fn xx) + +-- Deterministic VarEnv +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DVarEnv. + +-- | Deterministic Variable Environment +type DVarEnv elt = UniqDFM elt + +-- | Deterministic Identifier Environment +type DIdEnv elt = DVarEnv elt + +-- | Deterministic Type Variable Environment +type DTyVarEnv elt = DVarEnv elt + +emptyDVarEnv :: DVarEnv a +emptyDVarEnv = emptyUDFM + +dVarEnvElts :: DVarEnv a -> [a] +dVarEnvElts = eltsUDFM + +mkDVarEnv :: [(Var, a)] -> DVarEnv a +mkDVarEnv = listToUDFM + +extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv = addToUDFM + +minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a +minusDVarEnv = minusUDFM + +lookupDVarEnv :: DVarEnv a -> Var -> Maybe a +lookupDVarEnv = lookupUDFM + +foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b +foldDVarEnv = foldUDFM + +mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b +mapDVarEnv = mapUDFM + +filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a +filterDVarEnv = filterUDFM + +alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a +alterDVarEnv = alterUDFM + +plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv = plusUDFM + +plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv_C = plusUDFM_C + +unitDVarEnv :: Var -> a -> DVarEnv a +unitDVarEnv = unitUDFM + +delDVarEnv :: DVarEnv a -> Var -> DVarEnv a +delDVarEnv = delFromUDFM + +delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a +delDVarEnvList = delListFromUDFM + +isEmptyDVarEnv :: DVarEnv a -> Bool +isEmptyDVarEnv = isNullUDFM + +elemDVarEnv :: Var -> DVarEnv a -> Bool +elemDVarEnv = elemUDFM + +extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv_C = addToUDFM_C + +modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a +modifyDVarEnv mangle_fn env key + = case (lookupDVarEnv env key) of + Nothing -> env + Just xx -> extendDVarEnv env key (mangle_fn xx) + +partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) +partitionDVarEnv = partitionUDFM + +extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a +extendDVarEnvList = addListToUDFM + +anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool +anyDVarEnv = anyUDFM diff --git a/compiler/GHC/Types/Var/Set.hs b/compiler/GHC/Types/Var/Set.hs new file mode 100644 index 0000000000..5126988a2c --- /dev/null +++ b/compiler/GHC/Types/Var/Set.hs @@ -0,0 +1,354 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +module GHC.Types.Var.Set ( + -- * Var, Id and TyVar set types + VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, + + -- ** Manipulating these sets + emptyVarSet, unitVarSet, mkVarSet, + extendVarSet, extendVarSetList, + elemVarSet, subVarSet, + unionVarSet, unionVarSets, mapUnionVarSet, + intersectVarSet, intersectsVarSet, disjointVarSet, + isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, + minusVarSet, filterVarSet, mapVarSet, + anyVarSet, allVarSet, + transCloVarSet, fixVarSet, + lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, + sizeVarSet, seqVarSet, + elemVarSetByKey, partitionVarSet, + pluralVarSet, pprVarSet, + nonDetFoldVarSet, + + -- * Deterministic Var set types + DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, + + -- ** Manipulating these sets + emptyDVarSet, unitDVarSet, mkDVarSet, + extendDVarSet, extendDVarSetList, + elemDVarSet, dVarSetElems, subDVarSet, + unionDVarSet, unionDVarSets, mapUnionDVarSet, + intersectDVarSet, dVarSetIntersectVarSet, + intersectsDVarSet, disjointDVarSet, + isEmptyDVarSet, delDVarSet, delDVarSetList, + minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet, + dVarSetMinusVarSet, anyDVarSet, allDVarSet, + transCloDVarSet, + sizeDVarSet, seqDVarSet, + partitionDVarSet, + dVarSetToVarSet, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Types.Var ( Var, TyVar, CoVar, TyCoVar, Id ) +import GHC.Types.Unique +import GHC.Types.Name ( Name ) +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) + +-- | A non-deterministic Variable Set +-- +-- A non-deterministic set of variables. +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why it's not +-- deterministic and why it matters. Use DVarSet if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code, for example when abstracting variables. +type VarSet = UniqSet Var + +-- | Identifier Set +type IdSet = UniqSet Id + +-- | Type Variable Set +type TyVarSet = UniqSet TyVar + +-- | Coercion Variable Set +type CoVarSet = UniqSet CoVar + +-- | Type or Coercion Variable Set +type TyCoVarSet = UniqSet TyCoVar + +emptyVarSet :: VarSet +intersectVarSet :: VarSet -> VarSet -> VarSet +unionVarSet :: VarSet -> VarSet -> VarSet +unionVarSets :: [VarSet] -> VarSet + +mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet +-- ^ map the function over the list, and union the results + +unitVarSet :: Var -> VarSet +extendVarSet :: VarSet -> Var -> VarSet +extendVarSetList:: VarSet -> [Var] -> VarSet +elemVarSet :: Var -> VarSet -> Bool +delVarSet :: VarSet -> Var -> VarSet +delVarSetList :: VarSet -> [Var] -> VarSet +minusVarSet :: VarSet -> VarSet -> VarSet +isEmptyVarSet :: VarSet -> Bool +mkVarSet :: [Var] -> VarSet +lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var +lookupVarSet :: VarSet -> Var -> Maybe Var + -- Returns the set element, which may be + -- (==) to the argument, but not the same as +lookupVarSetByName :: VarSet -> Name -> Maybe Var +sizeVarSet :: VarSet -> Int +filterVarSet :: (Var -> Bool) -> VarSet -> VarSet + +delVarSetByKey :: VarSet -> Unique -> VarSet +elemVarSetByKey :: Unique -> VarSet -> Bool +partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) + +emptyVarSet = emptyUniqSet +unitVarSet = unitUniqSet +extendVarSet = addOneToUniqSet +extendVarSetList= addListToUniqSet +intersectVarSet = intersectUniqSets + +intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection +disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection +subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second + -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; + -- ditto disjointVarSet, subVarSet + +unionVarSet = unionUniqSets +unionVarSets = unionManyUniqSets +elemVarSet = elementOfUniqSet +minusVarSet = minusUniqSet +delVarSet = delOneFromUniqSet +delVarSetList = delListFromUniqSet +isEmptyVarSet = isEmptyUniqSet +mkVarSet = mkUniqSet +lookupVarSet_Directly = lookupUniqSet_Directly +lookupVarSet = lookupUniqSet +lookupVarSetByName = lookupUniqSet +sizeVarSet = sizeUniqSet +filterVarSet = filterUniqSet +delVarSetByKey = delOneFromUniqSet_Directly +elemVarSetByKey = elemUniqSet_Directly +partitionVarSet = partitionUniqSet + +mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs + +-- See comments with type signatures +intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) +disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) +subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) + +anyVarSet :: (Var -> Bool) -> VarSet -> Bool +anyVarSet = uniqSetAny + +allVarSet :: (Var -> Bool) -> VarSet -> Bool +allVarSet = uniqSetAll + +mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapVarSet = mapUniqSet + +nonDetFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a +nonDetFoldVarSet = nonDetFoldUniqSet + +fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set + -> VarSet -> VarSet +-- (fixVarSet f s) repeatedly applies f to the set s, +-- until it reaches a fixed point. +fixVarSet fn vars + | new_vars `subVarSet` vars = vars + | otherwise = fixVarSet fn new_vars + where + new_vars = fn vars + +transCloVarSet :: (VarSet -> VarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> VarSet -> VarSet +-- (transCloVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 +-- Use fixVarSet if the function needs to see the whole set all at once +transCloVarSet fn seeds + = go seeds seeds + where + go :: VarSet -- Accumulating result + -> VarSet -- Work-list; un-processed subset of accumulating result + -> VarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyVarSet new_vs = acc + | otherwise = go (acc `unionVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusVarSet` acc + +seqVarSet :: VarSet -> () +seqVarSet s = sizeVarSet s `seq` () + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralVarSet :: VarSet -> SDoc +pluralVarSet = pluralUFM . getUniqSet + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +-- Passing a list to the pretty-printing function allows the caller +-- to decide on the order of Vars (eg. toposort them) without them having +-- to use nonDetEltsUFM at the call site. This prevents from let-binding +-- non-deterministically ordered lists and reusing them where determinism +-- matters. +pprVarSet :: VarSet -- ^ The things to be pretty printed + -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the + -- elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprVarSet = pprUFM . getUniqSet + +-- Deterministic VarSet +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need +-- DVarSet. + +-- | Deterministic Variable Set +type DVarSet = UniqDSet Var + +-- | Deterministic Identifier Set +type DIdSet = UniqDSet Id + +-- | Deterministic Type Variable Set +type DTyVarSet = UniqDSet TyVar + +-- | Deterministic Type or Coercion Variable Set +type DTyCoVarSet = UniqDSet TyCoVar + +emptyDVarSet :: DVarSet +emptyDVarSet = emptyUniqDSet + +unitDVarSet :: Var -> DVarSet +unitDVarSet = unitUniqDSet + +mkDVarSet :: [Var] -> DVarSet +mkDVarSet = mkUniqDSet + +-- The new element always goes to the right of existing ones. +extendDVarSet :: DVarSet -> Var -> DVarSet +extendDVarSet = addOneToUniqDSet + +elemDVarSet :: Var -> DVarSet -> Bool +elemDVarSet = elementOfUniqDSet + +dVarSetElems :: DVarSet -> [Var] +dVarSetElems = uniqDSetToList + +subDVarSet :: DVarSet -> DVarSet -> Bool +subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) + +unionDVarSet :: DVarSet -> DVarSet -> DVarSet +unionDVarSet = unionUniqDSets + +unionDVarSets :: [DVarSet] -> DVarSet +unionDVarSets = unionManyUniqDSets + +-- | Map the function over the list, and union the results +mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet +mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs + +intersectDVarSet :: DVarSet -> DVarSet -> DVarSet +intersectDVarSet = intersectUniqDSets + +dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetIntersectVarSet = uniqDSetIntersectUniqSet + +-- | True if empty intersection +disjointDVarSet :: DVarSet -> DVarSet -> Bool +disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2) + +-- | True if non-empty intersection +intersectsDVarSet :: DVarSet -> DVarSet -> Bool +intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) + +isEmptyDVarSet :: DVarSet -> Bool +isEmptyDVarSet = isEmptyUniqDSet + +delDVarSet :: DVarSet -> Var -> DVarSet +delDVarSet = delOneFromUniqDSet + +minusDVarSet :: DVarSet -> DVarSet -> DVarSet +minusDVarSet = minusUniqDSet + +dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetMinusVarSet = uniqDSetMinusUniqSet + +foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a +foldDVarSet = foldUniqDSet + +anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool +anyDVarSet p = anyUDFM p . getUniqDSet + +allDVarSet :: (Var -> Bool) -> DVarSet -> Bool +allDVarSet p = allUDFM p . getUniqDSet + +mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapDVarSet = mapUniqDSet + +filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet +filterDVarSet = filterUniqDSet + +sizeDVarSet :: DVarSet -> Int +sizeDVarSet = sizeUniqDSet + +-- | Partition DVarSet according to the predicate given +partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) +partitionDVarSet = partitionUniqDSet + +-- | Delete a list of variables from DVarSet +delDVarSetList :: DVarSet -> [Var] -> DVarSet +delDVarSetList = delListFromUniqDSet + +seqDVarSet :: DVarSet -> () +seqDVarSet s = sizeDVarSet s `seq` () + +-- | Add a list of variables to DVarSet +extendDVarSetList :: DVarSet -> [Var] -> DVarSet +extendDVarSetList = addListToUniqDSet + +-- | Convert a DVarSet to a VarSet by forgetting the order of insertion +dVarSetToVarSet :: DVarSet -> VarSet +dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet + +-- | transCloVarSet for DVarSet +transCloDVarSet :: (DVarSet -> DVarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> DVarSet -> DVarSet +-- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 +transCloDVarSet fn seeds + = go seeds seeds + where + go :: DVarSet -- Accumulating result + -> DVarSet -- Work-list; un-processed subset of accumulating result + -> DVarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyDVarSet new_vs = acc + | otherwise = go (acc `unionDVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusDVarSet` acc diff --git a/compiler/GHC/Utils/Lexeme.hs b/compiler/GHC/Utils/Lexeme.hs new file mode 100644 index 0000000000..2ea773a2f0 --- /dev/null +++ b/compiler/GHC/Utils/Lexeme.hs @@ -0,0 +1,240 @@ +-- (c) The GHC Team +-- +-- Functions to evaluate whether or not a string is a valid identifier. +-- There is considerable overlap between the logic here and the logic +-- in Lexer.x, but sadly there seems to be no way to merge them. + +module GHC.Utils.Lexeme ( + -- * Lexical characteristics of Haskell names + + -- | Use these functions to figure what kind of name a 'FastString' + -- represents; these functions do /not/ check that the identifier + -- is valid. + + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + startsVarSym, startsVarId, startsConSym, startsConId, + + -- * Validating identifiers + + -- | These functions (working over plain old 'String's) check + -- to make sure that the identifier is valid. + okVarOcc, okConOcc, okTcOcc, + okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc + + -- Some of the exports above are not used within GHC, but may + -- be of value to GHC API users. + + ) where + +import GhcPrelude + +import FastString + +import Data.Char +import qualified Data.Set as Set + +import GHC.Lexeme + +{- + +************************************************************************ +* * + Lexical categories +* * +************************************************************************ + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. + +Note [Classification of generated names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some names generated for internal use can show up in debugging output, +e.g. when using -ddump-simpl. These generated names start with a $ +but should still be pretty-printed using prefix notation. We make sure +this is the case in isLexVarSym by only classifying a name as a symbol +if all its characters are symbols, not just its first one. +-} + +isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool + +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs + +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs + +------------- +isLexConId cs -- Prefix type or data constructors + | nullFS cs = False -- e.g. "Foo", "[]", "(,)" + | cs == (fsLit "[]") = True + | otherwise = startsConId (headFS cs) + +isLexVarId cs -- Ordinary prefix identifiers + | nullFS cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) + +isLexConSym cs -- Infix type or data constructors + | nullFS cs = False -- e.g. ":-:", ":", "->" + | cs == (fsLit "->") = True + | otherwise = startsConSym (headFS cs) + +isLexVarSym fs -- Infix identifiers e.g. "+" + | fs == (fsLit "~R#") = True + | otherwise + = case (if nullFS fs then [] else unpackFS fs) of + [] -> False + (c:cs) -> startsVarSym c && all isVarSymChar cs + -- See Note [Classification of generated names] + +{- + +************************************************************************ +* * + Detecting valid names for Template Haskell +* * +************************************************************************ + +-} + +---------------------- +-- External interface +---------------------- + +-- | Is this an acceptable variable name? +okVarOcc :: String -> Bool +okVarOcc str@(c:_) + | startsVarId c + = okVarIdOcc str + | startsVarSym c + = okVarSymOcc str +okVarOcc _ = False + +-- | Is this an acceptable constructor name? +okConOcc :: String -> Bool +okConOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | str == "[]" + = True +okConOcc _ = False + +-- | Is this an acceptable type name? +okTcOcc :: String -> Bool +okTcOcc "[]" = True +okTcOcc "->" = True +okTcOcc "~" = True +okTcOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | startsVarSym c + = okVarSymOcc str +okTcOcc _ = False + +-- | Is this an acceptable alphanumeric variable name, assuming it starts +-- with an acceptable letter? +okVarIdOcc :: String -> Bool +okVarIdOcc str = okIdOcc str && + -- admit "_" as a valid identifier. Required to support typed + -- holes in Template Haskell. See #10267 + (str == "_" || not (str `Set.member` reservedIds)) + +-- | Is this an acceptable symbolic variable name, assuming it starts +-- with an acceptable character? +okVarSymOcc :: String -> Bool +okVarSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) && + not (isDashes str) + +-- | Is this an acceptable alphanumeric constructor name, assuming it +-- starts with an acceptable letter? +okConIdOcc :: String -> Bool +okConIdOcc str = okIdOcc str || + is_tuple_name1 True str || + -- Is it a boxed tuple... + is_tuple_name1 False str || + -- ...or an unboxed tuple (#12407)... + is_sum_name1 str + -- ...or an unboxed sum (#12514)? + where + -- check for tuple name, starting at the beginning + is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest + is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest + is_tuple_name1 _ _ = False + + -- check for tuple tail + is_tuple_name2 True ")" = True + is_tuple_name2 False "#)" = True + is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest + is_tuple_name2 boxed (ws : rest) + | isSpace ws = is_tuple_name2 boxed rest + is_tuple_name2 _ _ = False + + -- check for sum name, starting at the beginning + is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest + is_sum_name1 _ = False + + -- check for sum tail, only allowing at most one underscore + is_sum_name2 _ "#)" = True + is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest + is_sum_name2 False ('_' : rest) = is_sum_name2 True rest + is_sum_name2 underscore (ws : rest) + | isSpace ws = is_sum_name2 underscore rest + is_sum_name2 _ _ = False + +-- | Is this an acceptable symbolic constructor name, assuming it +-- starts with an acceptable character? +okConSymOcc :: String -> Bool +okConSymOcc ":" = True +okConSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) + +---------------------- +-- Internal functions +---------------------- + +-- | Is this string an acceptable id, possibly with a suffix of hashes, +-- but not worrying about case or clashing with reserved words? +okIdOcc :: String -> Bool +okIdOcc str + = let hashes = dropWhile okIdChar str in + all (== '#') hashes -- -XMagicHash allows a suffix of hashes + -- of course, `all` says "True" to an empty list + +-- | Is this character acceptable in an identifier (after the first letter)? +-- See alexGetByte in Lexer.x +okIdChar :: Char -> Bool +okIdChar c = case generalCategory c of + UppercaseLetter -> True + LowercaseLetter -> True + TitlecaseLetter -> True + ModifierLetter -> True -- See #10196 + OtherLetter -> True -- See #1103 + NonSpacingMark -> True -- See #7650 + DecimalNumber -> True + OtherNumber -> True -- See #4373 + _ -> c == '\'' || c == '_' + +-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. +reservedIds :: Set.Set String +reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" + , "do", "else", "foreign", "if", "import", "in" + , "infix", "infixl", "infixr", "instance", "let" + , "module", "newtype", "of", "then", "type", "where" + , "_" ] + +-- | All reserved operators. Taken from section 2.4 of the 2010 Report. +reservedOps :: Set.Set String +reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" + , "@", "~", "=>" ] + +-- | Does this string contain only dashes and has at least 2 of them? +isDashes :: String -> Bool +isDashes ('-' : '-' : rest) = all (== '-') rest +isDashes _ = False diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs deleted file mode 100644 index 6c15828cde..0000000000 --- a/compiler/basicTypes/Avail.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} --- --- (c) The University of Glasgow --- - -#include "HsVersions.h" - -module Avail ( - Avails, - AvailInfo(..), - avail, - availsToNameSet, - availsToNameSetWithSelectors, - availsToNameEnv, - availName, availNames, availNonFldNames, - availNamesWithSelectors, - availFlds, - availsNamesWithOccs, - availNamesWithOccs, - stableAvailCmp, - plusAvail, - trimAvail, - filterAvail, - filterAvails, - nubAvails - - - ) where - -import GhcPrelude - -import Name -import NameEnv -import NameSet - -import FieldLabel -import Binary -import ListSetOps -import Outputable -import Util - -import Data.Data ( Data ) -import Data.List ( find ) -import Data.Function - --- ----------------------------------------------------------------------------- --- The AvailInfo type - --- | Records what things are \"available\", i.e. in scope -data AvailInfo - - -- | An ordinary identifier in scope - = Avail Name - - -- | A type or class in scope - -- - -- The __AvailTC Invariant__: If the type or class is itself to be in scope, - -- it must be /first/ in this list. Thus, typically: - -- - -- > AvailTC Eq [Eq, ==, \/=] [] - | AvailTC - Name -- ^ The name of the type or class - [Name] -- ^ The available pieces of type or class, - -- excluding field selectors. - [FieldLabel] -- ^ The record fields of the type - -- (see Note [Representing fields in AvailInfo]). - - deriving ( Eq -- ^ Used when deciding if the interface has changed - , Data ) - --- | A collection of 'AvailInfo' - several things that are \"available\" -type Avails = [AvailInfo] - -{- -Note [Representing fields in AvailInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When -XDuplicateRecordFields is disabled (the normal case), a -datatype like - - data T = MkT { foo :: Int } - -gives rise to the AvailInfo - - AvailTC T [T, MkT] [FieldLabel "foo" False foo] - -whereas if -XDuplicateRecordFields is enabled it gives - - AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] - -since the label does not match the selector name. - -The labels in a field list are not necessarily unique: -data families allow the same parent (the family tycon) to have -multiple distinct fields with the same label. For example, - - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool} - -gives rise to - - AvailTC F [ F, MkFInt, MkFBool ] - [ FieldLabel "foo" True $sel:foo:MkFInt - , FieldLabel "foo" True $sel:foo:MkFBool ] - -Moreover, note that the flIsOverloaded flag need not be the same for -all the elements of the list. In the example above, this occurs if -the two data instances are defined in different modules, one with -`-XDuplicateRecordFields` enabled and one with it disabled. Thus it -is possible to have - - AvailTC F [ F, MkFInt, MkFBool ] - [ FieldLabel "foo" True $sel:foo:MkFInt - , FieldLabel "foo" False foo ] - -If the two data instances are defined in different modules, both -without `-XDuplicateRecordFields`, it will be impossible to export -them from the same module (even with `-XDuplicateRecordfields` -enabled), because they would be represented identically. The -workaround here is to enable `-XDuplicateRecordFields` on the defining -modules. --} - --- | Compare lexicographically -stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering -stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 -stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = - (n `stableNameCmp` m) `thenCmp` - (cmpList stableNameCmp ns ms) `thenCmp` - (cmpList (stableNameCmp `on` flSelector) nfs mfs) -stableAvailCmp (AvailTC {}) (Avail {}) = GT - -avail :: Name -> AvailInfo -avail n = Avail n - --- ----------------------------------------------------------------------------- --- Operations on AvailInfo - -availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNames avail) - -availsToNameSetWithSelectors :: [AvailInfo] -> NameSet -availsToNameSetWithSelectors avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNamesWithSelectors avail) - -availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo -availsToNameEnv avails = foldr add emptyNameEnv avails - where add avail env = extendNameEnvList env - (zip (availNames avail) (repeat avail)) - --- | Just the main name made available, i.e. not the available pieces --- of type or class brought into scope by the 'GenAvailInfo' -availName :: AvailInfo -> Name -availName (Avail n) = n -availName (AvailTC n _ _) = n - --- | All names made available by the availability information (excluding overloaded selectors) -availNames :: AvailInfo -> [Name] -availNames (Avail n) = [n] -availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] - --- | All names made available by the availability information (including overloaded selectors) -availNamesWithSelectors :: AvailInfo -> [Name] -availNamesWithSelectors (Avail n) = [n] -availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs - --- | Names for non-fields made available by the availability information -availNonFldNames :: AvailInfo -> [Name] -availNonFldNames (Avail n) = [n] -availNonFldNames (AvailTC _ ns _) = ns - --- | Fields made available by the availability information -availFlds :: AvailInfo -> [FieldLabel] -availFlds (AvailTC _ _ fs) = fs -availFlds _ = [] - -availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] -availsNamesWithOccs = concatMap availNamesWithOccs - --- | 'Name's made available by the availability information, paired with --- the 'OccName' used to refer to each one. --- --- When @DuplicateRecordFields@ is in use, the 'Name' may be the --- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the --- 'OccName' will be the label of the field (e.g. @foo@). --- --- See Note [Representing fields in AvailInfo]. -availNamesWithOccs :: AvailInfo -> [(Name, OccName)] -availNamesWithOccs (Avail n) = [(n, nameOccName n)] -availNamesWithOccs (AvailTC _ ns fs) - = [ (n, nameOccName n) | n <- ns ] ++ - [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] - --- ----------------------------------------------------------------------------- --- Utility - -plusAvail :: AvailInfo -> AvailInfo -> AvailInfo -plusAvail a1 a2 - | debugIsOn && availName a1 /= availName a2 - = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) -plusAvail a1@(Avail {}) (Avail {}) = a1 -plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 -plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 -plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) - = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first - (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) - (fs1 `unionLists` fs2) - (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) - (fs1 `unionLists` fs2) - (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) - (fs1 `unionLists` fs2) - (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) - (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) - = AvailTC n1 ss1 (fs1 `unionLists` fs2) -plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) - = AvailTC n1 ss2 (fs1 `unionLists` fs2) -plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) - --- | trims an 'AvailInfo' to keep only a single name -trimAvail :: AvailInfo -> Name -> AvailInfo -trimAvail (Avail n) _ = Avail n -trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of - Just x -> AvailTC n [] [x] - Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] - --- | filters 'AvailInfo's by the given predicate -filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] -filterAvails keep avails = foldr (filterAvail keep) [] avails - --- | filters an 'AvailInfo' by the given predicate -filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] -filterAvail keep ie rest = - case ie of - Avail n | keep n -> ie : rest - | otherwise -> rest - AvailTC tc ns fs -> - let ns' = filter keep ns - fs' = filter (keep . flSelector) fs in - if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest - - --- | Combines 'AvailInfo's from the same family --- 'avails' may have several items with the same availName --- E.g import Ix( Ix(..), index ) --- will give Ix(Ix,index,range) and Ix(index) --- We want to combine these; addAvail does that -nubAvails :: [AvailInfo] -> [AvailInfo] -nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) - where - add env avail = extendNameEnv_C plusAvail env (availName avail) avail - --- ----------------------------------------------------------------------------- --- Printing - -instance Outputable AvailInfo where - ppr = pprAvail - -pprAvail :: AvailInfo -> SDoc -pprAvail (Avail n) - = ppr n -pprAvail (AvailTC n ns fs) - = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi - , fsep (punctuate comma (map (ppr . flLabel) fs))]) - -instance Binary AvailInfo where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac ad) = do - putByte bh 1 - put_ bh ab - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - ad <- get bh - return (AvailTC ab ac ad) diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs deleted file mode 100644 index a954a7449b..0000000000 --- a/compiler/basicTypes/BasicTypes.hs +++ /dev/null @@ -1,1736 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 - -\section[BasicTypes]{Miscellaneous types} - -This module defines a miscellaneously collection of very simple -types that - -\begin{itemize} -\item have no other obvious home -\item don't depend on any other complicated types -\item are used in more than one "part" of the compiler -\end{itemize} --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module BasicTypes( - Version, bumpVersion, initialVersion, - - LeftOrRight(..), - pickLR, - - ConTag, ConTagZ, fIRST_TAG, - - Arity, RepArity, JoinArity, - - Alignment, mkAlignment, alignmentOf, alignmentBytes, - - PromotionFlag(..), isPromoted, - FunctionOrData(..), - - WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), - - Fixity(..), FixityDirection(..), - defaultFixity, maxPrecedence, minPrecedence, - negateFixity, funTyFixity, - compareFixity, - LexicalFixity(..), - - RecFlag(..), isRec, isNonRec, boolToRecFlag, - Origin(..), isGenerated, - - RuleName, pprRuleName, - - TopLevelFlag(..), isTopLevel, isNotTopLevel, - - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, - - Boxity(..), isBoxed, - - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec, - maybeParen, - - TupleSort(..), tupleSortBoxity, boxityTupleSort, - tupleParens, - - sumParens, pprAlternative, - - -- ** The OneShotInfo type - OneShotInfo(..), - noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, - bestOneShot, worstOneShot, - - OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, - isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, - strongLoopBreaker, weakLoopBreaker, - - InsideLam(..), - OneBranch(..), - InterestingCxt(..), - TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, - isAlwaysTailCalled, - - EP(..), - - DefMethSpec(..), - SwapFlag(..), flipSwap, unSwap, isSwapped, - - CompilerPhase(..), PhaseNum, - - Activation(..), isActive, isActiveIn, competesWith, - isNeverActive, isAlwaysActive, isEarlyActive, - activeAfterInitial, activeDuringFinal, - - RuleMatchInfo(..), isConLike, isFunLike, - InlineSpec(..), noUserInlineSpec, - InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, - neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, - isInlinePragma, isInlinablePragma, isAnyInlinePragma, - inlinePragmaSpec, inlinePragmaSat, - inlinePragmaActivation, inlinePragmaRuleMatchInfo, - setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - pprInline, pprInlineDebug, - - SuccessFlag(..), succeeded, failed, successIf, - - IntegralLit(..), FractionalLit(..), - negateIntegralLit, negateFractionalLit, - mkIntegralLit, mkFractionalLit, - integralFractionalLit, - - SourceText(..), pprWithSourceText, - - IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, - - SpliceExplicitFlag(..), - - TypeOrKind(..), isTypeLevel, isKindLevel - ) where - -import GhcPrelude - -import FastString -import Outputable -import SrcLoc ( Located,unLoc ) -import Data.Data hiding (Fixity, Prefix, Infix) -import Data.Function (on) -import Data.Bits -import qualified Data.Semigroup as Semi - -{- -************************************************************************ -* * - Binary choice -* * -************************************************************************ --} - -data LeftOrRight = CLeft | CRight - deriving( Eq, Data ) - -pickLR :: LeftOrRight -> (a,a) -> a -pickLR CLeft (l,_) = l -pickLR CRight (_,r) = r - -instance Outputable LeftOrRight where - ppr CLeft = text "Left" - ppr CRight = text "Right" - -{- -************************************************************************ -* * -\subsection[Arity]{Arity} -* * -************************************************************************ --} - --- | The number of value arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has arity 0 --- \x -> fib x has arity 1 --- See also Note [Definition of arity] in GHC.Core.Arity -type Arity = Int - --- | Representation Arity --- --- The number of represented arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has representation arity 0 --- \x -> fib x has representation arity 1 --- \(# x, y #) -> fib (x + y) has representation arity 2 -type RepArity = Int - --- | The number of arguments that a join point takes. Unlike the arity of a --- function, this is a purely syntactic property and is fixed when the join --- point is created (or converted from a value). Both type and value arguments --- are counted. -type JoinArity = Int - -{- -************************************************************************ -* * - Constructor tags -* * -************************************************************************ --} - --- | Constructor Tag --- --- Type of the tags associated with each constructor possibility or superclass --- selector -type ConTag = Int - --- | A *zero-indexed* constructor tag -type ConTagZ = Int - -fIRST_TAG :: ConTag --- ^ Tags are allocated from here for real constructors --- or for superclass selectors -fIRST_TAG = 1 - -{- -************************************************************************ -* * -\subsection[Alignment]{Alignment} -* * -************************************************************************ --} - --- | A power-of-two alignment -newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord) - --- Builds an alignment, throws on non power of 2 input. This is not --- ideal, but convenient for internal use and better then silently --- passing incorrect data. -mkAlignment :: Int -> Alignment -mkAlignment n - | n == 1 = Alignment 1 - | n == 2 = Alignment 2 - | n == 4 = Alignment 4 - | n == 8 = Alignment 8 - | n == 16 = Alignment 16 - | n == 32 = Alignment 32 - | n == 64 = Alignment 64 - | n == 128 = Alignment 128 - | n == 256 = Alignment 256 - | n == 512 = Alignment 512 - | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512" - --- Calculates an alignment of a number. x is aligned at N bytes means --- the remainder from x / N is zero. Currently, interested in N <= 8, --- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX --- context. -alignmentOf :: Int -> Alignment -alignmentOf x = case x .&. 7 of - 0 -> Alignment 8 - 4 -> Alignment 4 - 2 -> Alignment 2 - _ -> Alignment 1 - -instance Outputable Alignment where - ppr (Alignment m) = ppr m -{- -************************************************************************ -* * - One-shot information -* * -************************************************************************ --} - --- | If the 'Id' is a lambda-bound variable then it may have lambda-bound --- variable info. Sometimes we know whether the lambda binding this variable --- is a \"one-shot\" lambda; that is, whether it is applied at most once. --- --- This information may be useful in optimisation, as computations may --- safely be floated inside such a lambda without risk of duplicating --- work. -data OneShotInfo - = NoOneShotInfo -- ^ No information - | OneShotLam -- ^ The lambda is applied at most once. - deriving (Eq) - --- | It is always safe to assume that an 'Id' has no lambda-bound variable information -noOneShotInfo :: OneShotInfo -noOneShotInfo = NoOneShotInfo - -isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool -isOneShotInfo OneShotLam = True -isOneShotInfo _ = False - -hasNoOneShotInfo NoOneShotInfo = True -hasNoOneShotInfo _ = False - -worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo -worstOneShot NoOneShotInfo _ = NoOneShotInfo -worstOneShot OneShotLam os = os - -bestOneShot NoOneShotInfo os = os -bestOneShot OneShotLam _ = OneShotLam - -pprOneShotInfo :: OneShotInfo -> SDoc -pprOneShotInfo NoOneShotInfo = empty -pprOneShotInfo OneShotLam = text "OneShot" - -instance Outputable OneShotInfo where - ppr = pprOneShotInfo - -{- -************************************************************************ -* * - Swap flag -* * -************************************************************************ --} - -data SwapFlag - = NotSwapped -- Args are: actual, expected - | IsSwapped -- Args are: expected, actual - -instance Outputable SwapFlag where - ppr IsSwapped = text "Is-swapped" - ppr NotSwapped = text "Not-swapped" - -flipSwap :: SwapFlag -> SwapFlag -flipSwap IsSwapped = NotSwapped -flipSwap NotSwapped = IsSwapped - -isSwapped :: SwapFlag -> Bool -isSwapped IsSwapped = True -isSwapped NotSwapped = False - -unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b -unSwap NotSwapped f a b = f a b -unSwap IsSwapped f a b = f b a - - -{- ********************************************************************* -* * - Promotion flag -* * -********************************************************************* -} - --- | Is a TyCon a promoted data constructor or just a normal type constructor? -data PromotionFlag - = NotPromoted - | IsPromoted - deriving ( Eq, Data ) - -isPromoted :: PromotionFlag -> Bool -isPromoted IsPromoted = True -isPromoted NotPromoted = False - -instance Outputable PromotionFlag where - ppr NotPromoted = text "NotPromoted" - ppr IsPromoted = text "IsPromoted" - -{- -************************************************************************ -* * -\subsection[FunctionOrData]{FunctionOrData} -* * -************************************************************************ --} - -data FunctionOrData = IsFunction | IsData - deriving (Eq, Ord, Data) - -instance Outputable FunctionOrData where - ppr IsFunction = text "(function)" - ppr IsData = text "(data)" - -{- -************************************************************************ -* * -\subsection[Version]{Module and identifier version numbers} -* * -************************************************************************ --} - -type Version = Int - -bumpVersion :: Version -> Version -bumpVersion v = v+1 - -initialVersion :: Version -initialVersion = 1 - -{- -************************************************************************ -* * - Deprecations -* * -************************************************************************ --} - --- | A String Literal in the source, including its original raw format for use by --- source to source manipulation tools. -data StringLiteral = StringLiteral - { sl_st :: SourceText, -- literal raw source. - -- See not [Literal source text] - sl_fs :: FastString -- literal string value - } deriving Data - -instance Eq StringLiteral where - (StringLiteral _ a) == (StringLiteral _ b) = a == b - -instance Outputable StringLiteral where - ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) - --- | Warning Text --- --- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt = WarningTxt (Located SourceText) - [Located StringLiteral] - | DeprecatedTxt (Located SourceText) - [Located StringLiteral] - deriving (Eq, Data) - -instance Outputable WarningTxt where - ppr (WarningTxt lsrc ws) - = case unLoc lsrc of - NoSourceText -> pp_ws ws - SourceText src -> text src <+> pp_ws ws <+> text "#-}" - - ppr (DeprecatedTxt lsrc ds) - = case unLoc lsrc of - NoSourceText -> pp_ws ds - SourceText src -> text src <+> pp_ws ds <+> text "#-}" - -pp_ws :: [Located StringLiteral] -> SDoc -pp_ws [l] = ppr $ unLoc l -pp_ws ws - = text "[" - <+> vcat (punctuate comma (map (ppr . unLoc) ws)) - <+> text "]" - - -pprWarningTxtForMsg :: WarningTxt -> SDoc -pprWarningTxtForMsg (WarningTxt _ ws) - = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) -pprWarningTxtForMsg (DeprecatedTxt _ ds) - = text "Deprecated:" <+> - doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) - -{- -************************************************************************ -* * - Rules -* * -************************************************************************ --} - -type RuleName = FastString - -pprRuleName :: RuleName -> SDoc -pprRuleName rn = doubleQuotes (ftext rn) - -{- -************************************************************************ -* * -\subsection[Fixity]{Fixity info} -* * -************************************************************************ --} - ------------------------- -data Fixity = Fixity SourceText Int FixityDirection - -- Note [Pragma source text] - deriving Data - -instance Outputable Fixity where - ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] - -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 - ------------------------- -data FixityDirection = InfixL | InfixR | InfixN - deriving (Eq, Data) - -instance Outputable FixityDirection where - ppr InfixL = text "infixl" - ppr InfixR = text "infixr" - ppr InfixN = text "infix" - ------------------------- -maxPrecedence, minPrecedence :: Int -maxPrecedence = 9 -minPrecedence = 0 - -defaultFixity :: Fixity -defaultFixity = Fixity NoSourceText maxPrecedence InfixL - -negateFixity, funTyFixity :: Fixity --- Wired-in fixities -negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate -funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235 - -{- -Consider - -\begin{verbatim} - a `op1` b `op2` c -\end{verbatim} -@(compareFixity op1 op2)@ tells which way to arrange application, or -whether there's an error. --} - -compareFixity :: Fixity -> Fixity - -> (Bool, -- Error please - Bool) -- Associate to the right: a op1 (b op2 c) -compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) - = case prec1 `compare` prec2 of - GT -> left - LT -> right - EQ -> case (dir1, dir2) of - (InfixR, InfixR) -> right - (InfixL, InfixL) -> left - _ -> error_please - where - right = (False, True) - left = (False, False) - error_please = (True, False) - --- |Captures the fixity of declarations as they are parsed. This is not --- necessarily the same as the fixity declaration, as the normal fixity may be --- overridden using parens or backticks. -data LexicalFixity = Prefix | Infix deriving (Data,Eq) - -instance Outputable LexicalFixity where - ppr Prefix = text "Prefix" - ppr Infix = text "Infix" - -{- -************************************************************************ -* * -\subsection[Top-level/local]{Top-level/not-top level flag} -* * -************************************************************************ --} - -data TopLevelFlag - = TopLevel - | NotTopLevel - -isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool - -isNotTopLevel NotTopLevel = True -isNotTopLevel TopLevel = False - -isTopLevel TopLevel = True -isTopLevel NotTopLevel = False - -instance Outputable TopLevelFlag where - ppr TopLevel = text "" - ppr NotTopLevel = text "" - -{- -************************************************************************ -* * - Boxity flag -* * -************************************************************************ --} - -data Boxity - = Boxed - | Unboxed - deriving( Eq, Data ) - -isBoxed :: Boxity -> Bool -isBoxed Boxed = True -isBoxed Unboxed = False - -instance Outputable Boxity where - ppr Boxed = text "Boxed" - ppr Unboxed = text "Unboxed" - -{- -************************************************************************ -* * - Recursive/Non-Recursive flag -* * -************************************************************************ --} - --- | Recursivity Flag -data RecFlag = Recursive - | NonRecursive - deriving( Eq, Data ) - -isRec :: RecFlag -> Bool -isRec Recursive = True -isRec NonRecursive = False - -isNonRec :: RecFlag -> Bool -isNonRec Recursive = False -isNonRec NonRecursive = True - -boolToRecFlag :: Bool -> RecFlag -boolToRecFlag True = Recursive -boolToRecFlag False = NonRecursive - -instance Outputable RecFlag where - ppr Recursive = text "Recursive" - ppr NonRecursive = text "NonRecursive" - -{- -************************************************************************ -* * - Code origin -* * -************************************************************************ --} - -data Origin = FromSource - | Generated - deriving( Eq, Data ) - -isGenerated :: Origin -> Bool -isGenerated Generated = True -isGenerated FromSource = False - -instance Outputable Origin where - ppr FromSource = text "FromSource" - ppr Generated = text "Generated" - -{- -************************************************************************ -* * - Instance overlap flag -* * -************************************************************************ --} - --- | The semantics allowed for overlapping instances for a particular --- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a --- explanation of the `isSafeOverlap` field. --- --- - 'ApiAnnotation.AnnKeywordId' : --- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or --- @'\{-\# OVERLAPPING'@ or --- @'\{-\# OVERLAPS'@ or --- @'\{-\# INCOHERENT'@, --- 'ApiAnnotation.AnnClose' @`\#-\}`@, - --- For details on above see note [Api annotations] in ApiAnnotation -data OverlapFlag = OverlapFlag - { overlapMode :: OverlapMode - , isSafeOverlap :: Bool - } deriving (Eq, Data) - -setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag -setOverlapModeMaybe f Nothing = f -setOverlapModeMaybe f (Just m) = f { overlapMode = m } - -hasIncoherentFlag :: OverlapMode -> Bool -hasIncoherentFlag mode = - case mode of - Incoherent _ -> True - _ -> False - -hasOverlappableFlag :: OverlapMode -> Bool -hasOverlappableFlag mode = - case mode of - Overlappable _ -> True - Overlaps _ -> True - Incoherent _ -> True - _ -> False - -hasOverlappingFlag :: OverlapMode -> Bool -hasOverlappingFlag mode = - case mode of - Overlapping _ -> True - Overlaps _ -> True - Incoherent _ -> True - _ -> False - -data OverlapMode -- See Note [Rules for instance lookup] in GHC.Core.InstEnv - = NoOverlap SourceText - -- See Note [Pragma source text] - -- ^ This instance must not overlap another `NoOverlap` instance. - -- However, it may be overlapped by `Overlapping` instances, - -- and it may overlap `Overlappable` instances. - - - | Overlappable SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instance Foo [Int] - -- instance {-# OVERLAPPABLE #-} Foo [a] - -- - -- Since the second instance has the Overlappable flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - - | Overlapping SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore any more general instances that may be - -- used to solve the constraint. - -- - -- Example: constraint (Foo [Int]) - -- instance {-# OVERLAPPING #-} Foo [Int] - -- instance Foo [a] - -- - -- Since the first instance has the Overlapping flag, - -- the second---more general---instance will be ignored (otherwise - -- it is ambiguous which to choose) - - - | Overlaps SourceText - -- See Note [Pragma source text] - -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. - - | Incoherent SourceText - -- See Note [Pragma source text] - -- ^ Behave like Overlappable and Overlapping, and in addition pick - -- an an arbitrary one if there are multiple matching candidates, and - -- don't worry about later instantiation - -- - -- Example: constraint (Foo [b]) - -- instance {-# INCOHERENT -} Foo [Int] - -- instance Foo [a] - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also note [Incoherent instances] in GHC.Core.InstEnv - - deriving (Eq, Data) - - -instance Outputable OverlapFlag where - ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) - -instance Outputable OverlapMode where - ppr (NoOverlap _) = empty - ppr (Overlappable _) = text "[overlappable]" - ppr (Overlapping _) = text "[overlapping]" - ppr (Overlaps _) = text "[overlap ok]" - ppr (Incoherent _) = text "[incoherent]" - -pprSafeOverlap :: Bool -> SDoc -pprSafeOverlap True = text "[safe]" -pprSafeOverlap False = empty - -{- -************************************************************************ -* * - Precedence -* * -************************************************************************ --} - --- | A general-purpose pretty-printing precedence type. -newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) --- See Note [Precedence in types] - -topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec -topPrec = PprPrec 0 -- No parens -sigPrec = PprPrec 1 -- Explicit type signatures -funPrec = PprPrec 2 -- Function args; no parens for constructor apps - -- See [Type operator precedence] for why both - -- funPrec and opPrec exist. -opPrec = PprPrec 2 -- Infix operator -starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *) - -- See Note [Star kind precedence] -appPrec = PprPrec 4 -- Constructor args; no parens for atomic - -maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty - -{- Note [Precedence in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Many pretty-printing functions have type - ppr_ty :: PprPrec -> Type -> SDoc - -The PprPrec gives the binding strength of the context. For example, in - T ty1 ty2 -we will pretty-print 'ty1' and 'ty2' with the call - (ppr_ty appPrec ty) -to indicate that the context is that of an argument of a TyConApp. - -We use this consistently for Type and HsType. - -Note [Type operator precedence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't keep the fixity of type operators in the operator. So the -pretty printer follows the following precedence order: - - TyConPrec Type constructor application - TyOpPrec/FunPrec Operator application and function arrow - -We have funPrec and opPrec to represent the precedence of function -arrow and type operators respectively, but currently we implement -funPrec == opPrec, so that we don't distinguish the two. Reason: -it's hard to parse a type like - a ~ b => c * d -> e - f - -By treating opPrec = funPrec we end up with more parens - (a ~ b) => (c * d) -> (e - f) - -But the two are different constructors of PprPrec so we could make -(->) bind more or less tightly if we wanted. - -Note [Star kind precedence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We parenthesize the (*) kind to avoid two issues: - -1. Printing invalid or incorrect code. - For example, instead of type F @(*) x = x - GHC used to print type F @* x = x - However, (@*) is a type operator, not a kind application. - -2. Printing kinds that are correct but hard to read. - Should Either * Int be read as Either (*) Int - or as (*) Either Int ? - This depends on whether -XStarIsType is enabled, but it would be - easier if we didn't have to check for the flag when reading the code. - -At the same time, we cannot parenthesize (*) blindly. -Consider this Haskell98 kind: ((* -> *) -> *) -> * -With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*) - -The solution is to assign a special precedence to (*), 'starPrec', which is -higher than 'funPrec' but lower than 'appPrec': - - F * * * becomes F (*) (*) (*) - F A * B becomes F A (*) B - Proxy * becomes Proxy (*) - a * -> * becomes a (*) -> * --} - -{- -************************************************************************ -* * - Tuples -* * -************************************************************************ --} - -data TupleSort - = BoxedTuple - | UnboxedTuple - | ConstraintTuple - deriving( Eq, Data ) - -instance Outputable TupleSort where - ppr ts = text $ - case ts of - BoxedTuple -> "BoxedTuple" - UnboxedTuple -> "UnboxedTuple" - ConstraintTuple -> "ConstraintTuple" - -tupleSortBoxity :: TupleSort -> Boxity -tupleSortBoxity BoxedTuple = Boxed -tupleSortBoxity UnboxedTuple = Unboxed -tupleSortBoxity ConstraintTuple = Boxed - -boxityTupleSort :: Boxity -> TupleSort -boxityTupleSort Boxed = BoxedTuple -boxityTupleSort Unboxed = UnboxedTuple - -tupleParens :: TupleSort -> SDoc -> SDoc -tupleParens BoxedTuple p = parens p -tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") -tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) - = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) - (parens p) - -{- -************************************************************************ -* * - Sums -* * -************************************************************************ --} - -sumParens :: SDoc -> SDoc -sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") - --- | Pretty print an alternative in an unboxed sum e.g. "| a | |". -pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use - -> a -- ^ The things to be pretty printed - -> ConTag -- ^ Alternative (one-based) - -> Arity -- ^ Arity - -> SDoc -- ^ 'SDoc' where the alternative havs been pretty - -- printed and finally packed into a paragraph. -pprAlternative pp x alt arity = - fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) - -{- -************************************************************************ -* * -\subsection[Generic]{Generic flag} -* * -************************************************************************ - -This is the "Embedding-Projection pair" datatype, it contains -two pieces of code (normally either RenamedExpr's or Id's) -If we have a such a pair (EP from to), the idea is that 'from' and 'to' -represents functions of type - - from :: T -> Tring - to :: Tring -> T - -And we should have - - to (from x) = x - -T and Tring are arbitrary, but typically T is the 'main' type while -Tring is the 'representation' type. (This just helps us remember -whether to use 'from' or 'to'. --} - --- | Embedding Projection pair -data EP a = EP { fromEP :: a, -- :: T -> Tring - toEP :: a } -- :: Tring -> T - -{- -Embedding-projection pairs are used in several places: - -First of all, each type constructor has an EP associated with it, the -code in EP converts (datatype T) from T to Tring and back again. - -Secondly, when we are filling in Generic methods (in the typechecker, -tcMethodBinds), we are constructing bimaps by induction on the structure -of the type of the method signature. - - -************************************************************************ -* * -\subsection{Occurrence information} -* * -************************************************************************ - -This data type is used exclusively by the simplifier, but it appears in a -SubstResult, which is currently defined in VarEnv, which is pretty near -the base of the module hierarchy. So it seemed simpler to put the -defn of OccInfo here, safely at the bottom --} - --- | identifier Occurrence Information -data OccInfo - = ManyOccs { occ_tail :: !TailCallInfo } - -- ^ There are many occurrences, or unknown occurrences - - | IAmDead -- ^ Marks unused variables. Sometimes useful for - -- lambda and case-bound variables. - - | OneOcc { occ_in_lam :: !InsideLam - , occ_one_br :: !OneBranch - , occ_int_cxt :: !InterestingCxt - , occ_tail :: !TailCallInfo } - -- ^ Occurs exactly once (per branch), not inside a rule - - -- | This identifier breaks a loop of mutually recursive functions. The field - -- marks whether it is only a loop breaker due to a reference in a rule - | IAmALoopBreaker { occ_rules_only :: !RulesOnly - , occ_tail :: !TailCallInfo } - -- Note [LoopBreaker OccInfo] - deriving (Eq) - -type RulesOnly = Bool - -{- -Note [LoopBreaker OccInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - IAmALoopBreaker True <=> A "weak" or rules-only loop breaker - Do not preInlineUnconditionally - - IAmALoopBreaker False <=> A "strong" loop breaker - Do not inline at all - -See OccurAnal Note [Weak loop breakers] --} - -noOccInfo :: OccInfo -noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } - -isManyOccs :: OccInfo -> Bool -isManyOccs ManyOccs{} = True -isManyOccs _ = False - -seqOccInfo :: OccInfo -> () -seqOccInfo occ = occ `seq` () - ------------------ --- | Interesting Context -data InterestingCxt - = IsInteresting - -- ^ Function: is applied - -- Data value: scrutinised by a case with at least one non-DEFAULT branch - | NotInteresting - deriving (Eq) - --- | If there is any 'interesting' identifier occurrence, then the --- aggregated occurrence info of that identifier is considered interesting. -instance Semi.Semigroup InterestingCxt where - NotInteresting <> x = x - IsInteresting <> _ = IsInteresting - -instance Monoid InterestingCxt where - mempty = NotInteresting - mappend = (Semi.<>) - ------------------ --- | Inside Lambda -data InsideLam - = IsInsideLam - -- ^ Occurs inside a non-linear lambda - -- Substituting a redex for this occurrence is - -- dangerous because it might duplicate work. - | NotInsideLam - deriving (Eq) - --- | If any occurrence of an identifier is inside a lambda, then the --- occurrence info of that identifier marks it as occurring inside a lambda -instance Semi.Semigroup InsideLam where - NotInsideLam <> x = x - IsInsideLam <> _ = IsInsideLam - -instance Monoid InsideLam where - mempty = NotInsideLam - mappend = (Semi.<>) - ------------------ -data OneBranch - = InOneBranch - -- ^ One syntactic occurrence: Occurs in only one case branch - -- so no code-duplication issue to worry about - | MultipleBranches - deriving (Eq) - ------------------ -data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] - | NoTailCallInfo - deriving (Eq) - -tailCallInfo :: OccInfo -> TailCallInfo -tailCallInfo IAmDead = NoTailCallInfo -tailCallInfo other = occ_tail other - -zapOccTailCallInfo :: OccInfo -> OccInfo -zapOccTailCallInfo IAmDead = IAmDead -zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } - -isAlwaysTailCalled :: OccInfo -> Bool -isAlwaysTailCalled occ - = case tailCallInfo occ of AlwaysTailCalled{} -> True - NoTailCallInfo -> False - -instance Outputable TailCallInfo where - ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] - ppr _ = empty - ------------------ -strongLoopBreaker, weakLoopBreaker :: OccInfo -strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo -weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo - -isWeakLoopBreaker :: OccInfo -> Bool -isWeakLoopBreaker (IAmALoopBreaker{}) = True -isWeakLoopBreaker _ = False - -isStrongLoopBreaker :: OccInfo -> Bool -isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True - -- Loop-breaker that breaks a non-rule cycle -isStrongLoopBreaker _ = False - -isDeadOcc :: OccInfo -> Bool -isDeadOcc IAmDead = True -isDeadOcc _ = False - -isOneOcc :: OccInfo -> Bool -isOneOcc (OneOcc {}) = True -isOneOcc _ = False - -zapFragileOcc :: OccInfo -> OccInfo --- Keep only the most robust data: deadness, loop-breaker-hood -zapFragileOcc (OneOcc {}) = noOccInfo -zapFragileOcc occ = zapOccTailCallInfo occ - -instance Outputable OccInfo where - -- only used for debugging; never parsed. KSW 1999-07 - ppr (ManyOccs tails) = pprShortTailCallInfo tails - ppr IAmDead = text "Dead" - ppr (IAmALoopBreaker rule_only tails) - = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails - where - pp_ro | rule_only = char '!' - | otherwise = empty - ppr (OneOcc inside_lam one_branch int_cxt tail_info) - = text "Once" <> pp_lam inside_lam <> pp_br one_branch <> pp_args int_cxt <> pp_tail - where - pp_lam IsInsideLam = char 'L' - pp_lam NotInsideLam = empty - pp_br MultipleBranches = char '*' - pp_br InOneBranch = empty - pp_args IsInteresting = char '!' - pp_args NotInteresting = empty - pp_tail = pprShortTailCallInfo tail_info - -pprShortTailCallInfo :: TailCallInfo -> SDoc -pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) -pprShortTailCallInfo NoTailCallInfo = empty - -{- -Note [TailCallInfo] -~~~~~~~~~~~~~~~~~~~ -The occurrence analyser determines what can be made into a join point, but it -doesn't change the binder into a JoinId because then it would be inconsistent -with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to -change the IdDetails. - -The AlwaysTailCalled marker actually means slightly more than simply that the -function is always tail-called. See Note [Invariants on join points]. - -This info is quite fragile and should not be relied upon unless the occurrence -analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of -the join-point-hood of a binder; a join id itself will not be marked -AlwaysTailCalled. - -Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that -being tail-called would mean that the variable could only appear once per branch -(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join -point can also be invoked from other join points, not just from case branches: - - let j1 x = ... - j2 y = ... j1 z {- tail call -} ... - in case w of - A -> j1 v - B -> j2 u - C -> j2 q - -Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get -ManyOccs and j2 will get `OneOcc { occ_one_br = True }`. - -************************************************************************ -* * - Default method specification -* * -************************************************************************ - -The DefMethSpec enumeration just indicates what sort of default method -is used for a class. It is generated from source code, and present in -interface files; it is converted to Class.DefMethInfo before begin put in a -Class object. --} - --- | Default Method Specification -data DefMethSpec ty - = VanillaDM -- Default method given with polymorphic code - | GenericDM ty -- Default method given with code of this type - -instance Outputable (DefMethSpec ty) where - ppr VanillaDM = text "{- Has default method -}" - ppr (GenericDM {}) = text "{- Has generic default method -}" - -{- -************************************************************************ -* * -\subsection{Success flag} -* * -************************************************************************ --} - -data SuccessFlag = Succeeded | Failed - -instance Outputable SuccessFlag where - ppr Succeeded = text "Succeeded" - ppr Failed = text "Failed" - -successIf :: Bool -> SuccessFlag -successIf True = Succeeded -successIf False = Failed - -succeeded, failed :: SuccessFlag -> Bool -succeeded Succeeded = True -succeeded Failed = False - -failed Succeeded = False -failed Failed = True - -{- -************************************************************************ -* * -\subsection{Source Text} -* * -************************************************************************ -Keeping Source Text for source to source conversions - -Note [Pragma source text] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The lexer does a case-insensitive match for pragmas, as well as -accepting both UK and US spelling variants. - -So - - {-# SPECIALISE #-} - {-# SPECIALIZE #-} - {-# Specialize #-} - -will all generate ITspec_prag token for the start of the pragma. - -In order to be able to do source to source conversions, the original -source text for the token needs to be preserved, hence the -`SourceText` field. - -So the lexer will then generate - - ITspec_prag "{ -# SPECIALISE" - ITspec_prag "{ -# SPECIALIZE" - ITspec_prag "{ -# Specialize" - -for the cases above. - [without the space between '{' and '-', otherwise this comment won't parse] - - -Note [Literal source text] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The lexer/parser converts literals from their original source text -versions to an appropriate internal representation. This is a problem -for tools doing source to source conversions, so the original source -text is stored in literals where this can occur. - -Motivating examples for HsLit - - HsChar '\n' == '\x20` - HsCharPrim '\x41`# == `A` - HsString "\x20\x41" == " A" - HsStringPrim "\x20"# == " "# - HsInt 001 == 1 - HsIntPrim 002# == 2# - HsWordPrim 003## == 3## - HsInt64Prim 004## == 4## - HsWord64Prim 005## == 5## - HsInteger 006 == 6 - -For OverLitVal - - HsIntegral 003 == 0x003 - HsIsString "\x41nd" == "And" --} - - -- Note [Literal source text],[Pragma source text] -data SourceText = SourceText String - | NoSourceText -- ^ For when code is generated, e.g. TH, - -- deriving. The pretty printer will then make - -- its own representation of the item. - deriving (Data, Show, Eq ) - -instance Outputable SourceText where - ppr (SourceText s) = text "SourceText" <+> text s - ppr NoSourceText = text "NoSourceText" - --- | Special combinator for showing string literals. -pprWithSourceText :: SourceText -> SDoc -> SDoc -pprWithSourceText NoSourceText d = d -pprWithSourceText (SourceText src) _ = text src - -{- -************************************************************************ -* * -\subsection{Activation} -* * -************************************************************************ - -When a rule or inlining is active --} - --- | Phase Number -type PhaseNum = Int -- Compilation phase - -- Phases decrease towards zero - -- Zero is the last phase - -data CompilerPhase - = Phase PhaseNum - | InitialPhase -- The first phase -- number = infinity! - -instance Outputable CompilerPhase where - ppr (Phase n) = int n - ppr InitialPhase = text "InitialPhase" - -activeAfterInitial :: Activation --- Active in the first phase after the initial phase --- Currently we have just phases [2,1,0] -activeAfterInitial = ActiveAfter NoSourceText 2 - -activeDuringFinal :: Activation --- Active in the final simplification phase (which is repeated) -activeDuringFinal = ActiveAfter NoSourceText 0 - --- See note [Pragma source text] -data Activation = NeverActive - | AlwaysActive - | ActiveBefore SourceText PhaseNum - -- Active only *strictly before* this phase - | ActiveAfter SourceText PhaseNum - -- Active in this phase and later - deriving( Eq, Data ) - -- Eq used in comparing rules in GHC.Hs.Decls - --- | Rule Match Information -data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] - | FunLike - deriving( Eq, Data, Show ) - -- Show needed for Lexer.x - -data InlinePragma -- Note [InlinePragma] - = InlinePragma - { inl_src :: SourceText -- Note [Pragma source text] - , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] - - , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n - -- explicit (non-type, non-dictionary) args - -- That is, inl_sat describes the number of *source-code* - -- arguments the thing must be applied to. We add on the - -- number of implicit, dictionary arguments when making - -- the Unfolding, and don't look at inl_sat further - - , inl_act :: Activation -- Says during which phases inlining is allowed - -- See Note [inl_inline and inl_act] - - , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? - } deriving( Eq, Data ) - --- | Inline Specification -data InlineSpec -- What the user's INLINE pragma looked like - = Inline -- User wrote INLINE - | Inlinable -- User wrote INLINABLE - | NoInline -- User wrote NOINLINE - | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE - -- e.g. in `defaultInlinePragma` or when created by CSE - deriving( Eq, Data, Show ) - -- Show needed for Lexer.x - -{- Note [InlinePragma] -~~~~~~~~~~~~~~~~~~~~~~ -This data type mirrors what you can write in an INLINE or NOINLINE pragma in -the source program. - -If you write nothing at all, you get defaultInlinePragma: - inl_inline = NoUserInline - inl_act = AlwaysActive - inl_rule = FunLike - -It's not possible to get that combination by *writing* something, so -if an Id has defaultInlinePragma it means the user didn't specify anything. - -If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. - -If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair - -Note [inl_inline and inl_act] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* inl_inline says what the user wrote: did she say INLINE, NOINLINE, - INLINABLE, or nothing at all - -* inl_act says in what phases the unfolding is active or inactive - E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 - If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 - If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 - So note that inl_act does not say what pragma you wrote: it just - expresses its consequences - -* inl_act just says when the unfolding is active; it doesn't say what - to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, - but in addition f will get a "stable unfolding" with UnfoldingGuidance - that tells the inliner to be pretty eager about it. - -Note [CONLIKE pragma] -~~~~~~~~~~~~~~~~~~~~~ -The ConLike constructor of a RuleMatchInfo is aimed at the following. -Consider first - {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} - g b bs = let x = b:bs in ..x...x...(r x)... -Now, the rule applies to the (r x) term, because GHC "looks through" -the definition of 'x' to see that it is (b:bs). - -Now consider - {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} - g v = let x = f v in ..x...x...(r x)... -Normally the (r x) would *not* match the rule, because GHC would be -scared about duplicating the redex (f v), so it does not "look -through" the bindings. - -However the CONLIKE modifier says to treat 'f' like a constructor in -this situation, and "look through" the unfolding for x. So (r x) -fires, yielding (f (v+1)). - -This is all controlled with a user-visible pragma: - {-# NOINLINE CONLIKE [1] f #-} - -The main effects of CONLIKE are: - - - The occurrence analyser (OccAnal) and simplifier (Simplify) treat - CONLIKE thing like constructors, by ANF-ing them - - - New function GHC.Core.Utils.exprIsExpandable is like exprIsCheap, but - additionally spots applications of CONLIKE functions - - - A CoreUnfolding has a field that caches exprIsExpandable - - - The rule matcher consults this field. See - Note [Expanding variables] in GHC.Core.Rules. --} - -isConLike :: RuleMatchInfo -> Bool -isConLike ConLike = True -isConLike _ = False - -isFunLike :: RuleMatchInfo -> Bool -isFunLike FunLike = True -isFunLike _ = False - -noUserInlineSpec :: InlineSpec -> Bool -noUserInlineSpec NoUserInline = True -noUserInlineSpec _ = False - -defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma - :: InlinePragma -defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_act = AlwaysActive - , inl_rule = FunLike - , inl_inline = NoUserInline - , inl_sat = Nothing } - -alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } -neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } - -inlinePragmaSpec :: InlinePragma -> InlineSpec -inlinePragmaSpec = inl_inline - --- A DFun has an always-active inline activation so that --- exprIsConApp_maybe can "see" its unfolding --- (However, its actual Unfolding is a DFunUnfolding, which is --- never inlined other than via exprIsConApp_maybe.) -dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive - , inl_rule = ConLike } - -isDefaultInlinePragma :: InlinePragma -> Bool -isDefaultInlinePragma (InlinePragma { inl_act = activation - , inl_rule = match_info - , inl_inline = inline }) - = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info - -isInlinePragma :: InlinePragma -> Bool -isInlinePragma prag = case inl_inline prag of - Inline -> True - _ -> False - -isInlinablePragma :: InlinePragma -> Bool -isInlinablePragma prag = case inl_inline prag of - Inlinable -> True - _ -> False - -isAnyInlinePragma :: InlinePragma -> Bool --- INLINE or INLINABLE -isAnyInlinePragma prag = case inl_inline prag of - Inline -> True - Inlinable -> True - _ -> False - -inlinePragmaSat :: InlinePragma -> Maybe Arity -inlinePragmaSat = inl_sat - -inlinePragmaActivation :: InlinePragma -> Activation -inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation - -inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info - -setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma -setInlinePragmaActivation prag activation = prag { inl_act = activation } - -setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma -setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } - -instance Outputable Activation where - ppr AlwaysActive = empty - ppr NeverActive = brackets (text "~") - ppr (ActiveBefore _ n) = brackets (char '~' <> int n) - ppr (ActiveAfter _ n) = brackets (int n) - -instance Outputable RuleMatchInfo where - ppr ConLike = text "CONLIKE" - ppr FunLike = text "FUNLIKE" - -instance Outputable InlineSpec where - ppr Inline = text "INLINE" - ppr NoInline = text "NOINLINE" - ppr Inlinable = text "INLINABLE" - ppr NoUserInline = text "NOUSERINLINE" -- what is better? - -instance Outputable InlinePragma where - ppr = pprInline - -pprInline :: InlinePragma -> SDoc -pprInline = pprInline' True - -pprInlineDebug :: InlinePragma -> SDoc -pprInlineDebug = pprInline' False - -pprInline' :: Bool -- True <=> do not display the inl_inline field - -> InlinePragma - -> SDoc -pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation - , inl_rule = info, inl_sat = mb_arity }) - = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info - where - pp_inl x = if emptyInline then empty else ppr x - - pp_act Inline AlwaysActive = empty - pp_act NoInline NeverActive = empty - pp_act _ act = ppr act - - pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) - | otherwise = empty - pp_info | isFunLike info = empty - | otherwise = ppr info - -isActive :: CompilerPhase -> Activation -> Bool -isActive InitialPhase AlwaysActive = True -isActive InitialPhase (ActiveBefore {}) = True -isActive InitialPhase _ = False -isActive (Phase p) act = isActiveIn p act - -isActiveIn :: PhaseNum -> Activation -> Bool -isActiveIn _ NeverActive = False -isActiveIn _ AlwaysActive = True -isActiveIn p (ActiveAfter _ n) = p <= n -isActiveIn p (ActiveBefore _ n) = p > n - -competesWith :: Activation -> Activation -> Bool --- See Note [Activation competition] -competesWith NeverActive _ = False -competesWith _ NeverActive = False -competesWith AlwaysActive _ = True - -competesWith (ActiveBefore {}) AlwaysActive = True -competesWith (ActiveBefore {}) (ActiveBefore {}) = True -competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b - -competesWith (ActiveAfter {}) AlwaysActive = False -competesWith (ActiveAfter {}) (ActiveBefore {}) = False -competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b - -{- Note [Competing activations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes a RULE and an inlining may compete, or two RULES. -See Note [Rules and inlining/other rules] in GHC.HsToCore. - -We say that act1 "competes with" act2 iff - act1 is active in the phase when act2 *becomes* active -NB: remember that phases count *down*: 2, 1, 0! - -It's too conservative to ensure that the two are never simultaneously -active. For example, a rule might be always active, and an inlining -might switch on in phase 2. We could switch off the rule, but it does -no harm. --} - -isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool -isNeverActive NeverActive = True -isNeverActive _ = False - -isAlwaysActive AlwaysActive = True -isAlwaysActive _ = False - -isEarlyActive AlwaysActive = True -isEarlyActive (ActiveBefore {}) = True -isEarlyActive _ = False - --- | Integral Literal --- --- Used (instead of Integer) to represent negative zegative zero which is --- required for NegativeLiterals extension to correctly parse `-0::Double` --- as negative zero. See also #13211. -data IntegralLit - = IL { il_text :: SourceText - , il_neg :: Bool -- See Note [Negative zero] - , il_value :: Integer - } - deriving (Data, Show) - -mkIntegralLit :: Integral a => a -> IntegralLit -mkIntegralLit i = IL { il_text = SourceText (show i_integer) - , il_neg = i < 0 - , il_value = i_integer } - where - i_integer :: Integer - i_integer = toInteger i - -negateIntegralLit :: IntegralLit -> IntegralLit -negateIntegralLit (IL text neg value) - = case text of - SourceText ('-':src) -> IL (SourceText src) False (negate value) - SourceText src -> IL (SourceText ('-':src)) True (negate value) - NoSourceText -> IL NoSourceText (not neg) (negate value) - --- | Fractional Literal --- --- Used (instead of Rational) to represent exactly the floating point literal that we --- encountered in the user's source program. This allows us to pretty-print exactly what --- the user wrote, which is important e.g. for floating point numbers that can't represented --- as Doubles (we used to via Double for pretty-printing). See also #2245. -data FractionalLit - = FL { fl_text :: SourceText -- How the value was written in the source - , fl_neg :: Bool -- See Note [Negative zero] - , fl_value :: Rational -- Numeric value of the literal - } - deriving (Data, Show) - -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on - -mkFractionalLit :: Real a => a -> FractionalLit -mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) - -- Converting to a Double here may technically lose - -- precision (see #15502). We could alternatively - -- convert to a Rational for the most accuracy, but - -- it would cause Floats and Doubles to be displayed - -- strangely, so we opt not to do this. (In contrast - -- to mkIntegralLit, where we always convert to an - -- Integer for the highest accuracy.) - , fl_neg = r < 0 - , fl_value = toRational r } - -negateFractionalLit :: FractionalLit -> FractionalLit -negateFractionalLit (FL text neg value) - = case text of - SourceText ('-':src) -> FL (SourceText src) False value - SourceText src -> FL (SourceText ('-':src)) True value - NoSourceText -> FL NoSourceText (not neg) (negate value) - -integralFractionalLit :: Bool -> Integer -> FractionalLit -integralFractionalLit neg i = FL { fl_text = SourceText (show i), - fl_neg = neg, - fl_value = fromInteger i } - --- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) - -instance Eq IntegralLit where - (==) = (==) `on` il_value - -instance Ord IntegralLit where - compare = compare `on` il_value - -instance Outputable IntegralLit where - ppr (IL (SourceText src) _ _) = text src - ppr (IL NoSourceText _ value) = text (show value) - -instance Eq FractionalLit where - (==) = (==) `on` fl_value - -instance Ord FractionalLit where - compare = compare `on` fl_value - -instance Outputable FractionalLit where - ppr f = pprWithSourceText (fl_text f) (rational (fl_value f)) - -{- -************************************************************************ -* * - IntWithInf -* * -************************************************************************ - -Represents an integer or positive infinity - --} - --- | An integer or infinity -data IntWithInf = Int {-# UNPACK #-} !Int - | Infinity - deriving Eq - --- | A representation of infinity -infinity :: IntWithInf -infinity = Infinity - -instance Ord IntWithInf where - compare Infinity Infinity = EQ - compare (Int _) Infinity = LT - compare Infinity (Int _) = GT - compare (Int a) (Int b) = a `compare` b - -instance Outputable IntWithInf where - ppr Infinity = char '∞' - ppr (Int n) = int n - -instance Num IntWithInf where - (+) = plusWithInf - (*) = mulWithInf - - abs Infinity = Infinity - abs (Int n) = Int (abs n) - - signum Infinity = Int 1 - signum (Int n) = Int (signum n) - - fromInteger = Int . fromInteger - - (-) = panic "subtracting IntWithInfs" - -intGtLimit :: Int -> IntWithInf -> Bool -intGtLimit _ Infinity = False -intGtLimit n (Int m) = n > m - --- | Add two 'IntWithInf's -plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf -plusWithInf Infinity _ = Infinity -plusWithInf _ Infinity = Infinity -plusWithInf (Int a) (Int b) = Int (a + b) - --- | Multiply two 'IntWithInf's -mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf -mulWithInf Infinity _ = Infinity -mulWithInf _ Infinity = Infinity -mulWithInf (Int a) (Int b) = Int (a * b) - --- | Turn a positive number into an 'IntWithInf', where 0 represents infinity -treatZeroAsInf :: Int -> IntWithInf -treatZeroAsInf 0 = Infinity -treatZeroAsInf n = Int n - --- | Inject any integer into an 'IntWithInf' -mkIntWithInf :: Int -> IntWithInf -mkIntWithInf = Int - -data SpliceExplicitFlag - = ExplicitSplice | -- ^ <=> $(f x y) - ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression - deriving Data - -{- ********************************************************************* -* * - Types vs Kinds -* * -********************************************************************* -} - --- | Flag to see whether we're type-checking terms or kind-checking types -data TypeOrKind = TypeLevel | KindLevel - deriving Eq - -instance Outputable TypeOrKind where - ppr TypeLevel = text "TypeLevel" - ppr KindLevel = text "KindLevel" - -isTypeLevel :: TypeOrKind -> Bool -isTypeLevel TypeLevel = True -isTypeLevel KindLevel = False - -isKindLevel :: TypeOrKind -> Bool -isKindLevel TypeLevel = False -isKindLevel KindLevel = True diff --git a/compiler/basicTypes/Cpr.hs b/compiler/basicTypes/Cpr.hs deleted file mode 100644 index 3a987fe2b5..0000000000 --- a/compiler/basicTypes/Cpr.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE GeneralisedNewtypeDeriving #-} --- | Types for the Constructed Product Result lattice. "GHC.Core.Op.CprAnal" and "GHC.Core.Op.WorkWrap.Lib" --- are its primary customers via 'idCprInfo'. -module Cpr ( - CprResult, topCpr, botCpr, conCpr, asConCpr, - CprType (..), topCprType, botCprType, conCprType, - lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy, - CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig - ) where - -import GhcPrelude - -import BasicTypes -import Outputable -import Binary - --- --- * CprResult --- - --- | The constructed product result lattice. --- --- @ --- NoCPR --- | --- ConCPR ConTag --- | --- BotCPR --- @ -data CprResult = NoCPR -- ^ Top of the lattice - | ConCPR !ConTag -- ^ Returns a constructor from a data type - | BotCPR -- ^ Bottom of the lattice - deriving( Eq, Show ) - -lubCpr :: CprResult -> CprResult -> CprResult -lubCpr (ConCPR t1) (ConCPR t2) - | t1 == t2 = ConCPR t1 -lubCpr BotCPR cpr = cpr -lubCpr cpr BotCPR = cpr -lubCpr _ _ = NoCPR - -topCpr :: CprResult -topCpr = NoCPR - -botCpr :: CprResult -botCpr = BotCPR - -conCpr :: ConTag -> CprResult -conCpr = ConCPR - -trimCpr :: CprResult -> CprResult -trimCpr ConCPR{} = NoCPR -trimCpr cpr = cpr - -asConCpr :: CprResult -> Maybe ConTag -asConCpr (ConCPR t) = Just t -asConCpr NoCPR = Nothing -asConCpr BotCPR = Nothing - --- --- * CprType --- - --- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper. -data CprType - = CprType - { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression - -- eats before returning the 'ct_cpr' - , ct_cpr :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to - -- 'ct_arty' arguments - } - -instance Eq CprType where - a == b = ct_cpr a == ct_cpr b - && (ct_arty a == ct_arty b || ct_cpr a == topCpr) - -topCprType :: CprType -topCprType = CprType 0 topCpr - -botCprType :: CprType -botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments - -conCprType :: ConTag -> CprType -conCprType con_tag = CprType 0 (conCpr con_tag) - -lubCprType :: CprType -> CprType -> CprType -lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2) - -- The arity of bottom CPR types can be extended arbitrarily. - | cpr1 == botCpr && n1 <= n2 = ty2 - | cpr2 == botCpr && n2 <= n1 = ty1 - -- There might be non-bottom CPR types with mismatching arities. - -- Consider test DmdAnalGADTs. We want to return top in these cases. - | n1 == n2 = CprType n1 (lubCpr cpr1 cpr2) - | otherwise = topCprType - -applyCprTy :: CprType -> CprType -applyCprTy (CprType n res) - | n > 0 = CprType (n-1) res - | res == botCpr = botCprType - | otherwise = topCprType - -abstractCprTy :: CprType -> CprType -abstractCprTy (CprType n res) - | res == topCpr = topCprType - | otherwise = CprType (n+1) res - -ensureCprTyArity :: Arity -> CprType -> CprType -ensureCprTyArity n ty@(CprType m _) - | n == m = ty - | otherwise = topCprType - -trimCprTy :: CprType -> CprType -trimCprTy (CprType arty res) = CprType arty (trimCpr res) - --- | The arity of the wrapped 'CprType' is the arity at which it is safe --- to unleash. See Note [Understanding DmdType and StrictSig] in Demand -newtype CprSig = CprSig { getCprSig :: CprType } - deriving (Eq, Binary) - --- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig' --- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in --- Demand -mkCprSigForArity :: Arity -> CprType -> CprSig -mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty) - -topCprSig :: CprSig -topCprSig = CprSig topCprType - -mkCprSig :: Arity -> CprResult -> CprSig -mkCprSig arty cpr = CprSig (CprType arty cpr) - -seqCprSig :: CprSig -> () -seqCprSig sig = sig `seq` () - -instance Outputable CprResult where - ppr NoCPR = empty - ppr (ConCPR n) = char 'm' <> int n - ppr BotCPR = char 'b' - -instance Outputable CprType where - ppr (CprType arty res) = ppr arty <> ppr res - --- | Only print the CPR result -instance Outputable CprSig where - ppr (CprSig ty) = ppr (ct_cpr ty) - -instance Binary CprResult where - put_ bh (ConCPR n) = do { putByte bh 0; put_ bh n } - put_ bh NoCPR = putByte bh 1 - put_ bh BotCPR = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> do { n <- get bh; return (ConCPR n) } - 1 -> return NoCPR - _ -> return BotCPR - -instance Binary CprType where - put_ bh (CprType arty cpr) = do - put_ bh arty - put_ bh cpr - get bh = CprType <$> get bh <*> get bh diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs deleted file mode 100644 index 28282d4382..0000000000 --- a/compiler/basicTypes/Demand.hs +++ /dev/null @@ -1,1974 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Demand]{@Demand@: A decoupled implementation of a demand domain} --} - -{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Demand ( - StrDmd, UseDmd(..), Count, - - Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd, - mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, - toCleanDmd, - absDmd, topDmd, botDmd, seqDmd, - lubDmd, bothDmd, - lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, - isTopDmd, isAbsDmd, isSeqDmd, - peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, - addCaseBndrDmd, - - DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, - nopDmdType, botDmdType, mkDmdType, - addDemand, ensureArgs, - BothDmdArg, mkBothDmdArg, toBothDmdArg, - - DmdEnv, emptyDmdEnv, - peelFV, findIdDemand, - - Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv, - appIsBottom, isBottomingSig, pprIfaceStrictSig, - StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, - nopSig, botSig, cprProdSig, - isTopSig, hasDemandEnvSig, - splitStrictSig, strictSigDmdEnv, - increaseStrictSigArity, etaExpandStrictSig, - - seqDemand, seqDemandList, seqDmdType, seqStrictSig, - - evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, - splitDmdTy, splitFVs, - deferAfterIO, - postProcessUnsat, postProcessDmdType, - - splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, - mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, - dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, - TypeShape(..), peelTsFuns, trimToType, - - useCount, isUsedOnce, reuseEnv, - zapUsageDemand, zapUsageEnvSig, - zapUsedOnceDemand, zapUsedOnceSig, - strictifyDictDmd, strictifyDmd - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Outputable -import Var ( Var ) -import VarEnv -import UniqFM -import Util -import BasicTypes -import Binary -import Maybes ( orElse ) - -import GHC.Core.Type ( Type ) -import GHC.Core.TyCon ( isNewTyCon, isClassTyCon ) -import GHC.Core.DataCon ( splitDataProductType_maybe ) - -{- -************************************************************************ -* * - Joint domain for Strictness and Absence -* * -************************************************************************ --} - -data JointDmd s u = JD { sd :: s, ud :: u } - deriving ( Eq, Show ) - -getStrDmd :: JointDmd s u -> s -getStrDmd = sd - -getUseDmd :: JointDmd s u -> u -getUseDmd = ud - --- Pretty-printing -instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where - ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) - --- Well-formedness preserving constructors for the joint domain -mkJointDmd :: s -> u -> JointDmd s u -mkJointDmd s u = JD { sd = s, ud = u } - -mkJointDmds :: [s] -> [u] -> [JointDmd s u] -mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as - - -{- -************************************************************************ -* * - Strictness domain -* * -************************************************************************ - - Lazy - | - HeadStr - / \ - SCall SProd - \ / - HyperStr - -Note [Exceptions and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to smart about catching exceptions, but we aren't anymore. -See #14998 for the way it's resolved at the moment. - -Here's a historic breakdown: - -Apparently, exception handling prim-ops didn't use to have any special -strictness signatures, thus defaulting to topSig, which assumes they use their -arguments lazily. Joachim was the first to realise that we could provide richer -information. Thus, in 0558911f91c (Dec 13), he added signatures to -primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call -their argument, which is useful information for usage analysis. Still with a -'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. - -In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a -'strictApply1Dmd' leads to substantial performance gains. That was at the cost -of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in -28638dfe79e (Dec 15). - -Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, -Ben opened #11222. Simon made the demand analyser "understand catch" in -9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call -its argument strictly, but also swallow any thrown exceptions in -'postProcessDivergence'. This was realized by extending the 'Str' constructor of -'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and -adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element -between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, -so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). - -This left the other variants like 'catchRetry#' having 'catchArgDmd', which is -where #14998 picked up. Item 1 was concerned with measuring the impact of also -making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that -there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 -(Apr 18). There was a lot of dead code resulting from that change, that we -removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and -removed any code that was dealing with the peculiarities. - -Where did the speed-ups vanish to? In #14998, item 3 established that -turning 'catch#' strict in its first argument didn't bring back any of the -alleged performance benefits. Item 2 of that ticket finally found out that it -was entirely due to 'catchException's new (since #11555) definition, which -was simply - - catchException !io handler = catch io handler - -While 'catchException' is arguably the saner semantics for 'catch', it is an -internal helper function in "GHC.IO". Its use in -"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: -Remove the bang and you find the regressions we originally wanted to avoid with -'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". - -So history keeps telling us that the only possibly correct strictness annotation -for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really -is not strict in its argument: Just try this in GHCi - - :set -XScopedTypeVariables - import Control.Exception - catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") - -Any analysis that assumes otherwise will be broken in some way or another -(beyond `-fno-pendantic-bottoms`). --} - --- | Vanilla strictness domain -data StrDmd - = HyperStr -- ^ Hyper-strict (bottom of the lattice). - -- See Note [HyperStr and Use demands] - - | SCall StrDmd -- ^ Call demand - -- Used only for values of function type - - | SProd [ArgStr] -- ^ Product - -- Used only for values of product type - -- Invariant: not all components are HyperStr (use HyperStr) - -- not all components are Lazy (use HeadStr) - - | HeadStr -- ^ Head-Strict - -- A polymorphic demand: used for values of all types, - -- including a type variable - - deriving ( Eq, Show ) - --- | Strictness of a function argument. -type ArgStr = Str StrDmd - --- | Strictness demand. -data Str s = Lazy -- ^ Lazy (top of the lattice) - | Str s -- ^ Strict - deriving ( Eq, Show ) - --- Well-formedness preserving constructors for the Strictness domain -strBot, strTop :: ArgStr -strBot = Str HyperStr -strTop = Lazy - -mkSCall :: StrDmd -> StrDmd -mkSCall HyperStr = HyperStr -mkSCall s = SCall s - -mkSProd :: [ArgStr] -> StrDmd -mkSProd sx - | any isHyperStr sx = HyperStr - | all isLazy sx = HeadStr - | otherwise = SProd sx - -isLazy :: ArgStr -> Bool -isLazy Lazy = True -isLazy (Str {}) = False - -isHyperStr :: ArgStr -> Bool -isHyperStr (Str HyperStr) = True -isHyperStr _ = False - --- Pretty-printing -instance Outputable StrDmd where - ppr HyperStr = char 'B' - ppr (SCall s) = char 'C' <> parens (ppr s) - ppr HeadStr = char 'S' - ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) - -instance Outputable ArgStr where - ppr (Str s) = ppr s - ppr Lazy = char 'L' - -lubArgStr :: ArgStr -> ArgStr -> ArgStr -lubArgStr Lazy _ = Lazy -lubArgStr _ Lazy = Lazy -lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) - -lubStr :: StrDmd -> StrDmd -> StrDmd -lubStr HyperStr s = s -lubStr (SCall s1) HyperStr = SCall s1 -lubStr (SCall _) HeadStr = HeadStr -lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) -lubStr (SCall _) (SProd _) = HeadStr -lubStr (SProd sx) HyperStr = SProd sx -lubStr (SProd _) HeadStr = HeadStr -lubStr (SProd s1) (SProd s2) - | s1 `equalLength` s2 = mkSProd (zipWith lubArgStr s1 s2) - | otherwise = HeadStr -lubStr (SProd _) (SCall _) = HeadStr -lubStr HeadStr _ = HeadStr - -bothArgStr :: ArgStr -> ArgStr -> ArgStr -bothArgStr Lazy s = s -bothArgStr s Lazy = s -bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) - -bothStr :: StrDmd -> StrDmd -> StrDmd -bothStr HyperStr _ = HyperStr -bothStr HeadStr s = s -bothStr (SCall _) HyperStr = HyperStr -bothStr (SCall s1) HeadStr = SCall s1 -bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) -bothStr (SCall _) (SProd _) = HyperStr -- Weird - -bothStr (SProd _) HyperStr = HyperStr -bothStr (SProd s1) HeadStr = SProd s1 -bothStr (SProd s1) (SProd s2) - | s1 `equalLength` s2 = mkSProd (zipWith bothArgStr s1 s2) - | otherwise = HyperStr -- Weird -bothStr (SProd _) (SCall _) = HyperStr - --- utility functions to deal with memory leaks -seqStrDmd :: StrDmd -> () -seqStrDmd (SProd ds) = seqStrDmdList ds -seqStrDmd (SCall s) = seqStrDmd s -seqStrDmd _ = () - -seqStrDmdList :: [ArgStr] -> () -seqStrDmdList [] = () -seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds - -seqArgStr :: ArgStr -> () -seqArgStr Lazy = () -seqArgStr (Str s) = seqStrDmd s - --- Splitting polymorphic demands -splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] -splitArgStrProdDmd n Lazy = Just (replicate n Lazy) -splitArgStrProdDmd n (Str s) = splitStrProdDmd n s - -splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] -splitStrProdDmd n HyperStr = Just (replicate n strBot) -splitStrProdDmd n HeadStr = Just (replicate n strTop) -splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), - text "splitStrProdDmd" $$ ppr n $$ ppr ds ) - Just ds -splitStrProdDmd _ (SCall {}) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (#9208) - -{- -************************************************************************ -* * - Absence domain -* * -************************************************************************ - - Used - / \ - UCall UProd - \ / - UHead - | - Count x - - | - Abs --} - --- | Domain for genuine usage -data UseDmd - = UCall Count UseDmd -- ^ Call demand for absence. - -- Used only for values of function type - - | UProd [ArgUse] -- ^ Product. - -- Used only for values of product type - -- See Note [Don't optimise UProd(Used) to Used] - -- - -- Invariant: Not all components are Abs - -- (in that case, use UHead) - - | UHead -- ^ May be used but its sub-components are - -- definitely *not* used. For product types, UHead - -- is equivalent to U(AAA); see mkUProd. - -- - -- UHead is needed only to express the demand - -- of 'seq' and 'case' which are polymorphic; - -- i.e. the scrutinised value is of type 'a' - -- rather than a product type. That's why we - -- can't use UProd [A,A,A] - -- - -- Since (UCall _ Abs) is ill-typed, UHead doesn't - -- make sense for lambdas - - | Used -- ^ May be used and its sub-components may be used. - -- (top of the lattice) - deriving ( Eq, Show ) - --- Extended usage demand for absence and counting -type ArgUse = Use UseDmd - -data Use u - = Abs -- Definitely unused - -- Bottom of the lattice - - | Use Count u -- May be used with some cardinality - deriving ( Eq, Show ) - --- | Abstract counting of usages -data Count = One | Many - deriving ( Eq, Show ) - --- Pretty-printing -instance Outputable ArgUse where - ppr Abs = char 'A' - ppr (Use Many a) = ppr a - ppr (Use One a) = char '1' <> char '*' <> ppr a - -instance Outputable UseDmd where - ppr Used = char 'U' - ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) - ppr UHead = char 'H' - ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) - -instance Outputable Count where - ppr One = char '1' - ppr Many = text "" - -useBot, useTop :: ArgUse -useBot = Abs -useTop = Use Many Used - -mkUCall :: Count -> UseDmd -> UseDmd ---mkUCall c Used = Used c -mkUCall c a = UCall c a - -mkUProd :: [ArgUse] -> UseDmd -mkUProd ux - | all (== Abs) ux = UHead - | otherwise = UProd ux - -lubCount :: Count -> Count -> Count -lubCount _ Many = Many -lubCount Many _ = Many -lubCount x _ = x - -lubArgUse :: ArgUse -> ArgUse -> ArgUse -lubArgUse Abs x = x -lubArgUse x Abs = x -lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) - -lubUse :: UseDmd -> UseDmd -> UseDmd -lubUse UHead u = u -lubUse (UCall c u) UHead = UCall c u -lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) -lubUse (UCall _ _) _ = Used -lubUse (UProd ux) UHead = UProd ux -lubUse (UProd ux1) (UProd ux2) - | ux1 `equalLength` ux2 = UProd $ zipWith lubArgUse ux1 ux2 - | otherwise = Used -lubUse (UProd {}) (UCall {}) = Used --- lubUse (UProd {}) Used = Used -lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) -lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) -lubUse Used _ = Used -- Note [Used should win] - --- `both` is different from `lub` in its treatment of counting; if --- `both` is computed for two used, the result always has --- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). --- Also, x `bothUse` x /= x (for anything but Abs). - -bothArgUse :: ArgUse -> ArgUse -> ArgUse -bothArgUse Abs x = x -bothArgUse x Abs = x -bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) - - -bothUse :: UseDmd -> UseDmd -> UseDmd -bothUse UHead u = u -bothUse (UCall c u) UHead = UCall c u - --- Exciting special treatment of inner demand for call demands: --- use `lubUse` instead of `bothUse`! -bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) - -bothUse (UCall {}) _ = Used -bothUse (UProd ux) UHead = UProd ux -bothUse (UProd ux1) (UProd ux2) - | ux1 `equalLength` ux2 = UProd $ zipWith bothArgUse ux1 ux2 - | otherwise = Used -bothUse (UProd {}) (UCall {}) = Used --- bothUse (UProd {}) Used = Used -- Note [Used should win] -bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) -bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) -bothUse Used _ = Used -- Note [Used should win] - -peelUseCall :: UseDmd -> Maybe (Count, UseDmd) -peelUseCall (UCall c u) = Just (c,u) -peelUseCall _ = Nothing - -addCaseBndrDmd :: Demand -- On the case binder - -> [Demand] -- On the components of the constructor - -> [Demand] -- Final demands for the components of the constructor --- See Note [Demand on case-alternative binders] -addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds - = case mu of - Abs -> alt_dmds - Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) - where - Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call - Just us = splitUseProdDmd arity u -- Ditto - where - arity = length alt_dmds - -{- Note [Demand on case-alternative binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand on a binder in a case alternative comes - (a) From the demand on the binder itself - (b) From the demand on the case binder -Forgetting (b) led directly to #10148. - -Example. Source code: - f x@(p,_) = if p then foo x else True - - foo (p,True) = True - foo (p,q) = foo (q,p) - -After strictness analysis: - f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> - case x_an1 - of wild_X7 [Dmd=] - { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> - case p_an2 of _ { - False -> GHC.Types.True; - True -> foo wild_X7 } - -It's true that ds_dnz is *itself* absent, but the use of wild_X7 means -that it is very much alive and demanded. See #10148 for how the -consequences play out. - -This is needed even for non-product types, in case the case-binder -is used but the components of the case alternative are not. - -Note [Don't optimise UProd(Used) to Used] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These two UseDmds: - UProd [Used, Used] and Used -are semantically equivalent, but we do not turn the former into -the latter, for a regrettable-subtle reason. Suppose we did. -then - f (x,y) = (y,x) -would get - StrDmd = Str = SProd [Lazy, Lazy] - UseDmd = Used = UProd [Used, Used] -But with the joint demand of doesn't convey any clue -that there is a product involved, and so the worthSplittingFun -will not fire. (We'd need to use the type as well to make it fire.) -Moreover, consider - g h p@(_,_) = h p -This too would get , but this time there really isn't any -point in w/w since the components of the pair are not used at all. - -So the solution is: don't aggressively collapse UProd [Used,Used] to -Used; instead leave it as-is. In effect we are using the UseDmd to do a -little bit of boxity analysis. Not very nice. - -Note [Used should win] -~~~~~~~~~~~~~~~~~~~~~~ -Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. -Why? Because Used carries the implication the whole thing is used, -box and all, so we don't want to w/w it. If we use it both boxed and -unboxed, then we are definitely using the box, and so we are quite -likely to pay a reboxing cost. So we make Used win here. - -Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer - -Baseline: (A) Not making Used win (UProd wins) -Compare with: (B) making Used win for lub and both - - Min -0.3% -5.6% -10.7% -11.0% -33.3% - Max +0.3% +45.6% +11.5% +11.5% +6.9% - Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% - -Baseline: (B) Making Used win for both lub and both -Compare with: (C) making Used win for both, but UProd win for lub - - Min -0.1% -0.3% -7.9% -8.0% -6.5% - Max +0.1% +1.0% +21.0% +21.0% +0.5% - Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% --} - --- If a demand is used multiple times (i.e. reused), than any use-once --- mentioned there, that is not protected by a UCall, can happen many times. -markReusedDmd :: ArgUse -> ArgUse -markReusedDmd Abs = Abs -markReusedDmd (Use _ a) = Use Many (markReused a) - -markReused :: UseDmd -> UseDmd -markReused (UCall _ u) = UCall Many u -- No need to recurse here -markReused (UProd ux) = UProd (map markReusedDmd ux) -markReused u = u - -isUsedMU :: ArgUse -> Bool --- True <=> markReusedDmd d = d -isUsedMU Abs = True -isUsedMU (Use One _) = False -isUsedMU (Use Many u) = isUsedU u - -isUsedU :: UseDmd -> Bool --- True <=> markReused d = d -isUsedU Used = True -isUsedU UHead = True -isUsedU (UProd us) = all isUsedMU us -isUsedU (UCall One _) = False -isUsedU (UCall Many _) = True -- No need to recurse - --- Squashing usage demand demands -seqUseDmd :: UseDmd -> () -seqUseDmd (UProd ds) = seqArgUseList ds -seqUseDmd (UCall c d) = c `seq` seqUseDmd d -seqUseDmd _ = () - -seqArgUseList :: [ArgUse] -> () -seqArgUseList [] = () -seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds - -seqArgUse :: ArgUse -> () -seqArgUse (Use c u) = c `seq` seqUseDmd u -seqArgUse _ = () - --- Splitting polymorphic Maybe-Used demands -splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] -splitUseProdDmd n Used = Just (replicate n useTop) -splitUseProdDmd n UHead = Just (replicate n Abs) -splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), - text "splitUseProdDmd" $$ ppr n - $$ ppr ds ) - Just ds -splitUseProdDmd _ (UCall _ _) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (#9208) - -useCount :: Use u -> Count -useCount Abs = One -useCount (Use One _) = One -useCount _ = Many - - -{- -************************************************************************ -* * - Clean demand for Strictness and Usage -* * -************************************************************************ - -This domain differst from JointDemand in the sense that pure absence -is taken away, i.e., we deal *only* with non-absent demands. - -Note [Strict demands] -~~~~~~~~~~~~~~~~~~~~~ -isStrictDmd returns true only of demands that are - both strict - and used -In particular, it is False for , which can and does -arise in, say (#7319) - f x = raise# -Then 'x' is not used, so f gets strictness -> . -Now the w/w generates - fx = let x = absentError "unused" - in raise -At this point we really don't want to convert to - fx = case absentError "unused" of x -> raise -Since the program is going to diverge, this swaps one error for another, -but it's really a bad idea to *ever* evaluate an absent argument. -In #7319 we get - T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] - -Note [Dealing with call demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Call demands are constructed and deconstructed coherently for -strictness and absence. For instance, the strictness signature for the -following function - -f :: (Int -> (Int, Int)) -> (Int, Bool) -f g = (snd (g 3), True) - -should be: m --} - -type CleanDemand = JointDmd StrDmd UseDmd - -- A demand that is at least head-strict - -bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand -bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) - = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } - -mkHeadStrict :: CleanDemand -> CleanDemand -mkHeadStrict cd = cd { sd = HeadStr } - -mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand -mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a } -mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a } - -evalDmd :: Demand --- Evaluated strictly, and used arbitrarily deeply -evalDmd = JD { sd = Str HeadStr, ud = useTop } - -mkProdDmd :: [Demand] -> CleanDemand -mkProdDmd dx - = JD { sd = mkSProd $ map getStrDmd dx - , ud = mkUProd $ map getUseDmd dx } - --- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@. -mkCallDmd :: CleanDemand -> CleanDemand -mkCallDmd (JD {sd = d, ud = u}) - = JD { sd = mkSCall d, ud = mkUCall One u } - --- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. -mkCallDmds :: Arity -> CleanDemand -> CleanDemand -mkCallDmds arity cd = iterate mkCallDmd cd !! arity - --- See Note [Demand on the worker] in GHC.Core.Op.WorkWrap -mkWorkerDemand :: Int -> Demand -mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } - where go 0 = Used - go n = mkUCall One $ go (n-1) - -cleanEvalDmd :: CleanDemand -cleanEvalDmd = JD { sd = HeadStr, ud = Used } - -cleanEvalProdDmd :: Arity -> CleanDemand -cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } - - -{- -************************************************************************ -* * - Demand: Combining Strictness and Usage -* * -************************************************************************ --} - -type Demand = JointDmd ArgStr ArgUse - -lubDmd :: Demand -> Demand -> Demand -lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `lubArgStr` s2 - , ud = a1 `lubArgUse` a2 } - -bothDmd :: Demand -> Demand -> Demand -bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `bothArgStr` s2 - , ud = a1 `bothArgUse` a2 } - -lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand - -strictApply1Dmd = JD { sd = Str (SCall HeadStr) - , ud = Use Many (UCall One Used) } - -lazyApply1Dmd = JD { sd = Lazy - , ud = Use One (UCall One Used) } - --- Second argument of catch#: --- uses its arg at most once, applies it once --- but is lazy (might not be called at all) -lazyApply2Dmd = JD { sd = Lazy - , ud = Use One (UCall One (UCall One Used)) } - -absDmd :: Demand -absDmd = JD { sd = Lazy, ud = Abs } - -topDmd :: Demand -topDmd = JD { sd = Lazy, ud = useTop } - -botDmd :: Demand -botDmd = JD { sd = strBot, ud = useBot } - -seqDmd :: Demand -seqDmd = JD { sd = Str HeadStr, ud = Use One UHead } - -oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u) -oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } -oneifyDmd jd = jd - -isTopDmd :: Demand -> Bool --- Used to suppress pretty-printing of an uninformative demand -isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True -isTopDmd _ = False - -isAbsDmd :: JointDmd (Str s) (Use u) -> Bool -isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr -isAbsDmd _ = False -- for a bottom demand - -isSeqDmd :: Demand -> Bool -isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True -isSeqDmd _ = False - -isUsedOnce :: JointDmd (Str s) (Use u) -> Bool -isUsedOnce (JD { ud = a }) = case useCount a of - One -> True - Many -> False - --- More utility functions for strictness -seqDemand :: Demand -> () -seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u - -seqDemandList :: [Demand] -> () -seqDemandList [] = () -seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds - -isStrictDmd :: JointDmd (Str s) (Use u) -> Bool --- See Note [Strict demands] -isStrictDmd (JD {ud = Abs}) = False -isStrictDmd (JD {sd = Lazy}) = False -isStrictDmd _ = True - -isWeakDmd :: Demand -> Bool -isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a - -cleanUseDmd_maybe :: Demand -> Maybe UseDmd -cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u -cleanUseDmd_maybe _ = Nothing - -splitFVs :: Bool -- Thunk - -> DmdEnv -> (DmdEnv, DmdEnv) -splitFVs is_thunk rhs_fvs - | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs - -- It's OK to use nonDetFoldUFM_Directly because we - -- immediately forget the ordering by putting the elements - -- in the envs again - | otherwise = partitionVarEnv isWeakDmd rhs_fvs - where - add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv) - | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) - | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) - , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) ) - -data TypeShape = TsFun TypeShape - | TsProd [TypeShape] - | TsUnk - -instance Outputable TypeShape where - ppr TsUnk = text "TsUnk" - ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) - ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) - --- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and --- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise. -peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape -peelTsFuns 0 ts = Just ts -peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts -peelTsFuns _ _ = Nothing - -trimToType :: Demand -> TypeShape -> Demand --- See Note [Trimming a demand to a type] -trimToType (JD { sd = ms, ud = mu }) ts - = JD (go_ms ms ts) (go_mu mu ts) - where - go_ms :: ArgStr -> TypeShape -> ArgStr - go_ms Lazy _ = Lazy - go_ms (Str s) ts = Str (go_s s ts) - - go_s :: StrDmd -> TypeShape -> StrDmd - go_s HyperStr _ = HyperStr - go_s (SCall s) (TsFun ts) = SCall (go_s s ts) - go_s (SProd mss) (TsProd tss) - | equalLength mss tss = SProd (zipWith go_ms mss tss) - go_s _ _ = HeadStr - - go_mu :: ArgUse -> TypeShape -> ArgUse - go_mu Abs _ = Abs - go_mu (Use c u) ts = Use c (go_u u ts) - - go_u :: UseDmd -> TypeShape -> UseDmd - go_u UHead _ = UHead - go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) - go_u (UProd mus) (TsProd tss) - | equalLength mus tss = UProd (zipWith go_mu mus tss) - go_u _ _ = Used - -{- -Note [Trimming a demand to a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f :: a -> Bool - f x = case ... of - A g1 -> case (x |> g1) of (p,q) -> ... - B -> error "urk" - -where A,B are the constructors of a GADT. We'll get a U(U,U) demand -on x from the A branch, but that's a stupid demand for x itself, which -has type 'a'. Indeed we get ASSERTs going off (notably in -splitUseProdDmd, #8569). - -Bottom line: we really don't want to have a binder whose demand is more -deeply-nested than its type. There are various ways to tackle this. -When processing (x |> g1), we could "trim" the incoming demand U(U,U) -to match x's type. But I'm currently doing so just at the moment when -we pin a demand on a binder, in GHC.Core.Op.DmdAnal.findBndrDmd. - - -Note [Threshold demands] -~~~~~~~~~~~~~~~~~~~~~~~~ -Threshold usage demand is generated to figure out if -cardinality-instrumented demands of a binding's free variables should -be unleashed. See also [Aggregated demand for cardinality]. - -Note [Replicating polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some demands can be considered as polymorphic. Generally, it is -applicable to such beasts as tops, bottoms as well as Head-Used and -Head-stricts demands. For instance, - -S ~ S(L, ..., L) - -Also, when top or bottom is occurred as a result demand, it in fact -can be expanded to saturate a callee's arity. --} - -splitProdDmd_maybe :: Demand -> Maybe [Demand] --- Split a product into its components, iff there is any --- useful information to be extracted thereby --- The demand is not necessarily strict! -splitProdDmd_maybe (JD { sd = s, ud = u }) - = case (s,u) of - (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u - -> Just (mkJointDmds sx ux) - (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s - -> Just (mkJointDmds sx ux) - (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) - _ -> Nothing - -{- -************************************************************************ -* * - Termination -* * -************************************************************************ - -Divergence: Dunno - / - Diverges - -In a fixpoint iteration, start from Diverges --} - -data Divergence - = Diverges -- Definitely diverges - | Dunno -- Might diverge or converge - deriving( Eq, Show ) - -lubDivergence :: Divergence -> Divergence ->Divergence -lubDivergence Diverges r = r -lubDivergence r Diverges = r -lubDivergence Dunno Dunno = Dunno --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `lubDivergence` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) - -bothDivergence :: Divergence -> Divergence -> Divergence --- See Note [Asymmetry of 'both' for DmdType and Divergence] -bothDivergence _ Diverges = Diverges -bothDivergence r Dunno = r --- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `bothDivergence` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 --- (See Note [Default demand on free variables] for why) - -instance Outputable Divergence where - ppr Diverges = char 'b' - ppr Dunno = empty - ------------------------------------------------------------------------- --- Combined demand result -- ------------------------------------------------------------------------- - --- [cprRes] lets us switch off CPR analysis --- by making sure that everything uses TopRes -topDiv, botDiv :: Divergence -topDiv = Dunno -botDiv = Diverges - -isTopDiv :: Divergence -> Bool -isTopDiv Dunno = True -isTopDiv _ = False - --- | True if the result diverges or throws an exception -isBotDiv :: Divergence -> Bool -isBotDiv Diverges = True -isBotDiv _ = False - --- See Notes [Default demand on free variables] --- and [defaultDmd vs. resTypeArgDmd] -defaultDmd :: Divergence -> Demand -defaultDmd Dunno = absDmd -defaultDmd _ = botDmd -- Diverges - -resTypeArgDmd :: Divergence -> Demand --- TopRes and BotRes are polymorphic, so that --- BotRes === (Bot -> BotRes) === ... --- TopRes === (Top -> TopRes) === ... --- This function makes that concrete --- Also see Note [defaultDmd vs. resTypeArgDmd] -resTypeArgDmd Dunno = topDmd -resTypeArgDmd _ = botDmd -- Diverges - -{- -Note [defaultDmd and resTypeArgDmd] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -These functions are similar: They express the demand on something not -explicitly mentioned in the environment resp. the argument list. Yet they are -different: - * Variables not mentioned in the free variables environment are definitely - unused, so we can use absDmd there. - * Further arguments *can* be used, of course. Hence topDmd is used. - - -************************************************************************ -* * - Demand environments and types -* * -************************************************************************ --} - -type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] - -data DmdType = DmdType - DmdEnv -- Demand on explicitly-mentioned - -- free variables - [Demand] -- Demand on arguments - Divergence -- See [Nature of result demand] - -{- -Note [Nature of result demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A Divergence contains information about termination (currently distinguishing -definite divergence and no information; it is possible to include definite -convergence here), and CPR information about the result. - -The semantics of this depends on whether we are looking at a DmdType, i.e. the -demand put on by an expression _under a specific incoming demand_ on its -environment, or at a StrictSig describing a demand transformer. - -For a - * DmdType, the termination information is true given the demand it was - generated with, while for - * a StrictSig it holds after applying enough arguments. - -The CPR information, though, is valid after the number of arguments mentioned -in the type is given. Therefore, when forgetting the demand on arguments, as in -dmdAnalRhs, this needs to be considered (via removeDmdTyArgs). - -Consider - b2 x y = x `seq` y `seq` error (show x) -this has a strictness signature of - b -meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but -for "b2 1 2 `seq` ()" we get definite divergence. - -For comparison, - b1 x = x `seq` error (show x) -has a strictness signature of - b -and "b1 1 `seq` ()" is known to terminate. - -Now consider a function h with signature "", and the expression - e1 = h b1 -now h puts a demand of onto its argument, and the demand transformer -turns it into - b -Now the Divergence "b" does apply to us, even though "b1 `seq` ()" does not -diverge, and we do not anything being passed to b. - -Note [Asymmetry of 'both' for DmdType and Divergence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'both' for DmdTypes is *asymmetrical*, because there is only one -result! For example, given (e1 e2), we get a DmdType dt1 for e1, use -its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). -Similarly with - case e of { p -> rhs } -we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then -compute (dt_rhs `bothType` dt_scrut). - -We - 1. combine the information on the free variables, - 2. take the demand on arguments from the first argument - 3. combine the termination results, but - 4. take CPR info from the first argument. - -3 and 4 are implemented in bothDivergence. --} - --- Equality needed for fixpoints in GHC.Core.Op.DmdAnal -instance Eq DmdType where - (==) (DmdType fv1 ds1 div1) - (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 - -- It's OK to use nonDetUFMToList here because we're testing for - -- equality and even though the lists will be in some arbitrary - -- Unique order, it is the same order for both - && ds1 == ds2 && div1 == div2 - -lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 - = DmdType lub_fv lub_ds lub_div - where - n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1 r1) = ensureArgs n d1 - (DmdType fv2 ds2 r2) = ensureArgs n d2 - - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) - lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 - lub_div = lubDivergence r1 r2 - -{- -Note [The need for BothDmdArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, the right argument to bothDmdType, as well as the return value of -dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs -to know about the free variables and termination information, but nothing about -the demand put on arguments, nor cpr information. So we make that explicit by -only passing the relevant information. --} - -type BothDmdArg = (DmdEnv, Divergence) - -mkBothDmdArg :: DmdEnv -> BothDmdArg -mkBothDmdArg env = (env, Dunno) - -toBothDmdArg :: DmdType -> BothDmdArg -toBothDmdArg (DmdType fv _ r) = (fv, go r) - where - go Dunno = Dunno - go Diverges = Diverges - -bothDmdType :: DmdType -> BothDmdArg -> DmdType -bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) - -- See Note [Asymmetry of 'both' for DmdType and Divergence] - -- 'both' takes the argument/result info from its *first* arg, - -- using its second arg just for its free-var info. - = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) - ds1 - (r1 `bothDivergence` t2) - -instance Outputable DmdType where - ppr (DmdType fv ds res) - = hsep [hcat (map ppr ds) <> ppr res, - if null fv_elts then empty - else braces (fsep (map pp_elt fv_elts))] - where - pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd - fv_elts = nonDetUFMToList fv - -- It's OK to use nonDetUFMToList here because we only do it for - -- pretty printing - -emptyDmdEnv :: VarEnv Demand -emptyDmdEnv = emptyVarEnv - --- nopDmdType is the demand of doing nothing --- (lazy, absent, no CPR information, no termination information). --- Note that it is ''not'' the top of the lattice (which would be "may use everything"), --- so it is (no longer) called topDmd -nopDmdType, botDmdType :: DmdType -nopDmdType = DmdType emptyDmdEnv [] topDiv -botDmdType = DmdType emptyDmdEnv [] botDiv - -isTopDmdType :: DmdType -> Bool -isTopDmdType (DmdType env [] res) - | isTopDiv res && isEmptyVarEnv env = True -isTopDmdType _ = False - -mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType -mkDmdType fv ds res = DmdType fv ds res - -dmdTypeDepth :: DmdType -> Arity -dmdTypeDepth (DmdType _ ds _) = length ds - --- | This makes sure we can use the demand type with n arguments. --- It extends the argument list with the correct resTypeArgDmd. --- It also adjusts the Divergence: Divergence survives additional arguments, --- CPR information does not (and definite converge also would not). -ensureArgs :: Arity -> DmdType -> DmdType -ensureArgs n d | n == depth = d - | otherwise = DmdType fv ds' r' - where depth = dmdTypeDepth d - DmdType fv ds r = d - - ds' = take n (ds ++ repeat (resTypeArgDmd r)) - r' = case r of -- See [Nature of result demand] - Dunno -> topDiv - _ -> r - - -seqDmdType :: DmdType -> () -seqDmdType (DmdType env ds res) = - seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () - -seqDmdEnv :: DmdEnv -> () -seqDmdEnv env = seqEltsUFM seqDemandList env - -splitDmdTy :: DmdType -> (Demand, DmdType) --- Split off one function argument --- We already have a suitable demand on all --- free vars, so no need to add more! -splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) -splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) - --- When e is evaluated after executing an IO action, and d is e's demand, then --- what of this demand should we consider, given that the IO action can cleanly --- exit? --- * We have to kill all strictness demands (i.e. lub with a lazy demand) --- * We can keep usage information (i.e. lub with an absent demand) --- * We have to kill definite divergence --- * We can keep CPR information. --- See Note [IO hack in the demand analyser] in GHC.Core.Op.DmdAnal -deferAfterIO :: DmdType -> DmdType -deferAfterIO d@(DmdType _ _ res) = - case d `lubDmdType` nopDmdType of - DmdType fv ds _ -> DmdType fv ds (defer_res res) - where - defer_res r@(Dunno {}) = r - defer_res _ = topDiv -- Diverges - -strictenDmd :: Demand -> CleanDemand -strictenDmd (JD { sd = s, ud = u}) - = JD { sd = poke_s s, ud = poke_u u } - where - poke_s Lazy = HeadStr - poke_s (Str s) = s - poke_u Abs = UHead - poke_u (Use _ u) = u - --- Deferring and peeling - -type DmdShell -- Describes the "outer shell" - -- of a Demand - = JointDmd (Str ()) (Use ()) - -toCleanDmd :: Demand -> (DmdShell, CleanDemand) --- Splits a Demand into its "shell" and the inner "clean demand" -toCleanDmd (JD { sd = s, ud = u }) - = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) - -- See Note [Analyzing with lazy demand and lambdas] - -- See Note [Analysing with absent demand] - where - (ss, s') = case s of - Str s' -> (Str (), s') - Lazy -> (Lazy, HeadStr) - - (us, u') = case u of - Use c u' -> (Use c (), u') - Abs -> (Abs, Used) - --- This is used in dmdAnalStar when post-processing --- a function's argument demand. So we only care about what --- does to free variables, and whether it terminates. --- see Note [The need for BothDmdArg] -postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg -postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) - = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty) - -postProcessDivergence :: Str () -> Divergence -> Divergence -postProcessDivergence Lazy _ = topDiv -postProcessDivergence _ res = res - -postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv -postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env - | Abs <- us = emptyDmdEnv - -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild - -- of the environment. Be careful, bad things will happen if this doesn't - -- match postProcessDmd (see #13977). - | Str _ <- ss - , Use One _ <- us = env - | otherwise = mapVarEnv (postProcessDmd ds) env - -- For the Absent case just discard all usage information - -- We only processed the thing at all to analyse the body - -- See Note [Always analyse in virgin pass] - -reuseEnv :: DmdEnv -> DmdEnv -reuseEnv = mapVarEnv (postProcessDmd - (JD { sd = Str (), ud = Use Many () })) - -postProcessUnsat :: DmdShell -> DmdType -> DmdType -postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) - = DmdType (postProcessDmdEnv ds fv) - (map (postProcessDmd ds) args) - (postProcessDivergence ss res_ty) - -postProcessDmd :: DmdShell -> Demand -> Demand -postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) - = JD { sd = s', ud = a' } - where - s' = case ss of - Lazy -> Lazy - Str _ -> s - a' = case us of - Abs -> Abs - Use Many _ -> markReusedDmd a - Use One _ -> a - --- Peels one call level from the demand, and also returns --- whether it was unsaturated (separately for strictness and usage) -peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) --- Exploiting the fact that --- on the strictness side C(B) = B --- and on the usage side C(U) = U -peelCallDmd (JD {sd = s, ud = u}) - = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) - where - (s', ss) = case s of - SCall s' -> (s', Str ()) - HyperStr -> (HyperStr, Str ()) - _ -> (HeadStr, Lazy) - (u', us) = case u of - UCall c u' -> (u', Use c ()) - _ -> (Used, Use Many ()) - -- The _ cases for usage includes UHead which seems a bit wrong - -- because the body isn't used at all! - -- c.f. the Abs case in toCleanDmd - --- Peels that multiple nestings of calls clean demand and also returns --- whether it was unsaturated (separately for strictness and usage --- see Note [Demands from unsaturated function calls] -peelManyCalls :: Int -> CleanDemand -> DmdShell -peelManyCalls n (JD { sd = str, ud = abs }) - = JD { sd = go_str n str, ud = go_abs n abs } - where - go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer - go_str 0 _ = Str () - go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) - go_str n (SCall d') = go_str (n-1) d' - go_str _ _ = Lazy - - go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least - go_abs 0 _ = Use One () -- one UCall Many in the demand - go_abs n (UCall One d') = go_abs (n-1) d' - go_abs _ _ = Use Many () - -{- -Note [Demands from unsaturated function calls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider a demand transformer d1 -> d2 -> r for f. -If a sufficiently detailed demand is fed into this transformer, -e.g arising from "f x1 x2" in a strict, use-once context, -then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for -the free variable environment) and furthermore the result information r is the -one we want to use. - -An anonymous lambda is also an unsaturated function all (needs one argument, -none given), so this applies to that case as well. - -But the demand fed into f might be less than . There are a few cases: - * Not enough demand on the strictness side: - - In that case, we need to zap all strictness in the demand on arguments and - free variables. - - Furthermore, we remove CPR information. It could be left, but given the incoming - demand is not enough to evaluate so far we just do not bother. - - And finally termination information: If r says that f diverges for sure, - then this holds when the demand guarantees that two arguments are going to - be passed. If the demand is lower, we may just as well converge. - If we were tracking definite convegence, than that would still hold under - a weaker demand than expected by the demand transformer. - * Not enough demand from the usage side: The missing usage can be expanded - using UCall Many, therefore this is subsumed by the third case: - * At least one of the uses has a cardinality of Many. - - Even if f puts a One demand on any of its argument or free variables, if - we call f multiple times, we may evaluate this argument or free variable - multiple times. So forget about any occurrence of "One" in the demand. - -In dmdTransformSig, we call peelManyCalls to find out if we are in any of these -cases, and then call postProcessUnsat to reduce the demand appropriately. - -Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use -peelCallDmd, which peels only one level, but also returns the demand put on the -body of the function. --} - -peelFV :: DmdType -> Var -> (DmdType, Demand) -peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) - (DmdType fv' ds res, dmd) - where - fv' = fv `delVarEnv` id - -- See Note [Default demand on free variables] - dmd = lookupVarEnv fv id `orElse` defaultDmd res - -addDemand :: Demand -> DmdType -> DmdType -addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res - -findIdDemand :: DmdType -> Var -> Demand -findIdDemand (DmdType fv _ res) id - = lookupVarEnv fv id `orElse` defaultDmd res - -{- -Note [Default demand on free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the variable is not mentioned in the environment of a demand type, -its demand is taken to be a result demand of the type. - For the strictness component, - if the result demand is a Diverges, then we use HyperStr - else we use Lazy - For the usage component, we use Absent. -So we use either absDmd or botDmd. - -Also note the equations for lubDivergence (resp. bothDivergence) noted there. - -Note [Always analyse in virgin pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tricky point: make sure that we analyse in the 'virgin' pass. Consider - rec { f acc x True = f (...rec { g y = ...g... }...) - f acc x False = acc } -In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. -That might mean that we analyse the sub-expression containing the -E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* -E, but just returned botType. - -Then in the *next* (non-virgin) iteration for 'f', we might analyse E -in a weaker demand, and that will trigger doing a fixpoint iteration -for g. But *because it's not the virgin pass* we won't start g's -iteration at bottom. Disaster. (This happened in $sfibToList' of -nofib/spectral/fibheaps.) - -So in the virgin pass we make sure that we do analyse the expression -at least once, to initialise its signatures. - -Note [Analyzing with lazy demand and lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The insight for analyzing lambdas follows from the fact that for -strictness S = C(L). This polymorphic expansion is critical for -cardinality analysis of the following example: - -{-# NOINLINE build #-} -build g = (g (:) [], g (:) []) - -h c z = build (\x -> - let z1 = z ++ z - in if c - then \y -> x (y ++ z1) - else \y -> x (z1 ++ y)) - -One can see that `build` assigns to `g` demand . -Therefore, when analyzing the lambda `(\x -> ...)`, we -expect each lambda \y -> ... to be annotated as "one-shot" -one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a -demand . - -This is achieved by, first, converting the lazy demand L into the -strict S by the second clause of the analysis. - -Note [Analysing with absent demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we analyse an expression with demand . The "A" means -"absent", so this expression will never be needed. What should happen? -There are several wrinkles: - -* We *do* want to analyse the expression regardless. - Reason: Note [Always analyse in virgin pass] - - But we can post-process the results to ignore all the usage - demands coming back. This is done by postProcessDmdType. - -* In a previous incarnation of GHC we needed to be extra careful in the - case of an *unlifted type*, because unlifted values are evaluated - even if they are not used. Example (see #9254): - f :: (() -> (# Int#, () #)) -> () - -- Strictness signature is - -- - -- I.e. calls k, but discards first component of result - f k = case k () of (# _, r #) -> r - - g :: Int -> () - g y = f (\n -> (# case y of I# y2 -> y2, n #)) - - Here f's strictness signature says (correctly) that it calls its - argument function and ignores the first component of its result. - This is correct in the sense that it'd be fine to (say) modify the - function so that always returned 0# in the first component. - - But in function g, we *will* evaluate the 'case y of ...', because - it has type Int#. So 'y' will be evaluated. So we must record this - usage of 'y', else 'g' will say 'y' is absent, and will w/w so that - 'y' is bound to an aBSENT_ERROR thunk. - - However, the argument of toCleanDmd always satisfies the let/app - invariant; so if it is unlifted it is also okForSpeculation, and so - can be evaluated in a short finite time -- and that rules out nasty - cases like the one above. (I'm not quite sure why this was a - problem in an earlier version of GHC, but it isn't now.) - - -************************************************************************ -* * - Demand signatures -* * -************************************************************************ - -In a let-bound Id we record its strictness info. -In principle, this strictness info is a demand transformer, mapping -a demand on the Id into a DmdType, which gives - a) the free vars of the Id's value - b) the Id's arguments - c) an indication of the result of applying - the Id to its arguments - -However, in fact we store in the Id an extremely emascuated demand -transfomer, namely - - a single DmdType -(Nevertheless we dignify StrictSig as a distinct type.) - -This DmdType gives the demands unleashed by the Id when it is applied -to as many arguments as are given in by the arg demands in the DmdType. -Also see Note [Nature of result demand] for the meaning of a Divergence in a -strictness signature. - -If an Id is applied to less arguments than its arity, it means that -the demand on the function at a call site is weaker than the vanilla -call demand, used for signature inference. Therefore we place a top -demand on all arguments. Otherwise, the demand is specified by Id's -signature. - -For example, the demand transformer described by the demand signature - StrictSig (DmdType {x -> } m) -says that when the function is applied to two arguments, it -unleashes demand on the free var x, on the first arg, -and on the second, then returning a constructor. - -If this same function is applied to one arg, all we can say is that it -uses x with , and its arg with demand . - -Note [Understanding DmdType and StrictSig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand types are sound approximations of an expression's semantics relative to -the incoming demand we put the expression under. Consider the following -expression: - - \x y -> x `seq` (y, 2*x) - -Here is a table with demand types resulting from different incoming demands we -put that expression under. Note the monotonicity; a stronger incoming demand -yields a more precise demand type: - - incoming demand | demand type - ---------------------------------------------------- - | {} - | {} - | {} - -Note that in the first example, the depth of the demand type was *higher* than -the arity of the incoming call demand due to the anonymous lambda. -The converse is also possible and happens when we unleash demand signatures. -In @f x y@, the incoming call demand on f has arity 2. But if all we have is a -demand signature with depth 1 for @f@ (which we can safely unleash, see below), -the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1. - -So: Demand types are elicited by putting an expression under an incoming (call) -demand, the arity of which can be lower or higher than the depth of the -resulting demand type. -In contrast, a demand signature summarises a function's semantics *without* -immediately specifying the incoming demand it was produced under. Despite StrSig -being a newtype wrapper around DmdType, it actually encodes two things: - - * The threshold (i.e., minimum arity) to unleash the signature - * A demand type that is sound to unleash when the minimum arity requirement is - met. - -Here comes the subtle part: The threshold is encoded in the wrapped demand -type's depth! So in mkStrictSigForArity we make sure to trim the list of -argument demands to the given threshold arity. Call sites will make sure that -this corresponds to the arity of the call demand that elicited the wrapped -demand type. See also Note [What are demand signatures?] in GHC.Core.Op.DmdAnal. - -Besides trimming argument demands, mkStrictSigForArity will also trim CPR -information if necessary. --} - --- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe --- to unleash. Better construct this through 'mkStrictSigForArity'. --- See Note [Understanding DmdType and StrictSig] -newtype StrictSig = StrictSig DmdType - deriving( Eq ) - -instance Outputable StrictSig where - ppr (StrictSig ty) = ppr ty - --- Used for printing top-level strictness pragmas in interface files -pprIfaceStrictSig :: StrictSig -> SDoc -pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) - = hcat (map ppr dmds) <> ppr res - --- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' --- unleashable at that arity. See Note [Understanding DmdType and StrictSig] -mkStrictSigForArity :: Arity -> DmdType -> StrictSig -mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty) - -mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig -mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) - -splitStrictSig :: StrictSig -> ([Demand], Divergence) -splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) - -increaseStrictSigArity :: Int -> StrictSig -> StrictSig --- ^ Add extra arguments to a strictness signature. --- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument --- demands and leaves CPR info intact. -increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res)) - | isTopDmdType dmd_ty = sig - | arity_increase == 0 = sig - | arity_increase < 0 = WARN( True, text "increaseStrictSigArity:" - <+> text "negative arity increase" - <+> ppr arity_increase ) - nopSig - | otherwise = StrictSig (DmdType env dmds' res) - where - dmds' = replicate arity_increase topDmd ++ dmds - -etaExpandStrictSig :: Arity -> StrictSig -> StrictSig --- ^ We are expanding (\x y. e) to (\x y z. e z). --- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if --- necessary, potentially destroying the signature's CPR property. -etaExpandStrictSig arity (StrictSig dmd_ty) - | arity < dmdTypeDepth dmd_ty - -- an arity decrease must zap the whole signature, because it was possibly - -- computed for a higher incoming call demand. - = nopSig - | otherwise - = StrictSig $ ensureArgs arity dmd_ty - -isTopSig :: StrictSig -> Bool -isTopSig (StrictSig ty) = isTopDmdType ty - -hasDemandEnvSig :: StrictSig -> Bool -hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) - -strictSigDmdEnv :: StrictSig -> DmdEnv -strictSigDmdEnv (StrictSig (DmdType env _ _)) = env - --- | True if the signature diverges or throws an exception -isBottomingSig :: StrictSig -> Bool -isBottomingSig (StrictSig (DmdType _ _ res)) = isBotDiv res - -nopSig, botSig :: StrictSig -nopSig = StrictSig nopDmdType -botSig = StrictSig botDmdType - -cprProdSig :: Arity -> StrictSig -cprProdSig _arity = nopSig - -seqStrictSig :: StrictSig -> () -seqStrictSig (StrictSig ty) = seqDmdType ty - -dmdTransformSig :: StrictSig -> CleanDemand -> DmdType --- (dmdTransformSig fun_sig dmd) considers a call to a function whose --- signature is fun_sig, with demand dmd. We return the demand --- that the function places on its context (eg its args) -dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd - = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty - -- see Note [Demands from unsaturated function calls] - -dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType --- Same as dmdTransformSig but for a data constructor (worker), --- which has a special kind of demand transformer. --- If the constructor is saturated, we feed the demand on --- the result into the constructor arguments. -dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) - (JD { sd = str, ud = abs }) - | Just str_dmds <- go_str arity str - , Just abs_dmds <- go_abs arity abs - = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res - -- Must remember whether it's a product, hence con_res, not TopRes - - | otherwise -- Not saturated - = nopDmdType - where - go_str 0 dmd = splitStrProdDmd arity dmd - go_str n (SCall s') = go_str (n-1) s' - go_str n HyperStr = go_str (n-1) HyperStr - go_str _ _ = Nothing - - go_abs 0 dmd = splitUseProdDmd arity dmd - go_abs n (UCall One u') = go_abs (n-1) u' - go_abs _ _ = Nothing - -dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType --- Like dmdTransformDataConSig, we have a special demand transformer --- for dictionary selectors. If the selector is saturated (ie has one --- argument: the dictionary), we feed the demand on the result into --- the indicated dictionary component. -dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd - | (cd',defer_use) <- peelCallDmd cd - , Just jds <- splitProdDmd_maybe dict_dmd - = postProcessUnsat defer_use $ - DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv - | otherwise - = nopDmdType -- See Note [Demand transformer for a dictionary selector] - where - enhance cd old | isAbsDmd old = old - | otherwise = mkOnceUsedDmd cd -- This is the one! - -dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" - -{- -Note [Demand transformer for a dictionary selector] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' -into the appropriate field of the dictionary. What *is* the appropriate field? -We just look at the strictness signature of the class op, which will be -something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. - -For single-method classes, which are represented by newtypes the signature -of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. -That's fine: if we are doing strictness analysis we are also doing inlining, -so we'll have inlined 'op' into a cast. So we can bale out in a conservative -way, returning nopDmdType. - -It is (just.. #8329) possible to be running strictness analysis *without* -having inlined class ops from single-method classes. Suppose you are using -ghc --make; and the first module has a local -O0 flag. So you may load a class -without interface pragmas, ie (currently) without an unfolding for the class -ops. Now if a subsequent module in the --make sweep has a local -O flag -you might do strictness analysis, but there is no inlining for the class op. -This is weird, so I'm not worried about whether this optimises brilliantly; but -it should not fall over. --} - -argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] --- See Note [Computing one-shot info] -argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args - | unsaturated_call = [] - | otherwise = go arg_ds - where - unsaturated_call = arg_ds `lengthExceeds` n_val_args - - go [] = [] - go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds - - -- Avoid list tail like [ [], [], [] ] - cons [] [] = [] - cons a as = a:as - --- saturatedByOneShots n C1(C1(...)) = True, --- <=> --- there are at least n nested C1(..) calls --- See Note [Demand on the worker] in GHC.Core.Op.WorkWrap -saturatedByOneShots :: Int -> Demand -> Bool -saturatedByOneShots n (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go n arg_usg - _ -> False - where - go 0 _ = True - go n (UCall One u) = go (n-1) u - go _ _ = False - -argOneShots :: Demand -- depending on saturation - -> [OneShotInfo] -argOneShots (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go arg_usg - _ -> [] - where - go (UCall One u) = OneShotLam : go u - go (UCall Many u) = NoOneShotInfo : go u - go _ = [] - -{- Note [Computing one-shot info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a call - f (\pqr. e1) (\xyz. e2) e3 -where f has usage signature - C1(C(C1(U))) C1(U) U -Then argsOneShots returns a [[OneShotInfo]] of - [[OneShot,NoOneShotInfo,OneShot], [OneShot]] -The occurrence analyser propagates this one-shot infor to the -binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. --} - --- | Returns true if an application to n args --- would diverge or throw an exception --- See Note [Unsaturated applications] -appIsBottom :: StrictSig -> Int -> Bool -appIsBottom (StrictSig (DmdType _ ds res)) n - | isBotDiv res = not $ lengthExceeds ds n -appIsBottom _ _ = False - -{- -Note [Unsaturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a function having bottom as its demand result is applied to a less -number of arguments than its syntactic arity, we cannot say for sure -that it is going to diverge. This is the reason why we use the -function appIsBottom, which, given a strictness signature and a number -of arguments, says conservatively if the function is going to diverge -or not. --} - -zapUsageEnvSig :: StrictSig -> StrictSig --- Remove the usage environment from the demand -zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r - -zapUsageDemand :: Demand -> Demand --- Remove the usage info, but not the strictness info, from the demand -zapUsageDemand = kill_usage $ KillFlags - { kf_abs = True - , kf_used_once = True - , kf_called_once = True - } - --- | Remove all 1* information (but not C1 information) from the demand -zapUsedOnceDemand :: Demand -> Demand -zapUsedOnceDemand = kill_usage $ KillFlags - { kf_abs = False - , kf_used_once = True - , kf_called_once = False - } - --- | Remove all 1* information (but not C1 information) from the strictness --- signature -zapUsedOnceSig :: StrictSig -> StrictSig -zapUsedOnceSig (StrictSig (DmdType env ds r)) - = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) - -data KillFlags = KillFlags - { kf_abs :: Bool - , kf_used_once :: Bool - , kf_called_once :: Bool - } - -kill_usage :: KillFlags -> Demand -> Demand -kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} - -zap_musg :: KillFlags -> ArgUse -> ArgUse -zap_musg kfs Abs - | kf_abs kfs = useTop - | otherwise = Abs -zap_musg kfs (Use c u) - | kf_used_once kfs = Use Many (zap_usg kfs u) - | otherwise = Use c (zap_usg kfs u) - -zap_usg :: KillFlags -> UseDmd -> UseDmd -zap_usg kfs (UCall c u) - | kf_called_once kfs = UCall Many (zap_usg kfs u) - | otherwise = UCall c (zap_usg kfs u) -zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) -zap_usg _ u = u - --- If the argument is a used non-newtype dictionary, give it strict --- demand. Also split the product type & demand and recur in order to --- similarly strictify the argument's contained used non-newtype --- superclass dictionaries. We use the demand as our recursive measure --- to guarantee termination. -strictifyDictDmd :: Type -> Demand -> Demand -strictifyDictDmd ty dmd = case getUseDmd dmd of - Use n _ | - Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) - <- splitDataProductType_maybe ty, - not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary - -> seqDmd `bothDmd` -- main idea: ensure it's strict - case splitProdDmd_maybe dmd of - -- superclass cycles should not be a problem, since the demand we are - -- consuming would also have to be infinite in order for us to diverge - Nothing -> dmd -- no components have interesting demand, so stop - -- looking for superclass dicts - Just dmds - | all (not . isAbsDmd) dmds -> evalDmd - -- abstract to strict w/ arbitrary component use, since this - -- smells like reboxing; results in CBV boxed - -- - -- TODO revisit this if we ever do boxity analysis - | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of - JD {sd = s,ud = a} -> JD (Str s) (Use n a) - -- TODO could optimize with an aborting variant of zipWith since - -- the superclass dicts are always a prefix - _ -> dmd -- unused or not a dictionary - -strictifyDmd :: Demand -> Demand -strictifyDmd dmd@(JD { sd = str }) - = dmd { sd = str `bothArgStr` Str HeadStr } - -{- -Note [HyperStr and Use demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The information "HyperStr" needs to be in the strictness signature, and not in -the demand signature, because we still want to know about the demand on things. Consider - - f (x,y) True = error (show x) - f (x,y) False = x+1 - -The signature of f should be m. If we were not -distinguishing the uses on x and y in the True case, we could either not figure -out how deeply we can unpack x, or that we do not have to pass y. - - -************************************************************************ -* * - Serialisation -* * -************************************************************************ --} - -instance Binary StrDmd where - put_ bh HyperStr = do putByte bh 0 - put_ bh HeadStr = do putByte bh 1 - put_ bh (SCall s) = do putByte bh 2 - put_ bh s - put_ bh (SProd sx) = do putByte bh 3 - put_ bh sx - get bh = do - h <- getByte bh - case h of - 0 -> do return HyperStr - 1 -> do return HeadStr - 2 -> do s <- get bh - return (SCall s) - _ -> do sx <- get bh - return (SProd sx) - -instance Binary ArgStr where - put_ bh Lazy = do - putByte bh 0 - put_ bh (Str s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return Lazy - _ -> do s <- get bh - return $ Str s - -instance Binary Count where - put_ bh One = do putByte bh 0 - put_ bh Many = do putByte bh 1 - - get bh = do h <- getByte bh - case h of - 0 -> return One - _ -> return Many - -instance Binary ArgUse where - put_ bh Abs = do - putByte bh 0 - put_ bh (Use c u) = do - putByte bh 1 - put_ bh c - put_ bh u - - get bh = do - h <- getByte bh - case h of - 0 -> return Abs - _ -> do c <- get bh - u <- get bh - return $ Use c u - -instance Binary UseDmd where - put_ bh Used = do - putByte bh 0 - put_ bh UHead = do - putByte bh 1 - put_ bh (UCall c u) = do - putByte bh 2 - put_ bh c - put_ bh u - put_ bh (UProd ux) = do - putByte bh 3 - put_ bh ux - - get bh = do - h <- getByte bh - case h of - 0 -> return $ Used - 1 -> return $ UHead - 2 -> do c <- get bh - u <- get bh - return (UCall c u) - _ -> do ux <- get bh - return (UProd ux) - -instance (Binary s, Binary u) => Binary (JointDmd s u) where - put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y - get bh = do - x <- get bh - y <- get bh - return $ JD { sd = x, ud = y } - -instance Binary StrictSig where - put_ bh (StrictSig aa) = do - put_ bh aa - get bh = do - aa <- get bh - return (StrictSig aa) - -instance Binary DmdType where - -- Ignore DmdEnv when spitting out the DmdType - put_ bh (DmdType _ ds dr) - = do put_ bh ds - put_ bh dr - get bh - = do ds <- get bh - dr <- get bh - return (DmdType emptyDmdEnv ds dr) - -instance Binary Divergence where - put_ bh Dunno = putByte bh 0 - put_ bh Diverges = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return Dunno - _ -> return Diverges } diff --git a/compiler/basicTypes/FieldLabel.hs b/compiler/basicTypes/FieldLabel.hs deleted file mode 100644 index d73dbd3ad3..0000000000 --- a/compiler/basicTypes/FieldLabel.hs +++ /dev/null @@ -1,130 +0,0 @@ -{- -% -% (c) Adam Gundry 2013-2015 -% - -This module defines the representation of FieldLabels as stored in -TyCons. As well as a selector name, these have some extra structure -to support the DuplicateRecordFields extension. - -In the normal case (with NoDuplicateRecordFields), a datatype like - - data T = MkT { foo :: Int } - -has - - FieldLabel { flLabel = "foo" - , flIsOverloaded = False - , flSelector = foo }. - -In particular, the Name of the selector has the same string -representation as the label. If DuplicateRecordFields -is enabled, however, the same declaration instead gives - - FieldLabel { flLabel = "foo" - , flIsOverloaded = True - , flSelector = $sel:foo:MkT }. - -Now the name of the selector ($sel:foo:MkT) does not match the label of -the field (foo). We must be careful not to show the selector name to -the user! The point of mangling the selector name is to allow a -module to define the same field label in different datatypes: - - data T = MkT { foo :: Int } - data U = MkU { foo :: Bool } - -Now there will be two FieldLabel values for 'foo', one in T and one in -U. They share the same label (FieldLabelString), but the selector -functions differ. - -See also Note [Representing fields in AvailInfo] in Avail. - -Note [Why selector names include data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -As explained above, a selector name includes the name of the first -data constructor in the type, so that the same label can appear -multiple times in the same module. (This is irrespective of whether -the first constructor has that field, for simplicity.) - -We use a data constructor name, rather than the type constructor name, -because data family instances do not have a representation type -constructor name generated until relatively late in the typechecking -process. - -Of course, datatypes with no constructors cannot have any fields. - --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE StandaloneDeriving #-} - -module FieldLabel ( FieldLabelString - , FieldLabelEnv - , FieldLbl(..) - , FieldLabel - , mkFieldLabelOccs - ) where - -import GhcPrelude - -import OccName -import Name - -import FastString -import FastStringEnv -import Outputable -import Binary - -import Data.Data - --- | Field labels are just represented as strings; --- they are not necessarily unique (even within a module) -type FieldLabelString = FastString - --- | A map from labels to all the auxiliary information -type FieldLabelEnv = DFastStringEnv FieldLabel - - -type FieldLabel = FieldLbl Name - --- | Fields in an algebraic record type -data FieldLbl a = FieldLabel { - flLabel :: FieldLabelString, -- ^ User-visible label of the field - flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on - -- in the defining module for this datatype? - flSelector :: a -- ^ Record selector function - } - deriving (Eq, Functor, Foldable, Traversable) -deriving instance Data a => Data (FieldLbl a) - -instance Outputable a => Outputable (FieldLbl a) where - ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) - -instance Binary a => Binary (FieldLbl a) where - put_ bh (FieldLabel aa ab ac) = do - put_ bh aa - put_ bh ab - put_ bh ac - get bh = do - ab <- get bh - ac <- get bh - ad <- get bh - return (FieldLabel ab ac ad) - - --- | Record selector OccNames are built from the underlying field name --- and the name of the first data constructor of the type, to support --- duplicate record field names. --- See Note [Why selector names include data constructors]. -mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName -mkFieldLabelOccs lbl dc is_overloaded - = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = sel_occ } - where - str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc - sel_occ | is_overloaded = mkRecFldSelOcc str - | otherwise = mkVarOccFS lbl diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs deleted file mode 100644 index 67cde9a0fc..0000000000 --- a/compiler/basicTypes/Id.hs +++ /dev/null @@ -1,971 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Id]{@Ids@: Value and constructor identifiers} --} - -{-# LANGUAGE CPP #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id' represents names that not only have a 'Name.Name' but also a --- 'GHC.Core.TyCo.Rep.Type' and some additional details (a 'IdInfo.IdInfo' and --- one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that are added, --- modified and inspected by various compiler passes. These 'Var.Var' names --- may either be global or local, see "Var#globalvslocal" --- --- * 'Var.Var': see "Var#name_types" - -module Id ( - -- * The main types - Var, Id, isId, - - -- * In and Out variants - InVar, InId, - OutVar, OutId, - - -- ** Simple construction - mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, - mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, - mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, - mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, - mkUserLocal, mkUserLocalOrCoVar, - mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, - mkWorkerId, - - -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, - recordSelectorTyCon, - - -- ** Modifying an Id - setIdName, setIdUnique, Id.setIdType, - setIdExported, setIdNotExported, - globaliseId, localiseId, - setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, - zapIdUsedOnceInfo, zapIdTailCallInfo, - zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, - transferPolyIdInfo, - - -- ** Predicates on Ids - isImplicitId, isDeadBinder, - isStrictId, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, isNaughtyRecordSelector, - isPatSynRecordSelector, - isDataConRecordSelector, - isClassOpId_maybe, isDFunId, - isPrimOpId, isPrimOpId_maybe, - isFCallId, isFCallId_maybe, - isDataConWorkId, isDataConWorkId_maybe, - isDataConWrapId, isDataConWrapId_maybe, - isDataConId_maybe, - idDataCon, - isConLikeId, isBottomingId, idIsFrom, - hasNoBinding, - - -- ** Join variables - JoinId, isJoinId, isJoinId_maybe, idJoinArity, - asJoinId, asJoinId_maybe, zapJoinId, - - -- ** Inline pragma stuff - idInlinePragma, setInlinePragma, modifyInlinePragma, - idInlineActivation, setInlineActivation, idRuleMatchInfo, - - -- ** One-shot lambdas - isOneShotBndr, isProbablyOneShotLambda, - setOneShotLambda, clearOneShotLambda, - updOneShotInfo, setIdOneShotInfo, - isStateHackType, stateHackOneShot, typeOneShot, - - -- ** Reading 'IdInfo' fields - idArity, - idCallArity, idFunRepArity, - idUnfolding, realIdUnfolding, - idSpecialisation, idCoreRules, idHasRules, - idCafInfo, - idOneShotInfo, idStateHackOneShotInfo, - idOccInfo, - isNeverLevPolyId, - - -- ** Writing 'IdInfo' fields - setIdUnfolding, setCaseBndrEvald, - setIdArity, - setIdCallArity, - - setIdSpecialisation, - setIdCafInfo, - setIdOccInfo, zapIdOccInfo, - - setIdDemandInfo, - setIdStrictness, - setIdCprInfo, - - idDemandInfo, - idStrictness, - idCprInfo, - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Session -import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, - isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) - -import IdInfo -import BasicTypes - --- Imported and re-exported -import Var( Id, CoVar, JoinId, - InId, InVar, - OutId, OutVar, - idInfo, idDetails, setIdDetails, globaliseId, varType, - isId, isLocalId, isGlobalId, isExportedId ) -import qualified Var - -import GHC.Core.Type -import GHC.Types.RepType -import TysPrim -import GHC.Core.DataCon -import Demand -import Cpr -import Name -import Module -import GHC.Core.Class -import {-# SOURCE #-} PrimOp (PrimOp) -import ForeignCall -import Maybes -import SrcLoc -import Outputable -import Unique -import UniqSupply -import FastString -import Util - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setIdUnfolding`, - `setIdArity`, - `setIdCallArity`, - `setIdOccInfo`, - `setIdOneShotInfo`, - - `setIdSpecialisation`, - `setInlinePragma`, - `setInlineActivation`, - `idCafInfo`, - - `setIdDemandInfo`, - `setIdStrictness`, - `setIdCprInfo`, - - `asJoinId`, - `asJoinId_maybe` - -{- -************************************************************************ -* * -\subsection{Basic Id manipulation} -* * -************************************************************************ --} - -idName :: Id -> Name -idName = Var.varName - -idUnique :: Id -> Unique -idUnique = Var.varUnique - -idType :: Id -> Kind -idType = Var.varType - -setIdName :: Id -> Name -> Id -setIdName = Var.setVarName - -setIdUnique :: Id -> Unique -> Id -setIdUnique = Var.setVarUnique - --- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and --- reduce space usage -setIdType :: Id -> Type -> Id -setIdType id ty = seqType ty `seq` Var.setVarType id ty - -setIdExported :: Id -> Id -setIdExported = Var.setIdExported - -setIdNotExported :: Id -> Id -setIdNotExported = Var.setIdNotExported - -localiseId :: Id -> Id --- Make an Id with the same unique and type as the --- incoming Id, but with an *Internal* Name and *LocalId* flavour -localiseId id - | ASSERT( isId id ) isLocalId id && isInternalName name - = id - | otherwise - = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) - where - name = idName id - -lazySetIdInfo :: Id -> IdInfo -> Id -lazySetIdInfo = Var.lazySetIdInfo - -setIdInfo :: Id -> IdInfo -> Id -setIdInfo id info = info `seq` (lazySetIdInfo id info) - -- Try to avoid space leaks by seq'ing - -modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id -modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) - --- maybeModifyIdInfo tries to avoid unnecessary thrashing -maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id -maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info -maybeModifyIdInfo Nothing id = id - -{- -************************************************************************ -* * -\subsection{Simple Id construction} -* * -************************************************************************ - -Absolutely all Ids are made by mkId. It is just like Var.mkId, -but in addition it pins free-tyvar-info onto the Id's type, -where it can easily be found. - -Note [Free type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one time we cached the free type variables of the type of an Id -at the root of the type in a TyNote. The idea was to avoid repeating -the free-type-variable calculation. But it turned out to slow down -the compiler overall. I don't quite know why; perhaps finding free -type variables of an Id isn't all that common whereas applying a -substitution (which changes the free type variables) is more common. -Anyway, we removed it in March 2008. --} - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalId = Var.mkGlobalVar - --- | Make a global 'Id' without any extra information at all -mkVanillaGlobal :: Name -> Type -> Id -mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo - --- | Make a global 'Id' with no global information but some generic 'IdInfo' -mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaId - - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkLocalId :: HasDebugCallStack => Name -> Type -> Id -mkLocalId name ty = ASSERT( not (isCoVarType ty) ) - mkLocalIdWithInfo name ty vanillaIdInfo - --- | Make a local CoVar -mkLocalCoVar :: Name -> Type -> CoVar -mkLocalCoVar name ty - = ASSERT( isCoVarType ty ) - Var.mkLocalVar CoVarId name ty vanillaIdInfo - --- | Like 'mkLocalId', but checks the type to see if it should make a covar -mkLocalIdOrCoVar :: Name -> Type -> Id -mkLocalIdOrCoVar name ty - | isCoVarType ty = mkLocalCoVar name ty - | otherwise = mkLocalId name ty - - -- proper ids only; no covars! -mkLocalIdWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id -mkLocalIdWithInfo name ty info = ASSERT( not (isCoVarType ty) ) - Var.mkLocalVar VanillaId name ty info - -- Note [Free type variables] - --- | Create a local 'Id' that is marked as exported. --- This prevents things attached to it from being removed as dead code. --- See Note [Exported LocalIds] -mkExportedLocalId :: IdDetails -> Name -> Type -> Id -mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo - -- Note [Free type variables] - -mkExportedVanillaId :: Name -> Type -> Id -mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo - -- Note [Free type variables] - - --- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") --- that are created by the compiler out of thin air -mkSysLocal :: FastString -> Unique -> Type -> Id -mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) ) - mkLocalId (mkSystemVarName uniq fs) ty - --- | Like 'mkSysLocal', but checks to see if we have a covar type -mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id -mkSysLocalOrCoVar fs uniq ty - = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty - -mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) - -mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalOrCoVarM fs ty - = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) - --- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize -mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) ) - mkLocalId (mkInternalName uniq occ loc) ty - --- | Like 'mkUserLocal', but checks if we have a coercion type -mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocalOrCoVar occ uniq ty loc - = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty - -{- -Make some local @Ids@ for a template @CoreExpr@. These have bogus -@Uniques@, but that's OK because the templates are supposed to be -instantiated before use. --} - --- | Workers get local names. "CoreTidy" will externalise these if necessary -mkWorkerId :: Unique -> Id -> Type -> Id -mkWorkerId uniq unwrkr ty - = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty - --- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings -mkTemplateLocal :: Int -> Type -> Id -mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty - -- "OrCoVar" since this is used in a superclass selector, - -- and "~" and "~~" have coercion "superclasses". - --- | Create a template local for a series of types -mkTemplateLocals :: [Type] -> [Id] -mkTemplateLocals = mkTemplateLocalsNum 1 - --- | Create a template local for a series of type, but start from a specified template local -mkTemplateLocalsNum :: Int -> [Type] -> [Id] -mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys - -{- Note [Exported LocalIds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use mkExportedLocalId for things like - - Dictionary functions (DFunId) - - Wrapper and matcher Ids for pattern synonyms - - Default methods for classes - - Pattern-synonym matcher and builder Ids - - etc - -They marked as "exported" in the sense that they should be kept alive -even if apparently unused in other bindings, and not dropped as dead -code by the occurrence analyser. (But "exported" here does not mean -"brought into lexical scope by an import declaration". Indeed these -things are always internal Ids that the user never sees.) - -It's very important that they are *LocalIds*, not GlobalIds, for lots -of reasons: - - * We want to treat them as free variables for the purpose of - dependency analysis (e.g. GHC.Core.FVs.exprFreeVars). - - * Look them up in the current substitution when we come across - occurrences of them (in Subst.lookupIdSubst). Lacking this we - can get an out-of-date unfolding, which can in turn make the - simplifier go into an infinite loop (#9857) - - * Ensure that for dfuns that the specialiser does not float dict uses - above their defns, which would prevent good simplifications happening. - - * The strictness analyser treats a occurrence of a GlobalId as - imported and assumes it contains strictness in its IdInfo, which - isn't true if the thing is bound in the same module as the - occurrence. - -In CoreTidy we must make all these LocalIds into GlobalIds, so that in -importing modules (in --make mode) we treat them as properly global. -That is what is happening in, say tidy_insts in GHC.Iface.Tidy. - -************************************************************************ -* * -\subsection{Special Ids} -* * -************************************************************************ --} - --- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. -recordSelectorTyCon :: Id -> RecSelParent -recordSelectorTyCon id - = case Var.idDetails id of - RecSelId { sel_tycon = parent } -> parent - _ -> panic "recordSelectorTyCon" - - -isRecordSelector :: Id -> Bool -isNaughtyRecordSelector :: Id -> Bool -isPatSynRecordSelector :: Id -> Bool -isDataConRecordSelector :: Id -> Bool -isPrimOpId :: Id -> Bool -isFCallId :: Id -> Bool -isDataConWorkId :: Id -> Bool -isDataConWrapId :: Id -> Bool -isDFunId :: Id -> Bool - -isClassOpId_maybe :: Id -> Maybe Class -isPrimOpId_maybe :: Id -> Maybe PrimOp -isFCallId_maybe :: Id -> Maybe ForeignCall -isDataConWorkId_maybe :: Id -> Maybe DataCon -isDataConWrapId_maybe :: Id -> Maybe DataCon - -isRecordSelector id = case Var.idDetails id of - RecSelId {} -> True - _ -> False - -isDataConRecordSelector id = case Var.idDetails id of - RecSelId {sel_tycon = RecSelData _} -> True - _ -> False - -isPatSynRecordSelector id = case Var.idDetails id of - RecSelId {sel_tycon = RecSelPatSyn _} -> True - _ -> False - -isNaughtyRecordSelector id = case Var.idDetails id of - RecSelId { sel_naughty = n } -> n - _ -> False - -isClassOpId_maybe id = case Var.idDetails id of - ClassOpId cls -> Just cls - _other -> Nothing - -isPrimOpId id = case Var.idDetails id of - PrimOpId _ -> True - _ -> False - -isDFunId id = case Var.idDetails id of - DFunId {} -> True - _ -> False - -isPrimOpId_maybe id = case Var.idDetails id of - PrimOpId op -> Just op - _ -> Nothing - -isFCallId id = case Var.idDetails id of - FCallId _ -> True - _ -> False - -isFCallId_maybe id = case Var.idDetails id of - FCallId call -> Just call - _ -> Nothing - -isDataConWorkId id = case Var.idDetails id of - DataConWorkId _ -> True - _ -> False - -isDataConWorkId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - _ -> Nothing - -isDataConWrapId id = case Var.idDetails id of - DataConWrapId _ -> True - _ -> False - -isDataConWrapId_maybe id = case Var.idDetails id of - DataConWrapId con -> Just con - _ -> Nothing - -isDataConId_maybe :: Id -> Maybe DataCon -isDataConId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - DataConWrapId con -> Just con - _ -> Nothing - -isJoinId :: Var -> Bool --- It is convenient in GHC.Core.Op.SetLevels.lvlMFE to apply isJoinId --- to the free vars of an expression, so it's convenient --- if it returns False for type variables -isJoinId id - | isId id = case Var.idDetails id of - JoinId {} -> True - _ -> False - | otherwise = False - -isJoinId_maybe :: Var -> Maybe JoinArity -isJoinId_maybe id - | isId id = ASSERT2( isId id, ppr id ) - case Var.idDetails id of - JoinId arity -> Just arity - _ -> Nothing - | otherwise = Nothing - -idDataCon :: Id -> DataCon --- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. --- --- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker -idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) - -hasNoBinding :: Id -> Bool --- ^ Returns @True@ of an 'Id' which may not have a --- binding, even though it is defined in this module. - --- Data constructor workers used to be things of this kind, but --- they aren't any more. Instead, we inject a binding for --- them at the CorePrep stage. --- --- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs. --- for the history of this. --- --- Note that CorePrep currently eta expands things no-binding things and this --- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things --- in CorePrep] in CorePrep for details. --- --- EXCEPT: unboxed tuples, which definitely have no binding -hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> False -- See Note [Primop wrappers] in PrimOp.hs - FCallId _ -> True - DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc - _ -> isCompulsoryUnfolding (idUnfolding id) - -- See Note [Levity-polymorphic Ids] - -isImplicitId :: Id -> Bool --- ^ 'isImplicitId' tells whether an 'Id's info is implied by other --- declarations, so we don't need to put its signature in an interface --- file, even if it's mentioned in some other interface unfolding. -isImplicitId id - = case Var.idDetails id of - FCallId {} -> True - ClassOpId {} -> True - PrimOpId {} -> True - DataConWorkId {} -> True - DataConWrapId {} -> True - -- These are implied by their type or class decl; - -- remember that all type and class decls appear in the interface file. - -- The dfun id is not an implicit Id; it must *not* be omitted, because - -- it carries version info for the instance decl - _ -> False - -idIsFrom :: Module -> Id -> Bool -idIsFrom mod id = nameIsLocalOrFrom mod (idName id) - -{- Note [Levity-polymorphic Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some levity-polymorphic Ids must be applied and inlined, not left -un-saturated. Example: - unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b - -This has a compulsory unfolding because we can't lambda-bind those -arguments. But the compulsory unfolding may leave levity-polymorphic -lambdas if it is not applied to enough arguments; e.g. (#14561) - bad :: forall (a :: TYPE r). a -> a - bad = unsafeCoerce# - -The desugar has special magic to detect such cases: GHC.HsToCore.Expr.badUseOfLevPolyPrimop. -And we want that magic to apply to levity-polymorphic compulsory-inline things. -The easiest way to do this is for hasNoBinding to return True of all things -that have compulsory unfolding. Some Ids with a compulsory unfolding also -have a binding, but it does not harm to say they don't here, and its a very -simple way to fix #14561. --} - -isDeadBinder :: Id -> Bool -isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) - | otherwise = False -- TyVars count as not dead - -{- -************************************************************************ -* * - Join variables -* * -************************************************************************ --} - -idJoinArity :: JoinId -> JoinArity -idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) - -asJoinId :: Id -> JoinArity -> JoinId -asJoinId id arity = WARN(not (isLocalId id), - text "global id being marked as join var:" <+> ppr id) - WARN(not (is_vanilla_or_join id), - ppr id <+> pprIdDetails (idDetails id)) - id `setIdDetails` JoinId arity - where - is_vanilla_or_join id = case Var.idDetails id of - VanillaId -> True - JoinId {} -> True - _ -> False - -zapJoinId :: Id -> Id --- May be a regular id already -zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId) - -- Core Lint may complain if still marked - -- as AlwaysTailCalled - | otherwise = jid - -asJoinId_maybe :: Id -> Maybe JoinArity -> Id -asJoinId_maybe id (Just arity) = asJoinId id arity -asJoinId_maybe id Nothing = zapJoinId id - -{- -************************************************************************ -* * -\subsection{IdInfo stuff} -* * -************************************************************************ --} - - --------------------------------- - -- ARITY -idArity :: Id -> Arity -idArity id = arityInfo (idInfo id) - -setIdArity :: Id -> Arity -> Id -setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id - -idCallArity :: Id -> Arity -idCallArity id = callArityInfo (idInfo id) - -setIdCallArity :: Id -> Arity -> Id -setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id - -idFunRepArity :: Id -> RepArity -idFunRepArity x = countFunRepArgs (idArity x) (idType x) - --- | Returns true if an application to n args would diverge -isBottomingId :: Var -> Bool -isBottomingId v - | isId v = isBottomingSig (idStrictness v) - | otherwise = False - --- | Accesses the 'Id''s 'strictnessInfo'. -idStrictness :: Id -> StrictSig -idStrictness id = strictnessInfo (idInfo id) - -setIdStrictness :: Id -> StrictSig -> Id -setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id - -idCprInfo :: Id -> CprSig -idCprInfo id = cprInfo (idInfo id) - -setIdCprInfo :: Id -> CprSig -> Id -setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id - -zapIdStrictness :: Id -> Id -zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id - --- | This predicate says whether the 'Id' has a strict demand placed on it or --- has a type such that it can always be evaluated strictly (i.e an --- unlifted type, as of GHC 7.6). We need to --- check separately whether the 'Id' has a so-called \"strict type\" because if --- the demand for the given @id@ hasn't been computed yet but @id@ has a strict --- type, we still want @isStrictId id@ to be @True@. -isStrictId :: Id -> Bool -isStrictId id - = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - not (isJoinId id) && ( - (isStrictType (idType id)) || - -- Take the best of both strictnesses - old and new - (isStrictDmd (idDemandInfo id)) - ) - - --------------------------------- - -- UNFOLDING -idUnfolding :: Id -> Unfolding --- Do not expose the unfolding of a loop breaker! -idUnfolding id - | isStrongLoopBreaker (occInfo info) = NoUnfolding - | otherwise = unfoldingInfo info - where - info = idInfo id - -realIdUnfolding :: Id -> Unfolding --- Expose the unfolding if there is one, including for loop breakers -realIdUnfolding id = unfoldingInfo (idInfo id) - -setIdUnfolding :: Id -> Unfolding -> Id -setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id - -idDemandInfo :: Id -> Demand -idDemandInfo id = demandInfo (idInfo id) - -setIdDemandInfo :: Id -> Demand -> Id -setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id - -setCaseBndrEvald :: StrictnessMark -> Id -> Id --- Used for variables bound by a case expressions, both the case-binder --- itself, and any pattern-bound variables that are argument of a --- strict constructor. It just marks the variable as already-evaluated, --- so that (for example) a subsequent 'seq' can be dropped -setCaseBndrEvald str id - | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding - | otherwise = id - - --------------------------------- - -- SPECIALISATION - --- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs - -idSpecialisation :: Id -> RuleInfo -idSpecialisation id = ruleInfo (idInfo id) - -idCoreRules :: Id -> [CoreRule] -idCoreRules id = ruleInfoRules (idSpecialisation id) - -idHasRules :: Id -> Bool -idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) - -setIdSpecialisation :: Id -> RuleInfo -> Id -setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id - - --------------------------------- - -- CAF INFO -idCafInfo :: Id -> CafInfo -idCafInfo id = cafInfo (idInfo id) - -setIdCafInfo :: Id -> CafInfo -> Id -setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id - - --------------------------------- - -- Occurrence INFO -idOccInfo :: Id -> OccInfo -idOccInfo id = occInfo (idInfo id) - -setIdOccInfo :: Id -> OccInfo -> Id -setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id - -zapIdOccInfo :: Id -> Id -zapIdOccInfo b = b `setIdOccInfo` noOccInfo - -{- - --------------------------------- - -- INLINING -The inline pragma tells us to be very keen to inline this Id, but it's still -OK not to if optimisation is switched off. --} - -idInlinePragma :: Id -> InlinePragma -idInlinePragma id = inlinePragInfo (idInfo id) - -setInlinePragma :: Id -> InlinePragma -> Id -setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id - -modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id -modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id - -idInlineActivation :: Id -> Activation -idInlineActivation id = inlinePragmaActivation (idInlinePragma id) - -setInlineActivation :: Id -> Activation -> Id -setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) - -idRuleMatchInfo :: Id -> RuleMatchInfo -idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) - -isConLikeId :: Id -> Bool -isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) - -{- - --------------------------------- - -- ONE-SHOT LAMBDAS --} - -idOneShotInfo :: Id -> OneShotInfo -idOneShotInfo id = oneShotInfo (idInfo id) - --- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account --- See Note [The state-transformer hack] in GHC.Core.Arity -idStateHackOneShotInfo :: Id -> OneShotInfo -idStateHackOneShotInfo id - | isStateHackType (idType id) = stateHackOneShot - | otherwise = idOneShotInfo id - --- | Returns whether the lambda associated with the 'Id' is certainly applied at most once --- This one is the "business end", called externally. --- It works on type variables as well as Ids, returning True --- Its main purpose is to encapsulate the Horrible State Hack --- See Note [The state-transformer hack] in GHC.Core.Arity -isOneShotBndr :: Var -> Bool -isOneShotBndr var - | isTyVar var = True - | OneShotLam <- idStateHackOneShotInfo var = True - | otherwise = False - --- | Should we apply the state hack to values of this 'Type'? -stateHackOneShot :: OneShotInfo -stateHackOneShot = OneShotLam - -typeOneShot :: Type -> OneShotInfo -typeOneShot ty - | isStateHackType ty = stateHackOneShot - | otherwise = NoOneShotInfo - -isStateHackType :: Type -> Bool -isStateHackType ty - | hasNoStateHack unsafeGlobalDynFlags - = False - | otherwise - = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon - _ -> False - -- This is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.hs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. - -isProbablyOneShotLambda :: Id -> Bool -isProbablyOneShotLambda id = case idStateHackOneShotInfo id of - OneShotLam -> True - NoOneShotInfo -> False - -setOneShotLambda :: Id -> Id -setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id - -clearOneShotLambda :: Id -> Id -clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id - -setIdOneShotInfo :: Id -> OneShotInfo -> Id -setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id - -updOneShotInfo :: Id -> OneShotInfo -> Id --- Combine the info in the Id with new info -updOneShotInfo id one_shot - | do_upd = setIdOneShotInfo id one_shot - | otherwise = id - where - do_upd = case (idOneShotInfo id, one_shot) of - (NoOneShotInfo, _) -> True - (OneShotLam, _) -> False - --- The OneShotLambda functions simply fiddle with the IdInfo flag --- But watch out: this may change the type of something else --- f = \x -> e --- If we change the one-shot-ness of x, f's type changes - -zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id -zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id - -zapLamIdInfo :: Id -> Id -zapLamIdInfo = zapInfo zapLamInfo - -zapFragileIdInfo :: Id -> Id -zapFragileIdInfo = zapInfo zapFragileInfo - -zapIdDemandInfo :: Id -> Id -zapIdDemandInfo = zapInfo zapDemandInfo - -zapIdUsageInfo :: Id -> Id -zapIdUsageInfo = zapInfo zapUsageInfo - -zapIdUsageEnvInfo :: Id -> Id -zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo - -zapIdUsedOnceInfo :: Id -> Id -zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo - -zapIdTailCallInfo :: Id -> Id -zapIdTailCallInfo = zapInfo zapTailCallInfo - -zapStableUnfolding :: Id -> Id -zapStableUnfolding id - | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding - | otherwise = id - -{- -Note [transferPolyIdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~ -This transfer is used in three places: - FloatOut (long-distance let-floating) - GHC.Core.Op.Simplify.Utils.abstractFloats (short-distance let-floating) - StgLiftLams (selectively lambda-lift local functions to top-level) - -Consider the short-distance let-floating: - - f = /\a. let g = rhs in ... - -Then if we float thus - - g' = /\a. rhs - f = /\a. ...[g' a/g].... - -we *do not* want to lose g's - * strictness information - * arity - * inline pragma (though that is bit more debatable) - * occurrence info - -Mostly this is just an optimisation, but it's *vital* to -transfer the occurrence info. Consider - - NonRec { f = /\a. let Rec { g* = ..g.. } in ... } - -where the '*' means 'LoopBreaker'. Then if we float we must get - - Rec { g'* = /\a. ...(g' a)... } - NonRec { f = /\a. ...[g' a/g]....} - -where g' is also marked as LoopBreaker. If not, terrible things -can happen if we re-simplify the binding (and the Simplifier does -sometimes simplify a term twice); see #4345. - -It's not so simple to retain - * worker info - * rules -so we simply discard those. Sooner or later this may bite us. - -If we abstract wrt one or more *value* binders, we must modify the -arity and strictness info before transferring it. E.g. - f = \x. e ---> - g' = \y. \x. e - + substitute (g' y) for g -Notice that g' has an arity one more than the original g --} - -transferPolyIdInfo :: Id -- Original Id - -> [Var] -- Abstract wrt these variables - -> Id -- New Id - -> Id -transferPolyIdInfo old_id abstract_wrt new_id - = modifyIdInfo transfer new_id - where - arity_increase = count isId abstract_wrt -- Arity increases by the - -- number of value binders - - old_info = idInfo old_id - old_arity = arityInfo old_info - old_inline_prag = inlinePragInfo old_info - old_occ_info = occInfo old_info - new_arity = old_arity + arity_increase - new_occ_info = zapOccTailCallInfo old_occ_info - - old_strictness = strictnessInfo old_info - new_strictness = increaseStrictSigArity arity_increase old_strictness - old_cpr = cprInfo old_info - - transfer new_info = new_info `setArityInfo` new_arity - `setInlinePragInfo` old_inline_prag - `setOccInfo` new_occ_info - `setStrictnessInfo` new_strictness - `setCprInfo` old_cpr - -isNeverLevPolyId :: Id -> Bool -isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs deleted file mode 100644 index dcf1740d3c..0000000000 --- a/compiler/basicTypes/IdInfo.hs +++ /dev/null @@ -1,652 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} - -(And a pretty good illustration of quite a few things wrong with -Haskell. [WDP 94/11]) --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module IdInfo ( - -- * The IdDetails type - IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, - JoinArity, isJoinIdDetails_maybe, - RecSelParent(..), - - -- * The IdInfo type - IdInfo, -- Abstract - vanillaIdInfo, noCafIdInfo, - - -- ** The OneShotInfo type - OneShotInfo(..), - oneShotInfo, noOneShotInfo, hasNoOneShotInfo, - setOneShotInfo, - - -- ** Zapping various forms of Info - zapLamInfo, zapFragileInfo, - zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, - zapTailCallInfo, zapCallArityInfo, zapUnfolding, - - -- ** The ArityInfo type - ArityInfo, - unknownArity, - arityInfo, setArityInfo, ppArityInfo, - - callArityInfo, setCallArityInfo, - - -- ** Demand and strictness Info - strictnessInfo, setStrictnessInfo, - cprInfo, setCprInfo, - demandInfo, setDemandInfo, pprStrictness, - - -- ** Unfolding Info - unfoldingInfo, setUnfoldingInfo, - - -- ** The InlinePragInfo type - InlinePragInfo, - inlinePragInfo, setInlinePragInfo, - - -- ** The OccInfo type - OccInfo(..), - isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, - occInfo, setOccInfo, - - InsideLam(..), OneBranch(..), - - TailCallInfo(..), - tailCallInfo, isAlwaysTailCalled, - - -- ** The RuleInfo type - RuleInfo(..), - emptyRuleInfo, - isEmptyRuleInfo, ruleInfoFreeVars, - ruleInfoRules, setRuleInfoHead, - ruleInfo, setRuleInfo, - - -- ** The CAFInfo type - CafInfo(..), - ppCafInfo, mayHaveCafRefs, - cafInfo, setCafInfo, - - -- ** Tick-box Info - TickBoxOp(..), TickBoxId, - - -- ** Levity info - LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, - isNeverLevPolyIdInfo - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core - -import GHC.Core.Class -import {-# SOURCE #-} PrimOp (PrimOp) -import Name -import VarSet -import BasicTypes -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.PatSyn -import GHC.Core.Type -import ForeignCall -import Outputable -import Module -import Demand -import Cpr -import Util - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setRuleInfo`, - `setArityInfo`, - `setInlinePragInfo`, - `setUnfoldingInfo`, - `setOneShotInfo`, - `setOccInfo`, - `setCafInfo`, - `setStrictnessInfo`, - `setCprInfo`, - `setDemandInfo`, - `setNeverLevPoly`, - `setLevityInfoWithType` - -{- -************************************************************************ -* * - IdDetails -* * -************************************************************************ --} - --- | Identifier Details --- --- The 'IdDetails' of an 'Id' give stable, and necessary, --- information about the Id. -data IdDetails - = VanillaId - - -- | The 'Id' for a record selector - | RecSelId - { sel_tycon :: RecSelParent - , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: - -- data T = forall a. MkT { x :: a } - } -- See Note [Naughty record selectors] in TcTyClsDecls - - | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ - | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ - - -- [the only reasons we need to know is so that - -- a) to support isImplicitId - -- b) when desugaring a RecordCon we can get - -- from the Id back to the data con] - | ClassOpId Class -- ^ The 'Id' is a superclass selector, - -- or class operation of a class - - | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator - | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. - -- Type will be simple: no type families, newtypes, etc - - | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - - | DFunId Bool -- ^ A dictionary function. - -- Bool = True <=> the class has only one method, so may be - -- implemented with a newtype, so it might be bad - -- to be strict on this dictionary - - | CoVarId -- ^ A coercion variable - -- This only covers /un-lifted/ coercions, of type - -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants - | JoinId JoinArity -- ^ An 'Id' for a join point taking n arguments - -- Note [Join points] in GHC.Core - --- | Recursive Selector Parent -data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq - -- Either `TyCon` or `PatSyn` depending - -- on the origin of the record selector. - -- For a data type family, this is the - -- /instance/ 'TyCon' not the family 'TyCon' - -instance Outputable RecSelParent where - ppr p = case p of - RecSelData ty_con -> ppr ty_con - RecSelPatSyn ps -> ppr ps - --- | Just a synonym for 'CoVarId'. Written separately so it can be --- exported in the hs-boot file. -coVarDetails :: IdDetails -coVarDetails = CoVarId - --- | Check if an 'IdDetails' says 'CoVarId'. -isCoVarDetails :: IdDetails -> Bool -isCoVarDetails CoVarId = True -isCoVarDetails _ = False - -isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity -isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity -isJoinIdDetails_maybe _ = Nothing - -instance Outputable IdDetails where - ppr = pprIdDetails - -pprIdDetails :: IdDetails -> SDoc -pprIdDetails VanillaId = empty -pprIdDetails other = brackets (pp other) - where - pp VanillaId = panic "pprIdDetails" - pp (DataConWorkId _) = text "DataCon" - pp (DataConWrapId _) = text "DataConWrapper" - pp (ClassOpId {}) = text "ClassOp" - pp (PrimOpId _) = text "PrimOp" - pp (FCallId _) = text "ForeignCall" - pp (TickBoxOpId _) = text "TickBoxOp" - pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") - pp (RecSelId { sel_naughty = is_naughty }) - = brackets $ text "RecSel" <> - ppWhen is_naughty (text "(naughty)") - pp CoVarId = text "CoVarId" - pp (JoinId arity) = text "JoinId" <> parens (int arity) - -{- -************************************************************************ -* * -\subsection{The main IdInfo type} -* * -************************************************************************ --} - --- | Identifier Information --- --- An 'IdInfo' gives /optional/ information about an 'Id'. If --- present it never lies, but it may not be present, in which case there --- is always a conservative assumption which can be made. --- --- Two 'Id's may have different info even though they have the same --- 'Unique' (and are hence the same 'Id'); for example, one might lack --- the properties attached to the other. --- --- Most of the 'IdInfo' gives information about the value, or definition, of --- the 'Id', independent of its usage. Exceptions to this --- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. --- --- Performance note: when we update 'IdInfo', we have to reallocate this --- entire record, so it is a good idea not to let this data structure get --- too big. -data IdInfo - = IdInfo { - arityInfo :: !ArityInfo, - -- ^ 'Id' arity, as computed by 'GHC.Core.Arity'. Specifies how many - -- arguments this 'Id' has to be applied to before it doesn any - -- meaningful work. - ruleInfo :: RuleInfo, - -- ^ Specialisations of the 'Id's function which exist. - -- See Note [Specialisations and RULES in IdInfo] - unfoldingInfo :: Unfolding, - -- ^ The 'Id's unfolding - cafInfo :: CafInfo, - -- ^ 'Id' CAF info - oneShotInfo :: OneShotInfo, - -- ^ Info about a lambda-bound variable, if the 'Id' is one - inlinePragInfo :: InlinePragma, - -- ^ Any inline pragma attached to the 'Id' - occInfo :: OccInfo, - -- ^ How the 'Id' occurs in the program - strictnessInfo :: StrictSig, - -- ^ A strictness signature. Digests how a function uses its arguments - -- if applied to at least 'arityInfo' arguments. - cprInfo :: CprSig, - -- ^ Information on whether the function will ultimately return a - -- freshly allocated constructor. - demandInfo :: Demand, - -- ^ ID demand information - callArityInfo :: !ArityInfo, - -- ^ How this is called. This is the number of arguments to which a - -- binding can be eta-expanded without losing any sharing. - -- n <=> all calls have at least n arguments - levityInfo :: LevityInfo - -- ^ when applied, will this Id ever have a levity-polymorphic type? - } - --- Setters - -setRuleInfo :: IdInfo -> RuleInfo -> IdInfo -setRuleInfo info sp = sp `seq` info { ruleInfo = sp } -setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo -setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } -setOccInfo :: IdInfo -> OccInfo -> IdInfo -setOccInfo info oc = oc `seq` info { occInfo = oc } - -- Try to avoid space leaks by seq'ing - -setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo -setUnfoldingInfo info uf - = -- We don't seq the unfolding, as we generate intermediate - -- unfoldings which are just thrown away, so evaluating them is a - -- waste of time. - -- seqUnfolding uf `seq` - info { unfoldingInfo = uf } - -setArityInfo :: IdInfo -> ArityInfo -> IdInfo -setArityInfo info ar = info { arityInfo = ar } -setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo -setCallArityInfo info ar = info { callArityInfo = ar } -setCafInfo :: IdInfo -> CafInfo -> IdInfo -setCafInfo info caf = info { cafInfo = caf } - -setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo -setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb } - -setDemandInfo :: IdInfo -> Demand -> IdInfo -setDemandInfo info dd = dd `seq` info { demandInfo = dd } - -setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo -setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } - -setCprInfo :: IdInfo -> CprSig -> IdInfo -setCprInfo info cpr = cpr `seq` info { cprInfo = cpr } - --- | Basic 'IdInfo' that carries no useful information whatsoever -vanillaIdInfo :: IdInfo -vanillaIdInfo - = IdInfo { - cafInfo = vanillaCafInfo, - arityInfo = unknownArity, - ruleInfo = emptyRuleInfo, - unfoldingInfo = noUnfolding, - oneShotInfo = NoOneShotInfo, - inlinePragInfo = defaultInlinePragma, - occInfo = noOccInfo, - demandInfo = topDmd, - strictnessInfo = nopSig, - cprInfo = topCprSig, - callArityInfo = unknownArity, - levityInfo = NoLevityInfo - } - --- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references -noCafIdInfo :: IdInfo -noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs - -- Used for built-in type Ids in MkId. - -{- -************************************************************************ -* * -\subsection[arity-IdInfo]{Arity info about an @Id@} -* * -************************************************************************ - -For locally-defined Ids, the code generator maintains its own notion -of their arities; so it should not be asking... (but other things -besides the code-generator need arity info!) --} - --- | Arity Information --- --- An 'ArityInfo' of @n@ tells us that partial application of this --- 'Id' to up to @n-1@ value arguments does essentially no work. --- --- That is not necessarily the same as saying that it has @n@ leading --- lambdas, because coerces may get in the way. --- --- The arity might increase later in the compilation process, if --- an extra lambda floats up to the binding site. -type ArityInfo = Arity - --- | It is always safe to assume that an 'Id' has an arity of 0 -unknownArity :: Arity -unknownArity = 0 - -ppArityInfo :: Int -> SDoc -ppArityInfo 0 = empty -ppArityInfo n = hsep [text "Arity", int n] - -{- -************************************************************************ -* * -\subsection{Inline-pragma information} -* * -************************************************************************ --} - --- | Inline Pragma Information --- --- Tells when the inlining is active. --- When it is active the thing may be inlined, depending on how --- big it is. --- --- If there was an @INLINE@ pragma, then as a separate matter, the --- RHS will have been made to look small with a Core inline 'Note' --- --- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves --- entirely as a way to inhibit inlining until we want it -type InlinePragInfo = InlinePragma - -{- -************************************************************************ -* * - Strictness -* * -************************************************************************ --} - -pprStrictness :: StrictSig -> SDoc -pprStrictness sig = ppr sig - -{- -************************************************************************ -* * - RuleInfo -* * -************************************************************************ - -Note [Specialisations and RULES in IdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking, a GlobalId has an *empty* RuleInfo. All their -RULES are contained in the globally-built rule-base. In principle, -one could attach the to M.f the RULES for M.f that are defined in M. -But we don't do that for instance declarations and so we just treat -them all uniformly. - -The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is -just for convenience really. - -However, LocalIds may have non-empty RuleInfo. We treat them -differently because: - a) they might be nested, in which case a global table won't work - b) the RULE might mention free variables, which we use to keep things alive - -In GHC.Iface.Tidy, when the LocalId becomes a GlobalId, its RULES are stripped off -and put in the global list. --} - --- | Rule Information --- --- Records the specializations of this 'Id' that we know about --- in the form of rewrite 'CoreRule's that target them -data RuleInfo - = RuleInfo - [CoreRule] - DVarSet -- Locally-defined free vars of *both* LHS and RHS - -- of rules. I don't think it needs to include the - -- ru_fn though. - -- Note [Rule dependency info] in OccurAnal - --- | Assume that no specializations exist: always safe -emptyRuleInfo :: RuleInfo -emptyRuleInfo = RuleInfo [] emptyDVarSet - -isEmptyRuleInfo :: RuleInfo -> Bool -isEmptyRuleInfo (RuleInfo rs _) = null rs - --- | Retrieve the locally-defined free variables of both the left and --- right hand sides of the specialization rules -ruleInfoFreeVars :: RuleInfo -> DVarSet -ruleInfoFreeVars (RuleInfo _ fvs) = fvs - -ruleInfoRules :: RuleInfo -> [CoreRule] -ruleInfoRules (RuleInfo rules _) = rules - --- | Change the name of the function the rule is keyed on on all of the 'CoreRule's -setRuleInfoHead :: Name -> RuleInfo -> RuleInfo -setRuleInfoHead fn (RuleInfo rules fvs) - = RuleInfo (map (setRuleIdName fn) rules) fvs - -{- -************************************************************************ -* * -\subsection[CG-IdInfo]{Code generator-related information} -* * -************************************************************************ --} - --- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). - --- | Constant applicative form Information --- --- Records whether an 'Id' makes Constant Applicative Form references -data CafInfo - = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: - -- - -- 1. A function or static constructor - -- that refers to one or more CAFs, or - -- - -- 2. A real live CAF - - | NoCafRefs -- ^ A function or static constructor - -- that refers to no CAFs. - deriving (Eq, Ord) - --- | Assumes that the 'Id' has CAF references: definitely safe -vanillaCafInfo :: CafInfo -vanillaCafInfo = MayHaveCafRefs - -mayHaveCafRefs :: CafInfo -> Bool -mayHaveCafRefs MayHaveCafRefs = True -mayHaveCafRefs _ = False - -instance Outputable CafInfo where - ppr = ppCafInfo - -ppCafInfo :: CafInfo -> SDoc -ppCafInfo NoCafRefs = text "NoCafRefs" -ppCafInfo MayHaveCafRefs = empty - -{- -************************************************************************ -* * -\subsection{Bulk operations on IdInfo} -* * -************************************************************************ --} - --- | This is used to remove information on lambda binders that we have --- setup as part of a lambda group, assuming they will be applied all at once, --- but turn out to be part of an unsaturated lambda as in e.g: --- --- > (\x1. \x2. e) arg1 -zapLamInfo :: IdInfo -> Maybe IdInfo -zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) - | is_safe_occ occ && is_safe_dmd demand - = Nothing - | otherwise - = Just (info {occInfo = safe_occ, demandInfo = topDmd}) - where - -- The "unsafe" occ info is the ones that say I'm not in a lambda - -- because that might not be true for an unsaturated lambda - is_safe_occ occ | isAlwaysTailCalled occ = False - is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False - is_safe_occ _other = True - - safe_occ = case occ of - OneOcc{} -> occ { occ_in_lam = IsInsideLam - , occ_tail = NoTailCallInfo } - IAmALoopBreaker{} - -> occ { occ_tail = NoTailCallInfo } - _other -> occ - - is_safe_dmd dmd = not (isStrictDmd dmd) - --- | Remove all demand info on the 'IdInfo' -zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info = Just (info {demandInfo = topDmd}) - --- | Remove usage (but not strictness) info on the 'IdInfo' -zapUsageInfo :: IdInfo -> Maybe IdInfo -zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) - --- | Remove usage environment info from the strictness signature on the 'IdInfo' -zapUsageEnvInfo :: IdInfo -> Maybe IdInfo -zapUsageEnvInfo info - | hasDemandEnvSig (strictnessInfo info) - = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) - | otherwise - = Nothing - -zapUsedOnceInfo :: IdInfo -> Maybe IdInfo -zapUsedOnceInfo info - = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) - , demandInfo = zapUsedOnceDemand (demandInfo info) } - -zapFragileInfo :: IdInfo -> Maybe IdInfo --- ^ Zap info that depends on free variables -zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) - = new_unf `seq` -- The unfolding field is not (currently) strict, so we - -- force it here to avoid a (zapFragileUnfolding unf) thunk - -- which might leak space - Just (info `setRuleInfo` emptyRuleInfo - `setUnfoldingInfo` new_unf - `setOccInfo` zapFragileOcc occ) - where - new_unf = zapFragileUnfolding unf - -zapFragileUnfolding :: Unfolding -> Unfolding -zapFragileUnfolding unf - | isFragileUnfolding unf = noUnfolding - | otherwise = unf - -zapUnfolding :: Unfolding -> Unfolding --- Squash all unfolding info, preserving only evaluated-ness -zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding - | otherwise = noUnfolding - -zapTailCallInfo :: IdInfo -> Maybe IdInfo -zapTailCallInfo info - = case occInfo info of - occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) - | otherwise -> Nothing - where - safe_occ = occ { occ_tail = NoTailCallInfo } - -zapCallArityInfo :: IdInfo -> IdInfo -zapCallArityInfo info = setCallArityInfo info 0 - -{- -************************************************************************ -* * -\subsection{TickBoxOp} -* * -************************************************************************ --} - -type TickBoxId = Int - --- | Tick box for Hpc-style coverage -data TickBoxOp - = TickBox Module {-# UNPACK #-} !TickBoxId - -instance Outputable TickBoxOp where - ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) - -{- -************************************************************************ -* * - Levity -* * -************************************************************************ - -Note [Levity info] -~~~~~~~~~~~~~~~~~~ - -Ids store whether or not they can be levity-polymorphic at any amount -of saturation. This is helpful in optimizing the levity-polymorphism check -done in the desugarer, where we can usually learn that something is not -levity-polymorphic without actually figuring out its type. See -isExprLevPoly in GHC.Core.Utils for where this info is used. Storing -this is required to prevent perf/compiler/T5631 from blowing up. - --} - --- See Note [Levity info] -data LevityInfo = NoLevityInfo -- always safe - | NeverLevityPolymorphic - deriving Eq - -instance Outputable LevityInfo where - ppr NoLevityInfo = text "NoLevityInfo" - ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" - --- | Marks an IdInfo describing an Id that is never levity polymorphic (even when --- applied). The Type is only there for checking that it's really never levity --- polymorphic -setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo -setNeverLevPoly info ty - = ASSERT2( not (resultIsLevPoly ty), ppr ty ) - info { levityInfo = NeverLevityPolymorphic } - -setLevityInfoWithType :: IdInfo -> Type -> IdInfo -setLevityInfoWithType info ty - | not (resultIsLevPoly ty) - = info { levityInfo = NeverLevityPolymorphic } - | otherwise - = info - -isNeverLevPolyIdInfo :: IdInfo -> Bool -isNeverLevPolyIdInfo info - | NeverLevityPolymorphic <- levityInfo info = True - | otherwise = False diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot deleted file mode 100644 index cacfe6af2e..0000000000 --- a/compiler/basicTypes/IdInfo.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ -module IdInfo where -import GhcPrelude -import Outputable -data IdInfo -data IdDetails - -vanillaIdInfo :: IdInfo -coVarDetails :: IdDetails -isCoVarDetails :: IdDetails -> Bool -pprIdDetails :: IdDetails -> SDoc - diff --git a/compiler/basicTypes/Lexeme.hs b/compiler/basicTypes/Lexeme.hs deleted file mode 100644 index 00559ab1c7..0000000000 --- a/compiler/basicTypes/Lexeme.hs +++ /dev/null @@ -1,240 +0,0 @@ --- (c) The GHC Team --- --- Functions to evaluate whether or not a string is a valid identifier. --- There is considerable overlap between the logic here and the logic --- in Lexer.x, but sadly there seems to be no way to merge them. - -module Lexeme ( - -- * Lexical characteristics of Haskell names - - -- | Use these functions to figure what kind of name a 'FastString' - -- represents; these functions do /not/ check that the identifier - -- is valid. - - isLexCon, isLexVar, isLexId, isLexSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym, - startsVarSym, startsVarId, startsConSym, startsConId, - - -- * Validating identifiers - - -- | These functions (working over plain old 'String's) check - -- to make sure that the identifier is valid. - okVarOcc, okConOcc, okTcOcc, - okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc - - -- Some of the exports above are not used within GHC, but may - -- be of value to GHC API users. - - ) where - -import GhcPrelude - -import FastString - -import Data.Char -import qualified Data.Set as Set - -import GHC.Lexeme - -{- - -************************************************************************ -* * - Lexical categories -* * -************************************************************************ - -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. - -Note [Classification of generated names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Some names generated for internal use can show up in debugging output, -e.g. when using -ddump-simpl. These generated names start with a $ -but should still be pretty-printed using prefix notation. We make sure -this is the case in isLexVarSym by only classifying a name as a symbol -if all its characters are symbols, not just its first one. --} - -isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool -isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs - -------------- -isLexConId cs -- Prefix type or data constructors - | nullFS cs = False -- e.g. "Foo", "[]", "(,)" - | cs == (fsLit "[]") = True - | otherwise = startsConId (headFS cs) - -isLexVarId cs -- Ordinary prefix identifiers - | nullFS cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (headFS cs) - -isLexConSym cs -- Infix type or data constructors - | nullFS cs = False -- e.g. ":-:", ":", "->" - | cs == (fsLit "->") = True - | otherwise = startsConSym (headFS cs) - -isLexVarSym fs -- Infix identifiers e.g. "+" - | fs == (fsLit "~R#") = True - | otherwise - = case (if nullFS fs then [] else unpackFS fs) of - [] -> False - (c:cs) -> startsVarSym c && all isVarSymChar cs - -- See Note [Classification of generated names] - -{- - -************************************************************************ -* * - Detecting valid names for Template Haskell -* * -************************************************************************ - --} - ----------------------- --- External interface ----------------------- - --- | Is this an acceptable variable name? -okVarOcc :: String -> Bool -okVarOcc str@(c:_) - | startsVarId c - = okVarIdOcc str - | startsVarSym c - = okVarSymOcc str -okVarOcc _ = False - --- | Is this an acceptable constructor name? -okConOcc :: String -> Bool -okConOcc str@(c:_) - | startsConId c - = okConIdOcc str - | startsConSym c - = okConSymOcc str - | str == "[]" - = True -okConOcc _ = False - --- | Is this an acceptable type name? -okTcOcc :: String -> Bool -okTcOcc "[]" = True -okTcOcc "->" = True -okTcOcc "~" = True -okTcOcc str@(c:_) - | startsConId c - = okConIdOcc str - | startsConSym c - = okConSymOcc str - | startsVarSym c - = okVarSymOcc str -okTcOcc _ = False - --- | Is this an acceptable alphanumeric variable name, assuming it starts --- with an acceptable letter? -okVarIdOcc :: String -> Bool -okVarIdOcc str = okIdOcc str && - -- admit "_" as a valid identifier. Required to support typed - -- holes in Template Haskell. See #10267 - (str == "_" || not (str `Set.member` reservedIds)) - --- | Is this an acceptable symbolic variable name, assuming it starts --- with an acceptable character? -okVarSymOcc :: String -> Bool -okVarSymOcc str = all okSymChar str && - not (str `Set.member` reservedOps) && - not (isDashes str) - --- | Is this an acceptable alphanumeric constructor name, assuming it --- starts with an acceptable letter? -okConIdOcc :: String -> Bool -okConIdOcc str = okIdOcc str || - is_tuple_name1 True str || - -- Is it a boxed tuple... - is_tuple_name1 False str || - -- ...or an unboxed tuple (#12407)... - is_sum_name1 str - -- ...or an unboxed sum (#12514)? - where - -- check for tuple name, starting at the beginning - is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest - is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest - is_tuple_name1 _ _ = False - - -- check for tuple tail - is_tuple_name2 True ")" = True - is_tuple_name2 False "#)" = True - is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest - is_tuple_name2 boxed (ws : rest) - | isSpace ws = is_tuple_name2 boxed rest - is_tuple_name2 _ _ = False - - -- check for sum name, starting at the beginning - is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest - is_sum_name1 _ = False - - -- check for sum tail, only allowing at most one underscore - is_sum_name2 _ "#)" = True - is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest - is_sum_name2 False ('_' : rest) = is_sum_name2 True rest - is_sum_name2 underscore (ws : rest) - | isSpace ws = is_sum_name2 underscore rest - is_sum_name2 _ _ = False - --- | Is this an acceptable symbolic constructor name, assuming it --- starts with an acceptable character? -okConSymOcc :: String -> Bool -okConSymOcc ":" = True -okConSymOcc str = all okSymChar str && - not (str `Set.member` reservedOps) - ----------------------- --- Internal functions ----------------------- - --- | Is this string an acceptable id, possibly with a suffix of hashes, --- but not worrying about case or clashing with reserved words? -okIdOcc :: String -> Bool -okIdOcc str - = let hashes = dropWhile okIdChar str in - all (== '#') hashes -- -XMagicHash allows a suffix of hashes - -- of course, `all` says "True" to an empty list - --- | Is this character acceptable in an identifier (after the first letter)? --- See alexGetByte in Lexer.x -okIdChar :: Char -> Bool -okIdChar c = case generalCategory c of - UppercaseLetter -> True - LowercaseLetter -> True - TitlecaseLetter -> True - ModifierLetter -> True -- See #10196 - OtherLetter -> True -- See #1103 - NonSpacingMark -> True -- See #7650 - DecimalNumber -> True - OtherNumber -> True -- See #4373 - _ -> c == '\'' || c == '_' - --- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. -reservedIds :: Set.Set String -reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" - , "do", "else", "foreign", "if", "import", "in" - , "infix", "infixl", "infixr", "instance", "let" - , "module", "newtype", "of", "then", "type", "where" - , "_" ] - --- | All reserved operators. Taken from section 2.4 of the 2010 Report. -reservedOps :: Set.Set String -reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" - , "@", "~", "=>" ] - --- | Does this string contain only dashes and has at least 2 of them? -isDashes :: String -> Bool -isDashes ('-' : '-' : rest) = all (== '-') rest -isDashes _ = False diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs deleted file mode 100644 index cd8a63e2ca..0000000000 --- a/compiler/basicTypes/Literal.hs +++ /dev/null @@ -1,847 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[Literal]{@Literal@: literals} --} - -{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Literal - ( - -- * Main data type - Literal(..) -- Exported to ParseIface - , LitNumType(..) - - -- ** Creating Literals - , mkLitInt, mkLitIntWrap, mkLitIntWrapC - , mkLitWord, mkLitWordWrap, mkLitWordWrapC - , mkLitInt64, mkLitInt64Wrap - , mkLitWord64, mkLitWord64Wrap - , mkLitFloat, mkLitDouble - , mkLitChar, mkLitString - , mkLitInteger, mkLitNatural - , mkLitNumber, mkLitNumberWrap - - -- ** Operations on Literals - , literalType - , absentLiteralOf - , pprLiteral - , litNumIsSigned - , litNumCheckRange - - -- ** Predicates on Literals and their contents - , litIsDupable, litIsTrivial, litIsLifted - , inCharRange - , isZeroLit - , litFitsInChar - , litValue, isLitValue, isLitValue_maybe, mapLitValue - - -- ** Coercions - , word2IntLit, int2WordLit - , narrowLit - , narrow8IntLit, narrow16IntLit, narrow32IntLit - , narrow8WordLit, narrow16WordLit, narrow32WordLit - , char2IntLit, int2CharLit - , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TysPrim -import PrelNames -import GHC.Core.Type -import GHC.Core.TyCon -import Outputable -import FastString -import BasicTypes -import Binary -import Constants -import GHC.Platform -import UniqFM -import Util - -import Data.ByteString (ByteString) -import Data.Int -import Data.Word -import Data.Char -import Data.Maybe ( isJust ) -import Data.Data ( Data ) -import Data.Proxy -import Numeric ( fromRat ) - -{- -************************************************************************ -* * -\subsection{Literals} -* * -************************************************************************ --} - --- | So-called 'Literal's are one of: --- --- * An unboxed numeric literal or floating-point literal which is presumed --- to be surrounded by appropriate constructors (@Int#@, etc.), so that --- the overall thing makes sense. --- --- We maintain the invariant that the 'Integer' in the 'LitNumber' --- constructor is actually in the (possibly target-dependent) range. --- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying --- the target machine's wrapping semantics. Use these in situations --- where you know the wrapping semantics are correct. --- --- * The literal derived from the label mentioned in a \"foreign label\" --- declaration ('LitLabel') --- --- * A 'LitRubbish' to be used in place of values of 'UnliftedRep' --- (i.e. 'MutVar#') when the the value is never used. --- --- * A character --- * A string --- * The NULL pointer --- -data Literal - = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with - -- 'mkLitChar' - - | LitNumber !LitNumType !Integer Type - -- ^ Any numeric literal that can be - -- internally represented with an Integer. - -- See Note [Types of LitNumbers] below for the - -- Type field. - - | LitString ByteString -- ^ A string-literal: stored and emitted - -- UTF-8 encoded, we'll arrange to decode it - -- at runtime. Also emitted with a @\'\\0\'@ - -- terminator. Create with 'mkLitString' - - | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value - -- that can be represented as a Literal. Create - -- with 'nullAddrLit' - - | LitRubbish -- ^ A nonsense value, used when an unlifted - -- binding is absent and has type - -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. - -- May be lowered by code-gen to any possible - -- value. Also see Note [Rubbish literals] - - | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' - | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' - - | LitLabel FastString (Maybe Int) FunctionOrData - -- ^ A label literal. Parameters: - -- - -- 1) The name of the symbol mentioned in the - -- declaration - -- - -- 2) The size (in bytes) of the arguments - -- the label expects. Only applicable with - -- @stdcall@ labels. @Just x@ => @\@ will - -- be appended to label name when emitting - -- assembly. - -- - -- 3) Flag indicating whether the symbol - -- references a function or a data - deriving Data - --- | Numeric literal type -data LitNumType - = LitNumInteger -- ^ @Integer@ (see Note [Integer literals]) - | LitNumNatural -- ^ @Natural@ (see Note [Natural literals]) - | LitNumInt -- ^ @Int#@ - according to target machine - | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits - | LitNumWord -- ^ @Word#@ - according to target machine - | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits - deriving (Data,Enum,Eq,Ord) - --- | Indicate if a numeric literal type supports negative numbers -litNumIsSigned :: LitNumType -> Bool -litNumIsSigned nt = case nt of - LitNumInteger -> True - LitNumNatural -> False - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> False - LitNumWord64 -> False - -{- -Note [Integer literals] -~~~~~~~~~~~~~~~~~~~~~~~ -An Integer literal is represented using, well, an Integer, to make it -easier to write RULEs for them. They also contain the Integer type, so -that e.g. literalType can return the right Type for them. - -They only get converted into real Core, - mkInteger [c1, c2, .., cn] -during the CorePrep phase, although GHC.Iface.Tidy looks ahead at what the -core will be, so that it can see whether it involves CAFs. - -When we initially build an Integer literal, notably when -deserialising it from an interface file (see the Binary instance -below), we don't have convenient access to the mkInteger Id. So we -just use an error thunk, and fill in the real Id when we do tcIfaceLit -in GHC.IfaceToCore. - -Note [Natural literals] -~~~~~~~~~~~~~~~~~~~~~~~ -Similar to Integer literals. - -Note [String literals] -~~~~~~~~~~~~~~~~~~~~~~ - -String literals are UTF-8 encoded and stored into ByteStrings in the following -ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals -with the BytesPrimL constructor (see #14741). - -It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite -bad for performance with large strings (see #16198 and #14741). - -To include string literals into output objects, the assembler code generator has -to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs] -for more details. - --} - -instance Binary LitNumType where - put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) - get bh = do - h <- getByte bh - return (toEnum (fromIntegral h)) - -instance Binary Literal where - put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa - put_ bh (LitString ab) = do putByte bh 1; put_ bh ab - put_ bh (LitNullAddr) = do putByte bh 2 - put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah - put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai - put_ bh (LitLabel aj mb fod) - = do putByte bh 5 - put_ bh aj - put_ bh mb - put_ bh fod - put_ bh (LitNumber nt i _) - = do putByte bh 6 - put_ bh nt - put_ bh i - put_ bh (LitRubbish) = do putByte bh 7 - get bh = do - h <- getByte bh - case h of - 0 -> do - aa <- get bh - return (LitChar aa) - 1 -> do - ab <- get bh - return (LitString ab) - 2 -> do - return (LitNullAddr) - 3 -> do - ah <- get bh - return (LitFloat ah) - 4 -> do - ai <- get bh - return (LitDouble ai) - 5 -> do - aj <- get bh - mb <- get bh - fod <- get bh - return (LitLabel aj mb fod) - 6 -> do - nt <- get bh - i <- get bh - -- Note [Types of LitNumbers] - let t = case nt of - LitNumInt -> intPrimTy - LitNumInt64 -> int64PrimTy - LitNumWord -> wordPrimTy - LitNumWord64 -> word64PrimTy - -- See Note [Integer literals] - LitNumInteger -> - panic "Evaluated the place holder for mkInteger" - -- and Note [Natural literals] - LitNumNatural -> - panic "Evaluated the place holder for mkNatural" - return (LitNumber nt i t) - _ -> do - return (LitRubbish) - -instance Outputable Literal where - ppr = pprLiteral id - -instance Eq Literal where - a == b = compare a b == EQ - --- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in --- 'TrieMap.CoreMap'. -instance Ord Literal where - compare = cmpLit - -{- - Construction - ~~~~~~~~~~~~ --} - -{- Note [Word/Int underflow/overflow] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and -unsigned integral types): "All arithmetic is performed modulo 2^n, where n is -the number of bits in the type." - -GHC stores Word# and Int# constant values as Integer. Core optimizations such -as constant folding must ensure that the Integer value remains in the valid -target Word/Int range (see #13172). The following functions are used to -ensure this. - -Note that we *don't* warn the user about overflow. It's not done at runtime -either, and compilation of completely harmless things like - ((124076834 :: Word32) + (2147483647 :: Word32)) -doesn't yield a warning. Instead we simply squash the value into the *target* -Int/Word range. --} - --- | Wrap a literal number according to its type -wrapLitNumber :: Platform -> Literal -> Literal -wrapLitNumber platform v@(LitNumber nt i t) = case nt of - LitNumInt -> case platformWordSize platform of - PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t - PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t - LitNumWord -> case platformWordSize platform of - PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t - PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t - LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t - LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t - LitNumInteger -> v - LitNumNatural -> v -wrapLitNumber _ x = x - --- | Create a numeric 'Literal' of the given type -mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Type -> Literal -mkLitNumberWrap platform nt i t = wrapLitNumber platform (LitNumber nt i t) - --- | Check that a given number is in the range of a numeric literal -litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool -litNumCheckRange platform nt i = case nt of - LitNumInt -> platformInIntRange platform i - LitNumWord -> platformInWordRange platform i - LitNumInt64 -> inInt64Range i - LitNumWord64 -> inWord64Range i - LitNumNatural -> i >= 0 - LitNumInteger -> True - --- | Create a numeric 'Literal' of the given type -mkLitNumber :: Platform -> LitNumType -> Integer -> Type -> Literal -mkLitNumber platform nt i t = - ASSERT2(litNumCheckRange platform nt i, integer i) - (LitNumber nt i t) - --- | Creates a 'Literal' of type @Int#@ -mkLitInt :: Platform -> Integer -> Literal -mkLitInt platform x = ASSERT2( platformInIntRange platform x, integer x ) - (mkLitIntUnchecked x) - --- | Creates a 'Literal' of type @Int#@. --- If the argument is out of the (target-dependent) range, it is wrapped. --- See Note [Word/Int underflow/overflow] -mkLitIntWrap :: Platform -> Integer -> Literal -mkLitIntWrap platform i = wrapLitNumber platform $ mkLitIntUnchecked i - --- | Creates a 'Literal' of type @Int#@ without checking its range. -mkLitIntUnchecked :: Integer -> Literal -mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy - --- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating --- overflow. That is, if the argument is out of the (target-dependent) range --- the argument is wrapped and the overflow flag will be set. --- See Note [Word/Int underflow/overflow] -mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool) -mkLitIntWrapC platform i = (n, i /= i') - where - n@(LitNumber _ i' _) = mkLitIntWrap platform i - --- | Creates a 'Literal' of type @Word#@ -mkLitWord :: Platform -> Integer -> Literal -mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x ) - (mkLitWordUnchecked x) - --- | Creates a 'Literal' of type @Word#@. --- If the argument is out of the (target-dependent) range, it is wrapped. --- See Note [Word/Int underflow/overflow] -mkLitWordWrap :: Platform -> Integer -> Literal -mkLitWordWrap platform i = wrapLitNumber platform $ mkLitWordUnchecked i - --- | Creates a 'Literal' of type @Word#@ without checking its range. -mkLitWordUnchecked :: Integer -> Literal -mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy - --- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating --- carry. That is, if the argument is out of the (target-dependent) range --- the argument is wrapped and the carry flag will be set. --- See Note [Word/Int underflow/overflow] -mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool) -mkLitWordWrapC platform i = (n, i /= i') - where - n@(LitNumber _ i' _) = mkLitWordWrap platform i - --- | Creates a 'Literal' of type @Int64#@ -mkLitInt64 :: Integer -> Literal -mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) - --- | Creates a 'Literal' of type @Int64#@. --- If the argument is out of the range, it is wrapped. -mkLitInt64Wrap :: Platform -> Integer -> Literal -mkLitInt64Wrap platform i = wrapLitNumber platform $ mkLitInt64Unchecked i - --- | Creates a 'Literal' of type @Int64#@ without checking its range. -mkLitInt64Unchecked :: Integer -> Literal -mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy - --- | Creates a 'Literal' of type @Word64#@ -mkLitWord64 :: Integer -> Literal -mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) - --- | Creates a 'Literal' of type @Word64#@. --- If the argument is out of the range, it is wrapped. -mkLitWord64Wrap :: Platform -> Integer -> Literal -mkLitWord64Wrap platform i = wrapLitNumber platform $ mkLitWord64Unchecked i - --- | Creates a 'Literal' of type @Word64#@ without checking its range. -mkLitWord64Unchecked :: Integer -> Literal -mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy - --- | Creates a 'Literal' of type @Float#@ -mkLitFloat :: Rational -> Literal -mkLitFloat = LitFloat - --- | Creates a 'Literal' of type @Double#@ -mkLitDouble :: Rational -> Literal -mkLitDouble = LitDouble - --- | Creates a 'Literal' of type @Char#@ -mkLitChar :: Char -> Literal -mkLitChar = LitChar - --- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to --- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ -mkLitString :: String -> Literal --- stored UTF-8 encoded -mkLitString s = LitString (bytesFS $ mkFastString s) - -mkLitInteger :: Integer -> Type -> Literal -mkLitInteger x ty = LitNumber LitNumInteger x ty - -mkLitNatural :: Integer -> Type -> Literal -mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) - (LitNumber LitNumNatural x ty) - -inNaturalRange :: Integer -> Bool -inNaturalRange x = x >= 0 - -inInt64Range, inWord64Range :: Integer -> Bool -inInt64Range x = x >= toInteger (minBound :: Int64) && - x <= toInteger (maxBound :: Int64) -inWord64Range x = x >= toInteger (minBound :: Word64) && - x <= toInteger (maxBound :: Word64) - -inCharRange :: Char -> Bool -inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR - --- | Tests whether the literal represents a zero of whatever type it is -isZeroLit :: Literal -> Bool -isZeroLit (LitNumber _ 0 _) = True -isZeroLit (LitFloat 0) = True -isZeroLit (LitDouble 0) = True -isZeroLit _ = False - --- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. -litValue :: Literal -> Integer -litValue l = case isLitValue_maybe l of - Just x -> x - Nothing -> pprPanic "litValue" (ppr l) - --- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char' and numbers. -isLitValue_maybe :: Literal -> Maybe Integer -isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c -isLitValue_maybe (LitNumber _ i _) = Just i -isLitValue_maybe _ = Nothing - --- | Apply a function to the 'Integer' contained in the 'Literal', for when that --- makes sense, e.g. for 'Char' and numbers. --- For fixed-size integral literals, the result will be wrapped in accordance --- with the semantics of the target type. --- See Note [Word/Int underflow/overflow] -mapLitValue :: Platform -> (Integer -> Integer) -> Literal -> Literal -mapLitValue _ f (LitChar c) = mkLitChar (fchar c) - where fchar = chr . fromInteger . f . toInteger . ord -mapLitValue platform f (LitNumber nt i t) = wrapLitNumber platform - (LitNumber nt (f i) t) -mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) - --- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', --- 'Int', 'Word', 'LitInteger' and 'LitNatural'. -isLitValue :: Literal -> Bool -isLitValue = isJust . isLitValue_maybe - -{- - Coercions - ~~~~~~~~~ --} - -narrow8IntLit, narrow16IntLit, narrow32IntLit, - narrow8WordLit, narrow16WordLit, narrow32WordLit, - char2IntLit, int2CharLit, - float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, - float2DoubleLit, double2FloatLit - :: Literal -> Literal - -word2IntLit, int2WordLit :: Platform -> Literal -> Literal -word2IntLit platform (LitNumber LitNumWord w _) - -- Map Word range [max_int+1, max_word] - -- to Int range [min_int , -1] - -- Range [0,max_int] has the same representation with both Int and Word - | w > platformMaxInt platform = mkLitInt platform (w - platformMaxWord platform - 1) - | otherwise = mkLitInt platform w -word2IntLit _ l = pprPanic "word2IntLit" (ppr l) - -int2WordLit platform (LitNumber LitNumInt i _) - -- Map Int range [min_int , -1] - -- to Word range [max_int+1, max_word] - -- Range [0,max_int] has the same representation with both Int and Word - | i < 0 = mkLitWord platform (1 + platformMaxWord platform + i) - | otherwise = mkLitWord platform i -int2WordLit _ l = pprPanic "int2WordLit" (ppr l) - --- | Narrow a literal number (unchecked result range) -narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal -narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t -narrowLit _ l = pprPanic "narrowLit" (ppr l) - -narrow8IntLit = narrowLit (Proxy :: Proxy Int8) -narrow16IntLit = narrowLit (Proxy :: Proxy Int16) -narrow32IntLit = narrowLit (Proxy :: Proxy Int32) -narrow8WordLit = narrowLit (Proxy :: Proxy Word8) -narrow16WordLit = narrowLit (Proxy :: Proxy Word16) -narrow32WordLit = narrowLit (Proxy :: Proxy Word32) - -char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) -char2IntLit l = pprPanic "char2IntLit" (ppr l) -int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i)) -int2CharLit l = pprPanic "int2CharLit" (ppr l) - -float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) -float2IntLit l = pprPanic "float2IntLit" (ppr l) -int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i) -int2FloatLit l = pprPanic "int2FloatLit" (ppr l) - -double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) -double2IntLit l = pprPanic "double2IntLit" (ppr l) -int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i) -int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) - -float2DoubleLit (LitFloat f) = LitDouble f -float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) -double2FloatLit (LitDouble d) = LitFloat d -double2FloatLit l = pprPanic "double2FloatLit" (ppr l) - -nullAddrLit :: Literal -nullAddrLit = LitNullAddr - --- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. -rubbishLit :: Literal -rubbishLit = LitRubbish - -{- - Predicates - ~~~~~~~~~~ --} - --- | True if there is absolutely no penalty to duplicating the literal. --- False principally of strings. --- --- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would --- blow up code sizes. Not only this, it's also unsafe. --- --- Consider a program that wants to traverse a string. One way it might do this --- is to first compute the Addr# pointing to the end of the string, and then, --- starting from the beginning, bump a pointer using eqAddr# to determine the --- end. For instance, --- --- @ --- -- Given pointers to the start and end of a string, count how many zeros --- -- the string contains. --- countZeros :: Addr# -> Addr# -> -> Int --- countZeros start end = go start 0 --- where --- go off n --- | off `addrEq#` end = n --- | otherwise = go (off `plusAddr#` 1) n' --- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 --- | otherwise = n --- @ --- --- Consider what happens if we considered strings to be trivial (and therefore --- duplicable) and emitted a call like @countZeros "hello"# ("hello"# --- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same --- string, meaning that an iteration like the above would blow up terribly. --- This is what happened in #12757. --- --- Ultimately the solution here is to make primitive strings a bit more --- structured, ensuring that the compiler can't inline in ways that will break --- user code. One approach to this is described in #8472. -litIsTrivial :: Literal -> Bool --- c.f. GHC.Core.Utils.exprIsTrivial -litIsTrivial (LitString _) = False -litIsTrivial (LitNumber nt _ _) = case nt of - LitNumInteger -> False - LitNumNatural -> False - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> True - LitNumWord64 -> True -litIsTrivial _ = True - --- | True if code space does not go bad if we duplicate this literal -litIsDupable :: Platform -> Literal -> Bool --- c.f. GHC.Core.Utils.exprIsDupable -litIsDupable platform x = case x of - (LitNumber nt i _) -> case nt of - LitNumInteger -> platformInIntRange platform i - LitNumNatural -> platformInWordRange platform i - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> True - LitNumWord64 -> True - (LitString _) -> False - _ -> True - -litFitsInChar :: Literal -> Bool -litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) - && i <= toInteger (ord maxBound) -litFitsInChar _ = False - -litIsLifted :: Literal -> Bool -litIsLifted (LitNumber nt _ _) = case nt of - LitNumInteger -> True - LitNumNatural -> True - LitNumInt -> False - LitNumInt64 -> False - LitNumWord -> False - LitNumWord64 -> False -litIsLifted _ = False - -{- - Types - ~~~~~ - -Note [Types of LitNumbers] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A LitNumber's type is always known from its LitNumType: - - LitNumInteger -> Integer - LitNumNatural -> Natural - LitNumInt -> Int# (intPrimTy) - LitNumInt64 -> Int64# (int64PrimTy) - LitNumWord -> Word# (wordPrimTy) - LitNumWord64 -> Word64# (word64PrimTy) - -The reason why we have a Type field is because Integer and Natural types live -outside of GHC (in the libraries), so we have to get the actual Type via -lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites -of literalType, so we do that when creating these literals, and literalType -simply reads the field. - -(But see also Note [Integer literals] and Note [Natural literals]) --} - --- | Find the Haskell 'Type' the literal occupies -literalType :: Literal -> Type -literalType LitNullAddr = addrPrimTy -literalType (LitChar _) = charPrimTy -literalType (LitString _) = addrPrimTy -literalType (LitFloat _) = floatPrimTy -literalType (LitDouble _) = doublePrimTy -literalType (LitLabel _ _ _) = addrPrimTy -literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers] -literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) - where - a = alphaTyVarUnliftedRep - -absentLiteralOf :: TyCon -> Maybe Literal --- Return a literal of the appropriate primitive --- TyCon, to use as a placeholder when it doesn't matter --- Rubbish literals are handled in GHC.Core.Op.WorkWrap.Lib, because --- 1. Looking at the TyCon is not enough, we need the actual type --- 2. This would need to return a type application to a literal -absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) - -absent_lits :: UniqFM Literal -absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr) - , (charPrimTyConKey, LitChar 'x') - , (intPrimTyConKey, mkLitIntUnchecked 0) - , (int64PrimTyConKey, mkLitInt64Unchecked 0) - , (wordPrimTyConKey, mkLitWordUnchecked 0) - , (word64PrimTyConKey, mkLitWord64Unchecked 0) - , (floatPrimTyConKey, LitFloat 0) - , (doublePrimTyConKey, LitDouble 0) - ] - -{- - Comparison - ~~~~~~~~~~ --} - -cmpLit :: Literal -> Literal -> Ordering -cmpLit (LitChar a) (LitChar b) = a `compare` b -cmpLit (LitString a) (LitString b) = a `compare` b -cmpLit (LitNullAddr) (LitNullAddr) = EQ -cmpLit (LitFloat a) (LitFloat b) = a `compare` b -cmpLit (LitDouble a) (LitDouble b) = a `compare` b -cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b -cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) - | nt1 == nt2 = a `compare` b - | otherwise = nt1 `compare` nt2 -cmpLit (LitRubbish) (LitRubbish) = EQ -cmpLit lit1 lit2 - | litTag lit1 < litTag lit2 = LT - | otherwise = GT - -litTag :: Literal -> Int -litTag (LitChar _) = 1 -litTag (LitString _) = 2 -litTag (LitNullAddr) = 3 -litTag (LitFloat _) = 4 -litTag (LitDouble _) = 5 -litTag (LitLabel _ _ _) = 6 -litTag (LitNumber {}) = 7 -litTag (LitRubbish) = 8 - -{- - Printing - ~~~~~~~~ -* See Note [Printing of literals in Core] --} - -pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc -pprLiteral _ (LitChar c) = pprPrimChar c -pprLiteral _ (LitString s) = pprHsBytes s -pprLiteral _ (LitNullAddr) = text "__NULL" -pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix -pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix -pprLiteral add_par (LitNumber nt i _) - = case nt of - LitNumInteger -> pprIntegerVal add_par i - LitNumNatural -> pprIntegerVal add_par i - LitNumInt -> pprPrimInt i - LitNumInt64 -> pprPrimInt64 i - LitNumWord -> pprPrimWord i - LitNumWord64 -> pprPrimWord64 i -pprLiteral add_par (LitLabel l mb fod) = - add_par (text "__label" <+> b <+> ppr fod) - where b = case mb of - Nothing -> pprHsString l - Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) -pprLiteral _ (LitRubbish) = text "__RUBBISH" - -pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc --- See Note [Printing of literals in Core]. -pprIntegerVal add_par i | i < 0 = add_par (integer i) - | otherwise = integer i - -{- -Note [Printing of literals in Core] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function `add_par` is used to wrap parenthesis around negative integers -(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring -an atomic thing (for example function application). - -Although not all Core literals would be valid Haskell, we are trying to stay -as close as possible to Haskell syntax in the printing of Core, to make it -easier for a Haskell user to read Core. - -To that end: - * We do print parenthesis around negative `LitInteger`, because we print - `LitInteger` using plain number literals (no prefix or suffix), and plain - number literals in Haskell require parenthesis in contexts like function - application (i.e. `1 - -1` is not valid Haskell). - - * We don't print parenthesis around other (negative) literals, because they - aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's - parser). - -Literal Output Output if context requires - an atom (if different) -------- ------- ---------------------- -LitChar 'a'# -LitString "aaa"# -LitNullAddr "__NULL" -LitInt -1# -LitInt64 -1L# -LitWord 1## -LitWord64 1L## -LitFloat -1.0# -LitDouble -1.0## -LitInteger -1 (-1) -LitLabel "__label" ... ("__label" ...) -LitRubbish "__RUBBISH" - -Note [Rubbish literals] -~~~~~~~~~~~~~~~~~~~~~~~ -During worker/wrapper after demand analysis, where an argument -is unused (absent) we do the following w/w split (supposing that -y is absent): - - f x y z = e -===> - f x y z = $wf x z - $wf x z = let y = - in e - -Usually the binding for y is ultimately optimised away, and -even if not it should never be evaluated -- but that's the -way the w/w split starts off. - -What is ? -* For lifted values can be a call to 'error'. -* For primitive types like Int# or Word# we can use any random - value of that type. -* But what about /unlifted/ but /boxed/ types like MutVar# or - Array#? We need a literal value of that type. - -That is 'LitRubbish'. Since we need a rubbish literal for -many boxed, unlifted types, we say that LitRubbish has type - LitRubbish :: forall (a :: TYPE UnliftedRep). a - -So we might see a w/w split like - $wf x z = let y :: Array# Int = LitRubbish @(Array# Int) - in e - -Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted -heap pointers. - -Here are the moving parts: - -* We define LitRubbish as a constructor in Literal.Literal - -* It is given its polymorphic type by Literal.literalType - -* GHC.Core.Op.WorkWrap.Lib.mk_absent_let introduces a LitRubbish for absent - arguments of boxed, unlifted type. - -* In CoreToSTG we convert (RubishLit @t) to just (). STG is - untyped, so it doesn't matter that it points to a lifted - value. The important thing is that it is a heap pointer, - which the garbage collector can follow if it encounters it. - - We considered maintaining LitRubbish in STG, and lowering - it in the code generators, but it seems simpler to do it - once and for all in CoreToSTG. - - In GHC.ByteCode.Asm we just lower it as a 0 literal, because - it's all boxed and lifted to the host GC anyway. --} diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs deleted file mode 100644 index d785642524..0000000000 --- a/compiler/basicTypes/MkId.hs +++ /dev/null @@ -1,1708 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - - -This module contains definitions for the IdInfo for things that -have a standard form, namely: - -- data constructors -- record selectors -- method and superclass selectors -- primitive operations --} - -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module MkId ( - mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, - - mkPrimOpId, mkFCallId, - - unwrapNewTypeBody, wrapFamInstBody, - DataConBoxer(..), vanillaDataConBoxer, - mkDataConRep, mkDataConWorkId, - - -- And some particular Ids; see below for why they are wired in - wiredInIds, ghcPrimIds, - realWorldPrimId, - voidPrimId, voidArgId, - nullAddrId, seqId, lazyId, lazyIdKey, - coercionTokenId, magicDictId, coerceId, - proxyHashId, noinlineId, noinlineIdName, - coerceName, - - -- Re-export error Ids - module GHC.Core.Op.ConstantFold - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Core.Rules -import TysPrim -import TysWiredIn -import GHC.Core.Op.ConstantFold -import GHC.Core.Type -import GHC.Core.TyCo.Rep -import GHC.Core.FamInstEnv -import GHC.Core.Coercion -import TcType -import GHC.Core.Make -import GHC.Core.Utils ( mkCast, mkDefaultCase ) -import GHC.Core.Unfold -import Literal -import GHC.Core.TyCon -import GHC.Core.Class -import NameSet -import Name -import PrimOp -import ForeignCall -import GHC.Core.DataCon -import Id -import IdInfo -import Demand -import Cpr -import GHC.Core -import Unique -import UniqSupply -import PrelNames -import BasicTypes hiding ( SuccessFlag(..) ) -import Util -import GHC.Driver.Session -import Outputable -import FastString -import ListSetOps -import Var (VarBndr(Bndr)) -import qualified GHC.LanguageExtensions as LangExt - -import Data.Maybe ( maybeToList ) - -{- -************************************************************************ -* * -\subsection{Wired in Ids} -* * -************************************************************************ - -Note [Wired-in Ids] -~~~~~~~~~~~~~~~~~~~ -A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') -rather than by looking it up its name in some environment or fetching -it from an interface file. - -There are several reasons why an Id might appear in the wiredInIds: - -* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] - -* magicIds: see Note [magicIds] - -* errorIds, defined in GHC.Core.Make. - These error functions (e.g. rUNTIME_ERROR_ID) are wired in - because the desugarer generates code that mentions them directly - -In all cases except ghcPrimIds, there is a definition site in a -library module, which may be called (e.g. in higher order situations); -but the wired-in version means that the details are never read from -that module's interface file; instead, the full definition is right -here. - -Note [ghcPrimIds (aka pseudoops)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ghcPrimIds - - * Are exported from GHC.Prim - - * Can't be defined in Haskell, and hence no Haskell binding site, - but have perfectly reasonable unfoldings in Core - - * Either have a CompulsoryUnfolding (hence always inlined), or - of an EvaldUnfolding and void representation (e.g. void#) - - * Are (or should be) defined in primops.txt.pp as 'pseudoop' - Reason: that's how we generate documentation for them - -Note [magicIds] -~~~~~~~~~~~~~~~ -The magicIds - - * Are exported from GHC.Magic - - * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). - This definition at least generates Haddock documentation for them. - - * May or may not have a CompulsoryUnfolding. - - * But have some special behaviour that can't be done via an - unfolding from an interface file --} - -wiredInIds :: [Id] -wiredInIds - = magicIds - ++ ghcPrimIds - ++ errorIds -- Defined in GHC.Core.Make - -magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId] - -ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] -ghcPrimIds - = [ realWorldPrimId - , voidPrimId - , nullAddrId - , seqId - , magicDictId - , coerceId - , proxyHashId - ] - -{- -************************************************************************ -* * -\subsection{Data constructors} -* * -************************************************************************ - -The wrapper for a constructor is an ordinary top-level binding that evaluates -any strict args, unboxes any args that are going to be flattened, and calls -the worker. - -We're going to build a constructor that looks like: - - data (Data a, C b) => T a b = T1 !a !Int b - - T1 = /\ a b -> - \d1::Data a, d2::C b -> - \p q r -> case p of { p -> - case q of { q -> - Con T1 [a,b] [p,q,r]}} - -Notice that - -* d2 is thrown away --- a context in a data decl is used to make sure - one *could* construct dictionaries at the site the constructor - is used, but the dictionary isn't actually used. - -* We have to check that we can construct Data dictionaries for - the types a and Int. Once we've done that we can throw d1 away too. - -* We use (case p of q -> ...) to evaluate p, rather than "seq" because - all that matters is that the arguments are evaluated. "seq" is - very careful to preserve evaluation order, which we don't need - to be here. - - You might think that we could simply give constructors some strictness - info, like PrimOps, and let CoreToStg do the let-to-case transformation. - But we don't do that because in the case of primops and functions strictness - is a *property* not a *requirement*. In the case of constructors we need to - do something active to evaluate the argument. - - Making an explicit case expression allows the simplifier to eliminate - it in the (common) case where the constructor arg is already evaluated. - -Note [Wrappers for data instance tycons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the case of data instances, the wrapper also applies the coercion turning -the representation type into the family instance type to cast the result of -the wrapper. For example, consider the declarations - - data family Map k :: * -> * - data instance Map (a, b) v = MapPair (Map a (Pair b v)) - -The tycon to which the datacon MapPair belongs gets a unique internal -name of the form :R123Map, and we call it the representation tycon. -In contrast, Map is the family tycon (accessible via -tyConFamInst_maybe). A coercion allows you to move between -representation and family type. It is accessible from :R123Map via -tyConFamilyCoercion_maybe and has kind - - Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} - -The wrapper and worker of MapPair get the types - - -- Wrapper - $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) - - -- Worker - MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v - -This coercion is conditionally applied by wrapFamInstBody. - -It's a bit more complicated if the data instance is a GADT as well! - - data instance T [a] where - T1 :: forall b. b -> T [Maybe b] - -Hence we translate to - - -- Wrapper - $WT1 :: forall b. b -> T [Maybe b] - $WT1 b v = T1 (Maybe b) b (Maybe b) v - `cast` sym (Co7T (Maybe b)) - - -- Worker - T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c - - -- Coercion from family type to representation type - Co7T a :: T [a] ~ :R7T a - -Newtype instances through an additional wrinkle into the mix. Consider the -following example (adapted from #15318, comment:2): - - data family T a - newtype instance T [a] = MkT [a] - -Within the newtype instance, there are three distinct types at play: - -1. The newtype's underlying type, [a]. -2. The instance's representation type, TList a (where TList is the - representation tycon). -3. The family type, T [a]. - -We need two coercions in order to cast from (1) to (3): - -(a) A newtype coercion axiom: - - axiom coTList a :: TList a ~ [a] - - (Where TList is the representation tycon of the newtype instance.) - -(b) A data family instance coercion axiom: - - axiom coT a :: T [a] ~ TList a - -When we translate the newtype instance to Core, we obtain: - - -- Wrapper - $WMkT :: forall a. [a] -> T [a] - $WMkT a x = MkT a x |> Sym (coT a) - - -- Worker - MkT :: forall a. [a] -> TList [a] - MkT a x = x |> Sym (coTList a) - -Unlike for data instances, the worker for a newtype instance is actually an -executable function which expands to a cast, but otherwise, the general -strategy is essentially the same as for data instances. Also note that we have -a wrapper, which is unusual for a newtype, but we make GHC produce one anyway -for symmetry with the way data instances are handled. - -Note [Newtype datacons] -~~~~~~~~~~~~~~~~~~~~~~~ -The "data constructor" for a newtype should always be vanilla. At one -point this wasn't true, because the newtype arising from - class C a => D a -looked like - newtype T:D a = D:D (C a) -so the data constructor for T:C had a single argument, namely the -predicate (C a). But now we treat that as an ordinary argument, not -part of the theta-type, so all is well. - -Note [Newtype workers] -~~~~~~~~~~~~~~~~~~~~~~ -A newtype does not really have a worker. Instead, newtype constructors -just unfold into a cast. But we need *something* for, say, MkAge to refer -to. So, we do this: - -* The Id used as the newtype worker will have a compulsory unfolding to - a cast. See Note [Compulsory newtype unfolding] - -* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId, - as those have special treatment in the back end. - -* There is no top-level binding, because the compulsory unfolding - means that it will be inlined (to a cast) at every call site. - -We probably should have a NewtypeWorkId, but these Ids disappear as soon as -we desugar anyway, so it seems a step too far. - -Note [Compulsory newtype unfolding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Newtype wrappers, just like workers, have compulsory unfoldings. -This is needed so that two optimizations involving newtypes have the same -effect whether a wrapper is present or not: - -(1) Case-of-known constructor. - See Note [beta-reduction in exprIsConApp_maybe]. - -(2) Matching against the map/coerce RULE. Suppose we have the RULE - - {-# RULE "map/coerce" map coerce = ... #-} - - As described in Note [Getting the map/coerce RULE to work], - the occurrence of 'coerce' is transformed into: - - {-# RULE "map/coerce" forall (c :: T1 ~R# T2). - map ((\v -> v) `cast` c) = ... #-} - - We'd like 'map Age' to match the LHS. For this to happen, Age - must be unfolded, otherwise we'll be stuck. This is tested in T16208. - -It also allows for the posssibility of levity polymorphic newtypes -with wrappers (with -XUnliftedNewtypes): - - newtype N (a :: TYPE r) = MkN a - -With -XUnliftedNewtypes, this is allowed -- even though MkN is levity- -polymorphic. It's OK because MkN evaporates in the compiled code, becoming -just a cast. That is, it has a compulsory unfolding. As long as its -argument is not levity-polymorphic (which it can't be, according to -Note [Levity polymorphism invariants] in GHC.Core), and it's saturated, -no levity-polymorphic code ends up in the code generator. The saturation -condition is effectively checked by Note [Detecting forced eta expansion] -in GHC.HsToCore.Expr. - -However, if we make a *wrapper* for a newtype, we get into trouble. -The saturation condition is no longer checked (because hasNoBinding -returns False) and indeed we generate a forbidden levity-polymorphic -binding. - -The solution is simple, though: just make the newtype wrappers -as ephemeral as the newtype workers. In other words, give the wrappers -compulsory unfoldings and no bindings. The compulsory unfolding is given -in wrap_unf in mkDataConRep, and the lack of a binding happens in -GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no -implicit bindings. - -************************************************************************ -* * -\subsection{Dictionary selectors} -* * -************************************************************************ - -Selecting a field for a dictionary. If there is just one field, then -there's nothing to do. - -Dictionary selectors may get nested forall-types. Thus: - - class Foo a where - op :: forall b. Ord b => a -> b -> b - -Then the top-level type for op is - - op :: forall a. Foo a => - forall b. Ord b => - a -> b -> b - --} - -mkDictSelId :: Name -- Name of one of the *value* selectors - -- (dictionary superclass or method) - -> Class -> Id -mkDictSelId name clas - = mkGlobalId (ClassOpId clas) name sel_ty info - where - tycon = classTyCon clas - sel_names = map idName (classAllSelIds clas) - new_tycon = isNewTyCon tycon - [data_con] = tyConDataCons tycon - tyvars = dataConUserTyVarBinders data_con - n_ty_args = length tyvars - arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name - - sel_ty = mkForAllTys tyvars $ - mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ - getNth arg_tys val_index - - base_info = noCafIdInfo - `setArityInfo` 1 - `setStrictnessInfo` strict_sig - `setCprInfo` topCprSig - `setLevityInfoWithType` sel_ty - - info | new_tycon - = base_info `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 - (mkDictSelRhs clas val_index) - -- See Note [Single-method classes] in TcInstDcls - -- for why alwaysInlinePragma - - | otherwise - = base_info `setRuleInfo` mkRuleInfo [rule] - -- Add a magic BuiltinRule, but no unfolding - -- so that the rule is always available to fire. - -- See Note [ClassOp/DFun selection] in TcInstDcls - - -- This is the built-in rule that goes - -- op (dfT d1 d2) ---> opT d1 d2 - rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` - occNameFS (getOccName name) - , ru_fn = name - , ru_nargs = n_ty_args + 1 - , ru_try = dictSelRule val_index n_ty_args } - - -- The strictness signature is of the form U(AAAVAAAA) -> T - -- where the V depends on which item we are selecting - -- It's worth giving one, so that absence info etc is generated - -- even if the selector isn't inlined - - strict_sig = mkClosedStrictSig [arg_dmd] topDiv - arg_dmd | new_tycon = evalDmd - | otherwise = mkManyUsedDmd $ - mkProdDmd [ if name == sel_name then evalDmd else absDmd - | sel_name <- sel_names ] - -mkDictSelRhs :: Class - -> Int -- 0-indexed selector among (superclasses ++ methods) - -> CoreExpr -mkDictSelRhs clas val_index - = mkLams tyvars (Lam dict_id rhs_body) - where - tycon = classTyCon clas - new_tycon = isNewTyCon tycon - [data_con] = tyConDataCons tycon - tyvars = dataConUnivTyVars data_con - arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - - the_arg_id = getNth arg_ids val_index - pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 pred - arg_ids = mkTemplateLocalsNum 2 arg_tys - - rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) - (Var dict_id) - | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) - arg_ids (varToCoreExpr the_arg_id) - -- varToCoreExpr needed for equality superclass selectors - -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } - -dictSelRule :: Int -> Arity -> RuleFun --- Tries to persuade the argument to look like a constructor --- application, using exprIsConApp_maybe, and then selects --- from it --- sel_i t1..tk (D t1..tk op1 ... opm) = opi --- -dictSelRule val_index n_ty_args _ id_unf _ args - | (dict_arg : _) <- drop n_ty_args args - , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg - = Just (wrapFloats floats $ getNth con_args val_index) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Data constructors -* * -************************************************************************ --} - -mkDataConWorkId :: Name -> DataCon -> Id -mkDataConWorkId wkr_name data_con - | isNewTyCon tycon - = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info - -- See Note [Newtype workers] - - | otherwise - = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info - - where - tycon = dataConTyCon data_con -- The representation TyCon - wkr_ty = dataConRepType data_con - - ----------- Workers for data types -------------- - alg_wkr_info = noCafIdInfo - `setArityInfo` wkr_arity - `setStrictnessInfo` wkr_sig - `setCprInfo` mkCprSig wkr_arity (dataConCPR data_con) - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, - -- even if arity = 0 - `setLevityInfoWithType` wkr_ty - -- NB: unboxed tuples have workers, so we can't use - -- setNeverLevPoly - - wkr_arity = dataConRepArity data_con - wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) topDiv - -- Note [Data-con worker strictness] - -- Notice that we do *not* say the worker Id is strict - -- even if the data constructor is declared strict - -- e.g. data T = MkT !(Int,Int) - -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has - -- case expressions that do the evals) but the *worker* MkT itself is - -- not. If we pretend it is strict then when we see - -- case x of y -> MkT y - -- the simplifier thinks that y is "sure to be evaluated" (because - -- the worker MkT is strict) and drops the case. No, the workerId - -- MkT is not strict. - -- - -- However, the worker does have StrictnessMarks. When the simplifier - -- sees a pattern - -- case e of MkT x -> ... - -- it uses the dataConRepStrictness of MkT to mark x as evaluated; - -- but that's fine... dataConRepStrictness comes from the data con - -- not from the worker Id. - - ----------- Workers for newtypes -------------- - univ_tvs = dataConUnivTyVars data_con - arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys - nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` 1 -- Arity 1 - `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` newtype_unf - `setLevityInfoWithType` wkr_ty - id_arg1 = mkTemplateLocal 1 (head arg_tys) - res_ty_args = mkTyCoVarTys univ_tvs - newtype_unf = ASSERT2( isVanillaDataCon data_con && - isSingleton arg_tys - , ppr data_con ) - -- Note [Newtype datacons] - mkCompulsoryUnfolding $ - mkLams univ_tvs $ Lam id_arg1 $ - wrapNewTypeBody tycon res_ty_args (Var id_arg1) - -dataConCPR :: DataCon -> CprResult -dataConCPR con - | isDataTyCon tycon -- Real data types only; that is, - -- not unboxed tuples or newtypes - , null (dataConExTyCoVars con) -- No existentials - , wkr_arity > 0 - , wkr_arity <= mAX_CPR_SIZE - = conCpr (dataConTag con) - | otherwise - = topCpr - where - tycon = dataConTyCon con - wkr_arity = dataConRepArity con - - mAX_CPR_SIZE :: Arity - mAX_CPR_SIZE = 10 - -- We do not treat very big tuples as CPR-ish: - -- a) for a start we get into trouble because there aren't - -- "enough" unboxed tuple types (a tiresome restriction, - -- but hard to fix), - -- b) more importantly, big unboxed tuples get returned mainly - -- on the stack, and are often then allocated in the heap - -- by the caller. So doing CPR for them may in fact make - -- things worse. - -{- -------------------------------------------------- --- Data constructor representation --- --- This is where we decide how to wrap/unwrap the --- constructor fields --- --------------------------------------------------- --} - -type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) - -- Unbox: bind rep vars by decomposing src var - -data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) - -- Box: build src arg using these rep vars - --- | Data Constructor Boxer -newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) - -- Bind these src-level vars, returning the - -- rep-level vars to bind in the pattern - -vanillaDataConBoxer :: DataConBoxer --- No transformation on arguments needed -vanillaDataConBoxer = DCB (\_tys args -> return (args, [])) - -{- -Note [Inline partially-applied constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We allow the wrapper to inline when partially applied to avoid -boxing values unnecessarily. For example, consider - - data Foo a = Foo !Int a - - instance Traversable Foo where - traverse f (Foo i a) = Foo i <$> f a - -This desugars to - - traverse f foo = case foo of - Foo i# a -> let i = I# i# - in map ($WFoo i) (f a) - -If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. -But if we inline the wrapper, we get - - map (\a. case i of I# i# a -> Foo i# a) (f a) - -and now case-of-known-constructor eliminates the redundant allocation. - --} - -mkDataConRep :: DynFlags - -> FamInstEnvs - -> Name - -> Maybe [HsImplBang] - -- See Note [Bangs on imported data constructors] - -> DataCon - -> UniqSM DataConRep -mkDataConRep dflags fam_envs wrap_name mb_bangs data_con - | not wrapper_reqd - = return NoDataConRep - - | otherwise - = do { wrap_args <- mapM newLocal wrap_arg_tys - ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) - initial_wrap_app - - ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info - wrap_info = noCafIdInfo - `setArityInfo` wrap_arity - -- It's important to specify the arity, so that partial - -- applications are treated as values - `setInlinePragInfo` wrap_prag - `setUnfoldingInfo` wrap_unf - `setStrictnessInfo` wrap_sig - `setCprInfo` mkCprSig wrap_arity (dataConCPR data_con) - -- We need to get the CAF info right here because GHC.Iface.Tidy - -- does not tidy the IdInfo of implicit bindings (like the wrapper) - -- so it not make sure that the CAF info is sane - `setLevityInfoWithType` wrap_ty - - wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv - - wrap_arg_dmds = - replicate (length theta) topDmd ++ map mk_dmd arg_ibangs - -- Don't forget the dictionary arguments when building - -- the strictness signature (#14290). - - mk_dmd str | isBanged str = evalDmd - | otherwise = topDmd - - wrap_prag = alwaysInlinePragma `setInlinePragmaActivation` - activeDuringFinal - -- See Note [Activation for data constructor wrappers] - - -- The wrapper will usually be inlined (see wrap_unf), so its - -- strictness and CPR info is usually irrelevant. But this is - -- not always the case; GHC may choose not to inline it. In - -- particular, the wrapper constructor is not inlined inside - -- an INLINE rhs or when it is not applied to any arguments. - -- See Note [Inline partially-applied constructor wrappers] - -- Passing Nothing here allows the wrapper to inline when - -- unsaturated. - wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs - -- See Note [Compulsory newtype unfolding] - | otherwise = mkInlineUnfolding wrap_rhs - wrap_rhs = mkLams wrap_tvs $ - mkLams wrap_args $ - wrapFamInstBody tycon res_ty_args $ - wrap_body - - ; return (DCR { dcr_wrap_id = wrap_id - , dcr_boxer = mk_boxer boxers - , dcr_arg_tys = rep_tys - , dcr_stricts = rep_strs - -- For newtypes, dcr_bangs is always [HsLazy]. - -- See Note [HsImplBangs for newtypes]. - , dcr_bangs = arg_ibangs }) } - - where - (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) - = dataConFullSig data_con - wrap_tvs = dataConUserTyVars data_con - res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs - - tycon = dataConTyCon data_con -- The representation TyCon (not family) - wrap_ty = dataConUserType data_con - ev_tys = eqSpecPreds eq_spec ++ theta - all_arg_tys = ev_tys ++ orig_arg_tys - ev_ibangs = map (const HsLazy) ev_tys - orig_bangs = dataConSrcBangs data_con - - wrap_arg_tys = theta ++ orig_arg_tys - wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys - -- The wrap_args are the arguments *other than* the eq_spec - -- Because we are going to apply the eq_spec args manually in the - -- wrapper - - new_tycon = isNewTyCon tycon - arg_ibangs - | new_tycon - = ASSERT( isSingleton orig_arg_tys ) - [HsLazy] -- See Note [HsImplBangs for newtypes] - | otherwise - = case mb_bangs of - Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) - orig_arg_tys orig_bangs - Just bangs -> bangs - - (rep_tys_w_strs, wrappers) - = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) - - (unboxers, boxers) = unzip wrappers - (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) - - wrapper_reqd = - (not new_tycon - -- (Most) newtypes have only a worker, with the exception - -- of some newtypes written with GADT syntax. See below. - && (any isBanged (ev_ibangs ++ arg_ibangs) - -- Some forcing/unboxing (includes eq_spec) - || (not $ null eq_spec))) -- GADT - || isFamInstTyCon tycon -- Cast result - || dataConUserTyVarsArePermuted data_con - -- If the data type was written with GADT syntax and - -- orders the type variables differently from what the - -- worker expects, it needs a data con wrapper to reorder - -- the type variables. - -- See Note [Data con wrappers and GADT syntax]. - - initial_wrap_app = Var (dataConWorkId data_con) - `mkTyApps` res_ty_args - `mkVarApps` ex_tvs - `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec - - mk_boxer :: [Boxer] -> DataConBoxer - mk_boxer boxers = DCB (\ ty_args src_vars -> - do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars - subst1 = zipTvSubst univ_tvs ty_args - subst2 = extendTCvSubstList subst1 ex_tvs - (mkTyCoVarTys ex_vars) - ; (rep_ids, binds) <- go subst2 boxers term_vars - ; return (ex_vars ++ rep_ids, binds) } ) - - go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) - go subst (UnitBox : boxers) (src_var : src_vars) - = do { (rep_ids2, binds) <- go subst boxers src_vars - ; return (src_var : rep_ids2, binds) } - go subst (Boxer boxer : boxers) (src_var : src_vars) - = do { (rep_ids1, arg) <- boxer subst - ; (rep_ids2, binds) <- go subst boxers src_vars - ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } - go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) - - mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr - mk_rep_app [] con_app - = return con_app - mk_rep_app ((wrap_arg, unboxer) : prs) con_app - = do { (rep_ids, unbox_fn) <- unboxer wrap_arg - ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) - ; return (unbox_fn expr) } - -{- Note [Activation for data constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Activation on a data constructor wrapper allows it to inline only in Phase -0. This way rules have a chance to fire if they mention a data constructor on -the left - RULE "foo" f (K a b) = ... -Since the LHS of rules are simplified with InitialPhase, we won't -inline the wrapper on the LHS either. - -On the other hand, this means that exprIsConApp_maybe must be able to deal -with wrappers so that case-of-constructor is not delayed; see -Note [exprIsConApp_maybe on data constructors with wrappers] for details. - -It used to activate in phases 2 (afterInitial) and later, but it makes it -awkward to write a RULE[1] with a constructor on the left: it would work if a -constructor has no wrapper, but whether a constructor has a wrapper depends, for -instance, on the order of type argument of that constructors. Therefore changing -the order of type argument could make previously working RULEs fail. - -See also https://gitlab.haskell.org/ghc/ghc/issues/15840 . - - -Note [Bangs on imported data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs -from imported modules. - -- Nothing <=> use HsSrcBangs -- Just bangs <=> use HsImplBangs - -For imported types we can't work it all out from the HsSrcBangs, -because we want to be very sure to follow what the original module -(where the data type was declared) decided, and that depends on what -flags were enabled when it was compiled. So we record the decisions in -the interface file. - -The HsImplBangs passed are in 1-1 correspondence with the -dataConOrigArgTys of the DataCon. - -Note [Data con wrappers and unlifted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT !Int# - -We certainly do not want to make a wrapper - $WMkT x = case x of y { DEFAULT -> MkT y } - -For a start, it's still to generate a no-op. But worse, since wrappers -are currently injected at TidyCore, we don't even optimise it away! -So the stupid case expression stays there. This actually happened for -the Integer data type (see #1600 comment:66)! - -Note [Data con wrappers and GADT syntax] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these two very similar data types: - - data T1 a b = MkT1 b - - data T2 a b where - MkT2 :: forall b a. b -> T2 a b - -Despite their similar appearance, T2 will have a data con wrapper but T1 will -not. What sets them apart? The types of their constructors, which are: - - MkT1 :: forall a b. b -> T1 a b - MkT2 :: forall b a. b -> T2 a b - -MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` -would normally appear. See Note [DataCon user type variable binders] in GHC.Core.DataCon -for further discussion on this topic. - -The worker data cons for T1 and T2, however, both have types such that `a` is -expected to come before `b` as arguments. Because MkT2 permutes this order, it -needs a data con wrapper to swizzle around the type variables to be in the -order the worker expects. - -A somewhat surprising consequence of this is that *newtypes* can have data con -wrappers! After all, a newtype can also be written with GADT syntax: - - newtype T3 a b where - MkT3 :: forall b a. b -> T3 a b - -Again, this needs a wrapper data con to reorder the type variables. It does -mean that this newtype constructor requires another level of indirection when -being called, but the inliner should make swift work of that. - -Note [HsImplBangs for newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the time, we use the dataConSrctoImplBang function to decide what -strictness/unpackedness to use for the fields of a data type constructor. But -there is an exception to this rule: newtype constructors. You might not think -that newtypes would pose a challenge, since newtypes are seemingly forbidden -from having strictness annotations in the first place. But consider this -(from #16141): - - {-# LANGUAGE StrictData #-} - {-# OPTIONS_GHC -O #-} - newtype T a b where - MkT :: forall b a. Int -> T a b - -Because StrictData (plus optimization) is enabled, invoking -dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#! -This would be disastrous, since the wrapper for `MkT` uses a coercion involving -Int, not Int#. - -Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the -case of a newtype constructor, we simply hardcode its dcr_bangs field to -[HsLazy]. --} - -------------------------- -newLocal :: Type -> UniqSM Var -newLocal ty = do { uniq <- getUniqueM - ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } - -- We should not have "OrCoVar" here, this is a bug (#17545) - - --- | Unpack/Strictness decisions from source module. --- --- This function should only ever be invoked for data constructor fields, and --- never on the field of a newtype constructor. --- See @Note [HsImplBangs for newtypes]@. -dataConSrcToImplBang - :: DynFlags - -> FamInstEnvs - -> Type - -> HsSrcBang - -> HsImplBang - -dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang ann unpk NoSrcStrict) - | xopt LangExt.StrictData dflags -- StrictData => strict field - = dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang ann unpk SrcStrict) - | otherwise -- no StrictData => lazy field - = HsLazy - -dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) - = HsLazy - -dataConSrcToImplBang dflags fam_envs arg_ty - (HsSrcBang _ unpk_prag SrcStrict) - | isUnliftedType arg_ty - = HsLazy -- For !Int#, say, use HsLazy - -- See Note [Data con wrappers and unlifted types] - - | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas - -- Don't unpack if we aren't optimising; rather arbitrarily, - -- we use -fomit-iface-pragmas as the indication - , let mb_co = topNormaliseType_maybe fam_envs arg_ty - -- Unwrap type families and newtypes - arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } - , isUnpackableType dflags fam_envs arg_ty' - , (rep_tys, _) <- dataConArgUnpack arg_ty' - , case unpk_prag of - NoSrcUnpack -> - gopt Opt_UnboxStrictFields dflags - || (gopt Opt_UnboxSmallStrictFields dflags - && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] - srcUnpack -> isSrcUnpacked srcUnpack - = case mb_co of - Nothing -> HsUnpack Nothing - Just (co,_) -> HsUnpack (Just co) - - | otherwise -- Record the strict-but-no-unpack decision - = HsStrict - - --- | Wrappers/Workers and representation following Unpack/Strictness --- decisions -dataConArgRep - :: Type - -> HsImplBang - -> ([(Type,StrictnessMark)] -- Rep types - ,(Unboxer,Boxer)) - -dataConArgRep arg_ty HsLazy - = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) - -dataConArgRep arg_ty HsStrict - = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) - -dataConArgRep arg_ty (HsUnpack Nothing) - | (rep_tys, wrappers) <- dataConArgUnpack arg_ty - = (rep_tys, wrappers) - -dataConArgRep _ (HsUnpack (Just co)) - | let co_rep_ty = coercionRKind co - , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty - = (rep_tys, wrapCo co co_rep_ty wrappers) - - -------------------------- -wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) -wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty - = (unboxer, boxer) - where - unboxer arg_id = do { rep_id <- newLocal rep_ty - ; (rep_ids, rep_fn) <- unbox_rep rep_id - ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) - ; return (rep_ids, Let co_bind . rep_fn) } - boxer = Boxer $ \ subst -> - do { (rep_ids, rep_expr) - <- case box_rep of - UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) - ; return ([rep_id], Var rep_id) } - Boxer boxer -> boxer subst - ; let sco = substCoUnchecked subst co - ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } - ------------------------- -seqUnboxer :: Unboxer -seqUnboxer v = return ([v], mkDefaultCase (Var v) v) - -unitUnboxer :: Unboxer -unitUnboxer v = return ([v], \e -> e) - -unitBoxer :: Boxer -unitBoxer = UnitBox - -------------------------- -dataConArgUnpack - :: Type - -> ( [(Type, StrictnessMark)] -- Rep types - , (Unboxer, Boxer) ) - -dataConArgUnpack arg_ty - | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty - , Just con <- tyConSingleAlgDataCon_maybe tc - -- NB: check for an *algebraic* data type - -- A recursive newtype might mean that - -- 'arg_ty' is a newtype - , let rep_tys = dataConInstArgTys con tc_args - = ASSERT( null (dataConExTyCoVars con) ) - -- Note [Unpacking GADTs and existentials] - ( rep_tys `zip` dataConRepStrictness con - ,( \ arg_id -> - do { rep_ids <- mapM newLocal rep_tys - ; let unbox_fn body - = mkSingleAltCase (Var arg_id) arg_id - (DataAlt con) rep_ids body - ; return (rep_ids, unbox_fn) } - , Boxer $ \ subst -> - do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys - ; return (rep_ids, Var (dataConWorkId con) - `mkTyApps` (substTysUnchecked subst tc_args) - `mkVarApps` rep_ids ) } ) ) - | otherwise - = pprPanic "dataConArgUnpack" (ppr arg_ty) - -- An interface file specified Unpacked, but we couldn't unpack it - -isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool --- True if we can unpack the UNPACK the argument type --- See Note [Recursive unboxing] --- We look "deeply" inside rather than relying on the DataCons --- we encounter on the way, because otherwise we might well --- end up relying on ourselves! -isUnpackableType dflags fam_envs ty - | Just data_con <- unpackable_type ty - = ok_con_args emptyNameSet data_con - | otherwise - = False - where - ok_con_args dcs con - | dc_name `elemNameSet` dcs - = False - | otherwise - = all (ok_arg dcs') - (dataConOrigArgTys con `zip` dataConSrcBangs con) - -- NB: dataConSrcBangs gives the *user* request; - -- We'd get a black hole if we used dataConImplBangs - where - dc_name = getName con - dcs' = dcs `extendNameSet` dc_name - - ok_arg dcs (ty, bang) - = not (attempt_unpack bang) || ok_ty dcs norm_ty - where - norm_ty = topNormaliseType fam_envs ty - - ok_ty dcs ty - | Just data_con <- unpackable_type ty - = ok_con_args dcs data_con - | otherwise - = True -- NB True here, in contrast to False at top level - - attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) - = xopt LangExt.StrictData dflags - attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) - = True - attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) - = True -- Be conservative - attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) - = xopt LangExt.StrictData dflags -- Be conservative - attempt_unpack _ = False - - unpackable_type :: Type -> Maybe DataCon - -- Works just on a single level - unpackable_type ty - | Just (tc, _) <- splitTyConApp_maybe ty - , Just data_con <- tyConSingleAlgDataCon_maybe tc - , null (dataConExTyCoVars data_con) - -- See Note [Unpacking GADTs and existentials] - = Just data_con - | otherwise - = Nothing - -{- -Note [Unpacking GADTs and existentials] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is nothing stopping us unpacking a data type with equality -components, like - data Equal a b where - Equal :: Equal a a - -And it'd be fine to unpack a product type with existential components -too, but that would require a bit more plumbing, so currently we don't. - -So for now we require: null (dataConExTyCoVars data_con) -See #14978 - -Note [Unpack one-wide fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The flag UnboxSmallStrictFields ensures that any field that can -(safely) be unboxed to a word-sized unboxed field, should be so unboxed. -For example: - - data A = A Int# - newtype B = B A - data C = C !B - data D = D !C - data E = E !() - data F = F !D - data G = G !F !F - -All of these should have an Int# as their representation, except -G which should have two Int#s. - -However - - data T = T !(S Int) - data S = S !a - -Here we can represent T with an Int#. - -Note [Recursive unboxing] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data R = MkR {-# UNPACK #-} !S Int - data S = MkS {-# UNPACK #-} !Int -The representation arguments of MkR are the *representation* arguments -of S (plus Int); the rep args of MkS are Int#. This is all fine. - -But be careful not to try to unbox this! - data T = MkT {-# UNPACK #-} !T Int -Because then we'd get an infinite number of arguments. - -Here is a more complicated case: - data S = MkS {-# UNPACK #-} !T Int - data T = MkT {-# UNPACK #-} !S Int -Each of S and T must decide independently whether to unpack -and they had better not both say yes. So they must both say no. - -Also behave conservatively when there is no UNPACK pragma - data T = MkS !T Int -with -funbox-strict-fields or -funbox-small-strict-fields -we need to behave as if there was an UNPACK pragma there. - -But it's the *argument* type that matters. This is fine: - data S = MkS S !Int -because Int is non-recursive. - -************************************************************************ -* * - Wrapping and unwrapping newtypes and type families -* * -************************************************************************ --} - -wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr --- The wrapper for the data constructor for a newtype looks like this: --- newtype T a = MkT (a,Int) --- MkT :: forall a. (a,Int) -> T a --- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) --- where CoT is the coercion TyCon associated with the newtype --- --- The call (wrapNewTypeBody T [a] e) returns the --- body of the wrapper, namely --- e `cast` (CoT [a]) --- --- If a coercion constructor is provided in the newtype, then we use --- it, otherwise the wrap/unwrap are both no-ops - -wrapNewTypeBody tycon args result_expr - = ASSERT( isNewTyCon tycon ) - mkCast result_expr (mkSymCo co) - where - co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] - --- When unwrapping, we do *not* apply any family coercion, because this will --- be done via a CoPat by the type checker. We have to do it this way as --- computing the right type arguments for the coercion requires more than just --- a splitting operation (cf, TcPat.tcConPat). - -unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -unwrapNewTypeBody tycon args result_expr - = ASSERT( isNewTyCon tycon ) - mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) - --- If the type constructor is a representation type of a data instance, wrap --- the expression into a cast adjusting the expression type, which is an --- instance of the representation type, to the corresponding instance of the --- family instance type. --- See Note [Wrappers for data instance tycons] -wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -wrapFamInstBody tycon args body - | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) - | otherwise - = body - -{- -************************************************************************ -* * -\subsection{Primitive operations} -* * -************************************************************************ --} - -mkPrimOpId :: PrimOp -> Id -mkPrimOpId prim_op - = id - where - (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op - ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) - name = mkWiredInName gHC_PRIM (primOpOcc prim_op) - (mkPrimOpIdUnique (primOpTag prim_op)) - (AnId id) UserSyntax - id = mkGlobalId (PrimOpId prim_op) name ty info - - -- PrimOps don't ever construct a product, but we want to preserve bottoms - cpr - | isBotDiv (snd (splitStrictSig strict_sig)) = botCpr - | otherwise = topCpr - - info = noCafIdInfo - `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) - `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setCprInfo` mkCprSig arity cpr - `setInlinePragInfo` neverInlinePragma - `setLevityInfoWithType` res_ty - -- We give PrimOps a NOINLINE pragma so that we don't - -- get silly warnings from Desugar.dsRule (the inline_shadows_rule - -- test) about a RULE conflicting with a possible inlining - -- cf #7287 - --- For each ccall we manufacture a separate CCallOpId, giving it --- a fresh unique, a type that is correct for this particular ccall, --- and a CCall structure that gives the correct details about calling --- convention etc. --- --- The *name* of this Id is a local name whose OccName gives the full --- details of the ccall, type and all. This means that the interface --- file reader can reconstruct a suitable Id - -mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id -mkFCallId dflags uniq fcall ty - = ASSERT( noFreeVarsOfType ty ) - -- A CCallOpId should have no free type variables; - -- when doing substitutions won't substitute over it - mkGlobalId (FCallId fcall) name ty info - where - occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) - -- The "occurrence name" of a ccall is the full info about the - -- ccall; it is encoded, but may have embedded spaces etc! - - name = mkFCallName uniq occ_str - - info = noCafIdInfo - `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setCprInfo` topCprSig - `setLevityInfoWithType` ty - - (bndrs, _) = tcSplitPiTys ty - arity = count isAnonTyCoBinder bndrs - strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv - -- the call does not claim to be strict in its arguments, since they - -- may be lifted (foreign import prim) and the called code doesn't - -- necessarily force them. See #11076. -{- -************************************************************************ -* * -\subsection{DictFuns and default methods} -* * -************************************************************************ - -Note [Dict funs and default methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dict funs and default methods are *not* ImplicitIds. Their definition -involves user-written code, so we can't figure out their strictness etc -based on fixed info, as we can for constructors and record selectors (say). - -NB: See also Note [Exported LocalIds] in Id --} - -mkDictFunId :: Name -- Name to use for the dict fun; - -> [TyVar] - -> ThetaType - -> Class - -> [Type] - -> Id --- Implements the DFun Superclass Invariant (see TcInstDcls) --- See Note [Dict funs and default methods] - -mkDictFunId dfun_name tvs theta clas tys - = mkExportedLocalId (DFunId is_nt) - dfun_name - dfun_ty - where - is_nt = isNewTyCon (classTyCon clas) - dfun_ty = mkDictFunTy tvs theta clas tys - -mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type -mkDictFunTy tvs theta clas tys - = mkSpecSigmaTy tvs theta (mkClassPred clas tys) - -{- -************************************************************************ -* * -\subsection{Un-definable} -* * -************************************************************************ - -These Ids can't be defined in Haskell. They could be defined in -unfoldings in the wired-in GHC.Prim interface file, but we'd have to -ensure that they were definitely, definitely inlined, because there is -no curried identifier for them. That's what mkCompulsoryUnfolding -does. If we had a way to get a compulsory unfolding from an interface -file, we could do that, but we don't right now. - -The type variables we use here are "open" type variables: this means -they can unify with both unlifted and lifted types. Hence we provide -another gun with which to shoot yourself in the foot. --} - -nullAddrName, seqName, - realWorldName, voidPrimIdName, coercionTokenName, - magicDictName, coerceName, proxyName :: Name -nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId -seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId -realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId -voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId -coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId -magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId -coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId -proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId - -lazyIdName, oneShotName, noinlineIdName :: Name -lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId -oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId -noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId - ------------------------------------------------- -proxyHashId :: Id -proxyHashId - = pcMiscPrelId proxyName ty - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverLevPoly` ty ) - where - -- proxy# :: forall {k} (a:k). Proxy# k a - -- - -- The visibility of the `k` binder is Inferred to match the type of the - -- Proxy data constructor (#16293). - [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id - kv_ty = mkTyVarTy kv - tv_ty = mkTyVarTy tv - ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty - ------------------------------------------------- -nullAddrId :: Id --- nullAddr# :: Addr# --- The reason it is here is because we don't provide --- a way to write this literal in Haskell. -nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) - `setNeverLevPoly` addrPrimTy - ------------------------------------------------- -seqId :: Id -- See Note [seqId magic] -seqId = pcMiscPrelId seqName ty info - where - info = noCafIdInfo `setInlinePragInfo` inline_prag - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - - inline_prag - = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter - NoSourceText 0 - -- Make 'seq' not inline-always, so that simpleOptExpr - -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the - -- LHS of rules. That way we can have rules for 'seq'; - -- see Note [seqId magic] - - -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b - ty = - mkInvForAllTy runtimeRep2TyVar - $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] - $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy) - - [x,y] = mkTemplateLocals [alphaTy, openBetaTy] - rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ - Case (Var x) x openBetaTy [(DEFAULT, [], Var y)] - ------------------------------------------------- -lazyId :: Id -- See Note [lazyId magic] -lazyId = pcMiscPrelId lazyIdName ty info - where - info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) - -noinlineId :: Id -- See Note [noinlineId magic] -noinlineId = pcMiscPrelId noinlineIdName ty info - where - info = noCafIdInfo `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) - -oneShotId :: Id -- See Note [The oneShot function] -oneShotId = pcMiscPrelId oneShotName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar ] - (mkVisFunTy fun_ty fun_ty) - fun_ty = mkVisFunTy openAlphaTy openBetaTy - [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] - x' = setOneShotLambda x -- Here is the magic bit! - rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar - , body, x'] $ - Var body `App` Var x - --------------------------------------------------------------------------------- -magicDictId :: Id -- See Note [magicDictId magic] -magicDictId = pcMiscPrelId magicDictName ty info - where - info = noCafIdInfo `setInlinePragInfo` neverInlinePragma - `setNeverLevPoly` ty - ty = mkSpecForAllTys [alphaTyVar] alphaTy - --------------------------------------------------------------------------------- - -coerceId :: Id -coerceId = pcMiscPrelId coerceName ty info - where - info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding rhs - eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] - eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] - ty = mkForAllTys [ Bndr rv Inferred - , Bndr av Specified - , Bndr bv Specified - ] $ - mkInvisFunTy eqRTy $ - mkVisFunTy a b - - bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy - (\r -> [tYPE r, tYPE r]) - - [r, a, b] = mkTyVarTys bndrs - - [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] - rhs = mkLams (bndrs ++ [eqR, x]) $ - mkWildCase (Var eqR) eqRTy b $ - [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] - -{- -Note [seqId magic] -~~~~~~~~~~~~~~~~~~ -'GHC.Prim.seq' is special in several ways. - -a) Its fixity is set in GHC.Iface.Load.ghcPrimIface - -b) It has quite a bit of desugaring magic. - See GHC.HsToCore.Utils.hs Note [Desugaring seq (1)] and (2) and (3) - -c) There is some special rule handing: Note [User-defined RULES for seq] - -Historical note: - In TcExpr we used to need a special typing rule for 'seq', to handle calls - whose second argument had an unboxed type, e.g. x `seq` 3# - - However, with levity polymorphism we can now give seq the type seq :: - forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this - case without special treatment in the typechecker. - -Note [User-defined RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Roman found situations where he had - case (f n) of _ -> e -where he knew that f (which was strict in n) would terminate if n did. -Notice that the result of (f n) is discarded. So it makes sense to -transform to - case n of _ -> e - -Rather than attempt some general analysis to support this, I've added -enough support that you can do this using a rewrite rule: - - RULE "f/seq" forall n. seq (f n) = seq n - -You write that rule. When GHC sees a case expression that discards -its result, it mentally transforms it to a call to 'seq' and looks for -a RULE. (This is done in GHC.Core.Op.Simplify.trySeqRules.) As usual, the -correctness of the rule is up to you. - -VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. -If we wrote - RULE "f/seq" forall n e. seq (f n) e = seq n e -with rule arity 2, then two bad things would happen: - - - The magical desugaring done in Note [seqId magic] item (b) - for saturated application of 'seq' would turn the LHS into - a case expression! - - - The code in GHC.Core.Op.Simplify.rebuildCase would need to actually supply - the value argument, which turns out to be awkward. - -See also: Note [User-defined RULES for seq] in GHC.Core.Op.Simplify. - - -Note [lazyId magic] -~~~~~~~~~~~~~~~~~~~ -lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) - -'lazy' is used to make sure that a sub-expression, and its free variables, -are truly used call-by-need, with no code motion. Key examples: - -* pseq: pseq a b = a `seq` lazy b - We want to make sure that the free vars of 'b' are not evaluated - before 'a', even though the expression is plainly strict in 'b'. - -* catch: catch a b = catch# (lazy a) b - Again, it's clear that 'a' will be evaluated strictly (and indeed - applied to a state token) but we want to make sure that any exceptions - arising from the evaluation of 'a' are caught by the catch (see - #11555). - -Implementing 'lazy' is a bit tricky: - -* It must not have a strictness signature: by being a built-in Id, - all the info about lazyId comes from here, not from GHC.Base.hi. - This is important, because the strictness analyser will spot it as - strict! - -* It must not have an unfolding: it gets "inlined" by a HACK in - CorePrep. It's very important to do this inlining *after* unfoldings - are exposed in the interface file. Otherwise, the unfolding for - (say) pseq in the interface file will not mention 'lazy', so if we - inline 'pseq' we'll totally miss the very thing that 'lazy' was - there for in the first place. See #3259 for a real world - example. - -* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must - avoid using call by value here: - case e of r -> catch# r b - Avoiding that is the whole point of 'lazy'. So in CorePrep (which - generate the 'case' expression for a call-by-value call) we must - spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' - instead. - -* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it - appears un-applied, we'll end up just calling it. - -Note [noinlineId magic] -~~~~~~~~~~~~~~~~~~~~~~~ -noinline :: forall a. a -> a - -'noinline' is used to make sure that a function f is never inlined, -e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE -could be used to achieve this effect; however, this has the unfortunate -result of leaving a (useless) call to noinline at runtime. So we have -a little bit of magic to optimize away 'noinline' after we are done -running the simplifier. - -'noinline' needs to be wired-in because it gets inserted automatically -when we serialize an expression to the interface format. See -Note [Inlining and hs-boot files] in GHC.CoreToIface - -Note that noinline as currently implemented can hide some simplifications since -it hides strictness from the demand analyser. Specifically, the demand analyser -will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f' -specifies that it is strict in its argument. We considered fixing this this by adding a -special case to the demand analyser to address #16588. However, the special -case seemed like a large and expensive hammer to address a rare case and -consequently we rather opted to use a more minimal solution. - -Note [The oneShot function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the context of making left-folds fuse somewhat okish (see ticket #7994 -and Note [Left folds via right fold]) it was determined that it would be useful -if library authors could explicitly tell the compiler that a certain lambda is -called at most once. The oneShot function allows that. - -'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted -types as well (#10744); e.g. - oneShot (\x:Int# -> x +# 1#) - -Like most magic functions it has a compulsory unfolding, so there is no need -for a real definition somewhere. We have one in GHC.Magic for the convenience -of putting the documentation there. - -It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: - -A typical call looks like - oneShot (\y. e) -after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get - (\f \x[oneshot]. f x) (\y. e) - --> \x[oneshot]. ((\y.e) x) - --> \x[oneshot] e[x/y] -which is what we want. - -It is only effective if the one-shot info survives as long as possible; in -particular it must make it into the interface in unfoldings. See Note [Preserve -OneShotInfo] in GHC.Core.Op.Tidy. - -Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. - - -Note [magicDictId magic] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The identifier `magicDict` is just a place-holder, which is used to -implement a primitive that we cannot define in Haskell but we can write -in Core. It is declared with a place-holder type: - - magicDict :: forall a. a - -The intention is that the identifier will be used in a very specific way, -to create dictionaries for classes with a single method. Consider a class -like this: - - class C a where - f :: T a - -We are going to use `magicDict`, in conjunction with a built-in Prelude -rule, to cast values of type `T a` into dictionaries for `C a`. To do -this, we define a function like this in the library: - - data WrapC a b = WrapC (C a => Proxy a -> b) - - withT :: (C a => Proxy a -> b) - -> T a -> Proxy a -> b - withT f x y = magicDict (WrapC f) x y - -The purpose of `WrapC` is to avoid having `f` instantiated. -Also, it avoids impredicativity, because `magicDict`'s type -cannot be instantiated with a forall. The field of `WrapC` contains -a `Proxy` parameter which is used to link the type of the constraint, -`C a`, with the type of the `Wrap` value being made. - -Next, we add a built-in Prelude rule (see GHC.Core.Op.ConstantFold), -which will replace the RHS of this definition with the appropriate -definition in Core. The rewrite rule works as follows: - - magicDict @t (wrap @a @b f) x y -----> - f (x `cast` co a) y - -The `co` coercion is the newtype-coercion extracted from the type-class. -The type class is obtain by looking at the type of wrap. - - -------------------------------------------------------------- -@realWorld#@ used to be a magic literal, \tr{void#}. If things get -nasty as-is, change it back to a literal (@Literal@). - -voidArgId is a Local Id used simply as an argument in functions -where we just want an arg to avoid having a thunk of unlifted type. -E.g. - x = \ void :: Void# -> (# p, q #) - -This comes up in strictness analysis - -Note [evaldUnfoldings] -~~~~~~~~~~~~~~~~~~~~~~ -The evaldUnfolding makes it look that some primitive value is -evaluated, which in turn makes Simplify.interestingArg return True, -which in turn makes INLINE things applied to said value likely to be -inlined. --} - -realWorldPrimId :: Id -- :: State# RealWorld -realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setOneShotInfo` stateHackOneShot - `setNeverLevPoly` realWorldStatePrimTy) - -voidPrimId :: Id -- Global constant :: Void# -voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverLevPoly` voidPrimTy) - -voidArgId :: Id -- Local lambda-bound :: Void# -voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy - -coercionTokenId :: Id -- :: () ~ () -coercionTokenId -- See Note [Coercion tokens] in CoreToStg.hs - = pcMiscPrelId coercionTokenName - (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) - noCafIdInfo - -pcMiscPrelId :: Name -> Type -> IdInfo -> Id -pcMiscPrelId name ty info - = mkVanillaGlobalWithInfo name ty info - -- We lie and say the thing is imported; otherwise, we get into - -- a mess with dependency analysis; e.g., core2stg may heave in - -- random calls to GHCbase.unpackPS__. If GHCbase is the module - -- being compiled, then it's just a matter of luck if the definition - -- will be in "the right place" to be in scope. diff --git a/compiler/basicTypes/MkId.hs-boot b/compiler/basicTypes/MkId.hs-boot deleted file mode 100644 index 46695c5b74..0000000000 --- a/compiler/basicTypes/MkId.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ -module MkId where -import Name( Name ) -import Var( Id ) -import GHC.Core.Class( Class ) -import {-# SOURCE #-} GHC.Core.DataCon( DataCon ) -import {-# SOURCE #-} PrimOp( PrimOp ) - -data DataConBoxer - -mkDataConWorkId :: Name -> DataCon -> Id -mkDictSelId :: Name -> Class -> Id - -mkPrimOpId :: PrimOp -> Id - -magicDictId :: Id diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs deleted file mode 100644 index 95031f50cd..0000000000 --- a/compiler/basicTypes/Module.hs +++ /dev/null @@ -1,1303 +0,0 @@ -{- -(c) The University of Glasgow, 2004-2006 - - -Module -~~~~~~~~~~ -Simply the name of a module, represented as a FastString. -These are Uniquable, hence we can build Maps with Modules as -the keys. --} - -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Module - ( - -- * The ModuleName type - ModuleName, - pprModuleName, - moduleNameFS, - moduleNameString, - moduleNameSlashes, moduleNameColons, - moduleStableString, - moduleFreeHoles, - moduleIsDefinite, - mkModuleName, - mkModuleNameFS, - stableModuleNameCmp, - - -- * The UnitId type - ComponentId(..), - UnitId(..), - unitIdFS, - unitIdKey, - IndefUnitId(..), - IndefModule(..), - indefUnitIdToUnitId, - indefModuleToModule, - InstalledUnitId(..), - toInstalledUnitId, - ShHoleSubst, - - unitIdIsDefinite, - unitIdString, - unitIdFreeHoles, - - newUnitId, - newIndefUnitId, - newSimpleUnitId, - hashUnitId, - fsToUnitId, - stringToUnitId, - stableUnitIdCmp, - - -- * HOLE renaming - renameHoleUnitId, - renameHoleModule, - renameHoleUnitId', - renameHoleModule', - - -- * Generalization - splitModuleInsts, - splitUnitIdInsts, - generalizeIndefUnitId, - generalizeIndefModule, - - -- * Parsers - parseModuleName, - parseUnitId, - parseComponentId, - parseModuleId, - parseModSubst, - - -- * Wired-in UnitIds - -- $wired_in_packages - primUnitId, - integerUnitId, - baseUnitId, - rtsUnitId, - thUnitId, - mainUnitId, - thisGhcUnitId, - isHoleModule, - interactiveUnitId, isInteractiveModule, - wiredInUnitIds, - - -- * The Module type - Module(Module), - moduleUnitId, moduleName, - pprModule, - mkModule, - mkHoleModule, - stableModuleCmp, - HasModule(..), - ContainsModule(..), - - -- * Installed unit ids and modules - InstalledModule(..), - InstalledModuleEnv, - installedModuleEq, - installedUnitIdEq, - installedUnitIdString, - fsToInstalledUnitId, - componentIdToInstalledUnitId, - stringToInstalledUnitId, - emptyInstalledModuleEnv, - lookupInstalledModuleEnv, - extendInstalledModuleEnv, - filterInstalledModuleEnv, - delInstalledModuleEnv, - DefUnitId(..), - - -- * The ModuleLocation type - ModLocation(..), - addBootSuffix, addBootSuffix_maybe, - addBootSuffixLocn, addBootSuffixLocnOut, - - -- * Module mappings - ModuleEnv, - elemModuleEnv, extendModuleEnv, extendModuleEnvList, - extendModuleEnvList_C, plusModuleEnv_C, - delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, - lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, - moduleEnvKeys, moduleEnvElts, moduleEnvToList, - unitModuleEnv, isEmptyModuleEnv, - extendModuleEnvWith, filterModuleEnv, - - -- * ModuleName mappings - ModuleNameEnv, DModuleNameEnv, - - -- * Sets of Modules - ModuleSet, - emptyModuleSet, mkModuleSet, moduleSetElts, - extendModuleSet, extendModuleSetList, delModuleSet, - elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet, - unitModuleSet - ) where - -import GhcPrelude - -import Outputable -import Unique -import UniqFM -import UniqDFM -import UniqDSet -import FastString -import Binary -import Util -import Data.List (sortBy, sort) -import Data.Ord -import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) -import Fingerprint - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS.Char8 -import Encoding - -import qualified Text.ParserCombinators.ReadP as Parse -import Text.ParserCombinators.ReadP (ReadP, (<++)) -import Data.Char (isAlphaNum) -import Control.DeepSeq -import Data.Coerce -import Data.Data -import Data.Function -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 System.FilePath - -import {-# SOURCE #-} GHC.Driver.Session (DynFlags) -import {-# SOURCE #-} GHC.Driver.Packages (componentIdString, improveUnitId, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId) - --- Note [The identifier lexicon] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Unit IDs, installed package IDs, ABI hashes, package names, --- versions, there are a *lot* of different identifiers for closely --- related things. What do they all mean? Here's what. (See also --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts ) --- --- THE IMPORTANT ONES --- --- ComponentId: An opaque identifier provided by Cabal, which should --- uniquely identify such things as the package name, the package --- version, the name of the component, the hash of the source code --- tarball, the selected Cabal flags, GHC flags, direct dependencies of --- the component. These are very similar to InstalledPackageId, but --- an 'InstalledPackageId' implies that it identifies a package, while --- a package may install multiple components with different --- 'ComponentId's. --- - Same as Distribution.Package.ComponentId --- --- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names --- (ModuleName) to Modules. This is how the compiler identifies instantiated --- components, and also is the main identifier by which GHC identifies things. --- - When Backpack is not being used, UnitId = ComponentId. --- this means a useful fiction for end-users is that there are --- only ever ComponentIds, and some ComponentIds happen to have --- more information (UnitIds). --- - Same as Language.Haskell.TH.Syntax:PkgName, see --- https://gitlab.haskell.org/ghc/ghc/issues/10279 --- - The same as PackageKey in GHC 7.10 (we renamed it because --- they don't necessarily identify packages anymore.) --- - Same as -this-package-key/-package-name flags --- - An InstalledUnitId corresponds to an actual package which --- we have installed on disk. It could be definite or indefinite, --- but if it's indefinite, it has nothing instantiated (we --- never install partially instantiated units.) --- --- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how --- the compiler identifies modules (e.g. a Name is a Module + OccName) --- - Same as Language.Haskell.TH.Syntax:Module --- --- THE LESS IMPORTANT ONES --- --- PackageName: The "name" field in a Cabal file, something like "lens". --- - Same as Distribution.Package.PackageName --- - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see --- https://gitlab.haskell.org/ghc/ghc/issues/10279 --- - DIFFERENT FROM -package-name flag --- - DIFFERENT FROM the 'name' field in an installed package --- information. This field could more accurately be described --- as a munged package name: when it's for the main library --- it is the same as the package name, but if it's an internal --- library it's a munged combination of the package name and --- the component name. --- --- LEGACY ONES --- --- InstalledPackageId: This is what we used to call ComponentId. --- It's a still pretty useful concept for packages that have only --- one library; in that case the logical InstalledPackageId = --- ComponentId. Also, the Cabal nix-local-build continues to --- compute an InstalledPackageId which is then forcibly used --- for all components in a package. This means that if a dependency --- from one component in a package changes, the InstalledPackageId --- changes: you don't get as fine-grained dependency tracking, --- but it means your builds are hermetic. Eventually, Cabal will --- deal completely in components and we can get rid of this. --- --- PackageKey: This is what we used to call UnitId. We ditched --- "Package" from the name when we realized that you might want to --- assign different "PackageKeys" to components from the same package. --- (For a brief, non-released period of time, we also called these --- UnitKeys). - -{- -************************************************************************ -* * -\subsection{Module locations} -* * -************************************************************************ --} - --- | Module Location --- --- Where a module lives on the file system: the actual locations --- of the .hs, .hi and .o files, if we have them -data ModLocation - = ModLocation { - ml_hs_file :: Maybe FilePath, - -- The source file, if we have one. Package modules - -- probably don't have source files. - - ml_hi_file :: FilePath, - -- Where the .hi file is, whether or not it exists - -- yet. Always of form foo.hi, even if there is an - -- hi-boot file (we add the -boot suffix later) - - ml_obj_file :: FilePath, - -- Where the .o file is, whether or not it exists yet. - -- (might not exist either because the module hasn't - -- been compiled yet, or because it is part of a - -- package with a .a file) - ml_hie_file :: FilePath - } deriving Show - -instance Outputable ModLocation where - ppr = text . show - -{- -For a module in another package, the hs_file and obj_file -components of ModLocation are undefined. - -The locations specified by a ModLocation may or may not -correspond to actual files yet: for example, even if the object -file doesn't exist, the ModLocation still contains the path to -where the object file will reside if/when it is created. --} - -addBootSuffix :: FilePath -> FilePath --- ^ Add the @-boot@ suffix to .hs, .hi and .o files -addBootSuffix path = path ++ "-boot" - -addBootSuffix_maybe :: Bool -> FilePath -> FilePath --- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ -addBootSuffix_maybe is_boot path - | is_boot = addBootSuffix path - | otherwise = path - -addBootSuffixLocn :: ModLocation -> ModLocation --- ^ Add the @-boot@ suffix to all file paths associated with the module -addBootSuffixLocn locn - = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) - , ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) - , ml_hie_file = addBootSuffix (ml_hie_file locn) } - -addBootSuffixLocnOut :: ModLocation -> ModLocation --- ^ Add the @-boot@ suffix to all output file paths associated with the --- module, not including the input file itself -addBootSuffixLocnOut locn - = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) - , ml_hie_file = addBootSuffix (ml_hie_file locn) } - -{- -************************************************************************ -* * -\subsection{The name of a module} -* * -************************************************************************ --} - --- | A ModuleName is essentially a simple string, e.g. @Data.List@. -newtype ModuleName = ModuleName FastString - -instance Uniquable ModuleName where - getUnique (ModuleName nm) = getUnique nm - -instance Eq ModuleName where - nm1 == nm2 = getUnique nm1 == getUnique nm2 - -instance Ord ModuleName where - nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 - -instance Outputable ModuleName where - ppr = pprModuleName - -instance Binary ModuleName where - put_ bh (ModuleName fs) = put_ bh fs - get bh = do fs <- get bh; return (ModuleName fs) - -instance BinaryStringRep ModuleName where - fromStringRep = mkModuleNameFS . mkFastStringByteString - toStringRep = bytesFS . moduleNameFS - -instance Data ModuleName where - -- don't traverse? - toConstr _ = abstractConstr "ModuleName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "ModuleName" - -instance NFData ModuleName where - rnf x = x `seq` () - -stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering --- ^ Compares module names lexically, rather than by their 'Unique's -stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 - -pprModuleName :: ModuleName -> SDoc -pprModuleName (ModuleName nm) = - getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS nm) - else ftext nm - -moduleNameFS :: ModuleName -> FastString -moduleNameFS (ModuleName mod) = mod - -moduleNameString :: ModuleName -> String -moduleNameString (ModuleName mod) = unpackFS mod - --- | Get a string representation of a 'Module' that's unique and stable --- across recompilations. --- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" -moduleStableString :: Module -> String -moduleStableString Module{..} = - "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName - -mkModuleName :: String -> ModuleName -mkModuleName s = ModuleName (mkFastString s) - -mkModuleNameFS :: FastString -> ModuleName -mkModuleNameFS s = ModuleName s - --- |Returns the string version of the module name, with dots replaced by slashes. --- -moduleNameSlashes :: ModuleName -> String -moduleNameSlashes = dots_to_slashes . moduleNameString - where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) - --- |Returns the string version of the module name, with dots replaced by colons. --- -moduleNameColons :: ModuleName -> String -moduleNameColons = dots_to_colons . moduleNameString - where dots_to_colons = map (\c -> if c == '.' then ':' else c) - -{- -************************************************************************ -* * -\subsection{A fully qualified module} -* * -************************************************************************ --} - --- | A Module is a pair of a 'UnitId' and a 'ModuleName'. --- --- Module variables (i.e. @@) which can be instantiated to a --- specific module at some later point in time are represented --- with 'moduleUnitId' set to 'holeUnitId' (this allows us to --- avoid having to make 'moduleUnitId' a partial operation.) --- -data Module = Module { - moduleUnitId :: !UnitId, -- pkg-1.0 - moduleName :: !ModuleName -- A.B.C - } - deriving (Eq, Ord) - --- | Calculate the free holes of a 'Module'. If this set is non-empty, --- this module was defined in an indefinite library that had required --- signatures. --- --- If a module has free holes, that means that substitutions can operate on it; --- if it has no free holes, substituting over a module has no effect. -moduleFreeHoles :: Module -> UniqDSet ModuleName -moduleFreeHoles m - | isHoleModule m = unitUniqDSet (moduleName m) - | otherwise = unitIdFreeHoles (moduleUnitId m) - --- | A 'Module' is definite if it has no free holes. -moduleIsDefinite :: Module -> Bool -moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles - --- | Create a module variable at some 'ModuleName'. --- See Note [Representation of module/name variables] -mkHoleModule :: ModuleName -> Module -mkHoleModule = mkModule holeUnitId - -instance Uniquable Module where - getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) - -instance Outputable Module where - ppr = pprModule - -instance Binary Module where - put_ bh (Module p n) = put_ bh p >> put_ bh n - get bh = do p <- get bh; n <- get bh; return (Module p n) - -instance Data Module where - -- don't traverse? - toConstr _ = abstractConstr "Module" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Module" - -instance NFData Module where - rnf x = x `seq` () - --- | This gives a stable ordering, as opposed to the Ord instance which --- gives an ordering based on the 'Unique's of the components, which may --- not be stable from run to run of the compiler. -stableModuleCmp :: Module -> Module -> Ordering -stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stableUnitIdCmp` p2) `thenCmp` - (n1 `stableModuleNameCmp` n2) - -mkModule :: UnitId -> ModuleName -> Module -mkModule = Module - -pprModule :: Module -> SDoc -pprModule mod@(Module p n) = getPprStyle doc - where - doc sty - | codeStyle sty = - (if p == mainUnitId - then empty -- never qualify the main package in code - else ztext (zEncodeFS (unitIdFS p)) <> char '_') - <> pprModuleName n - | qualModule sty mod = - if isHoleModule mod - then angleBrackets (pprModuleName n) - else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n - | otherwise = - pprModuleName n - -class ContainsModule t where - extractModule :: t -> Module - -class HasModule m where - getModule :: m Module - -instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where - fromDbModule (DbModule uid mod_name) = mkModule uid mod_name - fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name - fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts - fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid) - -- GHC never writes to the database, so it's not needed - toDbModule = error "toDbModule: not implemented" - toDbUnitId = error "toDbUnitId: not implemented" - -{- -************************************************************************ -* * -\subsection{ComponentId} -* * -************************************************************************ --} - --- | A 'ComponentId' consists of the package name, package version, component --- ID, the transitive dependencies of the component, and other information to --- uniquely identify the source code and build configuration of a component. --- --- This used to be known as an 'InstalledPackageId', but a package can contain --- multiple components and a 'ComponentId' uniquely identifies a component --- within a package. When a package only has one component, the 'ComponentId' --- coincides with the 'InstalledPackageId' -newtype ComponentId = ComponentId FastString deriving (Eq, Ord) - -instance BinaryStringRep ComponentId where - fromStringRep = ComponentId . mkFastStringByteString - toStringRep (ComponentId s) = bytesFS s - -instance Uniquable ComponentId where - getUnique (ComponentId n) = getUnique n - -instance Outputable ComponentId where - ppr cid@(ComponentId fs) = - getPprStyle $ \sty -> - sdocWithDynFlags $ \dflags -> - case componentIdString dflags cid of - Just str | not (debugStyle sty) -> text str - _ -> ftext fs - -{- -************************************************************************ -* * -\subsection{UnitId} -* * -************************************************************************ --} - --- | A unit identifier identifies a (possibly partially) instantiated --- library. It is primarily used as part of 'Module', which in turn --- is used in 'Name', which is used to give names to entities when --- typechecking. --- --- There are two possible forms for a 'UnitId'. It can be a --- 'DefiniteUnitId', in which case we just have a string that uniquely --- identifies some fully compiled, installed library we have on disk. --- However, when we are typechecking a library with missing holes, --- we may need to instantiate a library on the fly (in which case --- we don't have any on-disk representation.) In that case, you --- have an 'IndefiniteUnitId', which explicitly records the --- instantiation, so that we can substitute over it. -data UnitId - = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId - | DefiniteUnitId {-# UNPACK #-} !DefUnitId - -unitIdFS :: UnitId -> FastString -unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x -unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x - -unitIdKey :: UnitId -> Unique -unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x -unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x - --- | A unit identifier which identifies an indefinite --- library (with holes) that has been *on-the-fly* instantiated --- with a substitution 'indefUnitIdInsts'. In fact, an indefinite --- unit identifier could have no holes, but we haven't gotten --- around to compiling the actual library yet. --- --- An indefinite unit identifier pretty-prints to something like --- @p[H=,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the --- brackets enclose the module substitution). -data IndefUnitId - = IndefUnitId { - -- | A private, uniquely identifying representation of - -- a UnitId. This string is completely private to GHC - -- and is just used to get a unique; in particular, we don't use it for - -- symbols (indefinite libraries are not compiled). - indefUnitIdFS :: FastString, - -- | Cached unique of 'unitIdFS'. - indefUnitIdKey :: Unique, - -- | The component identity of the indefinite library that - -- is being instantiated. - indefUnitIdComponentId :: !ComponentId, - -- | The sorted (by 'ModuleName') instantiations of this library. - indefUnitIdInsts :: ![(ModuleName, Module)], - -- | A cache of the free module variables of 'unitIdInsts'. - -- This lets us efficiently tell if a 'UnitId' has been - -- fully instantiated (free module variables are empty) - -- and whether or not a substitution can have any effect. - indefUnitIdFreeHoles :: UniqDSet ModuleName - } - -instance Eq IndefUnitId where - u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 - -instance Ord IndefUnitId where - u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 - -instance Binary IndefUnitId where - put_ bh indef = do - put_ bh (indefUnitIdComponentId indef) - put_ bh (indefUnitIdInsts indef) - get bh = do - cid <- get bh - insts <- get bh - let fs = hashUnitId cid insts - return IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs - } - --- | Create a new 'IndefUnitId' given an explicit module substitution. -newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId -newIndefUnitId cid insts = - IndefUnitId { - indefUnitIdComponentId = cid, - indefUnitIdInsts = sorted_insts, - indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - indefUnitIdFS = fs, - indefUnitIdKey = getUnique fs - } - where - fs = hashUnitId cid sorted_insts - sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts - --- | Injects an 'IndefUnitId' (indefinite library which --- was on-the-fly instantiated) to a 'UnitId' (either --- an indefinite or definite library). -indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId -indefUnitIdToUnitId dflags iuid = - -- NB: suppose that we want to compare the indefinite - -- unit id p[H=impl:H] against p+abcd (where p+abcd - -- happens to be the existing, installed version of - -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] - -- IndefiniteUnitId, they won't compare equal; only - -- after improvement will the equality hold. - improveUnitId (getUnitInfoMap dflags) $ - IndefiniteUnitId iuid - -data IndefModule = IndefModule { - indefModuleUnitId :: IndefUnitId, - indefModuleName :: ModuleName - } deriving (Eq, Ord) - -instance Outputable IndefModule where - ppr (IndefModule uid m) = - ppr uid <> char ':' <> ppr m - --- | Injects an 'IndefModule' to 'Module' (see also --- 'indefUnitIdToUnitId'. -indefModuleToModule :: DynFlags -> IndefModule -> Module -indefModuleToModule dflags (IndefModule iuid mod_name) = - mkModule (indefUnitIdToUnitId dflags iuid) mod_name - --- | An installed unit identifier identifies a library which has --- been installed to the package database. These strings are --- provided to us via the @-this-unit-id@ flag. The library --- in question may be definite or indefinite; if it is indefinite, --- none of the holes have been filled (we never install partially --- instantiated libraries.) Put another way, an installed unit id --- is either fully instantiated, or not instantiated at all. --- --- Installed unit identifiers look something like @p+af23SAj2dZ219@, --- or maybe just @p@ if they don't use Backpack. -newtype InstalledUnitId = - InstalledUnitId { - -- | The full hashed unit identifier, including the component id - -- and the hash. - installedUnitIdFS :: FastString - } - -instance Binary InstalledUnitId where - put_ bh (InstalledUnitId fs) = put_ bh fs - get bh = do fs <- get bh; return (InstalledUnitId fs) - -instance BinaryStringRep InstalledUnitId where - fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) - -- GHC doesn't write to database - toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" - -instance Eq InstalledUnitId where - uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 - -instance Ord InstalledUnitId where - u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 - -instance Uniquable InstalledUnitId where - getUnique = installedUnitIdKey - -instance Outputable InstalledUnitId where - ppr uid@(InstalledUnitId fs) = - getPprStyle $ \sty -> - sdocWithDynFlags $ \dflags -> - case displayInstalledUnitId dflags uid of - Just str | not (debugStyle sty) -> text str - _ -> ftext fs - -installedUnitIdKey :: InstalledUnitId -> Unique -installedUnitIdKey = getUnique . installedUnitIdFS - --- | Lossy conversion to the on-disk 'InstalledUnitId' for a component. -toInstalledUnitId :: UnitId -> InstalledUnitId -toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid -toInstalledUnitId (IndefiniteUnitId indef) = - componentIdToInstalledUnitId (indefUnitIdComponentId indef) - -installedUnitIdString :: InstalledUnitId -> String -installedUnitIdString = unpackFS . installedUnitIdFS - -instance Outputable IndefUnitId where - ppr uid = - -- getPprStyle $ \sty -> - ppr cid <> - (if not (null insts) -- pprIf - then - brackets (hcat - (punctuate comma $ - [ ppr modname <> text "=" <> ppr m - | (modname, m) <- insts])) - else empty) - where - cid = indefUnitIdComponentId uid - insts = indefUnitIdInsts uid - --- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. -data InstalledModule = InstalledModule { - installedModuleUnitId :: !InstalledUnitId, - installedModuleName :: !ModuleName - } - deriving (Eq, Ord) - -instance Outputable InstalledModule where - ppr (InstalledModule p n) = - ppr p <> char ':' <> pprModuleName n - -fsToInstalledUnitId :: FastString -> InstalledUnitId -fsToInstalledUnitId fs = InstalledUnitId fs - -componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId -componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs - -stringToInstalledUnitId :: String -> InstalledUnitId -stringToInstalledUnitId = fsToInstalledUnitId . mkFastString - --- | Test if a 'Module' corresponds to a given 'InstalledModule', --- modulo instantiation. -installedModuleEq :: InstalledModule -> Module -> Bool -installedModuleEq imod mod = - fst (splitModuleInsts mod) == imod - --- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', --- modulo instantiation. -installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool -installedUnitIdEq iuid uid = - fst (splitUnitIdInsts uid) == iuid - --- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that --- it only refers to a definite library; i.e., one we have generated --- code for. -newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } - deriving (Eq, Ord) - -instance Outputable DefUnitId where - ppr (DefUnitId uid) = ppr uid - -instance Binary DefUnitId where - put_ bh (DefUnitId uid) = put_ bh uid - get bh = do uid <- get bh; return (DefUnitId uid) - --- | A map keyed off of 'InstalledModule' -newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) - -emptyInstalledModuleEnv :: InstalledModuleEnv a -emptyInstalledModuleEnv = InstalledModuleEnv Map.empty - -lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a -lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e - -extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a -extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) - -filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a -filterInstalledModuleEnv f (InstalledModuleEnv e) = - InstalledModuleEnv (Map.filterWithKey f e) - -delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a -delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) - --- Note [UnitId to InstalledUnitId improvement] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Just because a UnitId is definite (has no holes) doesn't --- mean it's necessarily a InstalledUnitId; it could just be --- that over the course of renaming UnitIds on the fly --- while typechecking an indefinite library, we --- ended up with a fully instantiated unit id with no hash, --- since we haven't built it yet. This is fine. --- --- However, if there is a hashed unit id for this instantiation --- in the package database, we *better use it*, because --- that hashed unit id may be lurking in another interface, --- and chaos will ensue if we attempt to compare the two --- (the unitIdFS for a UnitId never corresponds to a Cabal-provided --- hash of a compiled instantiated library). --- --- There is one last niggle: improvement based on the package database means --- that we might end up developing on a package that is not transitively --- depended upon by the packages the user specified directly via command line --- flags. This could lead to strange and difficult to understand bugs if those --- instantiations are out of date. The solution is to only improve a --- unit id if the new unit id is part of the 'preloadClosure'; i.e., the --- closure of all the packages which were explicitly specified. - --- | Retrieve the set of free holes of a 'UnitId'. -unitIdFreeHoles :: UnitId -> UniqDSet ModuleName -unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x --- Hashed unit ids are always fully instantiated -unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet - -instance Show UnitId where - show = unitIdString - --- | A 'UnitId' is definite if it has no free holes. -unitIdIsDefinite :: UnitId -> Bool -unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles - --- | Generate a uniquely identifying 'FastString' for a unit --- identifier. This is a one-way function. You can rely on one special --- property: if a unit identifier is in most general form, its 'FastString' --- coincides with its 'ComponentId'. This hash is completely internal --- to GHC and is not used for symbol names or file paths. -hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString -hashUnitId cid sorted_holes = - mkFastStringByteString - . fingerprintUnitId (toStringRep cid) - $ rawHashUnitId sorted_holes - --- | Generate a hash for a sorted module substitution. -rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint -rawHashUnitId sorted_holes = - fingerprintByteString - . BS.concat $ do - (m, b) <- sorted_holes - [ toStringRep m, BS.Char8.singleton ' ', - bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', - toStringRep (moduleName b), BS.Char8.singleton '\n'] - -fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString -fingerprintUnitId prefix (Fingerprint a b) - = BS.concat - $ [ prefix - , BS.Char8.singleton '-' - , BS.Char8.pack (toBase62Padded a) - , BS.Char8.pack (toBase62Padded b) ] - --- | Create a new, un-hashed unit identifier. -newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId -newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... -newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts - -pprUnitId :: UnitId -> SDoc -pprUnitId (DefiniteUnitId uid) = ppr uid -pprUnitId (IndefiniteUnitId uid) = ppr uid - -instance Eq UnitId where - uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 - -instance Uniquable UnitId where - getUnique = unitIdKey - -instance Ord UnitId where - nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 - -instance Data UnitId where - -- don't traverse? - toConstr _ = abstractConstr "UnitId" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "UnitId" - -instance NFData UnitId where - rnf x = x `seq` () - -stableUnitIdCmp :: UnitId -> UnitId -> Ordering --- ^ Compares package ids lexically, rather than by their 'Unique's -stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 - -instance Outputable UnitId where - ppr pk = pprUnitId pk - --- Performance: would prefer to have a NameCache like thing -instance Binary UnitId where - put_ bh (DefiniteUnitId def_uid) = do - putByte bh 0 - put_ bh def_uid - put_ bh (IndefiniteUnitId indef_uid) = do - putByte bh 1 - put_ bh indef_uid - get bh = do b <- getByte bh - case b of - 0 -> fmap DefiniteUnitId (get bh) - _ -> fmap IndefiniteUnitId (get bh) - -instance Binary ComponentId where - put_ bh (ComponentId fs) = put_ bh fs - get bh = do { fs <- get bh; return (ComponentId fs) } - --- | Create a new simple unit identifier (no holes) from a 'ComponentId'. -newSimpleUnitId :: ComponentId -> UnitId -newSimpleUnitId (ComponentId fs) = fsToUnitId fs - --- | Create a new simple unit identifier from a 'FastString'. Internally, --- this is primarily used to specify wired-in unit identifiers. -fsToUnitId :: FastString -> UnitId -fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId - -stringToUnitId :: String -> UnitId -stringToUnitId = fsToUnitId . mkFastString - -unitIdString :: UnitId -> String -unitIdString = unpackFS . unitIdFS - -{- -************************************************************************ -* * - Hole substitutions -* * -************************************************************************ --} - --- | Substitution on module variables, mapping module names to module --- identifiers. -type ShHoleSubst = ModuleNameEnv Module - --- | Substitutes holes in a 'Module'. NOT suitable for being called --- directly on a 'nameModule', see Note [Representation of module/name variable]. --- @p[A=]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; --- similarly, @@ maps to @q():A@. -renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module -renameHoleModule dflags = renameHoleModule' (getUnitInfoMap dflags) - --- | Substitutes holes in a 'UnitId', suitable for renaming when --- an include occurs; see Note [Representation of module/name variable]. --- --- @p[A=]@ maps to @p[A=]@ with @A=@. -renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId dflags = renameHoleUnitId' (getUnitInfoMap dflags) - --- | Like 'renameHoleModule', but requires only 'UnitInfoMap' --- so it can be used by "Packages". -renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map env m - | not (isHoleModule m) = - let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) - in mkModule uid (moduleName m) - | Just m' <- lookupUFM env (moduleName m) = m' - -- NB m = , that's what's in scope. - | otherwise = m - --- | Like 'renameHoleUnitId, but requires only 'UnitInfoMap' --- so it can be used by "Packages". -renameHoleUnitId' :: UnitInfoMap -> ShHoleSubst -> UnitId -> UnitId -renameHoleUnitId' pkg_map env uid = - case uid of - (IndefiniteUnitId - IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts - , indefUnitIdFreeHoles = fh }) - -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) - then uid - -- Functorially apply the substitution to the instantiation, - -- then check the 'UnitInfoMap' to see if there is - -- a compiled version of this 'UnitId' we can improve to. - -- See Note [UnitId to InstalledUnitId] improvement - else improveUnitId pkg_map $ - newUnitId cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) - _ -> uid - --- | Given a possibly on-the-fly instantiated module, split it into --- a 'Module' that we definitely can find on-disk, as well as an --- instantiation if we need to instantiate it on the fly. If the --- instantiation is @Nothing@ no on-the-fly renaming is needed. -splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule) -splitModuleInsts m = - let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m) - in (InstalledModule uid (moduleName m), - fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid) - --- | See 'splitModuleInsts'. -splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId) -splitUnitIdInsts (IndefiniteUnitId iuid) = - (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid) -splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) - -generalizeIndefUnitId :: IndefUnitId -> IndefUnitId -generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid - , indefUnitIdInsts = insts } = - newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) - -generalizeIndefModule :: IndefModule -> IndefModule -generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n - -parseModuleName :: ReadP ModuleName -parseModuleName = fmap mkModuleName - $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") - -parseUnitId :: ReadP UnitId -parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId - where - parseFullUnitId = do - cid <- parseComponentId - insts <- parseModSubst - return (newUnitId cid insts) - parseDefiniteUnitId = do - s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") - return (stringToUnitId s) - parseSimpleUnitId = do - cid <- parseComponentId - return (newSimpleUnitId cid) - -parseComponentId :: ReadP ComponentId -parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." - -parseModuleId :: ReadP Module -parseModuleId = parseModuleVar <++ parseModule - where - parseModuleVar = do - _ <- Parse.char '<' - modname <- parseModuleName - _ <- Parse.char '>' - return (mkHoleModule modname) - parseModule = do - uid <- parseUnitId - _ <- Parse.char ':' - modname <- parseModuleName - return (mkModule uid modname) - -parseModSubst :: ReadP [(ModuleName, Module)] -parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') - . flip Parse.sepBy (Parse.char ',') - $ do k <- parseModuleName - _ <- Parse.char '=' - v <- parseModuleId - return (k, v) - - -{- -Note [Wired-in packages] -~~~~~~~~~~~~~~~~~~~~~~~~ - -Certain packages are known to the compiler, in that we know about certain -entities that reside in these packages, and the compiler needs to -declare static Modules and Names that refer to these packages. Hence -the wired-in packages can't include version numbers in their package UnitId, -since we don't want to bake the version numbers of these packages into GHC. - -So here's the plan. Wired-in packages are still versioned as -normal in the packages database, and you can still have multiple -versions of them installed. To the user, everything looks normal. - -However, for each invocation of GHC, only a single instance of each wired-in -package will be recognised (the desired one is selected via -@-package@\/@-hide-package@), and GHC will internally pretend that it has the -*unversioned* 'UnitId', including in .hi files and object file symbols. - -Unselected versions of wired-in packages will be ignored, as will any other -package that depends directly or indirectly on it (much as if you -had used @-ignore-package@). - -The affected packages are compiled with, e.g., @-this-unit-id base@, so that -the symbols in the object files have the unversioned unit id in their name. - -Make sure you change 'Packages.findWiredInPackages' if you add an entry here. - -For `integer-gmp`/`integer-simple` we also change the base name to -`integer-wired-in`, but this is fundamentally no different. -See Note [The integer library] in PrelNames. --} - -integerUnitId, primUnitId, - baseUnitId, rtsUnitId, - thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId -primUnitId = fsToUnitId (fsLit "ghc-prim") -integerUnitId = fsToUnitId (fsLit "integer-wired-in") - -- See Note [The integer library] in PrelNames -baseUnitId = fsToUnitId (fsLit "base") -rtsUnitId = fsToUnitId (fsLit "rts") -thUnitId = fsToUnitId (fsLit "template-haskell") -thisGhcUnitId = fsToUnitId (fsLit "ghc") -interactiveUnitId = fsToUnitId (fsLit "interactive") - --- | This is the package Id for the current program. It is the default --- package Id if you don't specify a package name. We don't add this prefix --- to symbol names, since there can be only one main package per program. -mainUnitId = fsToUnitId (fsLit "main") - --- | This is a fake package id used to provide identities to any un-implemented --- signatures. The set of hole identities is global over an entire compilation. --- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. --- See Note [Representation of module/name variables] -holeUnitId :: UnitId -holeUnitId = fsToUnitId (fsLit "hole") - -isInteractiveModule :: Module -> Bool -isInteractiveModule mod = moduleUnitId mod == interactiveUnitId - --- Note [Representation of module/name variables] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In our ICFP'16, we use to represent module holes, and {A.T} to represent --- name holes. This could have been represented by adding some new cases --- to the core data types, but this would have made the existing 'nameModule' --- and 'moduleUnitId' partial, which would have required a lot of modifications --- to existing code. --- --- Instead, we adopted the following encoding scheme: --- --- ===> hole:A --- {A.T} ===> hole:A.T --- --- This encoding is quite convenient, but it is also a bit dangerous too, --- because if you have a 'hole:A' you need to know if it's actually a --- 'Module' or just a module stored in a 'Name'; these two cases must be --- treated differently when doing substitutions. 'renameHoleModule' --- and 'renameHoleUnitId' assume they are NOT operating on a --- 'Name'; 'NameShape' handles name substitutions exclusively. - -isHoleModule :: Module -> Bool -isHoleModule mod = moduleUnitId mod == holeUnitId - -wiredInUnitIds :: [UnitId] -wiredInUnitIds = [ primUnitId, - integerUnitId, - baseUnitId, - rtsUnitId, - thUnitId, - thisGhcUnitId ] - -{- -************************************************************************ -* * -\subsection{@ModuleEnv@s} -* * -************************************************************************ --} - --- | A map keyed off of 'Module's -newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) - -{- -Note [ModuleEnv performance and determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To prevent accidental reintroduction of nondeterminism the Ord instance -for Module was changed to not depend on Unique ordering and to use the -lexicographic order. This is potentially expensive, but when measured -there was no difference in performance. - -To be on the safe side and not pessimize ModuleEnv uses nondeterministic -ordering on Module and normalizes by doing the lexicographic sort when -turning the env to a list. -See Note [Unique Determinism] for more information about the source of -nondeterminismand and Note [Deterministic UniqFM] for explanation of why -it matters for maps. --} - -newtype NDModule = NDModule { unNDModule :: Module } - deriving Eq - -- A wrapper for Module with faster nondeterministic Ord. - -- Don't export, See [ModuleEnv performance and determinism] - -instance Ord NDModule where - compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = - (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` - (getUnique n1 `nonDetCmpUnique` getUnique n2) - -filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a -filterModuleEnv f (ModuleEnv e) = - ModuleEnv (Map.filterWithKey (f . unNDModule) e) - -elemModuleEnv :: Module -> ModuleEnv a -> Bool -elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e - -extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a -extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) - -extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a - -> ModuleEnv a -extendModuleEnvWith f (ModuleEnv e) m x = - ModuleEnv (Map.insertWith f (NDModule m) x e) - -extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a -extendModuleEnvList (ModuleEnv e) xs = - ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) - -extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] - -> ModuleEnv a -extendModuleEnvList_C f (ModuleEnv e) xs = - ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) - -plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = - ModuleEnv (Map.unionWith f e1 e2) - -delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a -delModuleEnvList (ModuleEnv e) ms = - ModuleEnv (Map.deleteList (map NDModule ms) e) - -delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a -delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) - -plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) - -lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a -lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e - -lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a -lookupWithDefaultModuleEnv (ModuleEnv e) x m = - Map.findWithDefault x (NDModule m) e - -mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b -mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) - -mkModuleEnv :: [(Module, a)] -> ModuleEnv a -mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) - -emptyModuleEnv :: ModuleEnv a -emptyModuleEnv = ModuleEnv Map.empty - -moduleEnvKeys :: ModuleEnv a -> [Module] -moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e - -- See Note [ModuleEnv performance and determinism] - -moduleEnvElts :: ModuleEnv a -> [a] -moduleEnvElts e = map snd $ moduleEnvToList e - -- See Note [ModuleEnv performance and determinism] - -moduleEnvToList :: ModuleEnv a -> [(Module, a)] -moduleEnvToList (ModuleEnv e) = - sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] - -- See Note [ModuleEnv performance and determinism] - -unitModuleEnv :: Module -> a -> ModuleEnv a -unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) - -isEmptyModuleEnv :: ModuleEnv a -> Bool -isEmptyModuleEnv (ModuleEnv e) = Map.null e - --- | A set of 'Module's -type ModuleSet = Set NDModule - -mkModuleSet :: [Module] -> ModuleSet -mkModuleSet = Set.fromList . coerce - -extendModuleSet :: ModuleSet -> Module -> ModuleSet -extendModuleSet s m = Set.insert (NDModule m) s - -extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet -extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms - -emptyModuleSet :: ModuleSet -emptyModuleSet = Set.empty - -moduleSetElts :: ModuleSet -> [Module] -moduleSetElts = sort . coerce . Set.toList - -elemModuleSet :: Module -> ModuleSet -> Bool -elemModuleSet = Set.member . coerce - -intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet -intersectModuleSet = coerce Set.intersection - -minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet -minusModuleSet = coerce Set.difference - -delModuleSet :: ModuleSet -> Module -> ModuleSet -delModuleSet = coerce (flip Set.delete) - -unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet -unionModuleSet = coerce Set.union - -unitModuleSet :: Module -> ModuleSet -unitModuleSet = coerce Set.singleton - -{- -A ModuleName has a Unique, so we can build mappings of these using -UniqFM. --} - --- | A map keyed off of 'ModuleName's (actually, their 'Unique's) -type ModuleNameEnv elt = UniqFM elt - - --- | A map keyed off of 'ModuleName's (actually, their 'Unique's) --- Has deterministic folds and can be deterministically converted to a list -type DModuleNameEnv elt = UniqDFM elt diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot deleted file mode 100644 index 36e8abf997..0000000000 --- a/compiler/basicTypes/Module.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module Module where - -import GhcPrelude -import FastString - -data Module -data ModuleName -data UnitId -data InstalledUnitId -newtype ComponentId = ComponentId FastString - -moduleName :: Module -> ModuleName -moduleUnitId :: Module -> UnitId -unitIdString :: UnitId -> String diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs deleted file mode 100644 index fd868a8489..0000000000 --- a/compiler/basicTypes/Name.hs +++ /dev/null @@ -1,693 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Name]{@Name@: to transmit name info from renamer to typechecker} --} - -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They --- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have --- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names --- also contain information about where they originated from, see "Name#name_sorts" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" --- --- #name_sorts# --- Names are one of: --- --- * External, if they name things declared in other modules. Some external --- Names are wired in, i.e. they name primitives defined in the compiler itself --- --- * Internal, if they name things in the module being compiled. Some internal --- Names are system names, if they are names manufactured by the compiler - -module Name ( - -- * The main types - Name, -- Abstract - BuiltInSyntax(..), - - -- ** Creating 'Name's - mkSystemName, mkSystemNameAt, - mkInternalName, mkClonedInternalName, mkDerivedInternalName, - mkSystemVarName, mkSysTvName, - mkFCallName, - mkExternalName, mkWiredInName, - - -- ** Manipulating and deconstructing 'Name's - nameUnique, setNameUnique, - nameOccName, nameNameSpace, nameModule, nameModule_maybe, - setNameLoc, - tidyNameOcc, - localiseName, - - nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, - - -- ** Predicates on 'Name's - isSystemName, isInternalName, isExternalName, - isTyVarName, isTyConName, isDataConName, - isValName, isVarName, - isWiredInName, isWiredIn, isBuiltInSyntax, - isHoleName, - wiredInNameTyThing_maybe, - nameIsLocalOrFrom, nameIsHomePackage, - nameIsHomePackageImport, nameIsFromExternalPackage, - stableNameCmp, - - -- * Class 'NamedThing' and overloaded friends - NamedThing(..), - getSrcLoc, getSrcSpan, getOccString, getOccFS, - - pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, - nameStableString, - - -- Re-export the OccName stuff - module OccName - ) where - -import GhcPrelude - -import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing ) - -import OccName -import Module -import SrcLoc -import Unique -import Util -import Maybes -import Binary -import FastString -import Outputable - -import Control.DeepSeq -import Data.Data - -{- -************************************************************************ -* * -\subsection[Name-datatype]{The @Name@ datatype, and name construction} -* * -************************************************************************ --} - --- | A unique, unambiguous name for something, containing information about where --- that thing originated. -data Name = Name { - n_sort :: NameSort, -- What sort of name it is - n_occ :: !OccName, -- Its occurrence name - n_uniq :: {-# UNPACK #-} !Unique, - n_loc :: !SrcSpan -- Definition site - } - --- NOTE: we make the n_loc field strict to eliminate some potential --- (and real!) space leaks, due to the fact that we don't look at --- the SrcLoc in a Name all that often. - --- See Note [About the NameSorts] -data NameSort - = External Module - - | WiredIn Module TyThing BuiltInSyntax - -- A variant of External, for wired-in things - - | Internal -- A user-defined Id or TyVar - -- defined in the module being compiled - - | System -- A system-defined Id or TyVar. Typically the - -- OccName is very uninformative (like 's') - -instance Outputable NameSort where - ppr (External _) = text "external" - ppr (WiredIn _ _ _) = text "wired-in" - ppr Internal = text "internal" - ppr System = text "system" - -instance NFData Name where - rnf Name{..} = rnf n_sort - -instance NFData NameSort where - rnf (External m) = rnf m - rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () - -- XXX this is a *lie*, we're not going to rnf the TyThing, but - -- since the TyThings for WiredIn Names are all static they can't - -- be hiding space leaks or errors. - rnf Internal = () - rnf System = () - --- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, --- which have special syntactic forms. They aren't in scope --- as such. -data BuiltInSyntax = BuiltInSyntax | UserSyntax - -{- -Note [About the NameSorts] - -1. Initially, top-level Ids (including locally-defined ones) get External names, - and all other local Ids get Internal names - -2. In any invocation of GHC, an External Name for "M.x" has one and only one - unique. This unique association is ensured via the Name Cache; - see Note [The Name Cache] in GHC.Iface.Env. - -3. Things with a External name are given C static labels, so they finally - appear in the .o file's symbol table. They appear in the symbol table - in the form M.n. If originally-local things have this property they - must be made @External@ first. - -4. In the tidy-core phase, a External that is not visible to an importer - is changed to Internal, and a Internal that is visible is changed to External - -5. A System Name differs in the following ways: - a) has unique attached when printing dumps - b) unifier eliminates sys tyvars in favour of user provs where possible - - Before anything gets printed in interface files or output code, it's - fed through a 'tidy' processor, which zaps the OccNames to have - unique names; and converts all sys-locals to user locals - If any desugarer sys-locals have survived that far, they get changed to - "ds1", "ds2", etc. - -Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) - -Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, - not read from an interface file. - E.g. Bool, True, Int, Float, and many others - -All built-in syntax is for wired-in things. --} - -instance HasOccName Name where - occName = nameOccName - -nameUnique :: Name -> Unique -nameOccName :: Name -> OccName -nameNameSpace :: Name -> NameSpace -nameModule :: HasDebugCallStack => Name -> Module -nameSrcLoc :: Name -> SrcLoc -nameSrcSpan :: Name -> SrcSpan - -nameUnique name = n_uniq name -nameOccName name = n_occ name -nameNameSpace name = occNameSpace (n_occ name) -nameSrcLoc name = srcSpanStart (n_loc name) -nameSrcSpan name = n_loc name - -{- -************************************************************************ -* * -\subsection{Predicates on names} -* * -************************************************************************ --} - -isInternalName :: Name -> Bool -isExternalName :: Name -> Bool -isSystemName :: Name -> Bool -isWiredInName :: Name -> Bool - -isWiredInName (Name {n_sort = WiredIn _ _ _}) = True -isWiredInName _ = False - -isWiredIn :: NamedThing thing => thing -> Bool -isWiredIn = isWiredInName . getName - -wiredInNameTyThing_maybe :: Name -> Maybe TyThing -wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing -wiredInNameTyThing_maybe _ = Nothing - -isBuiltInSyntax :: Name -> Bool -isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True -isBuiltInSyntax _ = False - -isExternalName (Name {n_sort = External _}) = True -isExternalName (Name {n_sort = WiredIn _ _ _}) = True -isExternalName _ = False - -isInternalName name = not (isExternalName name) - -isHoleName :: Name -> Bool -isHoleName = isHoleModule . nameModule - -nameModule name = - nameModule_maybe name `orElse` - pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) - -nameModule_maybe :: Name -> Maybe Module -nameModule_maybe (Name { n_sort = External mod}) = Just mod -nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod -nameModule_maybe _ = Nothing - -nameIsLocalOrFrom :: Module -> Name -> Bool --- ^ Returns True if the name is --- (a) Internal --- (b) External but from the specified module --- (c) External but from the 'interactive' package --- --- The key idea is that --- False means: the entity is defined in some other module --- you can find the details (type, fixity, instances) --- in some interface file --- those details will be stored in the EPT or HPT --- --- True means: the entity is defined in this module or earlier in --- the GHCi session --- you can find details (type, fixity, instances) in the --- TcGblEnv or TcLclEnv --- --- The isInteractiveModule part is because successive interactions of a GHCi session --- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come --- from the magic 'interactive' package; and all the details are kept in the --- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. --- See Note [The interactive package] in GHC.Driver.Types - -nameIsLocalOrFrom from name - | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod - | otherwise = True - -nameIsHomePackage :: Module -> Name -> Bool --- True if the Name is defined in module of this package -nameIsHomePackage this_mod - = \nm -> case n_sort nm of - External nm_mod -> moduleUnitId nm_mod == this_pkg - WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg - Internal -> True - System -> False - where - this_pkg = moduleUnitId this_mod - -nameIsHomePackageImport :: Module -> Name -> Bool --- True if the Name is defined in module of this package --- /other than/ the this_mod -nameIsHomePackageImport this_mod - = \nm -> case nameModule_maybe nm of - Nothing -> False - Just nm_mod -> nm_mod /= this_mod - && moduleUnitId nm_mod == this_pkg - where - this_pkg = moduleUnitId this_mod - --- | Returns True if the Name comes from some other package: neither this --- package nor the interactive package. -nameIsFromExternalPackage :: UnitId -> Name -> Bool -nameIsFromExternalPackage this_pkg name - | Just mod <- nameModule_maybe name - , moduleUnitId mod /= this_pkg -- Not this package - , not (isInteractiveModule mod) -- Not the 'interactive' package - = True - | otherwise - = False - -isTyVarName :: Name -> Bool -isTyVarName name = isTvOcc (nameOccName name) - -isTyConName :: Name -> Bool -isTyConName name = isTcOcc (nameOccName name) - -isDataConName :: Name -> Bool -isDataConName name = isDataOcc (nameOccName name) - -isValName :: Name -> Bool -isValName name = isValOcc (nameOccName name) - -isVarName :: Name -> Bool -isVarName = isVarOcc . nameOccName - -isSystemName (Name {n_sort = System}) = True -isSystemName _ = False - -{- -************************************************************************ -* * -\subsection{Making names} -* * -************************************************************************ --} - --- | Create a name which is (for now at least) local to the current module and hence --- does not need a 'Module' to disambiguate it from other 'Name's -mkInternalName :: Unique -> OccName -> SrcSpan -> Name -mkInternalName uniq occ loc = Name { n_uniq = uniq - , n_sort = Internal - , n_occ = occ - , n_loc = loc } - -- NB: You might worry that after lots of huffing and - -- puffing we might end up with two local names with distinct - -- uniques, but the same OccName. Indeed we can, but that's ok - -- * the insides of the compiler don't care: they use the Unique - -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the - -- uniques if you get confused - -- * for interface files we tidyCore first, which makes - -- the OccNames distinct when they need to be - -mkClonedInternalName :: Unique -> Name -> Name -mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = uniq, n_sort = Internal - , n_occ = occ, n_loc = loc } - -mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name -mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) - = Name { n_uniq = uniq, n_sort = Internal - , n_occ = derive_occ occ, n_loc = loc } - --- | Create a name which definitely originates in the given module -mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name --- WATCH OUT! External Names should be in the Name Cache --- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName --- with some fresh unique without populating the Name Cache -mkExternalName uniq mod occ loc - = Name { n_uniq = uniq, n_sort = External mod, - n_occ = occ, n_loc = loc } - --- | Create a name which is actually defined by the compiler itself -mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name -mkWiredInName mod occ uniq thing built_in - = Name { n_uniq = uniq, - n_sort = WiredIn mod thing built_in, - n_occ = occ, n_loc = wiredInSrcSpan } - --- | Create a name brought into being by the compiler -mkSystemName :: Unique -> OccName -> Name -mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan - -mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name -mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System - , n_occ = occ, n_loc = loc } - -mkSystemVarName :: Unique -> FastString -> Name -mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) - -mkSysTvName :: Unique -> FastString -> Name -mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) - --- | Make a name for a foreign call -mkFCallName :: Unique -> String -> Name -mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan - -- The encoded string completely describes the ccall - --- When we renumber/rename things, we need to be --- able to change a Name's Unique to match the cached --- one in the thing it's the name of. If you know what I mean. -setNameUnique :: Name -> Unique -> Name -setNameUnique name uniq = name {n_uniq = uniq} - --- This is used for hsigs: we want to use the name of the originally exported --- entity, but edit the location to refer to the reexport site -setNameLoc :: Name -> SrcSpan -> Name -setNameLoc name loc = name {n_loc = loc} - -tidyNameOcc :: Name -> OccName -> Name --- We set the OccName of a Name when tidying --- In doing so, we change System --> Internal, so that when we print --- it we don't get the unique by default. It's tidy now! -tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} -tidyNameOcc name occ = name { n_occ = occ } - --- | Make the 'Name' into an internal name, regardless of what it was to begin with -localiseName :: Name -> Name -localiseName n = n { n_sort = Internal } - -{- -************************************************************************ -* * -\subsection{Hashing and comparison} -* * -************************************************************************ --} - -cmpName :: Name -> Name -> Ordering -cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 - --- | Compare Names lexicographically --- This only works for Names that originate in the source code or have been --- tidied. -stableNameCmp :: Name -> Name -> Ordering -stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) - (Name { n_sort = s2, n_occ = occ2 }) - = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) - -- The ordinary compare on OccNames is lexicographic - where - -- Later constructors are bigger - sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 - sort_cmp (External {}) _ = LT - sort_cmp (WiredIn {}) (External {}) = GT - sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 - sort_cmp (WiredIn {}) _ = LT - sort_cmp Internal (External {}) = GT - sort_cmp Internal (WiredIn {}) = GT - sort_cmp Internal Internal = EQ - sort_cmp Internal System = LT - sort_cmp System System = EQ - sort_cmp System _ = GT - -{- -************************************************************************ -* * -\subsection[Name-instances]{Instance declarations} -* * -************************************************************************ --} - --- | The same comments as for `Name`'s `Ord` instance apply. -instance Eq Name where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - --- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which --- means that the ordering is not stable across deserialization or rebuilds. --- --- See `nonDetCmpUnique` for further information, and trac #15240 for a bug --- caused by improper use of this instance. - --- For a deterministic lexicographic ordering, use `stableNameCmp`. -instance Ord Name where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpName a b - -instance Uniquable Name where - getUnique = nameUnique - -instance NamedThing Name where - getName n = n - -instance Data Name where - -- don't traverse? - toConstr _ = abstractConstr "Name" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Name" - -{- -************************************************************************ -* * -\subsection{Binary} -* * -************************************************************************ --} - --- | Assumes that the 'Name' is a non-binding one. See --- 'GHC.Iface.Syntax.putIfaceTopBndr' and 'GHC.Iface.Syntax.getIfaceTopBndr' for --- serializing binding 'Name's. See 'UserData' for the rationale for this --- distinction. -instance Binary Name where - put_ bh name = - case getUserData bh of - UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name - - get bh = - case getUserData bh of - UserData { ud_get_name = get_name } -> get_name bh - -{- -************************************************************************ -* * -\subsection{Pretty printing} -* * -************************************************************************ --} - -instance Outputable Name where - ppr name = pprName name - -instance OutputableBndr Name where - pprBndr _ name = pprName name - pprInfixOcc = pprInfixName - pprPrefixOcc = pprPrefixName - -pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) - = getPprStyle $ \ sty -> - case sort of - WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin - External mod -> pprExternal sty uniq mod occ False UserSyntax - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ - --- | Print the string of Name unqualifiedly directly. -pprNameUnqualified :: Name -> SDoc -pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ - -pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc -pprExternal sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ - -- In code style, always qualify - -- ToDo: maybe we could print all wired-in things unqualified - -- in code style, to reduce symbol table bloat? - | debugStyle sty = pp_mod <> ppr_occ_name occ - <> braces (hsep [if is_wired then text "(w)" else empty, - pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax - | otherwise = - if isHoleModule mod - then case qualName sty mod occ of - NameUnqual -> ppr_occ_name occ - _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) - else pprModulePrefix sty mod occ <> ppr_occ_name occ - where - pp_mod = ppUnlessOption sdocSuppressModulePrefixes - (ppr mod <> dot) - -pprInternal :: PprStyle -> Unique -> OccName -> SDoc -pprInternal sty uniq occ - | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - -- For debug dumps, we're not necessarily dumping - -- tidied code, so we need to print the uniques. - | otherwise = ppr_occ_name occ -- User style - --- Like Internal, except that we only omit the unique in Iface style -pprSystem :: PprStyle -> Unique -> OccName -> SDoc -pprSystem sty uniq occ - | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - <> braces (pprNameSpaceBrief (occNameSpace occ)) - | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq - -- If the tidy phase hasn't run, the OccName - -- is unlikely to be informative (like 's'), - -- so print the unique - - -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc --- Print the "M." part of a name, based on whether it's in scope or not --- See Note [Printing original names] in GHC.Driver.Types -pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ - case qualName sty mod occ of -- See Outputable.QualifyName: - NameQual modname -> ppr modname <> dot -- Name is in scope - NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in - <> ppr (moduleName mod) <> dot -- scope either - NameUnqual -> empty -- In scope unqualified - -pprUnique :: Unique -> SDoc --- Print a unique unless we are suppressing them -pprUnique uniq - = ppUnlessOption sdocSuppressUniques $ - pprUniqueAlways uniq - -ppr_underscore_unique :: Unique -> SDoc --- Print an underscore separating the name from its unique --- But suppress it if we aren't printing the uniques anyway -ppr_underscore_unique uniq - = ppUnlessOption sdocSuppressUniques $ - char '_' <> pprUniqueAlways uniq - -ppr_occ_name :: OccName -> SDoc -ppr_occ_name occ = ftext (occNameFS occ) - -- Don't use pprOccName; instead, just print the string of the OccName; - -- we print the namespace in the debug stuff above - --- In code style, we Z-encode the strings. The results of Z-encoding each FastString are --- cached behind the scenes in the FastString implementation. -ppr_z_occ_name :: OccName -> SDoc -ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) - --- Prints (if mod information is available) "Defined at " or --- "Defined in " information for a Name. -pprDefinedAt :: Name -> SDoc -pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name - -pprNameDefnLoc :: Name -> SDoc --- Prints "at " or --- or "in " depending on what info is available -pprNameDefnLoc name - = case nameSrcLoc name of - -- nameSrcLoc rather than nameSrcSpan - -- It seems less cluttered to show a location - -- rather than a span for the definition point - RealSrcLoc s _ -> text "at" <+> ppr s - UnhelpfulLoc s - | isInternalName name || isSystemName name - -> text "at" <+> ftext s - | otherwise - -> text "in" <+> quotes (ppr (nameModule name)) - - --- | Get a string representation of a 'Name' that's unique and stable --- across recompilations. Used for deterministic generation of binds for --- derived instances. --- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" -nameStableString :: Name -> String -nameStableString Name{..} = - nameSortStableString n_sort ++ "$" ++ occNameString n_occ - -nameSortStableString :: NameSort -> String -nameSortStableString System = "$_sys" -nameSortStableString Internal = "$_in" -nameSortStableString (External mod) = moduleStableString mod -nameSortStableString (WiredIn mod _ _) = moduleStableString mod - -{- -************************************************************************ -* * -\subsection{Overloaded functions related to Names} -* * -************************************************************************ --} - --- | A class allowing convenient access to the 'Name' of various datatypes -class NamedThing a where - getOccName :: a -> OccName - getName :: a -> Name - - getOccName n = nameOccName (getName n) -- Default method - -instance NamedThing e => NamedThing (Located e) where - getName = getName . unLoc - -getSrcLoc :: NamedThing a => a -> SrcLoc -getSrcSpan :: NamedThing a => a -> SrcSpan -getOccString :: NamedThing a => a -> String -getOccFS :: NamedThing a => a -> FastString - -getSrcLoc = nameSrcLoc . getName -getSrcSpan = nameSrcSpan . getName -getOccString = occNameString . getOccName -getOccFS = occNameFS . getOccName - -pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc --- See Outputable.pprPrefixVar, pprInfixVar; --- add parens or back-quotes as appropriate -pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) - -pprPrefixName :: NamedThing a => a -> SDoc -pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) - where - name = getName thing diff --git a/compiler/basicTypes/Name.hs-boot b/compiler/basicTypes/Name.hs-boot deleted file mode 100644 index 54efe686ad..0000000000 --- a/compiler/basicTypes/Name.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Name where - -import GhcPrelude () - -data Name diff --git a/compiler/basicTypes/NameCache.hs b/compiler/basicTypes/NameCache.hs deleted file mode 100644 index 8b63e3d687..0000000000 --- a/compiler/basicTypes/NameCache.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} - --- | The Name Cache -module NameCache - ( lookupOrigNameCache - , extendOrigNameCache - , extendNameCache - , initNameCache - , NameCache(..), OrigNameCache - ) where - -import GhcPrelude - -import Module -import Name -import UniqSupply -import TysWiredIn -import Util -import Outputable -import PrelNames - -#include "HsVersions.h" - -{- - -Note [The Name Cache] -~~~~~~~~~~~~~~~~~~~~~ -The Name Cache makes sure that, during any invocation of GHC, each -External Name "M.x" has one, and only one globally-agreed Unique. - -* The first time we come across M.x we make up a Unique and record that - association in the Name Cache. - -* When we come across "M.x" again, we look it up in the Name Cache, - and get a hit. - -The functions newGlobalBinder, allocateGlobalBinder do the main work. -When you make an External name, you should probably be calling one -of them. - - -Note [Built-in syntax and the OrigNameCache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower -their cost we use two tricks, - - a. We specially encode tuple and sum Names in interface files' symbol tables - to avoid having to look up their names while loading interface files. - Namely these names are encoded as by their Uniques. We know how to get from - a Unique back to the Name which it represents via the mapping defined in - the SumTupleUniques module. See Note [Symbol table representation of names] - in GHC.Iface.Binary and for details. - - b. We don't include them in the Orig name cache but instead parse their - OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with - them. - -Why is the second measure necessary? Good question; afterall, 1) the parser -emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never -needs to looked-up during interface loading due to (a). It turns out that there -are two reasons why we might look up an Orig RdrName for built-in syntax, - - * If you use setRdrNameSpace on an Exact RdrName it may be - turned into an Orig RdrName. - - * Template Haskell turns a BuiltInSyntax Name into a TH.NameG - (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName - (GHC.ThToHs.thRdrName). So, e.g. $(do { reify '(,); ... }) will - go this route (#8954). - --} - --- | Per-module cache of original 'OccName's given 'Name's -type OrigNameCache = ModuleEnv (OccEnv Name) - -lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE - , Just name <- isBuiltInOcc_maybe occ - = -- See Note [Known-key names], 3(c) in PrelNames - -- Special case for tuples; there are too many - -- of them to pre-populate the original-name cache - Just name - - | otherwise - = case lookupModuleEnv nc mod of - Nothing -> Nothing - Just occ_env -> lookupOccEnv occ_env occ - -extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache -extendOrigNameCache nc name - = ASSERT2( isExternalName name, ppr name ) - extendNameCache nc (nameModule name) (nameOccName name) name - -extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache -extendNameCache nc mod occ name - = extendModuleEnvWith combine nc mod (unitOccEnv occ name) - where - combine _ occ_env = extendOccEnv occ_env occ name - --- | The NameCache makes sure that there is just one Unique assigned for --- each original name; i.e. (module-name, occ-name) pair and provides --- something of a lookup mechanism for those names. -data NameCache - = NameCache { nsUniqs :: !UniqSupply, - -- ^ Supply of uniques - nsNames :: !OrigNameCache - -- ^ Ensures that one original name gets one unique - } - --- | Return a function to atomically update the name cache. -initNameCache :: UniqSupply -> [Name] -> NameCache -initNameCache us names - = NameCache { nsUniqs = us, - nsNames = initOrigNames names } - -initOrigNames :: [Name] -> OrigNameCache -initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs deleted file mode 100644 index 6aef33e410..0000000000 --- a/compiler/basicTypes/NameEnv.hs +++ /dev/null @@ -1,175 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[NameEnv]{@NameEnv@: name environments} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module NameEnv ( - -- * Var, Id and TyVar environments (maps) - NameEnv, - - -- ** Manipulating these environments - mkNameEnv, mkNameEnvWith, - emptyNameEnv, isEmptyNameEnv, - unitNameEnv, nameEnvElts, - extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, - extendNameEnvList, extendNameEnvList_C, - filterNameEnv, anyNameEnv, - plusNameEnv, plusNameEnv_C, alterNameEnv, - lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, - elemNameEnv, mapNameEnv, disjointNameEnv, - - DNameEnv, - - emptyDNameEnv, - lookupDNameEnv, - delFromDNameEnv, filterDNameEnv, - mapDNameEnv, - adjustDNameEnv, alterDNameEnv, extendDNameEnv, - -- ** Dependency analysis - depAnal - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Digraph -import Name -import UniqFM -import UniqDFM -import Maybes - -{- -************************************************************************ -* * -\subsection{Name environment} -* * -************************************************************************ --} - -{- -Note [depAnal determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -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. --} - -depAnal :: forall node. - (node -> [Name]) -- Defs - -> (node -> [Name]) -- Uses - -> [node] - -> [SCC node] --- Perform dependency analysis on a group of definitions, --- where each definition may define more than one Name --- --- The get_defs and get_uses functions are called only once per node -depAnal get_defs get_uses nodes - = stronglyConnCompFromEdgedVerticesUniq graph_nodes - where - graph_nodes = (map mk_node keyed_nodes) :: [Node Int node] - keyed_nodes = nodes `zip` [(1::Int)..] - mk_node (node, key) = - let !edges = (mapMaybe (lookupNameEnv key_map) (get_uses node)) - in DigraphNode node key edges - - key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it - key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] - -{- -************************************************************************ -* * -\subsection{Name environment} -* * -************************************************************************ --} - --- | Name Environment -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -isEmptyNameEnv :: NameEnv a -> Bool -mkNameEnv :: [(Name,a)] -> NameEnv a -mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a -nameEnvElts :: NameEnv a -> [a] -alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a -extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b -extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a -extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a -extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool -unitNameEnv :: Name -> a -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -lookupNameEnv_NF :: NameEnv a -> Name -> a -filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt -anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool -mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 -disjointNameEnv :: NameEnv a -> NameEnv a -> Bool - -nameEnvElts x = eltsUFM x -emptyNameEnv = emptyUFM -isEmptyNameEnv = isNullUFM -unitNameEnv x y = unitUFM x y -extendNameEnv x y z = addToUFM x y z -extendNameEnvList x l = addListToUFM x l -lookupNameEnv x y = lookupUFM x y -alterNameEnv = alterUFM -mkNameEnv l = listToUFM l -mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) -elemNameEnv x y = elemUFM x y -plusNameEnv x y = plusUFM x y -plusNameEnv_C f x y = plusUFM_C f x y -extendNameEnv_C f x y z = addToUFM_C f x y z -mapNameEnv f x = mapUFM f x -extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b -extendNameEnvList_C x y z = addListToUFM_C x y z -delFromNameEnv x y = delFromUFM x y -delListFromNameEnv x y = delListFromUFM x y -filterNameEnv x y = filterUFM x y -anyNameEnv f x = foldUFM ((||) . f) False x -disjointNameEnv x y = isNullUFM (intersectUFM x y) - -lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) - --- | Deterministic Name Environment --- --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DNameEnv. -type DNameEnv a = UniqDFM a - -emptyDNameEnv :: DNameEnv a -emptyDNameEnv = emptyUDFM - -lookupDNameEnv :: DNameEnv a -> Name -> Maybe a -lookupDNameEnv = lookupUDFM - -delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a -delFromDNameEnv = delFromUDFM - -filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a -filterDNameEnv = filterUDFM - -mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b -mapDNameEnv = mapUDFM - -adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a -adjustDNameEnv = adjustUDFM - -alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a -alterDNameEnv = alterUDFM - -extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a -extendDNameEnv = addToUDFM diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs deleted file mode 100644 index 1605deb9af..0000000000 --- a/compiler/basicTypes/NameSet.hs +++ /dev/null @@ -1,215 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 --} - -{-# LANGUAGE CPP #-} -module NameSet ( - -- * Names set type - NameSet, - - -- ** Manipulating these sets - emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, - minusNameSet, elemNameSet, extendNameSet, extendNameSetList, - delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, - intersectsNameSet, intersectNameSet, - nameSetAny, nameSetAll, nameSetElemsStable, - - -- * Free variables - FreeVars, - - -- ** Manipulating sets of free variables - isEmptyFVs, emptyFVs, plusFVs, plusFV, - mkFVs, addOneFV, unitFV, delFV, delFVs, - intersectFVs, - - -- * Defs and uses - Defs, Uses, DefUse, DefUses, - - -- ** Manipulating defs and uses - emptyDUs, usesOnly, mkDUs, plusDU, - findUses, duDefs, duUses, allUses - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Name -import OrdList -import UniqSet -import Data.List (sortBy) - -{- -************************************************************************ -* * -\subsection[Sets of names} -* * -************************************************************************ --} - -type NameSet = UniqSet Name - -emptyNameSet :: NameSet -unitNameSet :: Name -> NameSet -extendNameSetList :: NameSet -> [Name] -> NameSet -extendNameSet :: NameSet -> Name -> NameSet -mkNameSet :: [Name] -> NameSet -unionNameSet :: NameSet -> NameSet -> NameSet -unionNameSets :: [NameSet] -> NameSet -minusNameSet :: NameSet -> NameSet -> NameSet -elemNameSet :: Name -> NameSet -> Bool -isEmptyNameSet :: NameSet -> Bool -delFromNameSet :: NameSet -> Name -> NameSet -delListFromNameSet :: NameSet -> [Name] -> NameSet -filterNameSet :: (Name -> Bool) -> NameSet -> NameSet -intersectNameSet :: NameSet -> NameSet -> NameSet -intersectsNameSet :: NameSet -> NameSet -> Bool --- ^ True if there is a non-empty intersection. --- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty - -isEmptyNameSet = isEmptyUniqSet -emptyNameSet = emptyUniqSet -unitNameSet = unitUniqSet -mkNameSet = mkUniqSet -extendNameSetList = addListToUniqSet -extendNameSet = addOneToUniqSet -unionNameSet = unionUniqSets -unionNameSets = unionManyUniqSets -minusNameSet = minusUniqSet -elemNameSet = elementOfUniqSet -delFromNameSet = delOneFromUniqSet -filterNameSet = filterUniqSet -intersectNameSet = intersectUniqSets - -delListFromNameSet set ns = foldl' delFromNameSet set ns - -intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) - -nameSetAny :: (Name -> Bool) -> NameSet -> Bool -nameSetAny = uniqSetAny - -nameSetAll :: (Name -> Bool) -> NameSet -> Bool -nameSetAll = uniqSetAll - --- | Get the elements of a NameSet with some stable ordering. --- This only works for Names that originate in the source code or have been --- tidied. --- See Note [Deterministic UniqFM] to learn about nondeterminism -nameSetElemsStable :: NameSet -> [Name] -nameSetElemsStable ns = - sortBy stableNameCmp $ nonDetEltsUniqSet ns - -- It's OK to use nonDetEltsUniqSet here because we immediately sort - -- with stableNameCmp - -{- -************************************************************************ -* * -\subsection{Free variables} -* * -************************************************************************ - -These synonyms are useful when we are thinking of free variables --} - -type FreeVars = NameSet - -plusFV :: FreeVars -> FreeVars -> FreeVars -addOneFV :: FreeVars -> Name -> FreeVars -unitFV :: Name -> FreeVars -emptyFVs :: FreeVars -plusFVs :: [FreeVars] -> FreeVars -mkFVs :: [Name] -> FreeVars -delFV :: Name -> FreeVars -> FreeVars -delFVs :: [Name] -> FreeVars -> FreeVars -intersectFVs :: FreeVars -> FreeVars -> FreeVars - -isEmptyFVs :: NameSet -> Bool -isEmptyFVs = isEmptyNameSet -emptyFVs = emptyNameSet -plusFVs = unionNameSets -plusFV = unionNameSet -mkFVs = mkNameSet -addOneFV = extendNameSet -unitFV = unitNameSet -delFV n s = delFromNameSet s n -delFVs ns s = delListFromNameSet s ns -intersectFVs = intersectNameSet - -{- -************************************************************************ -* * - Defs and uses -* * -************************************************************************ --} - --- | A set of names that are defined somewhere -type Defs = NameSet - --- | A set of names that are used somewhere -type Uses = NameSet - --- | @(Just ds, us) =>@ The use of any member of the @ds@ --- implies that all the @us@ are used too. --- Also, @us@ may mention @ds@. --- --- @Nothing =>@ Nothing is defined in this group, but --- nevertheless all the uses are essential. --- Used for instance declarations, for example -type DefUse = (Maybe Defs, Uses) - --- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' --- In a single (def, use) pair, the defs also scope over the uses -type DefUses = OrdList DefUse - -emptyDUs :: DefUses -emptyDUs = nilOL - -usesOnly :: Uses -> DefUses -usesOnly uses = unitOL (Nothing, uses) - -mkDUs :: [(Defs,Uses)] -> DefUses -mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs] - -plusDU :: DefUses -> DefUses -> DefUses -plusDU = appOL - -duDefs :: DefUses -> Defs -duDefs dus = foldr get emptyNameSet dus - where - get (Nothing, _u1) d2 = d2 - get (Just d1, _u1) d2 = d1 `unionNameSet` d2 - -allUses :: DefUses -> Uses --- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned -allUses dus = foldr get emptyNameSet dus - where - get (_d1, u1) u2 = u1 `unionNameSet` u2 - -duUses :: DefUses -> Uses --- ^ Collect all 'Uses', regardless of whether the group is itself used, --- but remove 'Defs' on the way -duUses dus = foldr get emptyNameSet dus - where - get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses - get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) - `minusNameSet` defs - -findUses :: DefUses -> Uses -> Uses --- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. --- The result is a superset of the input 'Uses'; and includes things defined --- in the input 'DefUses' (but only if they are used) -findUses dus uses - = foldr get uses dus - where - get (Nothing, rhs_uses) uses - = rhs_uses `unionNameSet` uses - get (Just defs, rhs_uses) uses - | defs `intersectsNameSet` uses -- Used - || nameSetAny (startsWithUnderscore . nameOccName) defs - -- At least one starts with an "_", - -- so treat the group as used - = rhs_uses `unionNameSet` uses - | otherwise -- No def is used - = uses diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs deleted file mode 100644 index 56864e26cf..0000000000 --- a/compiler/basicTypes/OccName.hs +++ /dev/null @@ -1,927 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName' represents names as strings with just a little more information: --- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or --- data constructors --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" - -module OccName ( - -- * The 'NameSpace' type - NameSpace, -- Abstract - - nameSpacesRelated, - - -- ** Construction - -- $real_vs_source_data_constructors - tcName, clsName, tcClsName, dataName, varName, - tvName, srcDataName, - - -- ** Pretty Printing - pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, - - -- * The 'OccName' type - OccName, -- Abstract, instance of Outputable - pprOccName, - - -- ** Construction - mkOccName, mkOccNameFS, - mkVarOcc, mkVarOccFS, - mkDataOcc, mkDataOccFS, - mkTyVarOcc, mkTyVarOccFS, - mkTcOcc, mkTcOccFS, - mkClsOcc, mkClsOccFS, - mkDFunOcc, - setOccNameSpace, - demoteOccName, - HasOccName(..), - - -- ** Derived 'OccName's - isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, - mkMatcherOcc, mkBuilderOcc, - mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, - mkNewTyCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, - mkGenR, mkGen1R, - mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, - mkSuperDictSelOcc, mkSuperDictAuxOcc, - mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, - mkInstTyCoOcc, mkEqPredCoOcc, - mkRecFldSelOcc, - mkTyConRepOcc, - - -- ** Deconstruction - occNameFS, occNameString, occNameSpace, - - isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, - parenSymOcc, startsWithUnderscore, - - isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, - - -- * The 'OccEnv' type - OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, - lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, - occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, - extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, - alterOccEnv, pprOccEnv, - - -- * The 'OccSet' type - OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, - extendOccSetList, - unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, - isEmptyOccSet, intersectOccSet, intersectsOccSet, - filterOccSet, - - -- * Tidying up - TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, - tidyOccName, avoidClashesOccEnv, delTidyOccEnvList, - - -- FsEnv - FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv - ) where - -import GhcPrelude - -import Util -import Unique -import UniqFM -import UniqSet -import FastString -import FastStringEnv -import Outputable -import Lexeme -import Binary -import Control.DeepSeq -import Data.Char -import Data.Data - -{- -************************************************************************ -* * -\subsection{Name space} -* * -************************************************************************ --} - -data NameSpace = VarName -- Variables, including "real" data constructors - | DataName -- "Source" data constructors - | TvName -- Type variables - | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. - deriving( Eq, Ord ) - --- Note [Data Constructors] --- see also: Note [Data Constructor Naming] in GHC.Core.DataCon --- --- $real_vs_source_data_constructors --- There are two forms of data constructor: --- --- [Source data constructors] The data constructors mentioned in Haskell source code --- --- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type --- --- For example: --- --- > data T = T !(Int, Int) --- --- The source datacon has type @(Int, Int) -> T@ --- The real datacon has type @Int -> Int -> T@ --- --- GHC chooses a representation based on the strictness etc. - -tcName, clsName, tcClsName :: NameSpace -dataName, srcDataName :: NameSpace -tvName, varName :: NameSpace - --- Though type constructors and classes are in the same name space now, --- the NameSpace type is abstract, so we can easily separate them later -tcName = TcClsName -- Type constructors -clsName = TcClsName -- Classes -tcClsName = TcClsName -- Not sure which! - -dataName = DataName -srcDataName = DataName -- Haskell-source data constructors should be - -- in the Data name space - -tvName = TvName -varName = VarName - -isDataConNameSpace :: NameSpace -> Bool -isDataConNameSpace DataName = True -isDataConNameSpace _ = False - -isTcClsNameSpace :: NameSpace -> Bool -isTcClsNameSpace TcClsName = True -isTcClsNameSpace _ = False - -isTvNameSpace :: NameSpace -> Bool -isTvNameSpace TvName = True -isTvNameSpace _ = False - -isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors -isVarNameSpace TvName = True -isVarNameSpace VarName = True -isVarNameSpace _ = False - -isValNameSpace :: NameSpace -> Bool -isValNameSpace DataName = True -isValNameSpace VarName = True -isValNameSpace _ = False - -pprNameSpace :: NameSpace -> SDoc -pprNameSpace DataName = text "data constructor" -pprNameSpace VarName = text "variable" -pprNameSpace TvName = text "type variable" -pprNameSpace TcClsName = text "type constructor or class" - -pprNonVarNameSpace :: NameSpace -> SDoc -pprNonVarNameSpace VarName = empty -pprNonVarNameSpace ns = pprNameSpace ns - -pprNameSpaceBrief :: NameSpace -> SDoc -pprNameSpaceBrief DataName = char 'd' -pprNameSpaceBrief VarName = char 'v' -pprNameSpaceBrief TvName = text "tv" -pprNameSpaceBrief TcClsName = text "tc" - --- demoteNameSpace lowers the NameSpace if possible. We can not know --- in advance, since a TvName can appear in an HsTyVar. --- See Note [Demotion] in GHC.Rename.Env -demoteNameSpace :: NameSpace -> Maybe NameSpace -demoteNameSpace VarName = Nothing -demoteNameSpace DataName = Nothing -demoteNameSpace TvName = Nothing -demoteNameSpace TcClsName = Just DataName - -{- -************************************************************************ -* * -\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} -* * -************************************************************************ --} - --- | Occurrence Name --- --- In this context that means: --- "classified (i.e. as a type name, value name, etc) but not qualified --- and not yet resolved" -data OccName = OccName - { occNameSpace :: !NameSpace - , occNameFS :: !FastString - } - -instance Eq OccName where - (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 - -instance Ord OccName where - -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) - = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) - -instance Data OccName where - -- don't traverse? - toConstr _ = abstractConstr "OccName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "OccName" - -instance HasOccName OccName where - occName = id - -instance NFData OccName where - rnf x = x `seq` () - -{- -************************************************************************ -* * -\subsection{Printing} -* * -************************************************************************ --} - -instance Outputable OccName where - ppr = pprOccName - -instance OutputableBndr OccName where - pprBndr _ = ppr - pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) - pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) - -pprOccName :: OccName -> SDoc -pprOccName (OccName sp occ) - = getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS occ) - else pp_occ <> pp_debug sty - where - pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) - | otherwise = empty - - pp_occ = sdocOption sdocSuppressUniques $ \case - True -> text (strip_th_unique (unpackFS occ)) - False -> ftext occ - - -- See Note [Suppressing uniques in OccNames] - strip_th_unique ('[' : c : _) | isAlphaNum c = [] - strip_th_unique (c : cs) = c : strip_th_unique cs - strip_th_unique [] = [] - -{- -Note [Suppressing uniques in OccNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This is a hack to de-wobblify the OccNames that contain uniques from -Template Haskell that have been turned into a string in the OccName. -See Note [Unique OccNames from Template Haskell] in Convert.hs - -************************************************************************ -* * -\subsection{Construction} -* * -************************************************************************ --} - -mkOccName :: NameSpace -> String -> OccName -mkOccName occ_sp str = OccName occ_sp (mkFastString str) - -mkOccNameFS :: NameSpace -> FastString -> OccName -mkOccNameFS occ_sp fs = OccName occ_sp fs - -mkVarOcc :: String -> OccName -mkVarOcc s = mkOccName varName s - -mkVarOccFS :: FastString -> OccName -mkVarOccFS fs = mkOccNameFS varName fs - -mkDataOcc :: String -> OccName -mkDataOcc = mkOccName dataName - -mkDataOccFS :: FastString -> OccName -mkDataOccFS = mkOccNameFS dataName - -mkTyVarOcc :: String -> OccName -mkTyVarOcc = mkOccName tvName - -mkTyVarOccFS :: FastString -> OccName -mkTyVarOccFS fs = mkOccNameFS tvName fs - -mkTcOcc :: String -> OccName -mkTcOcc = mkOccName tcName - -mkTcOccFS :: FastString -> OccName -mkTcOccFS = mkOccNameFS tcName - -mkClsOcc :: String -> OccName -mkClsOcc = mkOccName clsName - -mkClsOccFS :: FastString -> OccName -mkClsOccFS = mkOccNameFS clsName - --- demoteOccName lowers the Namespace of OccName. --- see Note [Demotion] -demoteOccName :: OccName -> Maybe OccName -demoteOccName (OccName space name) = do - space' <- demoteNameSpace space - return $ OccName space' name - --- Name spaces are related if there is a chance to mean the one when one writes --- the other, i.e. variables <-> data constructors and type variables <-> type constructors -nameSpacesRelated :: NameSpace -> NameSpace -> Bool -nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 - -otherNameSpace :: NameSpace -> NameSpace -otherNameSpace VarName = DataName -otherNameSpace DataName = VarName -otherNameSpace TvName = TcClsName -otherNameSpace TcClsName = TvName - - - -{- | Other names in the compiler add additional information to an OccName. -This class provides a consistent way to access the underlying OccName. -} -class HasOccName name where - occName :: name -> OccName - -{- -************************************************************************ -* * - Environments -* * -************************************************************************ - -OccEnvs are used mainly for the envts in ModIfaces. - -Note [The Unique of an OccName] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -They are efficient, because FastStrings have unique Int# keys. We assume -this key is less than 2^24, and indeed FastStrings are allocated keys -sequentially starting at 0. - -So we can make a Unique using - mkUnique ns key :: Unique -where 'ns' is a Char representing the name space. This in turn makes it -easy to build an OccEnv. --} - -instance Uniquable OccName where - -- See Note [The Unique of an OccName] - getUnique (OccName VarName fs) = mkVarOccUnique fs - getUnique (OccName DataName fs) = mkDataOccUnique fs - getUnique (OccName TvName fs) = mkTvOccUnique fs - getUnique (OccName TcClsName fs) = mkTcOccUnique fs - -newtype OccEnv a = A (UniqFM a) - deriving Data - -emptyOccEnv :: OccEnv a -unitOccEnv :: OccName -> a -> OccEnv a -extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a -extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a -lookupOccEnv :: OccEnv a -> OccName -> Maybe a -mkOccEnv :: [(OccName,a)] -> OccEnv a -mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a -elemOccEnv :: OccName -> OccEnv a -> Bool -foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b -occEnvElts :: OccEnv a -> [a] -extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a -extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b -plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a -plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a -mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b -delFromOccEnv :: OccEnv a -> OccName -> OccEnv a -delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a -filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt -alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt - -emptyOccEnv = A emptyUFM -unitOccEnv x y = A $ unitUFM x y -extendOccEnv (A x) y z = A $ addToUFM x y z -extendOccEnvList (A x) l = A $ addListToUFM x l -lookupOccEnv (A x) y = lookupUFM x y -mkOccEnv l = A $ listToUFM l -elemOccEnv x (A y) = elemUFM x y -foldOccEnv a b (A c) = foldUFM a b c -occEnvElts (A x) = eltsUFM x -plusOccEnv (A x) (A y) = A $ plusUFM x y -plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y -extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z -extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z -mapOccEnv f (A x) = A $ mapUFM f x -mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l -delFromOccEnv (A x) y = A $ delFromUFM x y -delListFromOccEnv (A x) y = A $ delListFromUFM x y -filterOccEnv x (A y) = A $ filterUFM x y -alterOccEnv fn (A y) k = A $ alterUFM fn y k - -instance Outputable a => Outputable (OccEnv a) where - ppr x = pprOccEnv ppr x - -pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc -pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env - -type OccSet = UniqSet OccName - -emptyOccSet :: OccSet -unitOccSet :: OccName -> OccSet -mkOccSet :: [OccName] -> OccSet -extendOccSet :: OccSet -> OccName -> OccSet -extendOccSetList :: OccSet -> [OccName] -> OccSet -unionOccSets :: OccSet -> OccSet -> OccSet -unionManyOccSets :: [OccSet] -> OccSet -minusOccSet :: OccSet -> OccSet -> OccSet -elemOccSet :: OccName -> OccSet -> Bool -isEmptyOccSet :: OccSet -> Bool -intersectOccSet :: OccSet -> OccSet -> OccSet -intersectsOccSet :: OccSet -> OccSet -> Bool -filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet - -emptyOccSet = emptyUniqSet -unitOccSet = unitUniqSet -mkOccSet = mkUniqSet -extendOccSet = addOneToUniqSet -extendOccSetList = addListToUniqSet -unionOccSets = unionUniqSets -unionManyOccSets = unionManyUniqSets -minusOccSet = minusUniqSet -elemOccSet = elementOfUniqSet -isEmptyOccSet = isEmptyUniqSet -intersectOccSet = intersectUniqSets -intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) -filterOccSet = filterUniqSet - -{- -************************************************************************ -* * -\subsection{Predicates and taking them apart} -* * -************************************************************************ --} - -occNameString :: OccName -> String -occNameString (OccName _ s) = unpackFS s - -setOccNameSpace :: NameSpace -> OccName -> OccName -setOccNameSpace sp (OccName _ occ) = OccName sp occ - -isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool - -isVarOcc (OccName VarName _) = True -isVarOcc _ = False - -isTvOcc (OccName TvName _) = True -isTvOcc _ = False - -isTcOcc (OccName TcClsName _) = True -isTcOcc _ = False - --- | /Value/ 'OccNames's are those that are either in --- the variable or data constructor namespaces -isValOcc :: OccName -> Bool -isValOcc (OccName VarName _) = True -isValOcc (OccName DataName _) = True -isValOcc _ = False - -isDataOcc (OccName DataName _) = True -isDataOcc _ = False - --- | Test if the 'OccName' is a data constructor that starts with --- a symbol (e.g. @:@, or @[]@) -isDataSymOcc :: OccName -> Bool -isDataSymOcc (OccName DataName s) = isLexConSym s -isDataSymOcc _ = False --- Pretty inefficient! - --- | Test if the 'OccName' is that for any operator (whether --- it is a data constructor or variable or whatever) -isSymOcc :: OccName -> Bool -isSymOcc (OccName DataName s) = isLexConSym s -isSymOcc (OccName TcClsName s) = isLexSym s -isSymOcc (OccName VarName s) = isLexSym s -isSymOcc (OccName TvName s) = isLexSym s --- Pretty inefficient! - -parenSymOcc :: OccName -> SDoc -> SDoc --- ^ Wrap parens around an operator -parenSymOcc occ doc | isSymOcc occ = parens doc - | otherwise = doc - -startsWithUnderscore :: OccName -> Bool --- ^ Haskell 98 encourages compilers to suppress warnings about unused --- names in a pattern if they start with @_@: this implements that test -startsWithUnderscore occ = headFS (occNameFS occ) == '_' - -{- -************************************************************************ -* * -\subsection{Making system names} -* * -************************************************************************ - -Here's our convention for splitting up the interface file name space: - - d... dictionary identifiers - (local variables, so no name-clash worries) - -All of these other OccNames contain a mixture of alphabetic -and symbolic characters, and hence cannot possibly clash with -a user-written type or function name - - $f... Dict-fun identifiers (from inst decls) - $dmop Default method for 'op' - $pnC n'th superclass selector for class C - $wf Worker for function 'f' - $sf.. Specialised version of f - D:C Data constructor for dictionary for class C - NTCo:T Coercion connecting newtype T with its representation type - TFCo:R Coercion connecting a data family to its representation type R - -In encoded form these appear as Zdfxxx etc - - :... keywords (export:, letrec: etc.) ---- I THINK THIS IS WRONG! - -This knowledge is encoded in the following functions. - -@mk_deriv@ generates an @OccName@ from the prefix and a string. -NB: The string must already be encoded! --} - --- | Build an 'OccName' derived from another 'OccName'. --- --- Note that the pieces of the name are passed in as a @[FastString]@ so that --- the whole name can be constructed with a single 'concatFS', minimizing --- unnecessary intermediate allocations. -mk_deriv :: NameSpace - -> FastString -- ^ A prefix which distinguishes one sort of - -- derived name from another - -> [FastString] -- ^ The name we are deriving from in pieces which - -- will be concatenated. - -> OccName -mk_deriv occ_sp sys_prefix str = - mkOccNameFS occ_sp (concatFS $ sys_prefix : str) - -isDerivedOccName :: OccName -> Bool --- ^ Test for definitions internally generated by GHC. This predicate --- is used to suppress printing of internal definitions in some debug prints -isDerivedOccName occ = - case occNameString occ of - '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo - c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions - _other -> False - -isDefaultMethodOcc :: OccName -> Bool -isDefaultMethodOcc occ = - case occNameString occ of - '$':'d':'m':_ -> True - _ -> False - --- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? --- This is needed as these bindings are renamed differently. --- See Note [Grand plan for Typeable] in TcTypeable. -isTypeableBindOcc :: OccName -> Bool -isTypeableBindOcc occ = - case occNameString occ of - '$':'t':'c':_ -> True -- mkTyConRepOcc - '$':'t':'r':_ -> True -- Module binding - _ -> False - -mkDataConWrapperOcc, mkWorkerOcc, - mkMatcherOcc, mkBuilderOcc, - mkDefaultMethodOcc, - mkClassDataConOcc, mkDictOcc, - mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, - mkGenR, mkGen1R, - mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkTyConRepOcc - :: OccName -> OccName - --- These derived variables have a prefix that no Haskell value could have -mkDataConWrapperOcc = mk_simple_deriv varName "$W" -mkWorkerOcc = mk_simple_deriv varName "$w" -mkMatcherOcc = mk_simple_deriv varName "$m" -mkBuilderOcc = mk_simple_deriv varName "$b" -mkDefaultMethodOcc = mk_simple_deriv varName "$dm" -mkClassOpAuxOcc = mk_simple_deriv varName "$c" -mkDictOcc = mk_simple_deriv varName "$d" -mkIPOcc = mk_simple_deriv varName "$i" -mkSpecOcc = mk_simple_deriv varName "$s" -mkForeignExportOcc = mk_simple_deriv varName "$f" -mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible -mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class -mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes -mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions -mkEqPredCoOcc = mk_simple_deriv tcName "$co" - --- Used in derived instances -mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" -mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" -mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" - --- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable -mkTyConRepOcc occ = mk_simple_deriv varName prefix occ - where - prefix | isDataOcc occ = "$tc'" - | otherwise = "$tc" - --- Generic deriving mechanism -mkGenR = mk_simple_deriv tcName "Rep_" -mkGen1R = mk_simple_deriv tcName "Rep1_" - --- Overloaded record field selectors -mkRecFldSelOcc :: String -> OccName -mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] - -mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName -mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] - --- Data constructor workers are made by setting the name space --- of the data constructor OccName (which should be a DataName) --- to VarName -mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ - -mkSuperDictAuxOcc :: Int -> OccName -> OccName -mkSuperDictAuxOcc index cls_tc_occ - = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] - -mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 - -> OccName -- ^ Class, e.g. @Ord@ - -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ -mkSuperDictSelOcc index cls_tc_occ - = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] - -mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' - -> OccName -- ^ Local name, e.g. @sat@ - -> OccName -- ^ Nice unique version, e.g. @$L23sat@ -mkLocalOcc uniq occ - = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] - -- The Unique might print with characters - -- that need encoding (e.g. 'z'!) - --- | Derive a name for the representation type constructor of a --- @data@\/@newtype@ instance. -mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ @R:Map@ -mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) - -mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. - -- Only used in debug mode, for extra clarity - -> Bool -- ^ Is this a hs-boot instance DFun? - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ E.g. @$f3OrdMaybe@ - --- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real --- thing when we compile the mother module. Reason: we don't know exactly --- what the mother module will call it. - -mkDFunOcc info_str is_boot set - = chooseUniqueOcc VarName (prefix ++ info_str) set - where - prefix | is_boot = "$fx" - | otherwise = "$f" - -mkDataTOcc, mkDataCOcc - :: OccName -- ^ TyCon or data con string - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ E.g. @$f3OrdMaybe@ --- data T = MkT ... deriving( Data ) needs definitions for --- $tT :: Data.Generics.Basics.DataType --- $cMkT :: Data.Generics.Basics.Constr -mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ) -mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ) - -{- -Sometimes we need to pick an OccName that has not already been used, -given a set of in-use OccNames. --} - -chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName -chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) - where - loop occ n - | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) - | otherwise = occ - -{- -We used to add a '$m' to indicate a method, but that gives rise to bad -error messages from the type checker when we print the function name or pattern -of an instance-decl binding. Why? Because the binding is zapped -to use the method name in place of the selector name. -(See TcClassDcl.tcMethodBind) - -The way it is now, -ddump-xx output may look confusing, but -you can always say -dppr-debug to get the uniques. - -However, we *do* have to zap the first character to be lower case, -because overloaded constructors (blarg) generate methods too. -And convert to VarName space - -e.g. a call to constructor MkFoo where - data (Ord a) => Foo a = MkFoo a - -If this is necessary, we do it by prefixing '$m'. These -guys never show up in error messages. What a hack. --} - -mkMethodOcc :: OccName -> OccName -mkMethodOcc occ@(OccName VarName _) = occ -mkMethodOcc occ = mk_simple_deriv varName "$m" occ - -{- -************************************************************************ -* * -\subsection{Tidying them up} -* * -************************************************************************ - -Before we print chunks of code we like to rename it so that -we don't have to print lots of silly uniques in it. But we mustn't -accidentally introduce name clashes! So the idea is that we leave the -OccName alone unless it accidentally clashes with one that is already -in scope; if so, we tack on '1' at the end and try again, then '2', and -so on till we find a unique one. - -There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' -because that isn't a single lexeme. So we encode it to 'lle' and *then* -tack on the '1', if necessary. - -Note [TidyOccEnv] -~~~~~~~~~~~~~~~~~ -type TidyOccEnv = UniqFM Int - -* Domain = The OccName's FastString. These FastStrings are "taken"; - make sure that we don't re-use - -* Int, n = A plausible starting point for new guesses - There is no guarantee that "FSn" is available; - you must look that up in the TidyOccEnv. But - it's a good place to start looking. - -* When looking for a renaming for "foo2" we strip off the "2" and start - with "foo". Otherwise if we tidy twice we get silly names like foo23. - - However, if it started with digits at the end, we always make a name - with digits at the end, rather than shortening "foo2" to just "foo", - even if "foo" is unused. Reasons: - - Plain "foo" might be used later - - We use trailing digits to subtly indicate a unification variable - in typechecker error message; see TypeRep.tidyTyVarBndr - -We have to take care though! Consider a machine-generated module (#10370) - module Foo where - a1 = e1 - a2 = e2 - ... - a2000 = e2000 -Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, -we have to do a linear search to find a free one, "a2001". That might just be -acceptable once. But if we now come across "a8" again, we don't want to repeat -that search. - -So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for -starting the search; and we make sure to update the starting point for "a" -after we allocate a new one. - - -Note [Tidying multiple names at once] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider - - > :t (id,id,id) - -Every id contributes a type variable to the type signature, and all of them are -"a". If we tidy them one by one, we get - - (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) - -which is a bit unfortunate, as it unfairly renames only two of them. What we -would like to see is - - (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) - -To achieve this, the function avoidClashesOccEnv can be used to prepare the -TidyEnv, by “blocking” every name that occurs twice in the map. This way, none -of the "a"s will get the privilege of keeping this name, and all of them will -get a suitable number by tidyOccName. - -This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs -for an example where this is used. - -This is #12382. - --} - -type TidyOccEnv = UniqFM Int -- The in-scope OccNames - -- See Note [TidyOccEnv] - -emptyTidyOccEnv :: TidyOccEnv -emptyTidyOccEnv = emptyUFM - -initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl' add emptyUFM - where - add env (OccName _ fs) = addToUFM env fs 1 - -delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv -delTidyOccEnvList = delListFromUFM - --- see Note [Tidying multiple names at once] -avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv -avoidClashesOccEnv env occs = go env emptyUFM occs - where - go env _ [] = env - go env seenOnce ((OccName _ fs):occs) - | fs `elemUFM` env = go env seenOnce occs - | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs - | otherwise = go env (addToUFM seenOnce fs ()) occs - -tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) -tidyOccName env occ@(OccName occ_sp fs) - | not (fs `elemUFM` env) - = -- Desired OccName is free, so use it, - -- and record in 'env' that it's no longer available - (addToUFM env fs 1, occ) - - | otherwise - = case lookupUFM env base1 of - Nothing -> (addToUFM env base1 2, OccName occ_sp base1) - Just n -> find 1 n - where - base :: String -- Drop trailing digits (see Note [TidyOccEnv]) - base = dropWhileEndLE isDigit (unpackFS fs) - base1 = mkFastString (base ++ "1") - - find !k !n - = case lookupUFM env new_fs of - Just {} -> find (k+1 :: Int) (n+k) - -- By using n+k, the n argument to find goes - -- 1, add 1, add 2, add 3, etc which - -- moves at quadratic speed through a dense patch - - Nothing -> (new_env, OccName occ_sp new_fs) - where - new_fs = mkFastString (base ++ show n) - new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) - -- Update: base1, so that next time we'll start where we left off - -- new_fs, so that we know it is taken - -- If they are the same (n==1), the former wins - -- See Note [TidyOccEnv] - - -{- -************************************************************************ -* * - Binary instance - Here rather than in GHC.Iface.Binary because OccName is abstract -* * -************************************************************************ --} - -instance Binary NameSpace where - put_ bh VarName = do - putByte bh 0 - put_ bh DataName = do - putByte bh 1 - put_ bh TvName = do - putByte bh 2 - put_ bh TcClsName = do - putByte bh 3 - get bh = do - h <- getByte bh - case h of - 0 -> do return VarName - 1 -> do return DataName - 2 -> do return TvName - _ -> do return TcClsName - -instance Binary OccName where - put_ bh (OccName aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (OccName aa ab) diff --git a/compiler/basicTypes/OccName.hs-boot b/compiler/basicTypes/OccName.hs-boot deleted file mode 100644 index 31d77a44a9..0000000000 --- a/compiler/basicTypes/OccName.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module OccName where - -import GhcPrelude () - -data OccName diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs deleted file mode 100644 index d0d12e3607..0000000000 --- a/compiler/basicTypes/RdrName.hs +++ /dev/null @@ -1,1387 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName' is the type of names that come directly from the parser. They --- have not yet had their scoping and binding resolved by the renamer and can be --- thought of to a first approximation as an 'OccName.OccName' with an optional module --- qualifier --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" - -module RdrName ( - -- * The main type - RdrName(..), -- Constructors exported only to GHC.Iface.Binary - - -- ** Construction - mkRdrUnqual, mkRdrQual, - mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, - - -- ** Destruction - rdrNameOcc, rdrNameSpace, demoteRdrName, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, - - -- * Local mapping of 'RdrName' to 'Name.Name' - LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, - lookupLocalRdrEnv, lookupLocalRdrOcc, - elemLocalRdrEnv, inLocalRdrEnvScope, - localRdrEnvElts, delLocalRdrEnvList, - - -- * Global mapping of 'RdrName' to 'GlobalRdrElt's - GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, - lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, - pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, - lookupGRE_Name_OccName, - getGRE_NameQualifier_maybes, - transformGREs, pickGREs, pickGREsModExp, - - -- * GlobalRdrElts - gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, - greRdrNames, greSrcSpan, greQualModName, - gresToAvailInfo, - - -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel, - unQualOK, qualSpecOK, unQualSpecOK, - pprNameProvenance, - Parent(..), greParent_maybe, - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem, bestImport, - - -- * Utils for StarIsType - starInfo - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Module -import Name -import Avail -import NameSet -import Maybes -import SrcLoc -import FastString -import FieldLabel -import Outputable -import Unique -import UniqFM -import UniqSet -import Util -import NameEnv - -import Data.Data -import Data.List( sortBy ) - -{- -************************************************************************ -* * -\subsection{The main data type} -* * -************************************************************************ --} - --- | Reader Name --- --- Do not use the data constructors of RdrName directly: prefer the family --- of functions that creates them, such as 'mkRdrUnqual' --- --- - Note: A Located RdrName will only have API Annotations if it is a --- compound one, --- e.g. --- --- > `bar` --- > ( ~ ) --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', --- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, --- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, --- 'ApiAnnotation.AnnBackquote' @'`'@, --- 'ApiAnnotation.AnnVal' --- 'ApiAnnotation.AnnTilde', - --- For details on above see note [Api annotations] in ApiAnnotation -data RdrName - = Unqual OccName - -- ^ Unqualified name - -- - -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ Qualified name - -- - -- A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ Original name - -- - -- An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ Exact name - -- - -- We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving Data - -{- -************************************************************************ -* * -\subsection{Simple functions} -* * -************************************************************************ --} - -instance HasOccName RdrName where - occName = rdrNameOcc - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Qual _ occ) = occ -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name - -rdrNameSpace :: RdrName -> NameSpace -rdrNameSpace = occNameSpace . rdrNameOcc - --- demoteRdrName lowers the NameSpace of RdrName. --- see Note [Demotion] in OccName -demoteRdrName :: RdrName -> Maybe RdrName -demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) -demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) -demoteRdrName (Orig _ _) = panic "demoteRdrName" -demoteRdrName (Exact _) = panic "demoteRdrName" - - -- These two are the basic constructors -mkRdrUnqual :: OccName -> RdrName -mkRdrUnqual occ = Unqual occ - -mkRdrQual :: ModuleName -> OccName -> RdrName -mkRdrQual mod occ = Qual mod occ - -mkOrig :: Module -> OccName -> RdrName -mkOrig mod occ = Orig mod occ - ---------------- - -- These two are used when parsing source files - -- They do encode the module and occurrence names -mkUnqual :: NameSpace -> FastString -> RdrName -mkUnqual sp n = Unqual (mkOccNameFS sp n) - -mkVarUnqual :: FastString -> RdrName -mkVarUnqual n = Unqual (mkVarOccFS n) - --- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and --- the 'OccName' are taken from the first and second elements of the tuple respectively -mkQual :: NameSpace -> (FastString, FastString) -> RdrName -mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) - -getRdrName :: NamedThing thing => thing -> RdrName -getRdrName name = nameRdrName (getName name) - -nameRdrName :: Name -> RdrName -nameRdrName name = Exact name --- Keep the Name even for Internal names, so that the --- unique is still there for debug printing, particularly --- of Types (which are converted to IfaceTypes before printing) - -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) - -isRdrDataCon :: RdrName -> Bool -isRdrTyVar :: RdrName -> Bool -isRdrTc :: RdrName -> Bool - -isRdrDataCon rn = isDataOcc (rdrNameOcc rn) -isRdrTyVar rn = isTvOcc (rdrNameOcc rn) -isRdrTc rn = isTcOcc (rdrNameOcc rn) - -isSrcRdrName :: RdrName -> Bool -isSrcRdrName (Unqual _) = True -isSrcRdrName (Qual _ _) = True -isSrcRdrName _ = False - -isUnqual :: RdrName -> Bool -isUnqual (Unqual _) = True -isUnqual _ = False - -isQual :: RdrName -> Bool -isQual (Qual _ _) = True -isQual _ = False - -isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) -isQual_maybe (Qual m n) = Just (m,n) -isQual_maybe _ = Nothing - -isOrig :: RdrName -> Bool -isOrig (Orig _ _) = True -isOrig _ = False - -isOrig_maybe :: RdrName -> Maybe (Module, OccName) -isOrig_maybe (Orig m n) = Just (m,n) -isOrig_maybe _ = Nothing - -isExact :: RdrName -> Bool -isExact (Exact _) = True -isExact _ = False - -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Outputable RdrName where - ppr (Exact name) = ppr name - ppr (Unqual occ) = ppr occ - ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) - -instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <> ppr n - | otherwise = ppr n - - pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name - -- pprPrefixName has some special cases, so - -- we delegate to them rather than reproduce them - | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - -instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 - - (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 - (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 - (Unqual o1) == (Unqual o2) = o1==o2 - _ == _ = False - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - - -- Exact < Unqual < Qual < Orig - -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig - -- before comparing so that Prelude.map == the exact Prelude.map, but - -- that meant that we reported duplicates when renaming bindings - -- generated by Template Haskell; e.g - -- do { n1 <- newName "foo"; n2 <- newName "foo"; - -- } - -- I think we can do without this conversion - compare (Exact n1) (Exact n2) = n1 `compare` n2 - compare (Exact _) _ = LT - - compare (Unqual _) (Exact _) = GT - compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT - - compare (Qual _ _) (Exact _) = GT - compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Qual _ _) (Orig _ _) = LT - - compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Orig _ _) _ = GT - -{- -************************************************************************ -* * - LocalRdrEnv -* * -************************************************************************ --} - --- | Local Reader Environment --- --- This environment is used to store local bindings --- (@let@, @where@, lambda, @case@). --- It is keyed by OccName, because we never use it for qualified names --- We keep the current mapping, *and* the set of all Names in scope --- Reason: see Note [Splicing Exact names] in GHC.Rename.Env -data LocalRdrEnv = LRE { lre_env :: OccEnv Name - , lre_in_scope :: NameSet } - -instance Outputable LocalRdrEnv where - ppr (LRE {lre_env = env, lre_in_scope = ns}) - = hang (text "LocalRdrEnv {") - 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env - , text "in_scope =" - <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) - ] <+> char '}') - where - ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name - -- So we can see if the keys line up correctly - -emptyLocalRdrEnv :: LocalRdrEnv -emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv - , lre_in_scope = emptyNameSet } - -extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv --- The Name should be a non-top-level thing -extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name - = WARN( isExternalName name, ppr name ) - lre { lre_env = extendOccEnv env (nameOccName name) name - , lre_in_scope = extendNameSet ns name } - -extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names - = WARN( any isExternalName names, ppr names ) - lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] - , lre_in_scope = extendNameSetList ns names } - -lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr - | Unqual occ <- rdr - = lookupOccEnv env occ - - -- See Note [Local bindings with Exact Names] - | Exact name <- rdr - , name `elemNameSet` ns - = Just name - - | otherwise - = Nothing - -lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name -lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ - -elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool -elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) - = case rdr_name of - Unqual occ -> occ `elemOccEnv` env - Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] - Qual {} -> False - Orig {} -> False - -localRdrEnvElts :: LocalRdrEnv -> [Name] -localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env - -inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool --- This is the point of the NameSet -inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns - -delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv -delLocalRdrEnvList lre@(LRE { lre_env = env }) occs - = lre { lre_env = delListFromOccEnv env occs } - -{- -Note [Local bindings with Exact Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Template Haskell we can make local bindings that have Exact Names. -Computing shadowing etc may use elemLocalRdrEnv (at least it certainly -does so in GHC.Rename.Types.bindHsQTyVars), so for an Exact Name we must consult -the in-scope-name-set. - - -************************************************************************ -* * - GlobalRdrEnv -* * -************************************************************************ --} - --- | Global Reader Environment -type GlobalRdrEnv = OccEnv [GlobalRdrElt] --- ^ Keyed by 'OccName'; when looking up a qualified name --- we look up the 'OccName' part, and then check the 'Provenance' --- to see if the appropriate qualification is valid. This --- saves routinely doubling the size of the env by adding both --- qualified and unqualified names to the domain. --- --- The list in the codomain is required because there may be name clashes --- These only get reported on lookup, not on construction --- --- INVARIANT 1: All the members of the list have distinct --- 'gre_name' fields; that is, no duplicate Names --- --- INVARIANT 2: Imported provenance => Name is an ExternalName --- However LocalDefs can have an InternalName. This --- happens only when type-checking a [d| ... |] Template --- Haskell quotation; see this note in GHC.Rename.Names --- Note [Top-level Names in Template Haskell decl quotes] --- --- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then --- greOccName gre = occ --- --- NB: greOccName gre is usually the same as --- nameOccName (gre_name gre), but not always in the --- case of record selectors; see greOccName - --- | Global Reader Element --- --- An element of the 'GlobalRdrEnv' -data GlobalRdrElt - = GRE { gre_name :: Name - , gre_par :: Parent - , gre_lcl :: Bool -- ^ True <=> the thing was defined locally - , gre_imp :: [ImportSpec] -- ^ In scope through these imports - } deriving (Data, Eq) - -- INVARIANT: either gre_lcl = True or gre_imp is non-empty - -- See Note [GlobalRdrElt provenance] - --- | The children of a Name are the things that are abbreviated by the ".." --- notation in export lists. See Note [Parents] -data Parent = NoParent - | ParentIs { par_is :: Name } - | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } - -- ^ See Note [Parents for record fields] - deriving (Eq, Data) - -instance Outputable Parent where - ppr NoParent = empty - ppr (ParentIs n) = text "parent:" <> ppr n - ppr (FldParent n f) = text "fldparent:" - <> ppr n <> colon <> ppr f - -plusParent :: Parent -> Parent -> Parent --- See Note [Combining parents] -plusParent p1@(ParentIs _) p2 = hasParent p1 p2 -plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 -plusParent p1 p2@(ParentIs _) = hasParent p2 p1 -plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 -plusParent _ _ = NoParent - -hasParent :: Parent -> Parent -> Parent -#if defined(DEBUG) -hasParent p NoParent = p -hasParent p p' - | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree -#endif -hasParent p _ = p - - -{- Note [GlobalRdrElt provenance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", -i.e. how the Name came to be in scope. It can be in scope two ways: - - gre_lcl = True: it is bound in this module - - gre_imp: a list of all the imports that brought it into scope - -It's an INVARIANT that you have one or the other; that is, either -gre_lcl is True, or gre_imp is non-empty. - -It is just possible to have *both* if there is a module loop: a Name -is defined locally in A, and also brought into scope by importing a -module that SOURCE-imported A. Example (#7672): - - A.hs-boot module A where - data T - - B.hs module B(Decl.T) where - import {-# SOURCE #-} qualified A as Decl - - A.hs module A where - import qualified B - data T = Z | S B.T - -In A.hs, 'T' is locally bound, *and* imported as B.T. - -Note [Parents] -~~~~~~~~~~~~~~~~~ - Parent Children -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - data T Data constructors - Record-field ids - - data family T Data constructors and record-field ids - of all visible data instances of T - - class C Class operations - Associated type constructors - -~~~~~~~~~~~~~~~~~~~~~~~~~ - Constructor Meaning - ~~~~~~~~~~~~~~~~~~~~~~~~ - NoParent Can not be bundled with a type constructor. - ParentIs n Can be bundled with the type constructor corresponding to - n. - FldParent See Note [Parents for record fields] - - - - -Note [Parents for record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For record fields, in addition to the Name of the type constructor -(stored in par_is), we use FldParent to store the field label. This -extra information is used for identifying overloaded record fields -during renaming. - -In a definition arising from a normal module (without --XDuplicateRecordFields), par_lbl will be Nothing, meaning that the -field's label is the same as the OccName of the selector's Name. The -GlobalRdrEnv will contain an entry like this: - - "x" |-> GRE x (FldParent T Nothing) LocalDef - -When -XDuplicateRecordFields is enabled for the module that contains -T, the selector's Name will be mangled (see comments in FieldLabel). -Thus we store the actual field label in par_lbl, and the GlobalRdrEnv -entry looks like this: - - "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef - -Note that the OccName used when adding a GRE to the environment -(greOccName) now depends on the parent field: for FldParent it is the -field label, if present, rather than the selector name. - -~~ - -Record pattern synonym selectors are treated differently. Their parent -information is `NoParent` in the module in which they are defined. This is because -a pattern synonym `P` has no parent constructor either. - -However, if `f` is bundled with a type constructor `T` then whenever `f` is -imported the parent will use the `Parent` constructor so the parent of `f` is -now `T`. - - -Note [Combining parents] -~~~~~~~~~~~~~~~~~~~~~~~~ -With an associated type we might have - module M where - class C a where - data T a - op :: T a -> a - instance C Int where - data T Int = TInt - instance C Bool where - data T Bool = TBool - -Then: C is the parent of T - T is the parent of TInt and TBool -So: in an export list - C(..) is short for C( op, T ) - T(..) is short for T( TInt, TBool ) - -Module M exports everything, so its exports will be - AvailTC C [C,T,op] - AvailTC T [T,TInt,TBool] -On import we convert to GlobalRdrElt and then combine -those. For T that will mean we have - one GRE with Parent C - one GRE with NoParent -That's why plusParent picks the "best" case. --} - --- | make a 'GlobalRdrEnv' where all the elements point to the same --- Provenance (useful for "hiding" imports, or imports with no details). -gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] --- prov = Nothing => locally bound --- Just spec => imported as described by spec -gresFromAvails prov avails - = concatMap (gresFromAvail (const prov)) avails - -localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] --- Turn an Avail into a list of LocalDef GlobalRdrElts -localGREsFromAvail = gresFromAvail (const Nothing) - -gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] -gresFromAvail prov_fn avail - = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) - where - mk_gre n - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = mkParent n avail - , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = mkParent n avail - , gre_lcl = False, gre_imp = [is] } - - mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded - , flSelector = n }) - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl - , gre_lcl = True, gre_imp = [] } - Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl - , gre_lcl = False, gre_imp = [is] } - where - mb_lbl | is_overloaded = Just lbl - | otherwise = Nothing - - -greQualModName :: GlobalRdrElt -> ModuleName --- Get a suitable module qualifier for the GRE --- (used in mkPrintUnqualified) --- Prerecondition: the gre_name is always External -greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - | lcl, Just mod <- nameModule_maybe name = moduleName mod - | (is:_) <- iss = is_as (is_decl is) - | otherwise = pprPanic "greQualModName" (ppr gre) - -greRdrNames :: GlobalRdrElt -> [RdrName] -greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } - = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) - where - occ = greOccName gre - unqual = Unqual occ - do_spec decl_spec - | is_qual decl_spec = [qual] - | otherwise = [unqual,qual] - where qual = Qual (is_as decl_spec) occ - --- the SrcSpan that pprNameProvenance prints out depends on whether --- the Name is defined locally or not: for a local definition the --- definition site is used, otherwise the location of the import --- declaration. We want to sort the export locations in --- exportClashErr by this SrcSpan, we need to extract it: -greSrcSpan :: GlobalRdrElt -> SrcSpan -greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) - | lcl = nameSrcSpan name - | (is:_) <- iss = is_dloc (is_decl is) - | otherwise = pprPanic "greSrcSpan" (ppr gre) - -mkParent :: Name -> AvailInfo -> Parent -mkParent _ (Avail _) = NoParent -mkParent n (AvailTC m _ _) | n == m = NoParent - | otherwise = ParentIs m - -greParent_maybe :: GlobalRdrElt -> Maybe Name -greParent_maybe gre = case gre_par gre of - NoParent -> Nothing - ParentIs n -> Just n - FldParent n _ -> Just n - --- | Takes a list of distinct GREs and folds them --- into AvailInfos. This is more efficient than mapping each individual --- GRE to an AvailInfo and the folding using `plusAvail` but needs the --- uniqueness assumption. -gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] -gresToAvailInfo gres - = nameEnvElts avail_env - where - avail_env :: NameEnv AvailInfo -- Keyed by the parent - (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres - - add :: (NameEnv AvailInfo, NameSet) - -> GlobalRdrElt - -> (NameEnv AvailInfo, NameSet) - add (env, done) gre - | name `elemNameSet` done - = (env, done) -- Don't insert twice into the AvailInfo - | otherwise - = ( extendNameEnv_Acc comb availFromGRE env key gre - , done `extendNameSet` name ) - where - name = gre_name gre - key = case greParent_maybe gre of - Just parent -> parent - Nothing -> gre_name gre - - -- We want to insert the child `k` into a list of children but - -- need to maintain the invariant that the parent is first. - -- - -- We also use the invariant that `k` is not already in `ns`. - insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] - insertChildIntoChildren _ [] k = [k] - insertChildIntoChildren p (n:ns) k - | p == k = k:n:ns - | otherwise = n:k:ns - - comb :: GlobalRdrElt -> AvailInfo -> AvailInfo - comb _ (Avail n) = Avail n -- Duplicated name, should not happen - comb gre (AvailTC m ns fls) - = case gre_par gre of - NoParent -> AvailTC m (name:ns) fls -- Not sure this ever happens - ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls - FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls) - -availFromGRE :: GlobalRdrElt -> AvailInfo -availFromGRE (GRE { gre_name = me, gre_par = parent }) - = case parent of - ParentIs p -> AvailTC p [me] [] - NoParent | isTyConName me -> AvailTC me [me] [] - | otherwise -> avail me - FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] - -mkFieldLabel :: Name -> Maybe FastString -> FieldLabel -mkFieldLabel me mb_lbl = - case mb_lbl of - Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) - , flIsOverloaded = False - , flSelector = me } - Just lbl -> FieldLabel { flLabel = lbl - , flIsOverloaded = True - , flSelector = me } - -emptyGlobalRdrEnv :: GlobalRdrEnv -emptyGlobalRdrEnv = emptyOccEnv - -globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] -globalRdrEnvElts env = foldOccEnv (++) [] env - -instance Outputable GlobalRdrElt where - ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) - 2 (pprNameProvenance gre) - -pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc -pprGlobalRdrEnv locals_only env - = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) - <+> lbrace - , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] - <+> rbrace) ] - where - remove_locals gres | locals_only = filter isLocalGRE gres - | otherwise = gres - pp [] = empty - pp gres = hang (ppr occ - <+> parens (text "unique" <+> ppr (getUnique occ)) - <> colon) - 2 (vcat (map ppr gres)) - where - occ = nameOccName (gre_name (head gres)) - -lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] -lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of - Nothing -> [] - Just gres -> gres - -greOccName :: GlobalRdrElt -> OccName -greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl -greOccName gre = nameOccName (gre_name gre) - -lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] -lookupGRE_RdrName rdr_name env - = case lookupOccEnv env (rdrNameOcc rdr_name) of - Nothing -> [] - Just gres -> pickGREs rdr_name gres - -lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment. This tests --- whether it is in scope, ignoring anything else that might be in --- scope with the same 'OccName'. -lookupGRE_Name env name - = lookupGRE_Name_OccName env name (nameOccName name) - -lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt --- ^ Look for a particular record field selector in the environment, where the --- selector name and field label may be different: the GlobalRdrEnv is keyed on --- the label. See Note [Parents for record fields] for why this happens. -lookupGRE_FieldLabel env fl - = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) - -lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' --- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and --- Note [Parents for record fields]. -lookupGRE_Name_OccName env name occ - = case [ gre | gre <- lookupGlobalRdrEnv env occ - , gre_name gre == name ] of - [] -> Nothing - [gre] -> Just gre - gres -> pprPanic "lookupGRE_Name_OccName" - (ppr name $$ ppr occ $$ ppr gres) - -- See INVARIANT 1 on GlobalRdrEnv - - -getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] --- Returns all the qualifiers by which 'x' is in scope --- Nothing means "the unqualified version is in scope" --- [] means the thing is not in scope at all -getGRE_NameQualifier_maybes env name - = case lookupGRE_Name env name of - Just gre -> [qualifier_maybe gre] - Nothing -> [] - where - qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) - | lcl = Nothing - | otherwise = Just $ map (is_as . is_decl) iss - -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_lcl = lcl }) = lcl - -isRecFldGRE :: GlobalRdrElt -> Bool -isRecFldGRE (GRE {gre_par = FldParent{}}) = True -isRecFldGRE _ = False - --- Returns the field label of this GRE, if it has one -greLabel :: GlobalRdrElt -> Maybe FieldLabelString -greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl -greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) -greLabel _ = Nothing - -unQualOK :: GlobalRdrElt -> Bool --- ^ Test if an unqualified version of this thing would be in scope -unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) - | lcl = True - | otherwise = any unQualSpecOK iss - -{- Note [GRE filtering] -~~~~~~~~~~~~~~~~~~~~~~~ -(pickGREs rdr gres) takes a list of GREs which have the same OccName -as 'rdr', say "x". It does two things: - -(a) filters the GREs to a subset that are in scope - * Qualified, as 'M.x' if want_qual is Qual M _ - * Unqualified, as 'x' if want_unqual is Unqual _ - -(b) for that subset, filter the provenance field (gre_lcl and gre_imp) - to ones that brought it into scope qualified or unqualified resp. - -Example: - module A ( f ) where - import qualified Foo( f ) - import Baz( f ) - f = undefined - -Let's suppose that Foo.f and Baz.f are the same entity really, but the local -'f' is different, so there will be two GREs matching "f": - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] - -The use of "f" in the export list is ambiguous because it's in scope -from the local def and the import Baz(f); but *not* the import qualified Foo. -pickGREs returns two GRE - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Bar ] - -Now the "ambiguous occurrence" message can correctly report how the -ambiguity arises. --} - -pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] --- ^ Takes a list of GREs which have the right OccName 'x' --- Pick those GREs that are in scope --- * Qualified, as 'M.x' if want_qual is Qual M _ --- * Unqualified, as 'x' if want_unqual is Unqual _ --- --- Return each such GRE, with its ImportSpecs filtered, to reflect --- how it is in scope qualified or unqualified respectively. --- See Note [GRE filtering] -pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres -pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres -pickGREs _ _ = [] -- I don't think this actually happens - -pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt -pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - | not lcl, null iss' = Nothing - | otherwise = Just (gre { gre_imp = iss' }) - where - iss' = filter unQualSpecOK iss - -pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt -pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) - | not lcl', null iss' = Nothing - | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) - where - iss' = filter (qualSpecOK mod) iss - lcl' = lcl && name_is_from mod n - - name_is_from :: ModuleName -> Name -> Bool - name_is_from mod name = case nameModule_maybe name of - Just n_mod -> moduleName n_mod == mod - Nothing -> False - -pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] --- ^ Pick GREs that are in scope *both* qualified *and* unqualified --- Return each GRE that is, as a pair --- (qual_gre, unqual_gre) --- These two GREs are the original GRE with imports filtered to express how --- it is in scope qualified an unqualified respectively --- --- Used only for the 'module M' item in export list; --- see GHC.Rename.Names.exports_from_avail -pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres - -pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) -pickBothGRE mod gre@(GRE { gre_name = n }) - | isBuiltInSyntax n = Nothing - | Just gre1 <- pickQualGRE mod gre - , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) - | otherwise = Nothing - where - -- isBuiltInSyntax filter out names for built-in syntax They - -- just clutter up the environment (esp tuples), and the - -- parser will generate Exact RdrNames for them, so the - -- cluttered envt is no use. Really, it's only useful for - -- GHC.Base and GHC.Tuple. - --- Building GlobalRdrEnvs - -plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 - -mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv -mkGlobalRdrEnv gres - = foldr add emptyGlobalRdrEnv gres - where - add gre env = extendOccEnv_Acc insertGRE singleton env - (greOccName gre) - gre - -insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] -insertGRE new_g [] = [new_g] -insertGRE new_g (old_g : old_gs) - | gre_name new_g == gre_name old_g - = new_g `plusGRE` old_g : old_gs - | otherwise - = old_g : insertGRE new_g old_gs - -plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt --- Used when the gre_name fields match -plusGRE g1 g2 - = GRE { gre_name = gre_name g1 - , gre_lcl = gre_lcl g1 || gre_lcl g2 - , gre_imp = gre_imp g1 ++ gre_imp g2 - , gre_par = gre_par g1 `plusParent` gre_par g2 } - -transformGREs :: (GlobalRdrElt -> GlobalRdrElt) - -> [OccName] - -> GlobalRdrEnv -> GlobalRdrEnv --- ^ Apply a transformation function to the GREs for these OccNames -transformGREs trans_gre occs rdr_env - = foldr trans rdr_env occs - where - trans occ env - = case lookupOccEnv env occ of - Just gres -> extendOccEnv env occ (map trans_gre gres) - Nothing -> env - -extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv -extendGlobalRdrEnv env gre - = extendOccEnv_Acc insertGRE singleton env - (greOccName gre) gre - -shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv -shadowNames = foldl' shadowName - -{- Note [GlobalRdrEnv shadowing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before adding new names to the GlobalRdrEnv we nuke some existing entries; -this is "shadowing". The actual work is done by RdrEnv.shadowName. -Suppose - env' = shadowName env M.f - -Then: - * Looking up (Unqual f) in env' should succeed, returning M.f, - even if env contains existing unqualified bindings for f. - They are shadowed - - * Looking up (Qual M.f) in env' should succeed, returning M.f - - * Looking up (Qual X.f) in env', where X /= M, should be the same as - looking up (Qual X.f) in env. - That is, shadowName does /not/ delete earlier qualified bindings - -There are two reasons for shadowing: - -* The GHCi REPL - - - Ids bought into scope on the command line (eg let x = True) have - External Names, like Ghci4.x. We want a new binding for 'x' (say) - to override the existing binding for 'x'. Example: - - ghci> :load M -- Brings `x` and `M.x` into scope - ghci> x - ghci> "Hello" - ghci> M.x - ghci> "hello" - ghci> let x = True -- Shadows `x` - ghci> x -- The locally bound `x` - -- NOT an ambiguous reference - ghci> True - ghci> M.x -- M.x is still in scope! - ghci> "Hello" - So when we add `x = True` we must not delete the `M.x` from the - `GlobalRdrEnv`; rather we just want to make it "qualified only"; - hence the `mk_fake-imp_spec` in `shadowName`. See also Note - [Interactively-bound Ids in GHCi] in GHC.Driver.Types - - - Data types also have External Names, like Ghci4.T; but we still want - 'T' to mean the newly-declared 'T', not an old one. - -* Nested Template Haskell declaration brackets - See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names - - Consider a TH decl quote: - module M where - f x = h [d| f = ...f...M.f... |] - We must shadow the outer unqualified binding of 'f', else we'll get - a complaint when extending the GlobalRdrEnv, saying that there are - two bindings for 'f'. There are several tricky points: - - - This shadowing applies even if the binding for 'f' is in a - where-clause, and hence is in the *local* RdrEnv not the *global* - RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. - - - The External Name M.f from the enclosing module must certainly - still be available. So we don't nuke it entirely; we just make - it seem like qualified import. - - - We only shadow *External* names (which come from the main module), - or from earlier GHCi commands. Do not shadow *Internal* names - because in the bracket - [d| class C a where f :: a - f = 4 |] - rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the - class decl, and *separately* extend the envt with the value binding. - At that stage, the class op 'f' will have an Internal name. --} - -shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv --- Remove certain old GREs that share the same OccName as this new Name. --- See Note [GlobalRdrEnv shadowing] for details -shadowName env name - = alterOccEnv (fmap alter_fn) env (nameOccName name) - where - alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] - alter_fn gres = mapMaybe (shadow_with name) gres - - shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt - shadow_with new_name - old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) - = case nameModule_maybe old_name of - Nothing -> Just old_gre -- Old name is Internal; do not shadow - Just old_mod - | Just new_mod <- nameModule_maybe new_name - , new_mod == old_mod -- Old name same as new name; shadow completely - -> Nothing - - | null iss' -- Nothing remains - -> Nothing - - | otherwise - -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) - - where - iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss - lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] - | otherwise = [] - - mk_fake_imp_spec old_name old_mod -- Urgh! - = ImpSpec id_spec ImpAll - where - old_mod_name = moduleName old_mod - id_spec = ImpDeclSpec { is_mod = old_mod_name - , is_as = old_mod_name - , is_qual = True - , is_dloc = nameSrcSpan old_name } - - shadow_is :: Name -> ImportSpec -> Maybe ImportSpec - shadow_is new_name is@(ImpSpec { is_decl = id_spec }) - | Just new_mod <- nameModule_maybe new_name - , is_as id_spec == moduleName new_mod - = Nothing -- Shadow both qualified and unqualified - | otherwise -- Shadow unqualified only - = Just (is { is_decl = id_spec { is_qual = True } }) - - -{- -************************************************************************ -* * - ImportSpec -* * -************************************************************************ --} - --- | Import Specification --- --- The 'ImportSpec' of something says how it came to be imported --- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } - deriving( Eq, Data ) - --- | Import Declaration Specification --- --- Describes a particular import declaration and is --- shared among all the 'Provenance's for that decl -data ImpDeclSpec - = ImpDeclSpec { - is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ - -- Note the @Muggle@ may well not be - -- the defining module for this thing! - - -- TODO: either should be Module, or there - -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration - } deriving (Eq, Data) - --- | Import Item Specification --- --- Describes import info a particular Name -data ImpItemSpec - = ImpAll -- ^ The import had no import list, - -- or had a hiding list - - | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item - } -- ^ The import had an import list. - -- The 'is_explicit' field is @True@ iff the thing was named - -- /explicitly/ in the import specs rather - -- than being imported as part of a "..." group. Consider: - -- - -- > import C( T(..) ) - -- - -- Here the constructors of @T@ are not named explicitly; - -- only @T@ is named explicitly. - deriving (Eq, Data) - -bestImport :: [ImportSpec] -> ImportSpec --- See Note [Choosing the best import declaration] -bestImport iss - = case sortBy best iss of - (is:_) -> is - [] -> pprPanic "bestImport" (ppr iss) - where - best :: ImportSpec -> ImportSpec -> Ordering - -- Less means better - -- Unqualified always wins over qualified; then - -- import-all wins over import-some; then - -- earlier declaration wins over later - best (ImpSpec { is_item = item1, is_decl = d1 }) - (ImpSpec { is_item = item2, is_decl = d2 }) - = (is_qual d1 `compare` is_qual d2) `thenCmp` - (best_item item1 item2) `thenCmp` - SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) - - best_item :: ImpItemSpec -> ImpItemSpec -> Ordering - best_item ImpAll ImpAll = EQ - best_item ImpAll (ImpSome {}) = LT - best_item (ImpSome {}) ImpAll = GT - best_item (ImpSome { is_explicit = e1 }) - (ImpSome { is_explicit = e2 }) = e1 `compare` e2 - -- False < True, so if e1 is explicit and e2 is not, we get GT - -{- Note [Choosing the best import declaration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reporting unused import declarations we use the following rules. - (see [wiki:commentary/compiler/unused-imports]) - -Say that an import-item is either - * an entire import-all decl (eg import Foo), or - * a particular item in an import list (eg import Foo( ..., x, ...)). -The general idea is that for each /occurrence/ of an imported name, we will -attribute that use to one import-item. Once we have processed all the -occurrences, any import items with no uses attributed to them are unused, -and are warned about. More precisely: - -1. For every RdrName in the program text, find its GlobalRdrElt. - -2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one - the "chosen import-item", and mark it "used". This is done - by 'bestImport' - -3. After processing all the RdrNames, bleat about any - import-items that are unused. - This is done in GHC.Rename.Names.warnUnusedImportDecls. - -The function 'bestImport' returns the dominant import among the -ImportSpecs it is given, implementing Step 2. We say import-item A -dominates import-item B if we choose A over B. In general, we try to -choose the import that is most likely to render other imports -unnecessary. Here is the dominance relationship we choose: - - a) import Foo dominates import qualified Foo. - - b) import Foo dominates import Foo(x). - - c) Otherwise choose the textually first one. - -Rationale for (a). Consider - import qualified M -- Import #1 - import M( x ) -- Import #2 - foo = M.x + x - -The unqualified 'x' can only come from import #2. The qualified 'M.x' -could come from either, but bestImport picks import #2, because it is -more likely to be useful in other imports, as indeed it is in this -case (see #5211 for a concrete example). - -But the rules are not perfect; consider - import qualified M -- Import #1 - import M( x ) -- Import #2 - foo = M.x + M.y - -The M.x will use import #2, but M.y can only use import #1. --} - - -unQualSpecOK :: ImportSpec -> Bool --- ^ Is in scope unqualified? -unQualSpecOK is = not (is_qual (is_decl is)) - -qualSpecOK :: ModuleName -> ImportSpec -> Bool --- ^ Is in scope qualified with the given module? -qualSpecOK mod is = mod == is_as (is_decl is) - -importSpecLoc :: ImportSpec -> SrcSpan -importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl -importSpecLoc (ImpSpec _ item) = is_iloc item - -importSpecModule :: ImportSpec -> ModuleName -importSpecModule is = is_mod (is_decl is) - -isExplicitItem :: ImpItemSpec -> Bool -isExplicitItem ImpAll = False -isExplicitItem (ImpSome {is_explicit = exp}) = exp - -pprNameProvenance :: GlobalRdrElt -> SDoc --- ^ Print out one place where the name was define/imported --- (With -dppr-debug, print them all) -pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - = ifPprDebug (vcat pp_provs) - (head pp_provs) - where - pp_provs = pp_lcl ++ map pp_is iss - pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] - else [] - pp_is is = sep [ppr is, ppr_defn_site is name] - --- If we know the exact definition point (which we may do with GHCi) --- then show that too. But not if it's just "imported from X". -ppr_defn_site :: ImportSpec -> Name -> SDoc -ppr_defn_site imp_spec name - | same_module && not (isGoodSrcSpan loc) - = empty -- Nothing interesting to say - | otherwise - = parens $ hang (text "and originally defined" <+> pp_mod) - 2 (pprLoc loc) - where - loc = nameSrcSpan name - defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - same_module = importSpecModule imp_spec == moduleName defining_mod - pp_mod | same_module = empty - | otherwise = text "in" <+> quotes (ppr defining_mod) - - -instance Outputable ImportSpec where - ppr imp_spec - = text "imported" <+> qual - <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) - <+> pprLoc (importSpecLoc imp_spec) - where - qual | is_qual (is_decl imp_spec) = text "qualified" - | otherwise = empty - -pprLoc :: SrcSpan -> SDoc -pprLoc (RealSrcSpan s _) = text "at" <+> ppr s -pprLoc (UnhelpfulSpan {}) = empty - --- | Display info about the treatment of '*' under NoStarIsType. --- --- With StarIsType, three properties of '*' hold: --- --- (a) it is not an infix operator --- (b) it is always in scope --- (c) it is a synonym for Data.Kind.Type --- --- However, the user might not know that he's working on a module with --- NoStarIsType and write code that still assumes (a), (b), and (c), which --- actually do not hold in that module. --- --- Violation of (a) shows up in the parser. For instance, in the following --- examples, we have '*' not applied to enough arguments: --- --- data A :: * --- data F :: * -> * --- --- Violation of (b) or (c) show up in the renamer and the typechecker --- respectively. For instance: --- --- type K = Either * Bool --- --- This will parse differently depending on whether StarIsType is enabled, --- but it will parse nonetheless. With NoStarIsType it is parsed as a type --- operator, thus we have ((*) Either Bool). Now there are two cases to --- consider: --- --- 1. There is no definition of (*) in scope. In this case the renamer will --- fail to look it up. This is a violation of assumption (b). --- --- 2. There is a definition of the (*) type operator in scope (for example --- coming from GHC.TypeNats). In this case the user will get a kind --- mismatch error. This is a violation of assumption (c). --- --- The user might unknowingly be working on a module with NoStarIsType --- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a --- hint whenever an assumption about '*' is violated. Unfortunately, it is --- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). --- --- 'starInfo' generates an appropriate hint to the user depending on the --- extensions enabled in the module and the name that triggered the error. --- That is, if we have NoStarIsType and the error is related to '*' or its --- Unicode variant, the resulting SDoc will contain a helpful suggestion. --- Otherwise it is empty. --- -starInfo :: Bool -> RdrName -> SDoc -starInfo star_is_type rdr_name = - -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to - -- take star_is_type as input? Why not refactor? - -- - -- The reason is that `sdocOption sdocStarIsType` would indicate that - -- StarIsType is enabled in the module that tries to load the problematic - -- definition, not in the module that is being loaded. - -- - -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint - -- must be displayed even if we load this definition from a module (or GHCi) - -- with StarIsType enabled! - -- - if isUnqualStar && not star_is_type - then text "With NoStarIsType, " <> - quotes (ppr rdr_name) <> - text " is treated as a regular type operator. " - $$ - text "Did you mean to use " <> quotes (text "Type") <> - text " from Data.Kind instead?" - else empty - where - -- Does rdr_name look like the user might have meant the '*' kind by it? - -- We focus on unqualified stars specifically, because qualified stars are - -- treated as type operators even under StarIsType. - isUnqualStar - | Unqual occName <- rdr_name - = let fs = occNameFS occName - in fs == fsLit "*" || fs == fsLit "★" - | otherwise = False diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs deleted file mode 100644 index 896168b474..0000000000 --- a/compiler/basicTypes/SrcLoc.hs +++ /dev/null @@ -1,741 +0,0 @@ --- (c) The University of Glasgow, 1992-2006 - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternSynonyms #-} - - --- | This module contains types that relate to the positions of things --- in source files, and allow tagging of those things with locations -module SrcLoc ( - -- * SrcLoc - RealSrcLoc, -- Abstract - SrcLoc(..), - - -- ** Constructing SrcLoc - mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, - - noSrcLoc, -- "I'm sorry, I haven't a clue" - generatedSrcLoc, -- Code generated within the compiler - interactiveSrcLoc, -- Code from an interactive session - - advanceSrcLoc, - advanceBufPos, - - -- ** Unsafely deconstructing SrcLoc - -- These are dubious exports, because they crash on some inputs - srcLocFile, -- return the file name part - srcLocLine, -- return the line part - srcLocCol, -- return the column part - - -- * SrcSpan - RealSrcSpan, -- Abstract - SrcSpan(..), - - -- ** Constructing SrcSpan - mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, - noSrcSpan, - wiredInSrcSpan, -- Something wired into the compiler - interactiveSrcSpan, - srcLocSpan, realSrcLocSpan, - combineSrcSpans, - srcSpanFirstCharacter, - - -- ** Deconstructing SrcSpan - srcSpanStart, srcSpanEnd, - realSrcSpanStart, realSrcSpanEnd, - srcSpanFileName_maybe, - pprUserRealSpan, - - -- ** Unsafely deconstructing SrcSpan - -- These are dubious exports, because they crash on some inputs - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Predicates on SrcSpan - isGoodSrcSpan, isOneLineSpan, - containsSpan, - - -- * StringBuffer locations - BufPos(..), - BufSpan(..), - - -- * Located - Located, - RealLocated, - GenLocated(..), - - -- ** Constructing Located - noLoc, - mkGeneralLocated, - - -- ** Deconstructing Located - getLoc, unLoc, - unRealSrcSpan, getRealSrcSpan, - - -- ** Modifying Located - mapLoc, - - -- ** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost_smallest, - spans, isSubspanOf, isRealSubspanOf, sortLocated, - sortRealLocated, - lookupSrcLoc, lookupSrcSpan, - - liftL, - - -- * Parser locations - PsLoc(..), - PsSpan(..), - PsLocated, - advancePsLoc, - mkPsSpan, - psSpanStart, - psSpanEnd, - mkSrcSpanPs, - - ) where - -import GhcPrelude - -import Util -import Json -import Outputable -import FastString - -import Control.DeepSeq -import Control.Applicative (liftA2) -import Data.Bits -import Data.Data -import Data.List (sortBy, intercalate) -import Data.Function (on) -import qualified Data.Map as Map - -{- -************************************************************************ -* * -\subsection[SrcLoc-SrcLocations]{Source-location information} -* * -************************************************************************ - -We keep information about the {\em definition} point for each entity; -this is the obvious stuff: --} - --- | Real Source Location --- --- Represents a single point within a file -data RealSrcLoc - = SrcLoc FastString -- A precise location (file name) - {-# UNPACK #-} !Int -- line number, begins at 1 - {-# UNPACK #-} !Int -- column number, begins at 1 - deriving (Eq, Ord) - --- | 0-based index identifying the raw location in the StringBuffer. --- --- Unlike 'RealSrcLoc', it is not affected by #line and {-# LINE ... #-} --- pragmas. In particular, notice how 'setSrcLoc' and 'resetAlrLastLoc' in --- Lexer.x update 'PsLoc' preserving 'BufPos'. --- --- The parser guarantees that 'BufPos' are monotonic. See #17632. -newtype BufPos = BufPos { bufPos :: Int } - deriving (Eq, Ord, Show) - --- | Source Location -data SrcLoc - = RealSrcLoc !RealSrcLoc !(Maybe BufPos) -- See Note [Why Maybe BufPos] - | UnhelpfulLoc FastString -- Just a general indication - deriving (Eq, Show) - -{- -************************************************************************ -* * -\subsection[SrcLoc-access-fns]{Access functions} -* * -************************************************************************ --} - -mkSrcLoc :: FastString -> Int -> Int -> SrcLoc -mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing - -mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc -mkRealSrcLoc x line col = SrcLoc x line col - --- | Built-in "bad" 'SrcLoc' values for particular locations -noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc -noSrcLoc = UnhelpfulLoc (fsLit "") -generatedSrcLoc = UnhelpfulLoc (fsLit "") -interactiveSrcLoc = UnhelpfulLoc (fsLit "") - --- | Creates a "bad" 'SrcLoc' that has no detailed information about its location -mkGeneralSrcLoc :: FastString -> SrcLoc -mkGeneralSrcLoc = UnhelpfulLoc - --- | Gives the filename of the 'RealSrcLoc' -srcLocFile :: RealSrcLoc -> FastString -srcLocFile (SrcLoc fname _ _) = fname - --- | Raises an error when used on a "bad" 'SrcLoc' -srcLocLine :: RealSrcLoc -> Int -srcLocLine (SrcLoc _ l _) = l - --- | Raises an error when used on a "bad" 'SrcLoc' -srcLocCol :: RealSrcLoc -> Int -srcLocCol (SrcLoc _ _ c) = c - --- | Move the 'SrcLoc' down by one line if the character is a newline, --- to the next 8-char tabstop if it is a tab, and across by one --- character in any other case -advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc -advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 -advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (advance_tabstop c) -advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) - -advance_tabstop :: Int -> Int -advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1 - -advanceBufPos :: BufPos -> BufPos -advanceBufPos (BufPos i) = BufPos (i+1) - -{- -************************************************************************ -* * -\subsection[SrcLoc-instances]{Instance declarations for various names} -* * -************************************************************************ --} - -sortLocated :: [Located a] -> [Located a] -sortLocated = sortBy (leftmost_smallest `on` getLoc) - -sortRealLocated :: [RealLocated a] -> [RealLocated a] -sortRealLocated = sortBy (compare `on` getLoc) - -lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a -lookupSrcLoc (RealSrcLoc l _) = Map.lookup l -lookupSrcLoc (UnhelpfulLoc _) = const Nothing - -lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a -lookupSrcSpan (RealSrcSpan l _) = Map.lookup l -lookupSrcSpan (UnhelpfulSpan _) = const Nothing - -instance Outputable RealSrcLoc where - ppr (SrcLoc src_path src_line src_col) - = hcat [ pprFastFilePath src_path <> colon - , int src_line <> colon - , int src_col ] - --- I don't know why there is this style-based difference --- if userStyle sty || debugStyle sty then --- hcat [ pprFastFilePath src_path, char ':', --- int src_line, --- char ':', int src_col --- ] --- else --- hcat [text "{-# LINE ", int src_line, space, --- char '\"', pprFastFilePath src_path, text " #-}"] - -instance Outputable SrcLoc where - ppr (RealSrcLoc l _) = ppr l - ppr (UnhelpfulLoc s) = ftext s - -instance Data RealSrcSpan where - -- don't traverse? - toConstr _ = abstractConstr "RealSrcSpan" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "RealSrcSpan" - -instance Data SrcSpan where - -- don't traverse? - toConstr _ = abstractConstr "SrcSpan" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "SrcSpan" - -{- -************************************************************************ -* * -\subsection[SrcSpan]{Source Spans} -* * -************************************************************************ --} - -{- | -A 'RealSrcSpan' delimits a portion of a text file. It could be represented -by a pair of (line,column) coordinates, but in fact we optimise -slightly by using more compact representations for single-line and -zero-length spans, both of which are quite common. - -The end position is defined to be the column /after/ the end of the -span. That is, a span of (1,1)-(1,2) is one character long, and a -span of (1,1)-(1,1) is zero characters long. --} - --- | Real Source Span -data RealSrcSpan - = RealSrcSpan' - { srcSpanFile :: !FastString, - srcSpanSLine :: {-# UNPACK #-} !Int, - srcSpanSCol :: {-# UNPACK #-} !Int, - srcSpanELine :: {-# UNPACK #-} !Int, - srcSpanECol :: {-# UNPACK #-} !Int - } - deriving Eq - --- | StringBuffer Source Span -data BufSpan = - BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } - deriving (Eq, Ord, Show) - --- | Source Span --- --- A 'SrcSpan' identifies either a specific portion of a text file --- or a human-readable description of a location. -data SrcSpan = - RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos] - | UnhelpfulSpan !FastString -- Just a general indication - -- also used to indicate an empty span - - deriving (Eq, Show) -- Show is used by Lexer.x, because we - -- derive Show for Token - -{- Note [Why Maybe BufPos] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan). -Why the Maybe? - -Surely, the lexer can always fill in the buffer position, and it guarantees to do so. -However, sometimes the SrcLoc/SrcSpan is constructed in a different context -where the buffer location is not available, and then we use Nothing instead of -a fake value like BufPos (-1). - -Perhaps the compiler could be re-engineered to pass around BufPos more -carefully and never discard it, and this 'Maybe' could be removed. If you're -interested in doing so, you may find this ripgrep query useful: - - rg "RealSrc(Loc|Span).*?Nothing" - -For example, it is not uncommon to whip up source locations for e.g. error -messages, constructing a SrcSpan without a BufSpan. --} - -instance ToJson SrcSpan where - json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] - json (RealSrcSpan rss _) = json rss - -instance ToJson RealSrcSpan where - json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) - , ("startLine", JSInt srcSpanSLine) - , ("startCol", JSInt srcSpanSCol) - , ("endLine", JSInt srcSpanELine) - , ("endCol", JSInt srcSpanECol) - ] - -instance NFData SrcSpan where - rnf x = x `seq` () - --- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty -noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan -noSrcSpan = UnhelpfulSpan (fsLit "") -wiredInSrcSpan = UnhelpfulSpan (fsLit "") -interactiveSrcSpan = UnhelpfulSpan (fsLit "") - --- | Create a "bad" 'SrcSpan' that has not location information -mkGeneralSrcSpan :: FastString -> SrcSpan -mkGeneralSrcSpan = UnhelpfulSpan - --- | Create a 'SrcSpan' corresponding to a single point -srcLocSpan :: SrcLoc -> SrcSpan -srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str -srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb) - -realSrcLocSpan :: RealSrcLoc -> RealSrcSpan -realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col - --- | Create a 'SrcSpan' between two points in a file -mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan -mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 - where - line1 = srcLocLine loc1 - line2 = srcLocLine loc2 - col1 = srcLocCol loc1 - col2 = srcLocCol loc2 - file = srcLocFile loc1 - --- | 'True' if the span is known to straddle only one line. -isOneLineRealSpan :: RealSrcSpan -> Bool -isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) - = line1 == line2 - --- | 'True' if the span is a single point -isPointRealSpan :: RealSrcSpan -> Bool -isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) - = line1 == line2 && col1 == col2 - --- | Create a 'SrcSpan' between two points in a file -mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan -mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str -mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str -mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) - = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2) - --- | Combines two 'SrcSpan' into one that spans at least all the characters --- within both spans. Returns UnhelpfulSpan if the files differ. -combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan -combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful -combineSrcSpans l (UnhelpfulSpan _) = l -combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) - | srcSpanFile span1 == srcSpanFile span2 - = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) - | otherwise = UnhelpfulSpan (fsLit "") - --- | Combines two 'SrcSpan' into one that spans at least all the characters --- within both spans. Assumes the "file" part is the same in both inputs -combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan -combineRealSrcSpans span1 span2 - = RealSrcSpan' file line_start col_start line_end col_end - where - (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) - (srcSpanStartLine span2, srcSpanStartCol span2) - (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) - (srcSpanEndLine span2, srcSpanEndCol span2) - file = srcSpanFile span1 - -combineBufSpans :: BufSpan -> BufSpan -> BufSpan -combineBufSpans span1 span2 = BufSpan start end - where - start = min (bufSpanStart span1) (bufSpanStart span2) - end = max (bufSpanEnd span1) (bufSpanEnd span2) - - --- | Convert a SrcSpan into one that represents only its first character -srcSpanFirstCharacter :: SrcSpan -> SrcSpan -srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l -srcSpanFirstCharacter (RealSrcSpan span mbspan) = - RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) - where - loc1@(SrcLoc f l c) = realSrcSpanStart span - loc2 = SrcLoc f l (c+1) - mkBufSpan bspan = - let bpos1@(BufPos i) = bufSpanStart bspan - bpos2 = BufPos (i+1) - in BufSpan bpos1 bpos2 - -{- -************************************************************************ -* * -\subsection[SrcSpan-predicates]{Predicates} -* * -************************************************************************ --} - --- | Test if a 'SrcSpan' is "good", i.e. has precise location information -isGoodSrcSpan :: SrcSpan -> Bool -isGoodSrcSpan (RealSrcSpan _ _) = True -isGoodSrcSpan (UnhelpfulSpan _) = False - -isOneLineSpan :: SrcSpan -> Bool --- ^ True if the span is known to straddle only one line. --- For "bad" 'SrcSpan', it returns False -isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s -isOneLineSpan (UnhelpfulSpan _) = False - --- | Tests whether the first span "contains" the other span, meaning --- that it covers at least as much source code. True where spans are equal. -containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool -containsSpan s1 s2 - = (srcSpanStartLine s1, srcSpanStartCol s1) - <= (srcSpanStartLine s2, srcSpanStartCol s2) - && (srcSpanEndLine s1, srcSpanEndCol s1) - >= (srcSpanEndLine s2, srcSpanEndCol s2) - && (srcSpanFile s1 == srcSpanFile s2) - -- We check file equality last because it is (presumably?) least - -- likely to fail. -{- -%************************************************************************ -%* * -\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} -* * -************************************************************************ --} - -srcSpanStartLine :: RealSrcSpan -> Int -srcSpanEndLine :: RealSrcSpan -> Int -srcSpanStartCol :: RealSrcSpan -> Int -srcSpanEndCol :: RealSrcSpan -> Int - -srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l -srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l -srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l -srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c - -{- -************************************************************************ -* * -\subsection[SrcSpan-access-fns]{Access functions} -* * -************************************************************************ --} - --- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable -srcSpanStart :: SrcSpan -> SrcLoc -srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) - --- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable -srcSpanEnd :: SrcSpan -> SrcLoc -srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) - -realSrcSpanStart :: RealSrcSpan -> RealSrcLoc -realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) - (srcSpanStartLine s) - (srcSpanStartCol s) - -realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc -realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) - (srcSpanEndLine s) - (srcSpanEndCol s) - --- | Obtains the filename for a 'SrcSpan' if it is "good" -srcSpanFileName_maybe :: SrcSpan -> Maybe FastString -srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) -srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing - -{- -************************************************************************ -* * -\subsection[SrcSpan-instances]{Instances} -* * -************************************************************************ --} - --- We want to order RealSrcSpans first by the start point, then by the --- end point. -instance Ord RealSrcSpan where - a `compare` b = - (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` - (realSrcSpanEnd a `compare` realSrcSpanEnd b) - -instance Show RealSrcLoc where - show (SrcLoc filename row col) - = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col - --- Show is used by Lexer.x, because we derive Show for Token -instance Show RealSrcSpan where - show span@(RealSrcSpan' file sl sc el ec) - | isPointRealSpan span - = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) - - | isOneLineRealSpan span - = "SrcSpanOneLine " ++ show file ++ " " - ++ intercalate " " (map show [sl,sc,ec]) - - | otherwise - = "SrcSpanMultiLine " ++ show file ++ " " - ++ intercalate " " (map show [sl,sc,el,ec]) - - -instance Outputable RealSrcSpan where - ppr span = pprUserRealSpan True span - --- I don't know why there is this style-based difference --- = getPprStyle $ \ sty -> --- if userStyle sty || debugStyle sty then --- text (showUserRealSpan True span) --- else --- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, --- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] - -instance Outputable SrcSpan where - ppr span = pprUserSpan True span - --- I don't know why there is this style-based difference --- = getPprStyle $ \ sty -> --- if userStyle sty || debugStyle sty then --- pprUserSpan True span --- else --- case span of --- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" --- RealSrcSpan s -> ppr s - -pprUserSpan :: Bool -> SrcSpan -> SDoc -pprUserSpan _ (UnhelpfulSpan s) = ftext s -pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s - -pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc -pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) - | isPointRealSpan span - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , int line <> colon - , int col ] - -pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) - | isOneLineRealSpan span - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , int line <> colon - , int scol - , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] - -- For single-character or point spans, we just - -- output the starting column number - -pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , parens (int sline <> comma <> int scol) - , char '-' - , parens (int eline <> comma <> int ecol') ] - where - ecol' = if ecol == 0 then ecol else ecol - 1 - -{- -************************************************************************ -* * -\subsection[Located]{Attaching SrcSpans to things} -* * -************************************************************************ --} - --- | We attach SrcSpans to lots of things, so let's have a datatype for it. -data GenLocated l e = L l e - deriving (Eq, Ord, Data, Functor, Foldable, Traversable) - -type Located = GenLocated SrcSpan -type RealLocated = GenLocated RealSrcSpan - -mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b -mapLoc = fmap - -unLoc :: GenLocated l e -> e -unLoc (L _ e) = e - -getLoc :: GenLocated l e -> l -getLoc (L l _) = l - -noLoc :: e -> Located e -noLoc e = L noSrcSpan e - -mkGeneralLocated :: String -> e -> Located e -mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e - -combineLocs :: Located a -> Located b -> SrcSpan -combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) - --- | Combine locations from two 'Located' things and add them to a third thing -addCLoc :: Located a -> Located b -> c -> Located c -addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c - --- not clear whether to add a general Eq instance, but this is useful sometimes: - --- | Tests whether the two located things are equal -eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool -eqLocated a b = unLoc a == unLoc b - --- not clear whether to add a general Ord instance, but this is useful sometimes: - --- | Tests the ordering of the two located things -cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering -cmpLocated a b = unLoc a `compare` unLoc b - -instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where - ppr (L l e) = -- TODO: We can't do this since Located was refactored into - -- GenLocated: - -- Print spans without the file name etc - -- ifPprDebug (braces (pprUserSpan False l)) - whenPprDebug (braces (ppr l)) - $$ ppr e - -{- -************************************************************************ -* * -\subsection{Ordering SrcSpans for InteractiveUI} -* * -************************************************************************ --} - --- | Strategies for ordering 'SrcSpan's -leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering -rightmost_smallest = compareSrcSpanBy (flip compare) -leftmost_smallest = compareSrcSpanBy compare -leftmost_largest = compareSrcSpanBy $ \a b -> - (realSrcSpanStart a `compare` realSrcSpanStart b) - `thenCmp` - (realSrcSpanEnd b `compare` realSrcSpanEnd a) - -compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering -compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b -compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT -compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT -compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ - --- | Determines whether a span encloses a given line and column index -spans :: SrcSpan -> (Int, Int) -> Bool -spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" -spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span - where loc = mkRealSrcLoc (srcSpanFile span) l c - --- | Determines whether a span is enclosed by another one -isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other - -> SrcSpan -- ^ The span it may be enclosed by - -> Bool -isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent -isSubspanOf _ _ = False - --- | Determines whether a span is enclosed by another one -isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other - -> RealSrcSpan -- ^ The span it may be enclosed by - -> Bool -isRealSubspanOf src parent - | srcSpanFile parent /= srcSpanFile src = False - | otherwise = realSrcSpanStart parent <= realSrcSpanStart src && - realSrcSpanEnd parent >= realSrcSpanEnd src - -liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) -liftL f (L loc a) = do - a' <- f a - return $ L loc a' - -getRealSrcSpan :: RealLocated a -> RealSrcSpan -getRealSrcSpan (L l _) = l - -unRealSrcSpan :: RealLocated a -> a -unRealSrcSpan (L _ e) = e - - --- | A location as produced by the parser. Consists of two components: --- --- * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc) --- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632) -data PsLoc - = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos } - deriving (Eq, Ord, Show) - -data PsSpan - = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } - deriving (Eq, Ord, Show) - -type PsLocated = GenLocated PsSpan - -advancePsLoc :: PsLoc -> Char -> PsLoc -advancePsLoc (PsLoc real_loc buf_loc) c = - PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc) - -mkPsSpan :: PsLoc -> PsLoc -> PsSpan -mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2) - -psSpanStart :: PsSpan -> PsLoc -psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b) - -psSpanEnd :: PsSpan -> PsLoc -psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) - -mkSrcSpanPs :: PsSpan -> SrcSpan -mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b) diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs deleted file mode 100644 index fb321454aa..0000000000 --- a/compiler/basicTypes/UniqSupply.hs +++ /dev/null @@ -1,224 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE BangPatterns #-} - -#if !defined(GHC_LOADED_INTO_GHCI) -{-# LANGUAGE UnboxedTuples #-} -#endif - -module UniqSupply ( - -- * Main data type - UniqSupply, -- Abstractly - - -- ** Operations on supplies - uniqFromSupply, uniqsFromSupply, -- basic ops - takeUniqFromSupply, uniqFromMask, - - mkSplitUniqSupply, - splitUniqSupply, listSplitUniqSupply, - - -- * Unique supply monad and its abstraction - UniqSM, MonadUnique(..), - - -- ** Operations on the monad - initUs, initUs_, - - -- * Set supply strategy - initUniqSupply - ) where - -import GhcPrelude - -import Unique -import PlainPanic (panic) - -import GHC.IO - -import MonadUtils -import Control.Monad -import Data.Bits -import Data.Char -import Control.Monad.Fail as Fail - -#include "Unique.h" - -{- -************************************************************************ -* * -\subsection{Splittable Unique supply: @UniqSupply@} -* * -************************************************************************ --} - --- | Unique Supply --- --- A value of type 'UniqSupply' is unique, and it can --- supply /one/ distinct 'Unique'. Also, from the supply, one can --- also manufacture an arbitrary number of further 'UniqueSupply' values, --- which will be distinct from the first and from all others. -data UniqSupply - = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this - UniqSupply UniqSupply - -- when split => these two supplies - -mkSplitUniqSupply :: Char -> IO UniqSupply --- ^ Create a unique supply out of thin air. The character given must --- be distinct from those of all calls to this function in the compiler --- for the values generated to be truly unique. - -splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) --- ^ Build two 'UniqSupply' from a single one, each of which --- can supply its own 'Unique'. -listSplitUniqSupply :: UniqSupply -> [UniqSupply] --- ^ Create an infinite list of 'UniqSupply' from a single one -uniqFromSupply :: UniqSupply -> Unique --- ^ Obtain the 'Unique' from this particular 'UniqSupply' -uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite --- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply -takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) --- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply - -uniqFromMask :: Char -> IO Unique -uniqFromMask mask - = do { uqNum <- genSym - ; return $! mkUnique mask uqNum } - -mkSplitUniqSupply c - = case ord c `shiftL` uNIQUE_BITS of - !mask -> let - -- here comes THE MAGIC: - - -- This is one of the most hammered bits in the whole compiler - mk_supply - -- NB: Use unsafeInterleaveIO for thread-safety. - = unsafeInterleaveIO ( - genSym >>= \ u -> - mk_supply >>= \ s1 -> - mk_supply >>= \ s2 -> - return (MkSplitUniqSupply (mask .|. u) s1 s2) - ) - in - mk_supply - -foreign import ccall unsafe "genSym" genSym :: IO Int -foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO () - -splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) -listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 - -uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n -uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 -takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) - -{- -************************************************************************ -* * -\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} -* * -************************************************************************ --} - --- Avoids using unboxed tuples when loading into GHCi -#if !defined(GHC_LOADED_INTO_GHCI) - -type UniqResult result = (# result, UniqSupply #) - -pattern UniqResult :: a -> b -> (# a, b #) -pattern UniqResult x y = (# x, y #) -{-# COMPLETE UniqResult #-} - -#else - -data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply - deriving (Functor) - -#endif - --- | A monad which just gives the ability to obtain 'Unique's -newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } - deriving (Functor) - -instance Monad UniqSM where - (>>=) = thenUs - (>>) = (*>) - -instance Applicative UniqSM where - pure = returnUs - (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of - UniqResult ff us1 -> case x us1 of - UniqResult xx us2 -> UniqResult (ff xx) us2 - (*>) = thenUs_ - --- TODO: try to get rid of this instance -instance Fail.MonadFail UniqSM where - fail = panic - --- | Run the 'UniqSM' action, returning the final 'UniqSupply' -initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) -initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) } - --- | Run the 'UniqSM' action, discarding the final 'UniqSupply' -initUs_ :: UniqSupply -> UniqSM a -> a -initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } - -{-# INLINE thenUs #-} -{-# INLINE returnUs #-} -{-# INLINE splitUniqSupply #-} - --- @thenUs@ is where we split the @UniqSupply@. - -liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) -liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) - -instance MonadFix UniqSM where - mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) - -thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -thenUs (USM expr) cont - = USM (\us0 -> case (expr us0) of - UniqResult result us1 -> unUSM (cont result) us1) - -thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b -thenUs_ (USM expr) (USM cont) - = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 }) - -returnUs :: a -> UniqSM a -returnUs result = USM (\us -> UniqResult result us) - -getUs :: UniqSM UniqSupply -getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) - --- | A monad for generating unique identifiers -class Monad m => MonadUnique m where - -- | Get a new UniqueSupply - getUniqueSupplyM :: m UniqSupply - -- | Get a new unique identifier - getUniqueM :: m Unique - -- | Get an infinite list of new unique identifiers - getUniquesM :: m [Unique] - - -- This default definition of getUniqueM, while correct, is not as - -- efficient as it could be since it needlessly generates and throws away - -- an extra Unique. For your instances consider providing an explicit - -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. - getUniqueM = liftM uniqFromSupply getUniqueSupplyM - getUniquesM = liftM uniqsFromSupply getUniqueSupplyM - -instance MonadUnique UniqSM where - getUniqueSupplyM = getUs - getUniqueM = getUniqueUs - getUniquesM = getUniquesUs - -getUniqueUs :: UniqSM Unique -getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of - (u,us1) -> UniqResult u us1) - -getUniquesUs :: UniqSM [Unique] -getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of - (us1,us2) -> UniqResult (uniqsFromSupply us1) us2) diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs deleted file mode 100644 index f6f46914f0..0000000000 --- a/compiler/basicTypes/Unique.hs +++ /dev/null @@ -1,448 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -@Uniques@ are used to distinguish entities in the compiler (@Ids@, -@Classes@, etc.) from each other. Thus, @Uniques@ are the basic -comparison key in the compiler. - -If there is any single operation that needs to be fast, it is @Unique@ - -comparison. Unsurprisingly, there is quite a bit of huff-and-puff -directed to that end. - -Some of the other hair in this code is to be able to use a -``splittable @UniqueSupply@'' if requested/possible (not standard -Haskell). --} - -{-# LANGUAGE CPP, BangPatterns, MagicHash #-} - -module Unique ( - -- * Main data types - Unique, Uniquable(..), - uNIQUE_BITS, - - -- ** Constructors, destructors and operations on 'Unique's - hasKey, - - pprUniqueAlways, - - mkUniqueGrimily, -- Used in UniqSupply only! - getKey, -- Used in Var, UniqFM, Name only! - mkUnique, unpkUnique, -- Used in GHC.Iface.Binary only - eqUnique, ltUnique, - incrUnique, - - newTagUnique, -- Used in CgCase - initTyVarUnique, - initExitJoinUnique, - nonDetCmpUnique, - isValidKnownKeyUnique, -- Used in PrelInfo.knownKeyNamesOkay - - -- ** Making built-in uniques - - -- now all the built-in Uniques (and functions to make them) - -- [the Oh-So-Wonderful Haskell module system wins again...] - mkAlphaTyVarUnique, - mkPrimOpIdUnique, mkPrimOpWrapperUnique, - mkPreludeMiscIdUnique, mkPreludeDataConUnique, - mkPreludeTyConUnique, mkPreludeClassUnique, - mkCoVarUnique, - - mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, - mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, - mkCostCentreUnique, - - mkBuiltinUnique, - mkPseudoUniqueD, - mkPseudoUniqueE, - mkPseudoUniqueH, - - -- ** Deriving uniques - -- *** From TyCon name uniques - tyConRepNameUnique, - -- *** From DataCon name uniques - dataConWorkerUnique, dataConTyRepNameUnique, - - -- ** Local uniques - -- | These are exposed exclusively for use by 'VarEnv.uniqAway', which - -- has rather peculiar needs. See Note [Local uniques]. - mkLocalUnique, minLocalUnique, maxLocalUnique - ) where - -#include "HsVersions.h" -#include "Unique.h" - -import GhcPrelude - -import BasicTypes -import FastString -import Outputable -import Util - --- just for implementing a fast [0,61) -> Char function -import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) - -import Data.Char ( chr, ord ) -import Data.Bits - -{- -************************************************************************ -* * -\subsection[Unique-type]{@Unique@ type and operations} -* * -************************************************************************ - -The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. -Fast comparison is everything on @Uniques@: --} - --- | Unique identifier. --- --- The type of unique identifiers that are used in many places in GHC --- for fast ordering and equality tests. You should generate these with --- the functions from the 'UniqSupply' module --- --- These are sometimes also referred to as \"keys\" in comments in GHC. -newtype Unique = MkUnique Int - -{-# INLINE uNIQUE_BITS #-} -uNIQUE_BITS :: Int -uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS - -{- -Now come the functions which construct uniques from their pieces, and vice versa. -The stuff about unique *supplies* is handled further down this module. --} - -unpkUnique :: Unique -> (Char, Int) -- The reverse - -mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply -getKey :: Unique -> Int -- for Var - -incrUnique :: Unique -> Unique -stepUnique :: Unique -> Int -> Unique -newTagUnique :: Unique -> Char -> Unique - -mkUniqueGrimily = MkUnique - -{-# INLINE getKey #-} -getKey (MkUnique x) = x - -incrUnique (MkUnique i) = MkUnique (i + 1) -stepUnique (MkUnique i) n = MkUnique (i + n) - -mkLocalUnique :: Int -> Unique -mkLocalUnique i = mkUnique 'X' i - -minLocalUnique :: Unique -minLocalUnique = mkLocalUnique 0 - -maxLocalUnique :: Unique -maxLocalUnique = mkLocalUnique uniqueMask - --- newTagUnique changes the "domain" of a unique to a different char -newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u - --- | How many bits are devoted to the unique index (as opposed to the class --- character). -uniqueMask :: Int -uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 - --- pop the Char in the top 8 bits of the Unique(Supply) - --- No 64-bit bugs here, as long as we have at least 32 bits. --JSM - --- and as long as the Char fits in 8 bits, which we assume anyway! - -mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces --- NOT EXPORTED, so that we can see all the Chars that --- are used in this one module -mkUnique c i - = MkUnique (tag .|. bits) - where - tag = ord c `shiftL` uNIQUE_BITS - bits = i .&. uniqueMask - -unpkUnique (MkUnique u) - = let - -- as long as the Char may have its eighth bit set, we - -- really do need the logical right-shift here! - tag = chr (u `shiftR` uNIQUE_BITS) - i = u .&. uniqueMask - in - (tag, i) - --- | The interface file symbol-table encoding assumes that known-key uniques fit --- in 30-bits; verify this. --- --- See Note [Symbol table representation of names] in GHC.Iface.Binary for details. -isValidKnownKeyUnique :: Unique -> Bool -isValidKnownKeyUnique u = - case unpkUnique u of - (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) - -{- -************************************************************************ -* * -\subsection[Uniquable-class]{The @Uniquable@ class} -* * -************************************************************************ --} - --- | Class of things that we can obtain a 'Unique' from -class Uniquable a where - getUnique :: a -> Unique - -hasKey :: Uniquable a => a -> Unique -> Bool -x `hasKey` k = getUnique x == k - -instance Uniquable FastString where - getUnique fs = mkUniqueGrimily (uniqueOfFS fs) - -instance Uniquable Int where - getUnique i = mkUniqueGrimily i - -{- -************************************************************************ -* * -\subsection[Unique-instances]{Instance declarations for @Unique@} -* * -************************************************************************ - -And the whole point (besides uniqueness) is fast equality. We don't -use `deriving' because we want {\em precise} control of ordering -(equality on @Uniques@ is v common). --} - --- Note [Unique Determinism] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- The order of allocated @Uniques@ is not stable across rebuilds. --- The main reason for that is that typechecking interface files pulls --- @Uniques@ from @UniqSupply@ and the interface file for the module being --- currently compiled can, but doesn't have to exist. --- --- It gets more complicated if you take into account that the interface --- files are loaded lazily and that building multiple files at once has to --- work for any subset of interface files present. When you add parallelism --- this makes @Uniques@ hopelessly random. --- --- As such, to get deterministic builds, the order of the allocated --- @Uniques@ should not affect the final result. --- see also wiki/deterministic-builds --- --- Note [Unique Determinism and code generation] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The goal of the deterministic builds (wiki/deterministic-builds, #4012) --- is to get ABI compatible binaries given the same inputs and environment. --- The motivation behind that is that if the ABI doesn't change the --- binaries can be safely reused. --- Note that this is weaker than bit-for-bit identical binaries and getting --- bit-for-bit identical binaries is not a goal for now. --- This means that we don't care about nondeterminism that happens after --- the interface files are created, in particular we don't care about --- register allocation and code generation. --- To track progress on bit-for-bit determinism see #12262. - -eqUnique :: Unique -> Unique -> Bool -eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 - -ltUnique :: Unique -> Unique -> Bool -ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 - --- Provided here to make it explicit at the call-site that it can --- introduce non-determinism. --- See Note [Unique Determinism] --- See Note [No Ord for Unique] -nonDetCmpUnique :: Unique -> Unique -> Ordering -nonDetCmpUnique (MkUnique u1) (MkUnique u2) - = if u1 == u2 then EQ else if u1 < u2 then LT else GT - -{- -Note [No Ord for Unique] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Unique Determinism] the relative order of Uniques -is nondeterministic. To prevent from accidental use the Ord Unique -instance has been removed. -This makes it easier to maintain deterministic builds, but comes with some -drawbacks. -The biggest drawback is that Maps keyed by Uniques can't directly be used. -The alternatives are: - - 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which - 2) Create a newtype wrapper based on Unique ordering where nondeterminism - is controlled. See Module.ModuleEnv - 3) Change the algorithm to use nonDetCmpUnique and document why it's still - deterministic - 4) Use TrieMap as done in GHC.Cmm.CommonBlockElim.groupByLabel --} - -instance Eq Unique where - a == b = eqUnique a b - a /= b = not (eqUnique a b) - -instance Uniquable Unique where - getUnique u = u - --- We do sometimes make strings with @Uniques@ in them: - -showUnique :: Unique -> String -showUnique uniq - = case unpkUnique uniq of - (tag, u) -> finish_show tag u (iToBase62 u) - -finish_show :: Char -> Int -> String -> String -finish_show 't' u _pp_u | u < 26 - = -- Special case to make v common tyvars, t1, t2, ... - -- come out as a, b, ... (shorter, easier to read) - [chr (ord 'a' + u)] -finish_show tag _ pp_u = tag : pp_u - -pprUniqueAlways :: Unique -> SDoc --- The "always" means regardless of -dsuppress-uniques --- It replaces the old pprUnique to remind callers that --- they should consider whether they want to consult --- Opt_SuppressUniques -pprUniqueAlways u - = text (showUnique u) - -instance Outputable Unique where - ppr = pprUniqueAlways - -instance Show Unique where - show uniq = showUnique uniq - -{- -************************************************************************ -* * -\subsection[Utils-base62]{Base-62 numbers} -* * -************************************************************************ - -A character-stingy way to read/write numbers (notably Uniques). -The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. -Code stolen from Lennart. --} - -iToBase62 :: Int -> String -iToBase62 n_ - = ASSERT(n_ >= 0) go n_ "" - where - go n cs | n < 62 - = let !c = chooseChar62 n in c : cs - | otherwise - = go q (c : cs) where (!q, r) = quotRem n 62 - !c = chooseChar62 r - - chooseChar62 :: Int -> Char - {-# INLINE chooseChar62 #-} - chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) - chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# - -{- -************************************************************************ -* * -\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} -* * -************************************************************************ - -Allocation of unique supply characters: - v,t,u : for renumbering value-, type- and usage- vars. - B: builtin - C-E: pseudo uniques (used in native-code generator) - X: uniques from mkLocalUnique - _: unifiable tyvars (above) - 0-9: prelude things below - (no numbers left any more..) - :: (prelude) parallel array data constructors - - other a-z: lower case chars for unique supplies. Used so far: - - d desugarer - f AbsC flattener - g SimplStg - k constraint tuple tycons - m constraint tuple datacons - n Native codegen - r Hsc name cache - s simplifier - z anonymous sums --} - -mkAlphaTyVarUnique :: Int -> Unique -mkPreludeClassUnique :: Int -> Unique -mkPreludeTyConUnique :: Int -> Unique -mkPreludeDataConUnique :: Arity -> Unique -mkPrimOpIdUnique :: Int -> Unique --- See Note [Primop wrappers] in PrimOp.hs. -mkPrimOpWrapperUnique :: Int -> Unique -mkPreludeMiscIdUnique :: Int -> Unique -mkCoVarUnique :: Int -> Unique - -mkAlphaTyVarUnique i = mkUnique '1' i -mkCoVarUnique i = mkUnique 'g' i -mkPreludeClassUnique i = mkUnique '2' i - --------------------------------------------------- --- Wired-in type constructor keys occupy *two* slots: --- * u: the TyCon itself --- * u+1: the TyConRepName of the TyCon -mkPreludeTyConUnique i = mkUnique '3' (2*i) - -tyConRepNameUnique :: Unique -> Unique -tyConRepNameUnique u = incrUnique u - --------------------------------------------------- --- Wired-in data constructor keys occupy *three* slots: --- * u: the DataCon itself --- * u+1: its worker Id --- * u+2: the TyConRepName of the promoted TyCon --- Prelude data constructors are too simple to need wrappers. - -mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic - --------------------------------------------------- -dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique -dataConWorkerUnique u = incrUnique u -dataConTyRepNameUnique u = stepUnique u 2 - --------------------------------------------------- -mkPrimOpIdUnique op = mkUnique '9' (2*op) -mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1) -mkPreludeMiscIdUnique i = mkUnique '0' i - --- The "tyvar uniques" print specially nicely: a, b, c, etc. --- See pprUnique for details - -initTyVarUnique :: Unique -initTyVarUnique = mkUnique 't' 0 - -mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, - mkBuiltinUnique :: Int -> Unique - -mkBuiltinUnique i = mkUnique 'B' i -mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs -mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs -mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs - -mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique -mkRegSingleUnique = mkUnique 'R' -mkRegSubUnique = mkUnique 'S' -mkRegPairUnique = mkUnique 'P' -mkRegClassUnique = mkUnique 'L' - -mkCostCentreUnique :: Int -> Unique -mkCostCentreUnique = mkUnique 'C' - -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique --- See Note [The Unique of an OccName] in OccName -mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) -mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) -mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) -mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) - -initExitJoinUnique :: Unique -initExitJoinUnique = mkUnique 's' 0 - diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs deleted file mode 100644 index c8dd8f11a0..0000000000 --- a/compiler/basicTypes/Var.hs +++ /dev/null @@ -1,763 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{@Vars@: Variables} --} - -{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally --- potentially contain type variables, which have a 'GHC.Core.TyCo.Rep.Kind' --- rather than a 'GHC.Core.TyCo.Rep.Type' and only contain some extra --- details during typechecking. --- --- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" --- --- #globalvslocal# --- Global 'Id's and 'Var's are those that are imported or correspond --- to a data constructor, primitive operation, or record selectors. --- Local 'Id's and 'Var's are those bound within an expression --- (e.g. by a lambda) or at the top level of the module being compiled. - -module Var ( - -- * The main data type and synonyms - Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, - TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, - - -- * In and Out variants - InVar, InCoVar, InId, InTyVar, - OutVar, OutCoVar, OutId, OutTyVar, - - -- ** Taking 'Var's apart - varName, varUnique, varType, - - -- ** Modifying 'Var's - setVarName, setVarUnique, setVarType, updateVarType, - updateVarTypeM, - - -- ** Constructing, taking apart, modifying 'Id's - mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, - idInfo, idDetails, - lazySetIdInfo, setIdDetails, globaliseId, - setIdExported, setIdNotExported, - - -- ** Predicates - isId, isTyVar, isTcTyVar, - isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, - isGlobalId, isExportedId, - mustHaveLocalBinding, - - -- * ArgFlags - ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis, - AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag, - - -- * TyVar's - VarBndr(..), TyCoVarBinder, TyVarBinder, - binderVar, binderVars, binderArgFlag, binderType, - mkTyCoVarBinder, mkTyCoVarBinders, - mkTyVarBinder, mkTyVarBinders, - isTyVarBinder, - - -- ** Constructing TyVar's - mkTyVar, mkTcTyVar, - - -- ** Taking 'TyVar's apart - tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, - - -- ** Modifying 'TyVar's - setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, - updateTyVarKindM, - - nonDetCmpVar - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind ) -import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) -import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) -import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, - vanillaIdInfo, pprIdDetails ) - -import Name hiding (varName) -import Unique ( Uniquable, Unique, getKey, getUnique - , mkUniqueGrimily, nonDetCmpUnique ) -import Util -import Binary -import Outputable - -import Data.Data - -{- -************************************************************************ -* * - Synonyms -* * -************************************************************************ --- These synonyms are here and not in Id because otherwise we need a very --- large number of SOURCE imports of Id.hs :-( --} - --- | Identifier -type Id = Var -- A term-level identifier - -- predicate: isId - --- | Coercion Variable -type CoVar = Id -- See Note [Evidence: EvIds and CoVars] - -- predicate: isCoVar - --- | -type NcId = Id -- A term-level (value) variable that is - -- /not/ an (unlifted) coercion - -- predicate: isNonCoVarId - --- | Type or kind Variable -type TyVar = Var -- Type *or* kind variable (historical) - --- | Type or Kind Variable -type TKVar = Var -- Type *or* kind variable (historical) - --- | Type variable that might be a metavariable -type TcTyVar = Var - --- | Type Variable -type TypeVar = Var -- Definitely a type variable - --- | Kind Variable -type KindVar = Var -- Definitely a kind variable - -- See Note [Kind and type variables] - --- See Note [Evidence: EvIds and CoVars] --- | Evidence Identifier -type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar - --- | Evidence Variable -type EvVar = EvId -- ...historical name for EvId - --- | Dictionary Function Identifier -type DFunId = Id -- A dictionary function - --- | Dictionary Identifier -type DictId = EvId -- A dictionary variable - --- | Implicit parameter Identifier -type IpId = EvId -- A term-level implicit parameter - --- | Equality Variable -type EqVar = EvId -- Boxed equality evidence -type JoinId = Id -- A join variable - --- | Type or Coercion Variable -type TyCoVar = Id -- Type, *or* coercion variable - -- predicate: isTyCoVar - - -{- Many passes apply a substitution, and it's very handy to have type - synonyms to remind us whether or not the substitution has been applied -} - -type InVar = Var -type InTyVar = TyVar -type InCoVar = CoVar -type InId = Id -type OutVar = Var -type OutTyVar = TyVar -type OutCoVar = CoVar -type OutId = Id - - - -{- Note [Evidence: EvIds and CoVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* An EvId (evidence Id) is a term-level evidence variable - (dictionary, implicit parameter, or equality). Could be boxed or unboxed. - -* DictId, IpId, and EqVar are synonyms when we know what kind of - evidence we are talking about. For example, an EqVar has type (t1 ~ t2). - -* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) - -Note [Kind and type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before kind polymorphism, TyVar were used to mean type variables. Now -they are used to mean kind *or* type variables. KindVar is used when we -know for sure that it is a kind variable. In future, we might want to -go over the whole compiler code to use: - - TKVar to mean kind or type variables - - TypeVar to mean type variables only - - KindVar to mean kind variables - - -************************************************************************ -* * -\subsection{The main data type declarations} -* * -************************************************************************ - - -Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a -@Type@, and an @IdInfo@ (non-essential info about it, e.g., -strictness). The essential info about different kinds of @Vars@ is -in its @VarDetails@. --} - --- | Variable --- --- Essentially a typed 'Name', that may also contain some additional information --- about the 'Var' and its use sites. -data Var - = TyVar { -- Type and kind variables - -- see Note [Kind and type variables] - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - -- ^ Key for fast comparison - -- Identical to the Unique in the name, - -- cached here for speed - varType :: Kind -- ^ The type or kind of the 'Var' in question - } - - | TcTyVar { -- Used only during type inference - -- Used for kind variables during - -- inference, as well - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - varType :: Kind, - tc_tv_details :: TcTyVarDetails - } - - | Id { - varName :: !Name, - realUnique :: {-# UNPACK #-} !Int, - varType :: Type, - idScope :: IdScope, - id_details :: IdDetails, -- Stable, doesn't change - id_info :: IdInfo } -- Unstable, updated by simplifier - --- | Identifier Scope -data IdScope -- See Note [GlobalId/LocalId] - = GlobalId - | LocalId ExportFlag - -data ExportFlag -- See Note [ExportFlag on binders] - = NotExported -- ^ Not exported: may be discarded as dead code. - | Exported -- ^ Exported: kept alive - -{- Note [ExportFlag on binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An ExportFlag of "Exported" on a top-level binder says "keep this -binding alive; do not drop it as dead code". This transitively -keeps alive all the other top-level bindings that this binding refers -to. This property is persisted all the way down the pipeline, so that -the binding will be compiled all the way to object code, and its -symbols will appear in the linker symbol table. - -However, note that this use of "exported" is quite different to the -export list on a Haskell module. Setting the ExportFlag on an Id does -/not/ mean that if you import the module (in Haskell source code) you -will see this Id. Of course, things that appear in the export list -of the source Haskell module do indeed have their ExportFlag set. -But many other things, such as dictionary functions, are kept alive -by having their ExportFlag set, even though they are not exported -in the source-code sense. - -We should probably use a different term for ExportFlag, like -KeepAlive. - -Note [GlobalId/LocalId] -~~~~~~~~~~~~~~~~~~~~~~~ -A GlobalId is - * always a constant (top-level) - * imported, or data constructor, or primop, or record selector - * has a Unique that is globally unique across the whole - GHC invocation (a single invocation may compile multiple modules) - * never treated as a candidate by the free-variable finder; - it's a constant! - -A LocalId is - * bound within an expression (lambda, case, local let(rec)) - * or defined at top level in the module being compiled - * always treated as a candidate by the free-variable finder - -After CoreTidy, top-level LocalIds are turned into GlobalIds --} - -instance Outputable Var where - ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds -> - getPprStyle $ \ppr_style -> - if | debugStyle ppr_style && (not supp_var_kinds) - -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> - dcolon <+> pprKind (tyVarKind var)) - | otherwise - -> ppr (varName var) <> ppr_debug var ppr_style - -ppr_debug :: Var -> PprStyle -> SDoc -ppr_debug (TyVar {}) sty - | debugStyle sty = brackets (text "tv") -ppr_debug (TcTyVar {tc_tv_details = d}) sty - | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) -ppr_debug (Id { idScope = s, id_details = d }) sty - | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) -ppr_debug _ _ = empty - -ppr_id_scope :: IdScope -> SDoc -ppr_id_scope GlobalId = text "gid" -ppr_id_scope (LocalId Exported) = text "lidx" -ppr_id_scope (LocalId NotExported) = text "lid" - -instance NamedThing Var where - getName = varName - -instance Uniquable Var where - getUnique = varUnique - -instance Eq Var where - a == b = realUnique a == realUnique b - -instance Ord Var where - a <= b = realUnique a <= realUnique b - a < b = realUnique a < realUnique b - a >= b = realUnique a >= realUnique b - a > b = realUnique a > realUnique b - a `compare` b = a `nonDetCmpVar` b - --- | Compare Vars by their Uniques. --- This is what Ord Var does, provided here to make it explicit at the --- call-site that it can introduce non-determinism. --- See Note [Unique Determinism] -nonDetCmpVar :: Var -> Var -> Ordering -nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b - -instance Data Var where - -- don't traverse? - toConstr _ = abstractConstr "Var" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Var" - -instance HasOccName Var where - occName = nameOccName . varName - -varUnique :: Var -> Unique -varUnique var = mkUniqueGrimily (realUnique var) - -setVarUnique :: Var -> Unique -> Var -setVarUnique var uniq - = var { realUnique = getKey uniq, - varName = setNameUnique (varName var) uniq } - -setVarName :: Var -> Name -> Var -setVarName var new_name - = var { realUnique = getKey (getUnique new_name), - varName = new_name } - -setVarType :: Id -> Type -> Id -setVarType id ty = id { varType = ty } - -updateVarType :: (Type -> Type) -> Id -> Id -updateVarType f id = id { varType = f (varType id) } - -updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id -updateVarTypeM f id = do { ty' <- f (varType id) - ; return (id { varType = ty' }) } - -{- ********************************************************************* -* * -* ArgFlag -* * -********************************************************************* -} - --- | Argument Flag --- --- Is something required to appear in source Haskell ('Required'), --- permitted by request ('Specified') (visible type application), or --- prohibited entirely from appearing in source Haskell ('Inferred')? --- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep -data ArgFlag = Inferred | Specified | Required - deriving (Eq, Ord, Data) - -- (<) on ArgFlag means "is less visible than" - --- | Does this 'ArgFlag' classify an argument that is written in Haskell? -isVisibleArgFlag :: ArgFlag -> Bool -isVisibleArgFlag Required = True -isVisibleArgFlag _ = False - --- | Does this 'ArgFlag' classify an argument that is not written in Haskell? -isInvisibleArgFlag :: ArgFlag -> Bool -isInvisibleArgFlag = not . isVisibleArgFlag - --- | Do these denote the same level of visibility? 'Required' --- arguments are visible, others are not. So this function --- equates 'Specified' and 'Inferred'. Used for printing. -sameVis :: ArgFlag -> ArgFlag -> Bool -sameVis Required Required = True -sameVis Required _ = False -sameVis _ Required = False -sameVis _ _ = True - -instance Outputable ArgFlag where - ppr Required = text "[req]" - ppr Specified = text "[spec]" - ppr Inferred = text "[infrd]" - -instance Binary ArgFlag where - put_ bh Required = putByte bh 0 - put_ bh Specified = putByte bh 1 - put_ bh Inferred = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> return Required - 1 -> return Specified - _ -> return Inferred - --- | The non-dependent version of 'ArgFlag'. - --- Appears here partly so that it's together with its friend ArgFlag, --- but also because it is used in IfaceType, rather early in the --- compilation chain --- See Note [AnonArgFlag vs. ForallVisFlag] -data AnonArgFlag - = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. - -- The argument is visible in source code. - | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. - -- The argument is invisible in source code. - deriving (Eq, Ord, Data) - -instance Outputable AnonArgFlag where - ppr VisArg = text "[vis]" - ppr InvisArg = text "[invis]" - -instance Binary AnonArgFlag where - put_ bh VisArg = putByte bh 0 - put_ bh InvisArg = putByte bh 1 - - get bh = do - h <- getByte bh - case h of - 0 -> return VisArg - _ -> return InvisArg - --- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible --- (e.g., @forall a b -> {...}@, with an arrow)? - --- See Note [AnonArgFlag vs. ForallVisFlag] -data ForallVisFlag - = ForallVis -- ^ A visible @forall@ (with an arrow) - | ForallInvis -- ^ An invisible @forall@ (with a dot) - deriving (Eq, Ord, Data) - -instance Outputable ForallVisFlag where - ppr f = text $ case f of - ForallVis -> "ForallVis" - ForallInvis -> "ForallInvis" - --- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'. -argToForallVisFlag :: ArgFlag -> ForallVisFlag -argToForallVisFlag Required = ForallVis -argToForallVisFlag Specified = ForallInvis -argToForallVisFlag Inferred = ForallInvis - -{- -Note [AnonArgFlag vs. ForallVisFlag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The AnonArgFlag and ForallVisFlag data types are quite similar at a first -glance: - - data AnonArgFlag = VisArg | InvisArg - data ForallVisFlag = ForallVis | ForallInvis - -Both data types keep track of visibility of some sort. AnonArgFlag tracks -whether a FunTy has a visible argument (->) or an invisible predicate argument -(=>). ForallVisFlag tracks whether a `forall` quantifier is visible -(forall a -> {...}) or invisible (forall a. {...}). - -Given their similarities, it's tempting to want to combine these two data types -into one, but they actually represent distinct concepts. AnonArgFlag reflects a -property of *Core* types, whereas ForallVisFlag reflects a property of the GHC -AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag -is all about surface syntax. Therefore, they are kept as separate data types. --} - -{- ********************************************************************* -* * -* VarBndr, TyCoVarBinder -* * -********************************************************************* -} - --- Variable Binder --- --- VarBndr is polymorphic in both var and visibility fields. --- Currently there are six different uses of 'VarBndr': --- * Var.TyVarBinder = VarBndr TyVar ArgFlag --- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag --- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis --- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis --- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag --- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -data VarBndr var argf = Bndr var argf - deriving( Data ) - --- | Variable Binder --- --- A 'TyCoVarBinder' is the binder of a ForAllTy --- It's convenient to define this synonym here rather its natural --- home in GHC.Core.TyCo.Rep, because it's used in GHC.Core.DataCon.hs-boot --- --- A 'TyVarBinder' is a binder with only TyVar -type TyCoVarBinder = VarBndr TyCoVar ArgFlag -type TyVarBinder = VarBndr TyVar ArgFlag - -binderVar :: VarBndr tv argf -> tv -binderVar (Bndr v _) = v - -binderVars :: [VarBndr tv argf] -> [tv] -binderVars tvbs = map binderVar tvbs - -binderArgFlag :: VarBndr tv argf -> argf -binderArgFlag (Bndr _ argf) = argf - -binderType :: VarBndr TyCoVar argf -> Type -binderType (Bndr tv _) = varType tv - --- | Make a named binder -mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder -mkTyCoVarBinder vis var = Bndr var vis - --- | Make a named binder --- 'var' should be a type variable -mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder -mkTyVarBinder vis var - = ASSERT( isTyVar var ) - Bndr var vis - --- | Make many named binders -mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] -mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) - --- | Make many named binders --- Input vars should be type variables -mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] -mkTyVarBinders vis = map (mkTyVarBinder vis) - -isTyVarBinder :: TyCoVarBinder -> Bool -isTyVarBinder (Bndr v _) = isTyVar v - -instance Outputable tv => Outputable (VarBndr tv ArgFlag) where - ppr (Bndr v Required) = ppr v - ppr (Bndr v Specified) = char '@' <> ppr v - ppr (Bndr v Inferred) = braces (ppr v) - -instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where - put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } - - get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } - -instance NamedThing tv => NamedThing (VarBndr tv flag) where - getName (Bndr tv _) = getName tv - -{- -************************************************************************ -* * -* Type and kind variables * -* * -************************************************************************ --} - -tyVarName :: TyVar -> Name -tyVarName = varName - -tyVarKind :: TyVar -> Kind -tyVarKind = varType - -setTyVarUnique :: TyVar -> Unique -> TyVar -setTyVarUnique = setVarUnique - -setTyVarName :: TyVar -> Name -> TyVar -setTyVarName = setVarName - -setTyVarKind :: TyVar -> Kind -> TyVar -setTyVarKind tv k = tv {varType = k} - -updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar -updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} - -updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar -updateTyVarKindM update tv - = do { k' <- update (tyVarKind tv) - ; return $ tv {varType = k'} } - -mkTyVar :: Name -> Kind -> TyVar -mkTyVar name kind = TyVar { varName = name - , realUnique = getKey (nameUnique name) - , varType = kind - } - -mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar -mkTcTyVar name kind details - = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' - TcTyVar { varName = name, - realUnique = getKey (nameUnique name), - varType = kind, - tc_tv_details = details - } - -tcTyVarDetails :: TyVar -> TcTyVarDetails --- See Note [TcTyVars in the typechecker] in TcType -tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details -tcTyVarDetails (TyVar {}) = vanillaSkolemTv -tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) - -setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar -setTcTyVarDetails tv details = tv { tc_tv_details = details } - -{- -%************************************************************************ -%* * -\subsection{Ids} -* * -************************************************************************ --} - -idInfo :: HasDebugCallStack => Id -> IdInfo -idInfo (Id { id_info = info }) = info -idInfo other = pprPanic "idInfo" (ppr other) - -idDetails :: Id -> IdDetails -idDetails (Id { id_details = details }) = details -idDetails other = pprPanic "idDetails" (ppr other) - --- The next three have a 'Var' suffix even though they always build --- Ids, because Id.hs uses 'mkGlobalId' etc with different types -mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalVar details name ty info - = mk_id name ty GlobalId details info - -mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkLocalVar details name ty info - = mk_id name ty (LocalId NotExported) details info - -mkCoVar :: Name -> Type -> CoVar --- Coercion variables have no IdInfo -mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo - --- | Exported 'Var's will not be removed as dead code -mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkExportedLocalVar details name ty info - = mk_id name ty (LocalId Exported) details info - -mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id -mk_id name ty scope details info - = Id { varName = name, - realUnique = getKey (nameUnique name), - varType = ty, - idScope = scope, - id_details = details, - id_info = info } - -------------------- -lazySetIdInfo :: Id -> IdInfo -> Var -lazySetIdInfo id info = id { id_info = info } - -setIdDetails :: Id -> IdDetails -> Id -setIdDetails id details = id { id_details = details } - -globaliseId :: Id -> Id --- ^ If it's a local, make it global -globaliseId id = id { idScope = GlobalId } - -setIdExported :: Id -> Id --- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors --- and class operations, which are born as global 'Id's and automatically exported -setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } -setIdExported id@(Id { idScope = GlobalId }) = id -setIdExported tv = pprPanic "setIdExported" (ppr tv) - -setIdNotExported :: Id -> Id --- ^ We can only do this to LocalIds -setIdNotExported id = ASSERT( isLocalId id ) - id { idScope = LocalId NotExported } - -{- -************************************************************************ -* * -\subsection{Predicates over variables} -* * -************************************************************************ --} - --- | Is this a type-level (i.e., computationally irrelevant, thus erasable) --- variable? Satisfies @isTyVar = not . isId@. -isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar -isTyVar (TyVar {}) = True -isTyVar (TcTyVar {}) = True -isTyVar _ = False - -isTcTyVar :: Var -> Bool -- True of TcTyVar only -isTcTyVar (TcTyVar {}) = True -isTcTyVar _ = False - -isTyCoVar :: Var -> Bool -isTyCoVar v = isTyVar v || isCoVar v - --- | Is this a value-level (i.e., computationally relevant) 'Id'entifier? --- Satisfies @isId = not . isTyVar@. -isId :: Var -> Bool -isId (Id {}) = True -isId _ = False - --- | Is this a coercion variable? --- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. -isCoVar :: Var -> Bool -isCoVar (Id { id_details = details }) = isCoVarDetails details -isCoVar _ = False - --- | Is this a term variable ('Id') that is /not/ a coercion variable? --- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. -isNonCoVarId :: Var -> Bool -isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) -isNonCoVarId _ = False - -isLocalId :: Var -> Bool -isLocalId (Id { idScope = LocalId _ }) = True -isLocalId _ = False - --- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's --- These are the variables that we need to pay attention to when finding free --- variables, or doing dependency analysis. -isLocalVar :: Var -> Bool -isLocalVar v = not (isGlobalId v) - -isGlobalId :: Var -> Bool -isGlobalId (Id { idScope = GlobalId }) = True -isGlobalId _ = False - --- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's --- that must have a binding in this module. The converse --- is not quite right: there are some global 'Id's that must have --- bindings, such as record selectors. But that doesn't matter, --- because it's only used for assertions -mustHaveLocalBinding :: Var -> Bool -mustHaveLocalBinding var = isLocalVar var - --- | 'isExportedIdVar' means \"don't throw this away\" -isExportedId :: Var -> Bool -isExportedId (Id { idScope = GlobalId }) = True -isExportedId (Id { idScope = LocalId Exported}) = True -isExportedId _ = False diff --git a/compiler/basicTypes/Var.hs-boot b/compiler/basicTypes/Var.hs-boot deleted file mode 100644 index 97b4d0348b..0000000000 --- a/compiler/basicTypes/Var.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module Var where - -import GhcPrelude () - -- 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 GHC.Type is built first. - -data ArgFlag -data AnonArgFlag -data Var diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs deleted file mode 100644 index dfdc933b67..0000000000 --- a/compiler/basicTypes/VarEnv.hs +++ /dev/null @@ -1,632 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module VarEnv ( - -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, - - -- ** Manipulating these environments - emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, - elemVarEnv, disjointVarEnv, - extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, - extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, - plusVarEnvList, alterVarEnv, - delVarEnvList, delVarEnv, delVarEnv_Directly, - minusVarEnv, intersectsVarEnv, - lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, - mapVarEnv, zipVarEnv, - modifyVarEnv, modifyVarEnv_Directly, - isEmptyVarEnv, - elemVarEnvByKey, lookupVarEnv_Directly, - filterVarEnv, filterVarEnv_Directly, restrictVarEnv, - partitionVarEnv, - - -- * Deterministic Var environments (maps) - DVarEnv, DIdEnv, DTyVarEnv, - - -- ** Manipulating these environments - emptyDVarEnv, mkDVarEnv, - dVarEnvElts, - extendDVarEnv, extendDVarEnv_C, - extendDVarEnvList, - lookupDVarEnv, elemDVarEnv, - isEmptyDVarEnv, foldDVarEnv, - mapDVarEnv, filterDVarEnv, - modifyDVarEnv, - alterDVarEnv, - plusDVarEnv, plusDVarEnv_C, - unitDVarEnv, - delDVarEnv, - delDVarEnvList, - minusDVarEnv, - partitionDVarEnv, - anyDVarEnv, - - -- * The InScopeSet type - InScopeSet, - - -- ** Operations on InScopeSets - emptyInScopeSet, mkInScopeSet, delInScopeSet, - extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, - getInScopeVars, lookupInScope, lookupInScope_Directly, - unionInScope, elemInScopeSet, uniqAway, - varSetInScope, - unsafeGetFreshLocalUnique, - - -- * The RnEnv2 type - RnEnv2, - - -- ** Operations on RnEnv2s - mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, - rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, - rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, - delBndrL, delBndrR, delBndrsL, delBndrsR, - addRnInScopeSet, - rnEtaL, rnEtaR, - rnInScope, rnInScopeSet, lookupRnInScope, - rnEnvL, rnEnvR, - - -- * TidyEnv and its operation - TidyEnv, - emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList - ) where - -import GhcPrelude -import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM - -import OccName -import Name -import Var -import VarSet -import UniqSet -import UniqFM -import UniqDFM -import Unique -import Util -import Maybes -import Outputable - -{- -************************************************************************ -* * - In-scope sets -* * -************************************************************************ --} - --- | A set of variables that are in scope at some point --- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides --- the motivation for this abstraction. -newtype InScopeSet = InScope VarSet - -- Note [Lookups in in-scope set] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- We store a VarSet here, but we use this for lookups rather than just - -- membership tests. Typically the InScopeSet contains the canonical - -- version of the variable (e.g. with an informative unfolding), so this - -- lookup is useful (see, for instance, Note [In-scope set as a - -- substitution]). - -instance Outputable InScopeSet where - ppr (InScope s) = - text "InScope" <+> - braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) - -- It's OK to use nonDetEltsUniqSet here because it's - -- only for pretty printing - -- In-scope sets get big, and with -dppr-debug - -- the output is overwhelming - -emptyInScopeSet :: InScopeSet -emptyInScopeSet = InScope emptyVarSet - -getInScopeVars :: InScopeSet -> VarSet -getInScopeVars (InScope vs) = vs - -mkInScopeSet :: VarSet -> InScopeSet -mkInScopeSet in_scope = InScope in_scope - -extendInScopeSet :: InScopeSet -> Var -> InScopeSet -extendInScopeSet (InScope in_scope) v - = InScope (extendVarSet in_scope v) - -extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet -extendInScopeSetList (InScope in_scope) vs - = InScope $ foldl' extendVarSet in_scope vs - -extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet -extendInScopeSetSet (InScope in_scope) vs - = InScope (in_scope `unionVarSet` vs) - -delInScopeSet :: InScopeSet -> Var -> InScopeSet -delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v) - -elemInScopeSet :: Var -> InScopeSet -> Bool -elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope - --- | Look up a variable the 'InScopeSet'. This lets you map from --- the variable's identity (unique) to its full value. -lookupInScope :: InScopeSet -> Var -> Maybe Var -lookupInScope (InScope in_scope) v = lookupVarSet in_scope v - -lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var -lookupInScope_Directly (InScope in_scope) uniq - = lookupVarSet_Directly in_scope uniq - -unionInScope :: InScopeSet -> InScopeSet -> InScopeSet -unionInScope (InScope s1) (InScope s2) - = InScope (s1 `unionVarSet` s2) - -varSetInScope :: VarSet -> InScopeSet -> Bool -varSetInScope vars (InScope s1) = vars `subVarSet` s1 - -{- -Note [Local uniques] -~~~~~~~~~~~~~~~~~~~~ -Sometimes one must create conjure up a unique which is unique in a particular -context (but not necessarily globally unique). For instance, one might need to -create a fresh local identifier which does not shadow any of the locally -in-scope variables. For this we purpose we provide 'uniqAway'. - -'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique' -operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To -ensure that we do not conflict with uniques allocated by future allocations -from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are -allocated into a dedicated region of the unique space (namely the X tag). - -Note that one must be quite carefully when using uniques generated in this way -since they are only locally unique. In particular, two successive calls to -'uniqAway' on the same 'InScopeSet' will produce the same unique. - -} - --- | @uniqAway in_scope v@ finds a unique that is not used in the --- in-scope set, and gives that to v. See Note [Local uniques]. -uniqAway :: InScopeSet -> Var -> Var --- It starts with v's current unique, of course, in the hope that it won't --- have to change, and thereafter uses the successor to the last derived unique --- found in the in-scope set. -uniqAway in_scope var - | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one - | otherwise = var -- Nothing to do - -uniqAway' :: InScopeSet -> Var -> Var --- This one *always* makes up a new variable -uniqAway' in_scope var - = setVarUnique var (unsafeGetFreshLocalUnique in_scope) - --- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the --- given 'InScopeSet'. This must be used very carefully since one can very easily --- introduce non-unique 'Unique's this way. See Note [Local uniques]. -unsafeGetFreshLocalUnique :: InScopeSet -> Unique -unsafeGetFreshLocalUnique (InScope set) - | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set) - , let uniq' = mkLocalUnique uniq - , not $ uniq' `ltUnique` minLocalUnique - = incrUnique uniq' - - | otherwise - = minLocalUnique - -{- -************************************************************************ -* * - Dual renaming -* * -************************************************************************ --} - --- | Rename Environment 2 --- --- When we are comparing (or matching) types or terms, we are faced with --- \"going under\" corresponding binders. E.g. when comparing: --- --- > \x. e1 ~ \y. e2 --- --- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of --- things we must be careful of. In particular, @x@ might be free in @e2@, or --- y in @e1@. So the idea is that we come up with a fresh binder that is free --- in neither, and rename @x@ and @y@ respectively. That means we must maintain: --- --- 1. A renaming for the left-hand expression --- --- 2. A renaming for the right-hand expressions --- --- 3. An in-scope set --- --- Furthermore, when matching, we want to be able to have an 'occurs check', --- to prevent: --- --- > \x. f ~ \y. y --- --- matching with [@f@ -> @y@]. So for each expression we want to know that set of --- locally-bound variables. That is precisely the domain of the mappings 1. --- and 2., but we must ensure that we always extend the mappings as we go in. --- --- All of this information is bundled up in the 'RnEnv2' -data RnEnv2 - = RV2 { envL :: VarEnv Var -- Renaming for Left term - , envR :: VarEnv Var -- Renaming for Right term - , in_scope :: InScopeSet } -- In scope in left or right terms - --- The renamings envL and envR are *guaranteed* to contain a binding --- for every variable bound as we go into the term, even if it is not --- renamed. That way we can ask what variables are locally bound --- (inRnEnvL, inRnEnvR) - -mkRnEnv2 :: InScopeSet -> RnEnv2 -mkRnEnv2 vars = RV2 { envL = emptyVarEnv - , envR = emptyVarEnv - , in_scope = vars } - -addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 -addRnInScopeSet env vs - | isEmptyVarSet vs = env - | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } - -rnInScope :: Var -> RnEnv2 -> Bool -rnInScope x env = x `elemInScopeSet` in_scope env - -rnInScopeSet :: RnEnv2 -> InScopeSet -rnInScopeSet = in_scope - --- | Retrieve the left mapping -rnEnvL :: RnEnv2 -> VarEnv Var -rnEnvL = envL - --- | Retrieve the right mapping -rnEnvR :: RnEnv2 -> VarEnv Var -rnEnvR = envR - -rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 --- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length -rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR - -rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 --- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, --- and binder @bR@ in the Right term. --- It finds a new binder, @new_b@, --- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ -rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR - -rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but returns the new variable as well as the --- new environment -rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR - = (RV2 { envL = extendVarEnv envL bL new_b -- See Note - , envR = extendVarEnv envR bR new_b -- [Rebinding] - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - -- Find a new binder not in scope in either term - new_b | not (bL `elemInScopeSet` in_scope) = bL - | not (bR `elemInScopeSet` in_scope) = bR - | otherwise = uniqAway' in_scope bL - - -- Note [Rebinding] - -- If the new var is the same as the old one, note that - -- the extendVarEnv *deletes* any current renaming - -- E.g. (\x. \x. ...) ~ (\y. \z. ...) - -- - -- Inside \x \y { [x->y], [y->y], {y} } - -- \x \z { [x->x], [y->y, z->x], {y,x} } - -rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the left --- side only. -rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL - = (RV2 { envL = extendVarEnv envL bL new_b - , envR = envR - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bL - -rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the right --- side only. -rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envR = extendVarEnv envR bR new_b - , envL = envL - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bR - -rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndrL' but used for eta expansion --- See Note [Eta expansion] -rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL - = (RV2 { envL = extendVarEnv envL bL new_b - , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bL - -rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used for eta expansion --- See Note [Eta expansion] -rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] - , envR = extendVarEnv envR bR new_b - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bR - -delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 -delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v - = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } -delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v - = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } - -delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 -delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v - = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } -delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v - = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } - -rnOccL, rnOccR :: RnEnv2 -> Var -> Var --- ^ Look up the renaming of an occurrence in the left or right term -rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v -rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v - -rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var --- ^ Look up the renaming of an occurrence in the left or right term -rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v -rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v - -inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool --- ^ Tells whether a variable is locally bound -inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env -inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env - -lookupRnInScope :: RnEnv2 -> Var -> Var -lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v - -nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 --- ^ Wipe the left or right side renaming -nukeRnEnvL env = env { envL = emptyVarEnv } -nukeRnEnvR env = env { envR = emptyVarEnv } - -rnSwap :: RnEnv2 -> RnEnv2 --- ^ swap the meaning of left and right -rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) - = RV2 { envL = envR, envR = envL, in_scope = in_scope } - -{- -Note [Eta expansion] -~~~~~~~~~~~~~~~~~~~~ -When matching - (\x.M) ~ N -we rename x to x' with, where x' is not in scope in -either term. Then we want to behave as if we'd seen - (\x'.M) ~ (\x'.N x') -Since x' isn't in scope in N, the form (\x'. N x') doesn't -capture any variables in N. But we must nevertheless extend -the envR with a binding [x' -> x'], to support the occurs check. -For example, if we don't do this, we can get silly matches like - forall a. (\y.a) ~ v -succeeding with [a -> v y], which is bogus of course. - - -************************************************************************ -* * - Tidying -* * -************************************************************************ --} - --- | Tidy Environment --- --- When tidying up print names, we keep a mapping of in-scope occ-names --- (the 'TidyOccEnv') and a Var-to-Var of the current renamings -type TidyEnv = (TidyOccEnv, VarEnv Var) - -emptyTidyEnv :: TidyEnv -emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) - -mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv -mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) - -delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv -delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env') - where - occ_env' = occ_env `delTidyOccEnvList` map (occNameFS . getOccName) vs - var_env' = var_env `delVarEnvList` vs - -{- -************************************************************************ -* * -\subsection{@VarEnv@s} -* * -************************************************************************ --} - --- | Variable Environment -type VarEnv elt = UniqFM elt - --- | Identifier Environment -type IdEnv elt = VarEnv elt - --- | Type Variable Environment -type TyVarEnv elt = VarEnv elt - --- | Type or Coercion Variable Environment -type TyCoVarEnv elt = VarEnv elt - --- | Coercion Variable Environment -type CoVarEnv elt = VarEnv elt - -emptyVarEnv :: VarEnv a -mkVarEnv :: [(Var, a)] -> VarEnv a -mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a -zipVarEnv :: [Var] -> [a] -> VarEnv a -unitVarEnv :: Var -> a -> VarEnv a -alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a -extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a -extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a -extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b -extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a -plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a -plusVarEnvList :: [VarEnv a] -> VarEnv a -extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a - -lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a -filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a -delVarEnv_Directly :: VarEnv a -> Unique -> VarEnv a -partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) -restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a -delVarEnvList :: VarEnv a -> [Var] -> VarEnv a -delVarEnv :: VarEnv a -> Var -> VarEnv a -minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a -intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool -plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a -plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a -plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a -mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b -modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a - -isEmptyVarEnv :: VarEnv a -> Bool -lookupVarEnv :: VarEnv a -> Var -> Maybe a -filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a -lookupVarEnv_NF :: VarEnv a -> Var -> a -lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a -elemVarEnv :: Var -> VarEnv a -> Bool -elemVarEnvByKey :: Unique -> VarEnv a -> Bool -disjointVarEnv :: VarEnv a -> VarEnv a -> Bool - -elemVarEnv = elemUFM -elemVarEnvByKey = elemUFM_Directly -disjointVarEnv = disjointUFM -alterVarEnv = alterUFM -extendVarEnv = addToUFM -extendVarEnv_C = addToUFM_C -extendVarEnv_Acc = addToUFM_Acc -extendVarEnv_Directly = addToUFM_Directly -extendVarEnvList = addListToUFM -plusVarEnv_C = plusUFM_C -plusVarEnv_CD = plusUFM_CD -plusMaybeVarEnv_C = plusMaybeUFM_C -delVarEnvList = delListFromUFM -delVarEnv = delFromUFM -minusVarEnv = minusUFM -intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) -plusVarEnv = plusUFM -plusVarEnvList = plusUFMList -lookupVarEnv = lookupUFM -filterVarEnv = filterUFM -lookupWithDefaultVarEnv = lookupWithDefaultUFM -mapVarEnv = mapUFM -mkVarEnv = listToUFM -mkVarEnv_Directly= listToUFM_Directly -emptyVarEnv = emptyUFM -unitVarEnv = unitUFM -isEmptyVarEnv = isNullUFM -lookupVarEnv_Directly = lookupUFM_Directly -filterVarEnv_Directly = filterUFM_Directly -delVarEnv_Directly = delFromUFM_Directly -partitionVarEnv = partitionUFM - -restrictVarEnv env vs = filterVarEnv_Directly keep env - where - keep u _ = u `elemVarSetByKey` vs - -zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) -lookupVarEnv_NF env id = case lookupVarEnv env id of - Just xx -> xx - Nothing -> panic "lookupVarEnv_NF: Nothing" - -{- -@modifyVarEnv@: Look up a thing in the VarEnv, -then mash it with the modify function, and put it back. --} - -modifyVarEnv mangle_fn env key - = case (lookupVarEnv env key) of - Nothing -> env - Just xx -> extendVarEnv env key (mangle_fn xx) - -modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a -modifyVarEnv_Directly mangle_fn env key - = case (lookupUFM_Directly env key) of - Nothing -> env - Just xx -> addToUFM_Directly env key (mangle_fn xx) - --- Deterministic VarEnv --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DVarEnv. - --- | Deterministic Variable Environment -type DVarEnv elt = UniqDFM elt - --- | Deterministic Identifier Environment -type DIdEnv elt = DVarEnv elt - --- | Deterministic Type Variable Environment -type DTyVarEnv elt = DVarEnv elt - -emptyDVarEnv :: DVarEnv a -emptyDVarEnv = emptyUDFM - -dVarEnvElts :: DVarEnv a -> [a] -dVarEnvElts = eltsUDFM - -mkDVarEnv :: [(Var, a)] -> DVarEnv a -mkDVarEnv = listToUDFM - -extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a -extendDVarEnv = addToUDFM - -minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a -minusDVarEnv = minusUDFM - -lookupDVarEnv :: DVarEnv a -> Var -> Maybe a -lookupDVarEnv = lookupUDFM - -foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b -foldDVarEnv = foldUDFM - -mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b -mapDVarEnv = mapUDFM - -filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a -filterDVarEnv = filterUDFM - -alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a -alterDVarEnv = alterUDFM - -plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a -plusDVarEnv = plusUDFM - -plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a -plusDVarEnv_C = plusUDFM_C - -unitDVarEnv :: Var -> a -> DVarEnv a -unitDVarEnv = unitUDFM - -delDVarEnv :: DVarEnv a -> Var -> DVarEnv a -delDVarEnv = delFromUDFM - -delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a -delDVarEnvList = delListFromUDFM - -isEmptyDVarEnv :: DVarEnv a -> Bool -isEmptyDVarEnv = isNullUDFM - -elemDVarEnv :: Var -> DVarEnv a -> Bool -elemDVarEnv = elemUDFM - -extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a -extendDVarEnv_C = addToUDFM_C - -modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a -modifyDVarEnv mangle_fn env key - = case (lookupDVarEnv env key) of - Nothing -> env - Just xx -> extendDVarEnv env key (mangle_fn xx) - -partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) -partitionDVarEnv = partitionUDFM - -extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a -extendDVarEnvList = addListToUDFM - -anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool -anyDVarEnv = anyUDFM diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs deleted file mode 100644 index 80493ef9d1..0000000000 --- a/compiler/basicTypes/VarSet.hs +++ /dev/null @@ -1,354 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} - -module VarSet ( - -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, - - -- ** Manipulating these sets - emptyVarSet, unitVarSet, mkVarSet, - extendVarSet, extendVarSetList, - elemVarSet, subVarSet, - unionVarSet, unionVarSets, mapUnionVarSet, - intersectVarSet, intersectsVarSet, disjointVarSet, - isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, - minusVarSet, filterVarSet, mapVarSet, - anyVarSet, allVarSet, - transCloVarSet, fixVarSet, - lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, - sizeVarSet, seqVarSet, - elemVarSetByKey, partitionVarSet, - pluralVarSet, pprVarSet, - nonDetFoldVarSet, - - -- * Deterministic Var set types - DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, - - -- ** Manipulating these sets - emptyDVarSet, unitDVarSet, mkDVarSet, - extendDVarSet, extendDVarSetList, - elemDVarSet, dVarSetElems, subDVarSet, - unionDVarSet, unionDVarSets, mapUnionDVarSet, - intersectDVarSet, dVarSetIntersectVarSet, - intersectsDVarSet, disjointDVarSet, - isEmptyDVarSet, delDVarSet, delDVarSetList, - minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet, - dVarSetMinusVarSet, anyDVarSet, allDVarSet, - transCloDVarSet, - sizeDVarSet, seqDVarSet, - partitionDVarSet, - dVarSetToVarSet, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Var ( Var, TyVar, CoVar, TyCoVar, Id ) -import Unique -import Name ( Name ) -import UniqSet -import UniqDSet -import UniqFM( disjointUFM, pluralUFM, pprUFM ) -import UniqDFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) -import Outputable (SDoc) - --- | A non-deterministic Variable Set --- --- A non-deterministic set of variables. --- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not --- deterministic and why it matters. Use DVarSet if the set eventually --- gets converted into a list or folded over in a way where the order --- changes the generated code, for example when abstracting variables. -type VarSet = UniqSet Var - --- | Identifier Set -type IdSet = UniqSet Id - --- | Type Variable Set -type TyVarSet = UniqSet TyVar - --- | Coercion Variable Set -type CoVarSet = UniqSet CoVar - --- | Type or Coercion Variable Set -type TyCoVarSet = UniqSet TyCoVar - -emptyVarSet :: VarSet -intersectVarSet :: VarSet -> VarSet -> VarSet -unionVarSet :: VarSet -> VarSet -> VarSet -unionVarSets :: [VarSet] -> VarSet - -mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet --- ^ map the function over the list, and union the results - -unitVarSet :: Var -> VarSet -extendVarSet :: VarSet -> Var -> VarSet -extendVarSetList:: VarSet -> [Var] -> VarSet -elemVarSet :: Var -> VarSet -> Bool -delVarSet :: VarSet -> Var -> VarSet -delVarSetList :: VarSet -> [Var] -> VarSet -minusVarSet :: VarSet -> VarSet -> VarSet -isEmptyVarSet :: VarSet -> Bool -mkVarSet :: [Var] -> VarSet -lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var -lookupVarSet :: VarSet -> Var -> Maybe Var - -- Returns the set element, which may be - -- (==) to the argument, but not the same as -lookupVarSetByName :: VarSet -> Name -> Maybe Var -sizeVarSet :: VarSet -> Int -filterVarSet :: (Var -> Bool) -> VarSet -> VarSet - -delVarSetByKey :: VarSet -> Unique -> VarSet -elemVarSetByKey :: Unique -> VarSet -> Bool -partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) - -emptyVarSet = emptyUniqSet -unitVarSet = unitUniqSet -extendVarSet = addOneToUniqSet -extendVarSetList= addListToUniqSet -intersectVarSet = intersectUniqSets - -intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection -disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection -subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second - -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; - -- ditto disjointVarSet, subVarSet - -unionVarSet = unionUniqSets -unionVarSets = unionManyUniqSets -elemVarSet = elementOfUniqSet -minusVarSet = minusUniqSet -delVarSet = delOneFromUniqSet -delVarSetList = delListFromUniqSet -isEmptyVarSet = isEmptyUniqSet -mkVarSet = mkUniqSet -lookupVarSet_Directly = lookupUniqSet_Directly -lookupVarSet = lookupUniqSet -lookupVarSetByName = lookupUniqSet -sizeVarSet = sizeUniqSet -filterVarSet = filterUniqSet -delVarSetByKey = delOneFromUniqSet_Directly -elemVarSetByKey = elemUniqSet_Directly -partitionVarSet = partitionUniqSet - -mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs - --- See comments with type signatures -intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) -disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) -subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) - -anyVarSet :: (Var -> Bool) -> VarSet -> Bool -anyVarSet = uniqSetAny - -allVarSet :: (Var -> Bool) -> VarSet -> Bool -allVarSet = uniqSetAll - -mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b -mapVarSet = mapUniqSet - -nonDetFoldVarSet :: (Var -> a -> a) -> a -> VarSet -> a -nonDetFoldVarSet = nonDetFoldUniqSet - -fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set - -> VarSet -> VarSet --- (fixVarSet f s) repeatedly applies f to the set s, --- until it reaches a fixed point. -fixVarSet fn vars - | new_vars `subVarSet` vars = vars - | otherwise = fixVarSet fn new_vars - where - new_vars = fn vars - -transCloVarSet :: (VarSet -> VarSet) - -- Map some variables in the set to - -- extra variables that should be in it - -> VarSet -> VarSet --- (transCloVarSet f s) repeatedly applies f to new candidates, adding any --- new variables to s that it finds thereby, until it reaches a fixed point. --- --- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) --- for efficiency, so that the test can be batched up. --- It's essential that fn will work fine if given new candidates --- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 --- Use fixVarSet if the function needs to see the whole set all at once -transCloVarSet fn seeds - = go seeds seeds - where - go :: VarSet -- Accumulating result - -> VarSet -- Work-list; un-processed subset of accumulating result - -> VarSet - -- Specification: go acc vs = acc `union` transClo fn vs - - go acc candidates - | isEmptyVarSet new_vs = acc - | otherwise = go (acc `unionVarSet` new_vs) new_vs - where - new_vs = fn candidates `minusVarSet` acc - -seqVarSet :: VarSet -> () -seqVarSet s = sizeVarSet s `seq` () - --- | Determines the pluralisation suffix appropriate for the length of a set --- in the same way that plural from Outputable does for lists. -pluralVarSet :: VarSet -> SDoc -pluralVarSet = pluralUFM . getUniqSet - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetEltsUFM. --- Passing a list to the pretty-printing function allows the caller --- to decide on the order of Vars (eg. toposort them) without them having --- to use nonDetEltsUFM at the call site. This prevents from let-binding --- non-deterministically ordered lists and reusing them where determinism --- matters. -pprVarSet :: VarSet -- ^ The things to be pretty printed - -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the - -- elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprVarSet = pprUFM . getUniqSet - --- Deterministic VarSet --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need --- DVarSet. - --- | Deterministic Variable Set -type DVarSet = UniqDSet Var - --- | Deterministic Identifier Set -type DIdSet = UniqDSet Id - --- | Deterministic Type Variable Set -type DTyVarSet = UniqDSet TyVar - --- | Deterministic Type or Coercion Variable Set -type DTyCoVarSet = UniqDSet TyCoVar - -emptyDVarSet :: DVarSet -emptyDVarSet = emptyUniqDSet - -unitDVarSet :: Var -> DVarSet -unitDVarSet = unitUniqDSet - -mkDVarSet :: [Var] -> DVarSet -mkDVarSet = mkUniqDSet - --- The new element always goes to the right of existing ones. -extendDVarSet :: DVarSet -> Var -> DVarSet -extendDVarSet = addOneToUniqDSet - -elemDVarSet :: Var -> DVarSet -> Bool -elemDVarSet = elementOfUniqDSet - -dVarSetElems :: DVarSet -> [Var] -dVarSetElems = uniqDSetToList - -subDVarSet :: DVarSet -> DVarSet -> Bool -subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) - -unionDVarSet :: DVarSet -> DVarSet -> DVarSet -unionDVarSet = unionUniqDSets - -unionDVarSets :: [DVarSet] -> DVarSet -unionDVarSets = unionManyUniqDSets - --- | Map the function over the list, and union the results -mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet -mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs - -intersectDVarSet :: DVarSet -> DVarSet -> DVarSet -intersectDVarSet = intersectUniqDSets - -dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet -dVarSetIntersectVarSet = uniqDSetIntersectUniqSet - --- | True if empty intersection -disjointDVarSet :: DVarSet -> DVarSet -> Bool -disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2) - --- | True if non-empty intersection -intersectsDVarSet :: DVarSet -> DVarSet -> Bool -intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) - -isEmptyDVarSet :: DVarSet -> Bool -isEmptyDVarSet = isEmptyUniqDSet - -delDVarSet :: DVarSet -> Var -> DVarSet -delDVarSet = delOneFromUniqDSet - -minusDVarSet :: DVarSet -> DVarSet -> DVarSet -minusDVarSet = minusUniqDSet - -dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet -dVarSetMinusVarSet = uniqDSetMinusUniqSet - -foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a -foldDVarSet = foldUniqDSet - -anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool -anyDVarSet p = anyUDFM p . getUniqDSet - -allDVarSet :: (Var -> Bool) -> DVarSet -> Bool -allDVarSet p = allUDFM p . getUniqDSet - -mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b -mapDVarSet = mapUniqDSet - -filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet -filterDVarSet = filterUniqDSet - -sizeDVarSet :: DVarSet -> Int -sizeDVarSet = sizeUniqDSet - --- | Partition DVarSet according to the predicate given -partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) -partitionDVarSet = partitionUniqDSet - --- | Delete a list of variables from DVarSet -delDVarSetList :: DVarSet -> [Var] -> DVarSet -delDVarSetList = delListFromUniqDSet - -seqDVarSet :: DVarSet -> () -seqDVarSet s = sizeDVarSet s `seq` () - --- | Add a list of variables to DVarSet -extendDVarSetList :: DVarSet -> [Var] -> DVarSet -extendDVarSetList = addListToUniqDSet - --- | Convert a DVarSet to a VarSet by forgetting the order of insertion -dVarSetToVarSet :: DVarSet -> VarSet -dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet - --- | transCloVarSet for DVarSet -transCloDVarSet :: (DVarSet -> DVarSet) - -- Map some variables in the set to - -- extra variables that should be in it - -> DVarSet -> DVarSet --- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any --- new variables to s that it finds thereby, until it reaches a fixed point. --- --- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) --- for efficiency, so that the test can be batched up. --- It's essential that fn will work fine if given new candidates --- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 -transCloDVarSet fn seeds - = go seeds seeds - where - go :: DVarSet -- Accumulating result - -> DVarSet -- Work-list; un-processed subset of accumulating result - -> DVarSet - -- Specification: go acc vs = acc `union` transClo fn vs - - go acc candidates - | isEmptyDVarSet new_vs = acc - | otherwise = go (acc `unionDVarSet` new_vs) new_vs - where - new_vs = fn candidates `minusDVarSet` acc diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index f40a0ce14f..6a013a4b0e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -160,13 +160,10 @@ Library hs-source-dirs: . - basicTypes - cmm iface main parser prelude - profiling typecheck utils @@ -186,26 +183,26 @@ Library GHC.Driver.Backpack.Syntax GHC.Types.Name.Shape GHC.Iface.Rename - Avail + GHC.Types.Avail AsmUtils - BasicTypes + GHC.Types.Basic GHC.Core.ConLike GHC.Core.DataCon GHC.Core.PatSyn - Demand - Cpr + GHC.Types.Demand + GHC.Types.Cpr GHC.Cmm.DebugBlock Exception - FieldLabel + GHC.Types.FieldLabel GHC.Driver.Monad GHC.Driver.Hooks GHC.Driver.Flags GHC.Driver.Ways - Id - IdInfo + GHC.Types.Id + GHC.Types.Id.Info GHC.Core.Predicate - Lexeme - Literal + GHC.Utils.Lexeme + GHC.Types.Literal GHC.Llvm GHC.Llvm.Syntax GHC.Llvm.MetaData @@ -218,21 +215,21 @@ Library GHC.CmmToLlvm.Ppr GHC.CmmToLlvm.Regs GHC.CmmToLlvm.Mangler - MkId - Module - Name - NameEnv - NameSet - OccName - RdrName - NameCache - SrcLoc - UniqSupply - Unique + GHC.Types.Id.Make + GHC.Types.Module + GHC.Types.Name + GHC.Types.Name.Env + GHC.Types.Name.Set + GHC.Types.Name.Occurrence + GHC.Types.Name.Reader + GHC.Types.Name.Cache + GHC.Types.SrcLoc + GHC.Types.Unique.Supply + GHC.Types.Unique UpdateCafInfos - Var - VarEnv - VarSet + GHC.Types.Var + GHC.Types.Var.Env + GHC.Types.Var.Set UnVarGraph GHC.Cmm.BlockId GHC.Cmm.CLabel @@ -359,7 +356,7 @@ Library GHC.Iface.Recomp GHC.IfaceToCore FlagChecker - Annotations + GHC.Types.Annotations GHC.Driver.CmdLine GHC.Driver.CodeOutput Config @@ -407,7 +404,7 @@ Library Parser RdrHsSyn ApiAnnotation - ForeignCall + GHC.Types.ForeignCall KnownUniques PrelInfo PrelNames @@ -416,9 +413,9 @@ Library ToolSettings TysPrim TysWiredIn - CostCentre - CostCentreState - ProfInit + GHC.Types.CostCentre + GHC.Types.CostCentre.State + GHC.Types.CostCentre.Init GHC.Rename.Binds GHC.Rename.Env GHC.Rename.Expr @@ -567,11 +564,11 @@ Library State Stream StringBuffer - UniqDFM - UniqDSet - UniqFM - UniqMap - UniqSet + GHC.Types.Unique.DFM + GHC.Types.Unique.DSet + GHC.Types.Unique.FM + GHC.Types.Unique.Map + GHC.Types.Unique.Set Util GHC.Cmm.Dataflow GHC.Cmm.Dataflow.Block diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs index 1eef4d67b4..51977968db 100644 --- a/compiler/iface/BinFingerprint.hs +++ b/compiler/iface/BinFingerprint.hs @@ -14,7 +14,7 @@ import GhcPrelude import Fingerprint import Binary -import Name +import GHC.Types.Name import PlainPanic import Util diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index bae7398b1c..e66c1e6fb6 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -25,22 +25,22 @@ import TysWiredIn( isCTupleTyConName ) import TysPrim ( voidPrimTy ) import GHC.Core.DataCon import GHC.Core.PatSyn -import Var -import VarSet -import BasicTypes -import Name -import NameEnv -import MkId +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id.Make import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Type -import Id +import GHC.Types.Id import TcType -import SrcLoc( SrcSpan, noSrcSpan ) +import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) import GHC.Driver.Session import TcRnMonad -import UniqSupply +import GHC.Types.Unique.Supply import Util import Outputable @@ -102,7 +102,7 @@ buildDataCon :: FamInstEnvs -> TyConRepName -> [HsSrcBang] -> Maybe [HsImplBang] - -- See Note [Bangs on imported data constructors] in MkId + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make -> [FieldLabel] -- Field labels -> [TyVar] -- Universals -> [TyCoVar] -- Existentials diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs index 7cac37cb4f..cab88ee5cc 100644 --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -13,8 +13,8 @@ import GhcPrelude import Binary import GHC.Driver.Session import GHC.Driver.Types -import Module -import Name +import GHC.Types.Module +import GHC.Types.Name import Fingerprint import BinFingerprint -- import Outputable diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs deleted file mode 100644 index 3c4340e900..0000000000 --- a/compiler/main/Annotations.hs +++ /dev/null @@ -1,142 +0,0 @@ --- | --- Support for source code annotation feature of GHC. That is the ANN pragma. --- --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- -{-# LANGUAGE DeriveFunctor #-} -module Annotations ( - -- * Main Annotation data types - Annotation(..), AnnPayload, - AnnTarget(..), CoreAnnTarget, - - -- * AnnEnv for collecting and querying Annotations - AnnEnv, - mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, - findAnns, findAnnsByTypeRep, - deserializeAnns - ) where - -import GhcPrelude - -import Binary -import Module ( Module - , ModuleEnv, emptyModuleEnv, extendModuleEnvWith - , plusModuleEnv_C, lookupWithDefaultModuleEnv - , mapModuleEnv ) -import NameEnv -import Name -import Outputable -import GHC.Serialized - -import Control.Monad -import Data.Maybe -import Data.Typeable -import Data.Word ( Word8 ) - - --- | Represents an annotation after it has been sufficiently desugared from --- it's initial form of 'HsDecls.AnnDecl' -data Annotation = Annotation { - ann_target :: CoreAnnTarget, -- ^ The target of the annotation - ann_value :: AnnPayload - } - -type AnnPayload = Serialized -- ^ The "payload" of an annotation - -- allows recovery of its value at a given type, - -- and can be persisted to an interface file - --- | An annotation target -data AnnTarget name - = NamedTarget name -- ^ We are annotating something with a name: - -- a type or identifier - | ModuleTarget Module -- ^ We are annotating a particular module - deriving (Functor) - --- | The kind of annotation target found in the middle end of the compiler -type CoreAnnTarget = AnnTarget Name - -instance Outputable name => Outputable (AnnTarget name) where - ppr (NamedTarget nm) = text "Named target" <+> ppr nm - ppr (ModuleTarget mod) = text "Module target" <+> ppr mod - -instance Binary name => Binary (AnnTarget name) where - put_ bh (NamedTarget a) = do - putByte bh 0 - put_ bh a - put_ bh (ModuleTarget a) = do - putByte bh 1 - put_ bh a - get bh = do - h <- getByte bh - case h of - 0 -> liftM NamedTarget $ get bh - _ -> liftM ModuleTarget $ get bh - -instance Outputable Annotation where - ppr ann = ppr (ann_target ann) - --- | A collection of annotations -data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload]) - , ann_name_env :: !(NameEnv [AnnPayload]) - } - --- | An empty annotation environment. -emptyAnnEnv :: AnnEnv -emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv - --- | Construct a new annotation environment that contains the list of --- annotations provided. -mkAnnEnv :: [Annotation] -> AnnEnv -mkAnnEnv = extendAnnEnvList emptyAnnEnv - --- | Add the given annotation to the environment. -extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv -extendAnnEnvList env = - foldl' extendAnnEnv env - -extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv -extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) = - case tgt of - NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload]) - ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env - --- | Union two annotation environments. -plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv -plusAnnEnv a b = - MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b) - , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b) - } - --- | Find the annotations attached to the given target as 'Typeable' --- values of your choice. If no deserializer is specified, --- only transient annotations will be returned. -findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] -findAnns deserialize env - = mapMaybe (fromSerialized deserialize) . findAnnPayloads env - --- | Find the annotations attached to the given target as 'Typeable' --- values of your choice. If no deserializer is specified, --- only transient annotations will be returned. -findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] -findAnnsByTypeRep env target tyrep - = [ ws | Serialized tyrep' ws <- findAnnPayloads env target - , tyrep' == tyrep ] - --- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'. -findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload] -findAnnPayloads env target = - case target of - ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod - NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name - --- | Deserialize all annotations of a given type. This happens lazily, that is --- no deserialization will take place until the [a] is actually demanded and --- the [a] can also be empty (the UniqFM is not filtered). -deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a]) -deserializeAnns deserialize env - = ( mapModuleEnv deserAnns (ann_mod_env env) - , mapNameEnv deserAnns (ann_name_env env) - ) - where deserAnns = mapMaybe (fromSerialized deserialize) - diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 118c5a70ba..0096891e54 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -71,7 +71,7 @@ import Exception import Outputable import Panic import qualified PprColour as Col -import SrcLoc +import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import FastString (unpackFS) import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot index e071d09272..f7f8b12f80 100644 --- a/compiler/main/ErrUtils.hs-boot +++ b/compiler/main/ErrUtils.hs-boot @@ -4,7 +4,7 @@ module ErrUtils where import GhcPrelude import Outputable (SDoc, PprStyle ) -import SrcLoc (SrcSpan) +import GHC.Types.SrcLoc (SrcSpan) import Json import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 8d88f7b097..cb1b1e3c2b 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -28,10 +28,10 @@ import Parser ( parseHeader ) import Lexer import FastString import GHC.Hs -import Module +import GHC.Types.Module import PrelNames import StringBuffer -import SrcLoc +import GHC.Types.SrcLoc import GHC.Driver.Session import ErrUtils import Util @@ -40,7 +40,7 @@ import Maybes import Bag ( emptyBag, listToBag, unitBag ) import MonadUtils import Exception -import BasicTypes +import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 5c034a373f..67eddf1f2a 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -15,7 +15,7 @@ import GhcPrelude import Bag import GHC.Hs import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Util import Data.Char diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs index 81a72230f3..24bb7c974f 100644 --- a/compiler/main/StaticPtrTable.hs +++ b/compiler/main/StaticPtrTable.hs @@ -130,10 +130,10 @@ import GHC.Core.Utils (collectMakeStaticArgs) import GHC.Core.DataCon import GHC.Driver.Session import GHC.Driver.Types -import Id +import GHC.Types.Id import GHC.Core.Make (mkStringExprFSWith) -import Module -import Name +import GHC.Types.Module +import GHC.Types.Name import Outputable import GHC.Platform import PrelNames diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index b2b13d424b..ea6eb178ee 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -42,7 +42,7 @@ import GhcPrelude import GHC.Settings -import Module +import GHC.Types.Module import GHC.Driver.Packages import Outputable import ErrUtils diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs index 73b28a368f..27cc4f7aae 100644 --- a/compiler/main/SysTools/ExtraObj.hs +++ b/compiler/main/SysTools/ExtraObj.hs @@ -19,8 +19,8 @@ import GHC.Driver.Session import GHC.Driver.Packages import GHC.Platform import Outputable -import SrcLoc ( noSrcSpan ) -import Module +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Types.Module import Elf import Util import GhcPrelude diff --git a/compiler/main/SysTools/Process.hs b/compiler/main/SysTools/Process.hs index aa5d6617d3..a95d9c958a 100644 --- a/compiler/main/SysTools/Process.hs +++ b/compiler/main/SysTools/Process.hs @@ -18,7 +18,7 @@ import Outputable import Panic import GhcPrelude import Util -import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) +import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) import Control.Concurrent import Data.Char diff --git a/compiler/main/UnitInfo.hs b/compiler/main/UnitInfo.hs index de8c94541a..b1a307a7fe 100644 --- a/compiler/main/UnitInfo.hs +++ b/compiler/main/UnitInfo.hs @@ -37,8 +37,8 @@ import Data.Version import FastString import Outputable -import Module -import Unique +import GHC.Types.Module as Module +import GHC.Types.Unique -- ----------------------------------------------------------------------------- -- Our UnitInfo type is the InstalledPackageInfo from ghc-boot, diff --git a/compiler/main/UpdateCafInfos.hs b/compiler/main/UpdateCafInfos.hs index dd4881ec6e..c8a0e725e3 100644 --- a/compiler/main/UpdateCafInfos.hs +++ b/compiler/main/UpdateCafInfos.hs @@ -9,13 +9,13 @@ import GhcPrelude import GHC.Core import GHC.Driver.Session import GHC.Driver.Types -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core.InstEnv -import NameEnv -import NameSet +import GHC.Types.Name.Env +import GHC.Types.Name.Set import Util -import Var +import GHC.Types.Var import Outputable #include "HsVersions.h" diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs index 52905902b6..5ad598da94 100644 --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -15,9 +15,9 @@ module ApiAnnotation ( import GhcPrelude -import RdrName +import GHC.Types.Name.Reader import Outputable -import SrcLoc +import GHC.Types.SrcLoc import qualified Data.Map as Map import Data.Data diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs index b8e0c564a6..73429ec14a 100644 --- a/compiler/parser/HaddockUtils.hs +++ b/compiler/parser/HaddockUtils.hs @@ -5,7 +5,7 @@ module HaddockUtils where import GhcPrelude import GHC.Hs -import SrcLoc +import GHC.Types.SrcLoc import Control.Monad diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 5fa0af85ad..a99a62913e 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -97,7 +97,7 @@ import Bag import Outputable import StringBuffer import FastString -import UniqFM +import GHC.Types.Unique.FM import Util ( readRational, readHexRational ) -- compiler/main @@ -105,11 +105,11 @@ import ErrUtils import GHC.Driver.Session as DynFlags -- compiler/basicTypes -import SrcLoc -import Module -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), - IntegralLit(..), FractionalLit(..), - SourceText(..) ) +import GHC.Types.SrcLoc +import GHC.Types.Module +import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..), + IntegralLit(..), FractionalLit(..), + SourceText(..) ) -- compiler/parser import Ctype diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 88422f9b3f..e87cad6dae 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -62,12 +62,12 @@ import Maybes ( isJust, orElse ) import Outputable -- compiler/basicTypes -import RdrName -import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) -import GHC.Core.DataCon ( DataCon, dataConName ) -import SrcLoc -import Module -import BasicTypes +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) +import GHC.Core.DataCon ( DataCon, dataConName ) +import GHC.Types.SrcLoc +import GHC.Types.Module +import GHC.Types.Basic -- compiler/types import GHC.Core.Type ( funTyCon ) @@ -83,7 +83,7 @@ import ApiAnnotation import TcEvidence ( emptyTcEvBinds ) -- compiler/prelude -import ForeignCall +import GHC.Types.ForeignCall import TysPrim ( eqPrimTyCon ) import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, @@ -2188,8 +2188,8 @@ When the user write Zero instead of 'Zero in types, we parse it a HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not bounded in the type level, then we look for it in the term level (we -change its namespace to DataName, see Note [Demotion] in OccName). And -both become a HsTyVar ("Zero", DataName) after the renamer. +change its namespace to DataName, see Note [Demotion] in GHC.Types.Names.OccName). +And both become a HsTyVar ("Zero", DataName) after the renamer. -} diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 599846398b..485d1bf80e 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -108,20 +108,20 @@ import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) import GHC.Core.DataCon ( DataCon, dataConTyCon ) import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) -import RdrName -import Name -import BasicTypes +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Basic import Lexer -import Lexeme ( isLexCon ) +import GHC.Utils.Lexeme ( isLexCon ) import GHC.Core.Type ( TyThing(..), funTyCon ) import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, listTyConName, listTyConKey, eqTyCon_RDR, tupleTyConName, cTupleTyConNameArity_maybe ) -import ForeignCall +import GHC.Types.ForeignCall import PrelNames ( allNameStrings ) -import SrcLoc -import Unique ( hasKey ) +import GHC.Types.SrcLoc +import GHC.Types.Unique ( hasKey ) import OrdList ( OrdList, fromOL ) import Bag ( emptyBag, consBag ) import Outputable @@ -2548,7 +2548,7 @@ mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -- The (Maybe Activation) is because the user can omit -- the activation spec (and usually does) mkInlinePragma src (inl, match_info) mb_act - = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes + = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.Basic , inl_inline = inl , inl_sat = Nothing , inl_act = act diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs deleted file mode 100644 index c143b1ed1e..0000000000 --- a/compiler/prelude/ForeignCall.hs +++ /dev/null @@ -1,348 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Foreign]{Foreign calls} --} - -{-# LANGUAGE DeriveDataTypeable #-} - -module ForeignCall ( - ForeignCall(..), isSafeForeignCall, - Safety(..), playSafe, playInterruptible, - - CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, - CCallSpec(..), - CCallTarget(..), isDynamicTarget, - CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, - - Header(..), CType(..), - ) where - -import GhcPrelude - -import FastString -import Binary -import Outputable -import Module -import BasicTypes ( SourceText, pprWithSourceText ) - -import Data.Char -import Data.Data - -{- -************************************************************************ -* * -\subsubsection{Data types} -* * -************************************************************************ --} - -newtype ForeignCall = CCall CCallSpec - deriving Eq - -isSafeForeignCall :: ForeignCall -> Bool -isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe - --- We may need more clues to distinguish foreign calls --- but this simple printer will do for now -instance Outputable ForeignCall where - ppr (CCall cc) = ppr cc - -data Safety - = PlaySafe -- Might invoke Haskell GC, or do a call back, or - -- switch threads, etc. So make sure things are - -- tidy before the call. Additionally, in the threaded - -- RTS we arrange for the external call to be executed - -- by a separate OS thread, i.e., _concurrently_ to the - -- execution of other Haskell threads. - - | PlayInterruptible -- Like PlaySafe, but additionally - -- the worker thread running this foreign call may - -- be unceremoniously killed, so it must be scheduled - -- on an unbound thread. - - | PlayRisky -- None of the above can happen; the call will return - -- without interacting with the runtime system at all - deriving ( Eq, Show, Data ) - -- Show used just for Show Lex.Token, I think - -instance Outputable Safety where - ppr PlaySafe = text "safe" - ppr PlayInterruptible = text "interruptible" - ppr PlayRisky = text "unsafe" - -playSafe :: Safety -> Bool -playSafe PlaySafe = True -playSafe PlayInterruptible = True -playSafe PlayRisky = False - -playInterruptible :: Safety -> Bool -playInterruptible PlayInterruptible = True -playInterruptible _ = False - -{- -************************************************************************ -* * -\subsubsection{Calling C} -* * -************************************************************************ --} - -data CExportSpec - = CExportStatic -- foreign export ccall foo :: ty - SourceText -- of the CLabelString. - -- See note [Pragma source text] in BasicTypes - CLabelString -- C Name of exported function - CCallConv - deriving Data - -data CCallSpec - = CCallSpec CCallTarget -- What to call - CCallConv -- Calling convention to use. - Safety - deriving( Eq ) - --- The call target: - --- | How to call a particular function in C-land. -data CCallTarget - -- An "unboxed" ccall# to named function in a particular package. - = StaticTarget - SourceText -- of the CLabelString. - -- See note [Pragma source text] in BasicTypes - CLabelString -- C-land name of label. - - (Maybe UnitId) -- What package the function is in. - -- If Nothing, then it's taken to be in the current package. - -- Note: This information is only used for PrimCalls on Windows. - -- See CLabel.labelDynamic and CoreToStg.coreToStgApp - -- for the difference in representation between PrimCalls - -- and ForeignCalls. If the CCallTarget is representing - -- a regular ForeignCall then it's safe to set this to Nothing. - - -- The first argument of the import is the name of a function pointer (an Addr#). - -- Used when importing a label as "foreign import ccall "dynamic" ..." - Bool -- True => really a function - -- False => a value; only - -- allowed in CAPI imports - | DynamicTarget - - deriving( Eq, Data ) - -isDynamicTarget :: CCallTarget -> Bool -isDynamicTarget DynamicTarget = True -isDynamicTarget _ = False - -{- -Stuff to do with calling convention: - -ccall: Caller allocates parameters, *and* deallocates them. - -stdcall: Caller allocates parameters, callee deallocates. - Function name has @N after it, where N is number of arg bytes - e.g. _Foo@8. This convention is x86 (win32) specific. - -See: http://www.programmersheaven.com/2/Calling-conventions --} - --- any changes here should be replicated in the CallConv type in template haskell -data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv - deriving (Eq, Data) - -instance Outputable CCallConv where - ppr StdCallConv = text "stdcall" - ppr CCallConv = text "ccall" - ppr CApiConv = text "capi" - ppr PrimCallConv = text "prim" - ppr JavaScriptCallConv = text "javascript" - -defaultCCallConv :: CCallConv -defaultCCallConv = CCallConv - -ccallConvToInt :: CCallConv -> Int -ccallConvToInt StdCallConv = 0 -ccallConvToInt CCallConv = 1 -ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" -ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" -ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" - -{- -Generate the gcc attribute corresponding to the given -calling convention (used by PprAbsC): --} - -ccallConvAttribute :: CCallConv -> SDoc -ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" -ccallConvAttribute CCallConv = empty -ccallConvAttribute CApiConv = empty -ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" -ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" - -type CLabelString = FastString -- A C label, completely unencoded - -pprCLabelString :: CLabelString -> SDoc -pprCLabelString lbl = ftext lbl - -isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label -isCLabelString lbl - = all ok (unpackFS lbl) - where - ok c = isAlphaNum c || c == '_' || c == '.' - -- The '.' appears in e.g. "foo.so" in the - -- module part of a ExtName. Maybe it should be separate - --- Printing into C files: - -instance Outputable CExportSpec where - ppr (CExportStatic _ str _) = pprCLabelString str - -instance Outputable CCallSpec where - ppr (CCallSpec fun cconv safety) - = hcat [ whenPprDebug callconv, ppr_fun fun ] - where - callconv = text "{-" <> ppr cconv <> text "-}" - - gc_suf | playSafe safety = text "_GC" - | otherwise = empty - - ppr_fun (StaticTarget st _fn mPkgId isFun) - = text (if isFun then "__pkg_ccall" - else "__pkg_ccall_value") - <> gc_suf - <+> (case mPkgId of - Nothing -> empty - Just pkgId -> ppr pkgId) - <+> (pprWithSourceText st empty) - - ppr_fun DynamicTarget - = text "__dyn_ccall" <> gc_suf <+> text "\"\"" - --- The filename for a C header file --- Note [Pragma source text] in BasicTypes -data Header = Header SourceText FastString - deriving (Eq, Data) - -instance Outputable Header where - ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) - --- | A C type, used in CAPI FFI calls --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, --- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', --- 'ApiAnnotation.AnnClose' @'\#-}'@, - --- For details on above see note [Api annotations] in ApiAnnotation -data CType = CType SourceText -- Note [Pragma source text] in BasicTypes - (Maybe Header) -- header to include for this type - (SourceText,FastString) -- the type itself - deriving (Eq, Data) - -instance Outputable CType where - ppr (CType stp mh (stct,ct)) - = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc - <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" - where hDoc = case mh of - Nothing -> empty - Just h -> ppr h - -{- -************************************************************************ -* * -\subsubsection{Misc} -* * -************************************************************************ --} - -instance Binary ForeignCall where - put_ bh (CCall aa) = put_ bh aa - get bh = do aa <- get bh; return (CCall aa) - -instance Binary Safety where - put_ bh PlaySafe = do - putByte bh 0 - put_ bh PlayInterruptible = do - putByte bh 1 - put_ bh PlayRisky = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return PlaySafe - 1 -> do return PlayInterruptible - _ -> do return PlayRisky - -instance Binary CExportSpec where - put_ bh (CExportStatic ss aa ab) = do - put_ bh ss - put_ bh aa - put_ bh ab - get bh = do - ss <- get bh - aa <- get bh - ab <- get bh - return (CExportStatic ss aa ab) - -instance Binary CCallSpec where - put_ bh (CCallSpec aa ab ac) = do - put_ bh aa - put_ bh ab - put_ bh ac - get bh = do - aa <- get bh - ab <- get bh - ac <- get bh - return (CCallSpec aa ab ac) - -instance Binary CCallTarget where - put_ bh (StaticTarget ss aa ab ac) = do - putByte bh 0 - put_ bh ss - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh DynamicTarget = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do ss <- get bh - aa <- get bh - ab <- get bh - ac <- get bh - return (StaticTarget ss aa ab ac) - _ -> do return DynamicTarget - -instance Binary CCallConv where - put_ bh CCallConv = do - putByte bh 0 - put_ bh StdCallConv = do - putByte bh 1 - put_ bh PrimCallConv = do - putByte bh 2 - put_ bh CApiConv = do - putByte bh 3 - put_ bh JavaScriptCallConv = do - putByte bh 4 - get bh = do - h <- getByte bh - case h of - 0 -> do return CCallConv - 1 -> do return StdCallConv - 2 -> do return PrimCallConv - 3 -> do return CApiConv - _ -> do return JavaScriptCallConv - -instance Binary CType where - put_ bh (CType s mh fs) = do put_ bh s - put_ bh mh - put_ bh fs - get bh = do s <- get bh - mh <- get bh - fs <- get bh - return (CType s mh fs) - -instance Binary Header where - put_ bh (Header s h) = put_ bh s >> put_ bh h - get bh = do s <- get bh - h <- get bh - return (Header s h) diff --git a/compiler/prelude/KnownUniques.hs b/compiler/prelude/KnownUniques.hs index 1d292d899b..75b6719bba 100644 --- a/compiler/prelude/KnownUniques.hs +++ b/compiler/prelude/KnownUniques.hs @@ -31,11 +31,11 @@ import GhcPrelude import TysWiredIn import GHC.Core.TyCon import GHC.Core.DataCon -import Id -import BasicTypes +import GHC.Types.Id +import GHC.Types.Basic import Outputable -import Unique -import Name +import GHC.Types.Unique +import GHC.Types.Name import Util import Data.Bits @@ -65,7 +65,7 @@ knownUniqueName u = -- tag (used to identify the sum's TypeRep binding). -- -- This layout is chosen to remain compatible with the usual unique allocation --- for wired-in data constructors described in Unique.hs +-- for wired-in data constructors described in GHC.Types.Unique -- -- TyCon for sum of arity k: -- 00000000 kkkkkkkk 11111100 diff --git a/compiler/prelude/KnownUniques.hs-boot b/compiler/prelude/KnownUniques.hs-boot index b217c84aca..b43598cc17 100644 --- a/compiler/prelude/KnownUniques.hs-boot +++ b/compiler/prelude/KnownUniques.hs-boot @@ -1,9 +1,9 @@ module KnownUniques where import GhcPrelude -import Unique -import Name -import BasicTypes +import GHC.Types.Unique +import GHC.Types.Name +import GHC.Types.Basic -- Needed by TysWiredIn knownUniqueName :: Unique -> Maybe Name diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs index 0b7a962f3f..1a47d59e38 100644 --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -49,26 +49,26 @@ module PrelInfo ( import GhcPrelude import KnownUniques -import Unique ( isValidKnownKeyUnique ) +import GHC.Types.Unique ( isValidKnownKeyUnique ) import GHC.Core.ConLike ( ConLike(..) ) import THNames ( templateHaskellNames ) import PrelNames import GHC.Core.Op.ConstantFold -import Avail +import GHC.Types.Avail import PrimOp import GHC.Core.DataCon -import Id -import Name -import NameEnv -import MkId +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id.Make import Outputable import TysPrim import TysWiredIn import GHC.Driver.Types import GHC.Core.Class import GHC.Core.TyCon -import UniqFM +import GHC.Types.Unique.FM import Util import TcTypeNats ( typeNatTyCons ) @@ -89,12 +89,12 @@ Note [About wired-in things] * Wired-in things are Ids\/TyCons that are completely known to the compiler. They are global values in GHC, (e.g. listTyCon :: TyCon). -* A wired in Name contains the thing itself inside the Name: +* A wired-in Name contains the thing itself inside the Name: see Name.wiredInNameTyThing_maybe (E.g. listTyConName contains listTyCon. * The name cache is initialised with (the names of) all wired-in things - (except tuples and sums; see Note [Known-]) + (except tuples and sums; see Note [Infinite families of known-key names]) * The type environment itself contains no wired in things. The type checker sees if the Name is wired in before looking up the name in diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index e0d957c00a..8452ac734c 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -139,7 +139,7 @@ this constructor directly (see CorePrep.lookupIntegerSDataConName) When GHC reads the package data base, it (internally only) pretends it has UnitId `integer-wired-in` instead of the actual UnitId (which includes the version number); just like for `base` and other packages, as described in -Note [Wired-in packages] in Module. This is done in Packages.findWiredInPackages. +Note [Wired-in packages] in GHC.Types.Module. This is done in Packages.findWiredInPackages. -} {-# LANGUAGE CPP #-} @@ -160,12 +160,12 @@ module PrelNames ( import GhcPrelude -import Module -import OccName -import RdrName -import Unique -import Name -import SrcLoc +import GHC.Types.Module +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC.Types.Unique +import GHC.Types.Name +import GHC.Types.SrcLoc import FastString {- diff --git a/compiler/prelude/PrelNames.hs-boot b/compiler/prelude/PrelNames.hs-boot index 0bd74d5577..9906496b37 100644 --- a/compiler/prelude/PrelNames.hs-boot +++ b/compiler/prelude/PrelNames.hs-boot @@ -1,7 +1,7 @@ module PrelNames where -import Module -import Unique +import GHC.Types.Module +import GHC.Types.Unique mAIN :: Module liftedTypeKindTyConKey :: Unique diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index 96160a27f3..0774edef63 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -31,22 +31,22 @@ import TysPrim import TysWiredIn import GHC.Cmm.Type -import Demand -import Id ( Id, mkVanillaGlobalWithInfo ) -import IdInfo ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) ) -import Name -import PrelNames ( gHC_PRIMOPWRAPPERS ) +import GHC.Types.Demand +import GHC.Types.Id ( Id, mkVanillaGlobalWithInfo ) +import GHC.Types.Id.Info ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) ) +import GHC.Types.Name +import PrelNames ( gHC_PRIMOPWRAPPERS ) import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import GHC.Core.Type import GHC.Types.RepType ( typePrimRep1, tyConPrimRep1 ) -import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..), - SourceText(..) ) -import SrcLoc ( wiredInSrcSpan ) -import ForeignCall ( CLabelString ) -import Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique ) +import GHC.Types.Basic ( Arity, Fixity(..), FixityDirection(..), Boxity(..), + SourceText(..) ) +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 Module ( UnitId ) {- ************************************************************************ diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 7e131aa1ca..e2efbdaa0d 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -9,11 +9,11 @@ module THNames where import GhcPrelude () import PrelNames( mk_known_key_name ) -import Module( Module, mkModuleNameFS, mkModule, thUnitId ) -import Name( Name ) -import OccName( tcName, clsName, dataName, varName ) -import RdrName( RdrName, nameRdrName ) -import Unique +import GHC.Types.Module( Module, mkModuleNameFS, mkModule, thUnitId ) +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 -- To add a name, do three things @@ -170,13 +170,13 @@ mkTHModule :: FastString -> Module mkTHModule m = mkModule thUnitId (mkModuleNameFS m) libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name -libFun = mk_known_key_name OccName.varName thLib -libTc = mk_known_key_name OccName.tcName thLib -thFun = mk_known_key_name OccName.varName thSyn -thTc = mk_known_key_name OccName.tcName thSyn -thCls = mk_known_key_name OccName.clsName thSyn -thCon = mk_known_key_name OccName.dataName thSyn -qqFun = mk_known_key_name OccName.varName qqLib +libFun = mk_known_key_name varName thLib +libTc = mk_known_key_name tcName thLib +thFun = mk_known_key_name varName thSyn +thTc = mk_known_key_name tcName thSyn +thCls = mk_known_key_name clsName thSyn +thCon = mk_known_key_name dataName thSyn +qqFun = mk_known_key_name varName qqLib -------------------- TH.Syntax ----------------------- liftClassName :: Name diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index e9cdb81fc8..422ed27fe1 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -110,11 +110,11 @@ import {-# SOURCE #-} TysWiredIn , doubleElemRepDataConTy , mkPromotedListTy ) -import Var ( TyVar, mkTyVar ) -import Name +import GHC.Types.Var ( TyVar, mkTyVar ) +import GHC.Types.Name import GHC.Core.TyCon -import SrcLoc -import Unique +import GHC.Types.SrcLoc +import GHC.Types.Unique import PrelNames import FastString import Outputable diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 908b0e1566..8db8379131 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -16,7 +16,7 @@ module TysWiredIn ( mkWiredInTyConName, -- This is used in TcTypeNats to define the -- built-in functions for evaluation. - mkWiredInIdName, -- used in MkId + mkWiredInIdName, -- used in GHC.Types.Id.Make -- * All wired in things wiredInTyCons, isBuiltInOcc_maybe, @@ -132,7 +132,7 @@ module TysWiredIn ( import GhcPrelude -import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId ) +import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId ) -- friends: import PrelNames @@ -141,23 +141,23 @@ import {-# SOURCE #-} KnownUniques -- others: import GHC.Core.Coercion.Axiom -import Id +import GHC.Types.Id import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) -import Module ( Module ) +import GHC.Types.Module ( Module ) import GHC.Core.Type import GHC.Types.RepType import GHC.Core.DataCon import {-# SOURCE #-} GHC.Core.ConLike import GHC.Core.TyCon -import GHC.Core.Class ( Class, mkClass ) -import RdrName -import Name -import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) -import NameSet ( NameSet, mkNameSet, elemNameSet ) -import BasicTypes -import ForeignCall -import SrcLoc ( noSrcSpan ) -import Unique +import GHC.Core.Class ( Class, mkClass ) +import GHC.Types.Name.Reader +import GHC.Types.Name as Name +import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) +import GHC.Types.Name.Set ( NameSet, mkNameSet, elemNameSet ) +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc ( noSrcSpan ) +import GHC.Types.Unique import Data.Array import FastString import Outputable diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot index 7fe222b825..426c1015a6 100644 --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -3,8 +3,8 @@ module TysWiredIn where import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind) -import BasicTypes (Arity, TupleSort) -import Name (Name) +import GHC.Types.Basic (Arity, TupleSort) +import GHC.Types.Name (Name) listTyCon :: TyCon typeNatKind, typeSymbolKind :: Type diff --git a/compiler/profiling-notes b/compiler/profiling-notes new file mode 100644 index 0000000000..824d52b12a --- /dev/null +++ b/compiler/profiling-notes @@ -0,0 +1,303 @@ +Profiling Implementation Notes -- June/July/Sept 1994 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Simon and Will + +Pre-code-generator-ish +~~~~~~~~~~~~~~~~~~~~~~ + +* Automagic insertion of _sccs_ on... + + - If -fprof-auto-exported is specified, add _scc_ on each *exported* top-level definition. + NB this includes CAFs. Done by addAutoCostCentres (Core-to-Core pass). + + - If -fprof-auto-top is specified, add _scc_ on *all* top-level definitions. + Done by same pass. + + - If -fprof-auto is specified, add _scc_ on *all* definitions. + + - Always: just before code generation of module M, onto any CAF + which hasn't already got an explicit cost centre attached, pin + "AllCAFs-M". + + Done by finalStgMassageForProfiling (final STG-to-STG pass) + + Only the one-off costs of evaluating the CAFs will be attributed + to the AllCAFs-M cost centre. We hope that these costs will be + small; since the _scc_s are introduced automatically it's + confusing to attribute any significant costs to them. However if + there *are* significant one-off costs we'd better know about it. + + Why so late in the compilation process? We aren't *absolutely* + sure what is and isn't a CAF until *just* before code generation. + So we don't want to mark them as such until then. + + - Individual DICTs + + We do it in the desugarer, because that's the *only* point at + which we *know* exactly what bindings are introduced by + overloading. NB should include bindings for selected methods, eg + + f d = let op = _scc_ DICT op_sel d in + ...op...op...op + + The DICT CC ensures that: + (a) [minor] that the selection cost is separately attributed + (b) [major] that the cost of executing op is attributed to + its call site, eg + + ...(scc "a" op)...(scc "b" op)...(scc "c" op)... + +* Automagic "boxing" of higher-order args: + + finalStgMassageForProfiling (final STG-to-STG pass) + + This (as well as CAF stuff above) is really quite separate + from the other business of finalStgMassageForProfiling + (collecting up CostCentres that need to be + declared/registered). + + But throwing it all into the pot together means that we don't + have to have Yet Another STG Syntax Walker. + + Furthermore, these "boxes" are really just let-bindings that + many other parts of the compiler will happily substitute away! + Doing them at the very last instant prevents this. + + A down side of doing these so late is that we get lots of + "let"s, which if generated earlier and not substituted away, + could be floated outwards. Having them floated outwards would + lessen the chance of skewing profiling results (because of + gratuitous "let"s added by the compiler into the inner loop of + some program...). The allocation itself will be attributed to + profiling overhead; the only thing which'll be skewed is time measurement. + + So if we have, post-boxing-higher-order-args... + + _scc_ "foo" ( let f' = [f] \ [] f + in + map f' xs ) + + ... we want "foo" to be put in the thunk for "f'", but we want the + allocation cost (heap census stuff) to be attr to OVERHEAD. + + As an example of what could be improved + f = _scc_ "f" (g h) + To save dynamic allocation, we could have a static closure for h: + h_inf = _scc_ "f" h + f = _scc_ "f" (g h_inf) + + + + + +Code generator-ish +~~~~~~~~~~~~~~~~~~ + +(1) _Entry_ code for a closure *usually* sets CC from the closure, + at the fast entry point + + Exceptions: + + (a) Top-level subsumed functions (i.e., w/ no _scc_ on them) + + Refrain from setting CC from the closure + + (b) Constructors + + Again, refrain. (This is *new*) + + Reasons: (i) The CC will be zapped very shortly by the restore + of the enclosing CC when we return to the eval'ing "case". + (ii) Any intervening updates will indirect to this existing + constructor (...mumble... new update mechanism... mumble...) + +(2) "_scc_ cc expr" + + Set current CC to "cc". + No later "restore" of the previous CC is reqd. + +(3) "case e of { ...alts... }" expression (eval) + + Save CC before eval'ing scrutinee + Restore CC at the start of the case-alternative(s) + +(4) _Updates_ : updatee gets current CC + + (???? not sure this is OK yet 94/07/04) + + Reasons: + + * Constructors : want to be insensitive to return-in-heap vs + return-in-regs. For example, + + f x = _scc_ "f" (x, x) + + The pair (x,x) would get CC of "f" if returned-in-heap; + therefore, updatees should get CC of "f". + + * PAPs : Example: + + f x = _scc_ "f" (let g = \ y -> ... in g) + + At the moment of update (updatePAP?), CC is "f", which + is what we want to set it to if the "updatee" is entered + + When we enter the PAP ("please put the arguments back so I can + use them"), we restore the setup as at the moment the + arg-satisfaction check failed. + + Be careful! UPDATE_PAP is called from the arg-satis check, + which is before the fast entry point. So the cost centre + won't yet have been set from the closure which has just + been entered. Solution: in UPDATE_PAP see if the cost centre inside + the function closure which is being entered is "SUB"; if so, use + the current cost centre to update the updatee; otherwise use that + inside the function closure. (See the computation of cc_pap + in rule 16_l for lexical semantics.) + + +(5) CAFs + +CAFs get their own cost centre. Ie + + x = e +is transformed to + x = _scc_ "CAF:x" e + +Or sometimes we lump all the CAFs in a module together. +(Reporting issue or code-gen issue?) + + + +Hybrid stuff +~~~~~~~~~~~~ + +The problem: + + f = _scc_ "CAF:f" (let g = \xy -> ... + in (g,g)) + +Now, g has cost-centre "CAF:f", and is returned as part of +the result. So whenever the function embedded in the result +is called, the costs will accumulate to "CAF:f". This is +particularly (de)pressing for dictionaries, which contain lots +of functions. + +Solution: + + A. Whenever in case (1) above we would otherwise "set the CC from the + closure", we *refrain* from doing so if + (a) the closure is a function, not a thunk; and + (b) the cost-centre in the closure is a CAF cost centre. + + B. Whenever we enter a thunk [at least, one which might return a function] + we save the current cost centre in the update frame. Then, UPDATE_PAP + restores the saved cost centre from the update frame iff the cost + centre at the point of update (cc_pap in (4) above) is a CAF cost centre. + + It isn't necessary to save and possibly-restore the cost centre for + thunks which will certainly return a constructor, because the + cost centre is about to be restored anyway by the enclosing case. + +Both A and B are runtime tests. For A, consider: + + f = _scc_ "CAF:f" (g 2) + + h y = _scc_ "h" g (y+y) + + g x = let w = \p -> ... + in (w,w) + + +Now, in the call to g from h, the cost-centre on w will be "h", and +indeed all calls to the result of the call should be attributed to +"h". + + ... _scc_ "x1" (let (t,_) = h 2 in t 3) ... + + Costs of executing (w 3) attributed to "h". + +But in the call to g from f, the cost-centre on w will be +"CAF:f", and calls to w should be attributed to the call site. + + ..._scc_ "x2" (let (t,_) = f in t 3)... + + Costs of executing (w 3) attributed to "x2". + + + Remaining problem + +Consider + + _scc_ "CAF:f" (if expensive then g 2 else g 3) + +where g is a function with arity 2. In theory we should +restore the enclosing cost centre once we've reduced to +(g 2) or (g 3). In practice this is pretty tiresome; and pretty rare. + +A quick fix: given (_scc_ "CAF" e) where e might be function-valued +(in practice we usually know, because CAF sccs are top level), transform to + + _scc_ "CAF" (let f = e in f) + + + + + +============ + +scc cc x ===> x + + UNLESS + +(a) cc is a user-defined, non-dup'd cost + centre (so we care about entry counts) + +OR + +(b) cc is not a CAF/DICT cost centre and x is top-level subsumed + function. + [If x is lambda/let bound it'll have a cost centre + attached dynamically.] + + To repeat, the transformation is OK if + x is a not top-level subsumed function + OR + cc is a CAF/DICT cost centre and x is a top-level + subsumed function + + + +(scc cc e) x ===> (scc cc e x) + + OK????? IFF + +cc is not CAF/DICT --- remains to be proved!!!!!! +True for lex +False for eval +Can we tell which in hybrid? + +eg Is this ok? + + (scc "f" (scc "CAF" (\x.b))) y ==> (scc "f" (scc "CAF" (\x.b) y)) + + +\x -> (scc cc e) ===> (scc cc \x->e) + + OK IFF cc is not CAF/DICT + + +scc cc1 (scc cc2 e)) ===> scc cc2 e + + IFF not interested in cc1's entry count + AND cc2 is not CAF/DICT + +(scc cc1 ... (scc cc2 e) ...) ===> (scc cc1 ... e ...) + + IFF cc2 is CAF/DICT + AND e is a lambda not appearing as the RHS of a let + OR + e is a variable not bound to SUB + + diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs deleted file mode 100644 index 91a4ef0ec7..0000000000 --- a/compiler/profiling/CostCentre.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module CostCentre ( - CostCentre(..), CcName, CCFlavour(..), - -- All abstract except to friend: ParseIface.y - - CostCentreStack, - CollectedCCs, emptyCollectedCCs, collectCC, - currentCCS, dontCareCCS, - isCurrentCCS, - maybeSingletonCCS, - - mkUserCC, mkAutoCC, mkAllCafsCC, - mkSingletonCCS, - isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, - - pprCostCentreCore, - costCentreUserName, costCentreUserNameFS, - costCentreSrcSpan, - - cmpCostCentre -- used for removing dups in a list - ) where - -import GhcPrelude - -import Binary -import Var -import Name -import Module -import Unique -import Outputable -import SrcLoc -import FastString -import Util -import CostCentreState - -import Data.Data - ------------------------------------------------------------------------------ --- Cost Centres - --- | A Cost Centre is a single @{-# SCC #-}@ annotation. - -data CostCentre - = NormalCC { - cc_flavour :: CCFlavour, - -- ^ Two cost centres may have the same name and - -- module but different SrcSpans, so we need a way to - -- distinguish them easily and give them different - -- object-code labels. So every CostCentre has an - -- associated flavour that indicates how it was - -- generated, and flavours that allow multiple instances - -- of the same name and module have a deterministic 0-based - -- index. - cc_name :: CcName, -- ^ Name of the cost centre itself - cc_mod :: Module, -- ^ Name of module defining this CC. - cc_loc :: SrcSpan - } - - | AllCafsCC { - cc_mod :: Module, -- Name of module defining this CC. - cc_loc :: SrcSpan - } - deriving Data - -type CcName = FastString - --- | The flavour of a cost centre. --- --- Index fields represent 0-based indices giving source-code ordering of --- centres with the same module, name, and flavour. -data CCFlavour = CafCC -- ^ Auto-generated top-level thunk - | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression - | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration - | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage - deriving (Eq, Ord, Data) - --- | Extract the index from a flavour -flavourIndex :: CCFlavour -> Int -flavourIndex CafCC = 0 -flavourIndex (ExprCC x) = unCostCentreIndex x -flavourIndex (DeclCC x) = unCostCentreIndex x -flavourIndex (HpcCC x) = unCostCentreIndex x - -instance Eq CostCentre where - c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } - -instance Ord CostCentre where - compare = cmpCostCentre - -cmpCostCentre :: CostCentre -> CostCentre -> Ordering - -cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) - = m1 `compare` m2 - -cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1} - NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2} - -- first key is module name, then centre name, then flavour - = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2) - -cmpCostCentre other_1 other_2 - = let - tag1 = tag_CC other_1 - tag2 = tag_CC other_2 - in - if tag1 < tag2 then LT else GT - where - tag_CC :: CostCentre -> Int - tag_CC (NormalCC {}) = 0 - tag_CC (AllCafsCC {}) = 1 - - ------------------------------------------------------------------------------ --- Predicates on CostCentre - -isCafCC :: CostCentre -> Bool -isCafCC (AllCafsCC {}) = True -isCafCC (NormalCC {cc_flavour = CafCC}) = True -isCafCC _ = False - --- | Is this a cost-centre which records scc counts -isSccCountCC :: CostCentre -> Bool -isSccCountCC cc | isCafCC cc = False - | otherwise = True - --- | Is this a cost-centre which can be sccd ? -sccAbleCC :: CostCentre -> Bool -sccAbleCC cc | isCafCC cc = False - | otherwise = True - -ccFromThisModule :: CostCentre -> Module -> Bool -ccFromThisModule cc m = cc_mod cc == m - - ------------------------------------------------------------------------------ --- Building cost centres - -mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre -mkUserCC cc_name mod loc flavour - = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc, - cc_flavour = flavour - } - -mkAutoCC :: Id -> Module -> CostCentre -mkAutoCC id mod - = NormalCC { cc_name = str, cc_mod = mod, - cc_loc = nameSrcSpan (getName id), - cc_flavour = CafCC - } - where - name = getName id - -- beware: only external names are guaranteed to have unique - -- Occnames. If the name is not external, we must append its - -- Unique. - -- See bug #249, tests prof001, prof002, also #2411 - str | isExternalName name = occNameFS (getOccName id) - | otherwise = occNameFS (getOccName id) - `appendFS` - mkFastString ('_' : show (getUnique name)) -mkAllCafsCC :: Module -> SrcSpan -> CostCentre -mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } - ------------------------------------------------------------------------------ --- Cost Centre Stacks - --- | A Cost Centre Stack is something that can be attached to a closure. --- This is either: --- --- * the current cost centre stack (CCCS) --- * a pre-defined cost centre stack (there are several --- pre-defined CCSs, see below). - -data CostCentreStack - = CurrentCCS -- Pinned on a let(rec)-bound - -- thunk/function/constructor, this says that the - -- cost centre to be attached to the object, when it - -- is allocated, is whatever is in the - -- current-cost-centre-stack register. - - | DontCareCCS -- We need a CCS to stick in static closures - -- (for data), but we *don't* expect them to - -- accumulate any costs. But we still need - -- the placeholder. This CCS is it. - - | SingletonCCS CostCentre - - deriving (Eq, Ord) -- needed for Ord on CLabel - - --- synonym for triple which describes the cost centre info in the generated --- code for a module. -type CollectedCCs - = ( [CostCentre] -- local cost-centres that need to be decl'd - , [CostCentreStack] -- pre-defined "singleton" cost centre stacks - ) - -emptyCollectedCCs :: CollectedCCs -emptyCollectedCCs = ([], []) - -collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs -collectCC cc ccs (c, cs) = (cc : c, ccs : cs) - -currentCCS, dontCareCCS :: CostCentreStack - -currentCCS = CurrentCCS -dontCareCCS = DontCareCCS - ------------------------------------------------------------------------------ --- Predicates on Cost-Centre Stacks - -isCurrentCCS :: CostCentreStack -> Bool -isCurrentCCS CurrentCCS = True -isCurrentCCS _ = False - -isCafCCS :: CostCentreStack -> Bool -isCafCCS (SingletonCCS cc) = isCafCC cc -isCafCCS _ = False - -maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre -maybeSingletonCCS (SingletonCCS cc) = Just cc -maybeSingletonCCS _ = Nothing - -mkSingletonCCS :: CostCentre -> CostCentreStack -mkSingletonCCS cc = SingletonCCS cc - - ------------------------------------------------------------------------------ --- Printing Cost Centre Stacks. - --- The outputable instance for CostCentreStack prints the CCS as a C --- expression. - -instance Outputable CostCentreStack where - ppr CurrentCCS = text "CCCS" - ppr DontCareCCS = text "CCS_DONT_CARE" - ppr (SingletonCCS cc) = ppr cc <> text "_ccs" - - ------------------------------------------------------------------------------ --- Printing Cost Centres --- --- There are several different ways in which we might want to print a --- cost centre: --- --- - the name of the cost centre, for profiling output (a C string) --- - the label, i.e. C label for cost centre in .hc file. --- - the debugging name, for output in -ddump things --- - the interface name, for printing in _scc_ exprs in iface files. --- --- The last 3 are derived from costCentreStr below. The first is given --- by costCentreName. - -instance Outputable CostCentre where - ppr cc = getPprStyle $ \ sty -> - if codeStyle sty - then ppCostCentreLbl cc - else text (costCentreUserName cc) - --- Printing in Core -pprCostCentreCore :: CostCentre -> SDoc -pprCostCentreCore (AllCafsCC {cc_mod = m}) - = text "__sccC" <+> braces (ppr m) -pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n, - cc_mod = m, cc_loc = loc}) - = text "__scc" <+> braces (hsep [ - ppr m <> char '.' <> ftext n, - pprFlavourCore flavour, - whenPprDebug (ppr loc) - ]) - --- ^ Print a flavour in Core -pprFlavourCore :: CCFlavour -> SDoc -pprFlavourCore CafCC = text "__C" -pprFlavourCore f = pprIdxCore $ flavourIndex f - --- ^ Print a flavour's index in Core -pprIdxCore :: Int -> SDoc -pprIdxCore 0 = empty -pprIdxCore idx = whenPprDebug $ ppr idx - --- Printing as a C label -ppCostCentreLbl :: CostCentre -> SDoc -ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" -ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) - = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> - ppFlavourLblComponent f <> text "_cc" - --- ^ Print the flavour component of a C label -ppFlavourLblComponent :: CCFlavour -> SDoc -ppFlavourLblComponent CafCC = text "CAF" -ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i -ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i -ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i - --- ^ Print the flavour index component of a C label -ppIdxLblComponent :: CostCentreIndex -> SDoc -ppIdxLblComponent n = - case unCostCentreIndex n of - 0 -> empty - n -> ppr n - --- This is the name to go in the user-displayed string, --- recorded in the cost centre declaration -costCentreUserName :: CostCentre -> String -costCentreUserName = unpackFS . costCentreUserNameFS - -costCentreUserNameFS :: CostCentre -> FastString -costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" -costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf}) - = case is_caf of - CafCC -> mkFastString "CAF:" `appendFS` name - _ -> name - -costCentreSrcSpan :: CostCentre -> SrcSpan -costCentreSrcSpan = cc_loc - -instance Binary CCFlavour where - put_ bh CafCC = do - putByte bh 0 - put_ bh (ExprCC i) = do - putByte bh 1 - put_ bh i - put_ bh (DeclCC i) = do - putByte bh 2 - put_ bh i - put_ bh (HpcCC i) = do - putByte bh 3 - put_ bh i - get bh = do - h <- getByte bh - case h of - 0 -> do return CafCC - 1 -> ExprCC <$> get bh - 2 -> DeclCC <$> get bh - _ -> HpcCC <$> get bh - -instance Binary CostCentre where - put_ bh (NormalCC aa ab ac _ad) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh (AllCafsCC ae _af) = do - putByte bh 1 - put_ bh ae - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - return (NormalCC aa ab ac noSrcSpan) - _ -> do ae <- get bh - return (AllCafsCC ae noSrcSpan) - - -- We ignore the SrcSpans in CostCentres when we serialise them, - -- and set the SrcSpans to noSrcSpan when deserialising. This is - -- ok, because we only need the SrcSpan when declaring the - -- CostCentre in the original module, it is not used by importing - -- modules. diff --git a/compiler/profiling/CostCentreState.hs b/compiler/profiling/CostCentreState.hs deleted file mode 100644 index 0050c1d033..0000000000 --- a/compiler/profiling/CostCentreState.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module CostCentreState ( CostCentreState, newCostCentreState - , CostCentreIndex, unCostCentreIndex, getCCIndex - ) where - -import GhcPrelude -import FastString -import FastStringEnv - -import Data.Data -import Binary - --- | Per-module state for tracking cost centre indices. --- --- See documentation of 'CostCentre.cc_flavour' for more details. -newtype CostCentreState = CostCentreState (FastStringEnv Int) - --- | Initialize cost centre state. -newCostCentreState :: CostCentreState -newCostCentreState = CostCentreState emptyFsEnv - --- | An index into a given cost centre module,name,flavour set -newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } - deriving (Eq, Ord, Data, Binary) - --- | Get a new index for a given cost centre name. -getCCIndex :: FastString - -> CostCentreState - -> (CostCentreIndex, CostCentreState) -getCCIndex nm (CostCentreState m) = - (CostCentreIndex idx, CostCentreState m') - where - m_idx = lookupFsEnv m nm - idx = maybe 0 id m_idx - m' = extendFsEnv m nm (idx + 1) diff --git a/compiler/profiling/NOTES b/compiler/profiling/NOTES deleted file mode 100644 index 824d52b12a..0000000000 --- a/compiler/profiling/NOTES +++ /dev/null @@ -1,303 +0,0 @@ -Profiling Implementation Notes -- June/July/Sept 1994 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Simon and Will - -Pre-code-generator-ish -~~~~~~~~~~~~~~~~~~~~~~ - -* Automagic insertion of _sccs_ on... - - - If -fprof-auto-exported is specified, add _scc_ on each *exported* top-level definition. - NB this includes CAFs. Done by addAutoCostCentres (Core-to-Core pass). - - - If -fprof-auto-top is specified, add _scc_ on *all* top-level definitions. - Done by same pass. - - - If -fprof-auto is specified, add _scc_ on *all* definitions. - - - Always: just before code generation of module M, onto any CAF - which hasn't already got an explicit cost centre attached, pin - "AllCAFs-M". - - Done by finalStgMassageForProfiling (final STG-to-STG pass) - - Only the one-off costs of evaluating the CAFs will be attributed - to the AllCAFs-M cost centre. We hope that these costs will be - small; since the _scc_s are introduced automatically it's - confusing to attribute any significant costs to them. However if - there *are* significant one-off costs we'd better know about it. - - Why so late in the compilation process? We aren't *absolutely* - sure what is and isn't a CAF until *just* before code generation. - So we don't want to mark them as such until then. - - - Individual DICTs - - We do it in the desugarer, because that's the *only* point at - which we *know* exactly what bindings are introduced by - overloading. NB should include bindings for selected methods, eg - - f d = let op = _scc_ DICT op_sel d in - ...op...op...op - - The DICT CC ensures that: - (a) [minor] that the selection cost is separately attributed - (b) [major] that the cost of executing op is attributed to - its call site, eg - - ...(scc "a" op)...(scc "b" op)...(scc "c" op)... - -* Automagic "boxing" of higher-order args: - - finalStgMassageForProfiling (final STG-to-STG pass) - - This (as well as CAF stuff above) is really quite separate - from the other business of finalStgMassageForProfiling - (collecting up CostCentres that need to be - declared/registered). - - But throwing it all into the pot together means that we don't - have to have Yet Another STG Syntax Walker. - - Furthermore, these "boxes" are really just let-bindings that - many other parts of the compiler will happily substitute away! - Doing them at the very last instant prevents this. - - A down side of doing these so late is that we get lots of - "let"s, which if generated earlier and not substituted away, - could be floated outwards. Having them floated outwards would - lessen the chance of skewing profiling results (because of - gratuitous "let"s added by the compiler into the inner loop of - some program...). The allocation itself will be attributed to - profiling overhead; the only thing which'll be skewed is time measurement. - - So if we have, post-boxing-higher-order-args... - - _scc_ "foo" ( let f' = [f] \ [] f - in - map f' xs ) - - ... we want "foo" to be put in the thunk for "f'", but we want the - allocation cost (heap census stuff) to be attr to OVERHEAD. - - As an example of what could be improved - f = _scc_ "f" (g h) - To save dynamic allocation, we could have a static closure for h: - h_inf = _scc_ "f" h - f = _scc_ "f" (g h_inf) - - - - - -Code generator-ish -~~~~~~~~~~~~~~~~~~ - -(1) _Entry_ code for a closure *usually* sets CC from the closure, - at the fast entry point - - Exceptions: - - (a) Top-level subsumed functions (i.e., w/ no _scc_ on them) - - Refrain from setting CC from the closure - - (b) Constructors - - Again, refrain. (This is *new*) - - Reasons: (i) The CC will be zapped very shortly by the restore - of the enclosing CC when we return to the eval'ing "case". - (ii) Any intervening updates will indirect to this existing - constructor (...mumble... new update mechanism... mumble...) - -(2) "_scc_ cc expr" - - Set current CC to "cc". - No later "restore" of the previous CC is reqd. - -(3) "case e of { ...alts... }" expression (eval) - - Save CC before eval'ing scrutinee - Restore CC at the start of the case-alternative(s) - -(4) _Updates_ : updatee gets current CC - - (???? not sure this is OK yet 94/07/04) - - Reasons: - - * Constructors : want to be insensitive to return-in-heap vs - return-in-regs. For example, - - f x = _scc_ "f" (x, x) - - The pair (x,x) would get CC of "f" if returned-in-heap; - therefore, updatees should get CC of "f". - - * PAPs : Example: - - f x = _scc_ "f" (let g = \ y -> ... in g) - - At the moment of update (updatePAP?), CC is "f", which - is what we want to set it to if the "updatee" is entered - - When we enter the PAP ("please put the arguments back so I can - use them"), we restore the setup as at the moment the - arg-satisfaction check failed. - - Be careful! UPDATE_PAP is called from the arg-satis check, - which is before the fast entry point. So the cost centre - won't yet have been set from the closure which has just - been entered. Solution: in UPDATE_PAP see if the cost centre inside - the function closure which is being entered is "SUB"; if so, use - the current cost centre to update the updatee; otherwise use that - inside the function closure. (See the computation of cc_pap - in rule 16_l for lexical semantics.) - - -(5) CAFs - -CAFs get their own cost centre. Ie - - x = e -is transformed to - x = _scc_ "CAF:x" e - -Or sometimes we lump all the CAFs in a module together. -(Reporting issue or code-gen issue?) - - - -Hybrid stuff -~~~~~~~~~~~~ - -The problem: - - f = _scc_ "CAF:f" (let g = \xy -> ... - in (g,g)) - -Now, g has cost-centre "CAF:f", and is returned as part of -the result. So whenever the function embedded in the result -is called, the costs will accumulate to "CAF:f". This is -particularly (de)pressing for dictionaries, which contain lots -of functions. - -Solution: - - A. Whenever in case (1) above we would otherwise "set the CC from the - closure", we *refrain* from doing so if - (a) the closure is a function, not a thunk; and - (b) the cost-centre in the closure is a CAF cost centre. - - B. Whenever we enter a thunk [at least, one which might return a function] - we save the current cost centre in the update frame. Then, UPDATE_PAP - restores the saved cost centre from the update frame iff the cost - centre at the point of update (cc_pap in (4) above) is a CAF cost centre. - - It isn't necessary to save and possibly-restore the cost centre for - thunks which will certainly return a constructor, because the - cost centre is about to be restored anyway by the enclosing case. - -Both A and B are runtime tests. For A, consider: - - f = _scc_ "CAF:f" (g 2) - - h y = _scc_ "h" g (y+y) - - g x = let w = \p -> ... - in (w,w) - - -Now, in the call to g from h, the cost-centre on w will be "h", and -indeed all calls to the result of the call should be attributed to -"h". - - ... _scc_ "x1" (let (t,_) = h 2 in t 3) ... - - Costs of executing (w 3) attributed to "h". - -But in the call to g from f, the cost-centre on w will be -"CAF:f", and calls to w should be attributed to the call site. - - ..._scc_ "x2" (let (t,_) = f in t 3)... - - Costs of executing (w 3) attributed to "x2". - - - Remaining problem - -Consider - - _scc_ "CAF:f" (if expensive then g 2 else g 3) - -where g is a function with arity 2. In theory we should -restore the enclosing cost centre once we've reduced to -(g 2) or (g 3). In practice this is pretty tiresome; and pretty rare. - -A quick fix: given (_scc_ "CAF" e) where e might be function-valued -(in practice we usually know, because CAF sccs are top level), transform to - - _scc_ "CAF" (let f = e in f) - - - - - -============ - -scc cc x ===> x - - UNLESS - -(a) cc is a user-defined, non-dup'd cost - centre (so we care about entry counts) - -OR - -(b) cc is not a CAF/DICT cost centre and x is top-level subsumed - function. - [If x is lambda/let bound it'll have a cost centre - attached dynamically.] - - To repeat, the transformation is OK if - x is a not top-level subsumed function - OR - cc is a CAF/DICT cost centre and x is a top-level - subsumed function - - - -(scc cc e) x ===> (scc cc e x) - - OK????? IFF - -cc is not CAF/DICT --- remains to be proved!!!!!! -True for lex -False for eval -Can we tell which in hybrid? - -eg Is this ok? - - (scc "f" (scc "CAF" (\x.b))) y ==> (scc "f" (scc "CAF" (\x.b) y)) - - -\x -> (scc cc e) ===> (scc cc \x->e) - - OK IFF cc is not CAF/DICT - - -scc cc1 (scc cc2 e)) ===> scc cc2 e - - IFF not interested in cc1's entry count - AND cc2 is not CAF/DICT - -(scc cc1 ... (scc cc2 e) ...) ===> (scc cc1 ... e ...) - - IFF cc2 is CAF/DICT - AND e is a lambda not appearing as the RHS of a let - OR - e is a variable not bound to SUB - - diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs deleted file mode 100644 index 411f136c98..0000000000 --- a/compiler/profiling/ProfInit.hs +++ /dev/null @@ -1,64 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2011 --- --- Generate code to initialise cost centres --- --- ----------------------------------------------------------------------------- - -module ProfInit (profilingInitCode) where - -import GhcPrelude - -import GHC.Cmm.CLabel -import CostCentre -import GHC.Driver.Session -import Outputable -import Module - --- ----------------------------------------------------------------------------- --- Initialising cost centres - --- We must produce declarations for the cost-centres defined in this --- module; - -profilingInitCode :: Module -> CollectedCCs -> SDoc -profilingInitCode this_mod (local_CCs, singleton_CCSs) - = sdocWithDynFlags $ \dflags -> - if not (gopt Opt_SccProfilingOn dflags) - then empty - else vcat - $ map emit_cc_decl local_CCs - ++ map emit_ccs_decl singleton_CCSs - ++ [emit_cc_list local_CCs] - ++ [emit_ccs_list singleton_CCSs] - ++ [ text "static void prof_init_" <> ppr this_mod - <> text "(void) __attribute__((constructor));" - , text "static void prof_init_" <> ppr this_mod <> text "(void)" - , braces (vcat - [ text "registerCcList" <> parens local_cc_list_label <> semi - , text "registerCcsList" <> parens singleton_cc_list_label <> semi - ]) - ] - where - emit_cc_decl cc = - text "extern CostCentre" <+> cc_lbl <> text "[];" - where cc_lbl = ppr (mkCCLabel cc) - local_cc_list_label = text "local_cc_" <> ppr this_mod - emit_cc_list ccs = - text "static CostCentre *" <> local_cc_list_label <> text "[] =" - <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma - | cc <- ccs - ] ++ [text "NULL"]) - <> semi - - emit_ccs_decl ccs = - text "extern CostCentreStack" <+> ccs_lbl <> text "[];" - where ccs_lbl = ppr (mkCCSLabel ccs) - singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod - emit_ccs_list ccs = - text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] =" - <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma - | cc <- ccs - ] ++ [text "NULL"]) - <> semi diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs index 8669c9d9bb..3c33c59180 100644 --- a/compiler/typecheck/ClsInst.hs +++ b/compiler/typecheck/ClsInst.hs @@ -21,7 +21,7 @@ import TcMType import TcEvidence import GHC.Core.Predicate import GHC.Rename.Env( addUsedGRE ) -import RdrName( lookupGRE_FieldLabel ) +import GHC.Types.Name.Reader( lookupGRE_FieldLabel ) import GHC.Core.InstEnv import Inst( instDFunType ) import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) @@ -30,12 +30,12 @@ import TysWiredIn import TysPrim( eqPrimTyCon, eqReprPrimTyCon ) import PrelNames -import Id +import GHC.Types.Id import GHC.Core.Type import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) -import Name ( Name, pprDefinedAt ) -import VarEnv ( VarEnv ) +import GHC.Types.Name ( Name, pprDefinedAt ) +import GHC.Types.Var.Env ( VarEnv ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class diff --git a/compiler/typecheck/Constraint.hs b/compiler/typecheck/Constraint.hs index 20a1a7d774..1ca3d4b405 100644 --- a/compiler/typecheck/Constraint.hs +++ b/compiler/typecheck/Constraint.hs @@ -85,7 +85,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Class import GHC.Core.TyCon -import Var +import GHC.Types.Var import TcType import TcEvidence @@ -94,14 +94,14 @@ import TcOrigin import GHC.Core import GHC.Core.TyCo.Ppr -import OccName +import GHC.Types.Name.Occurrence import FV -import VarSet +import GHC.Types.Var.Set import GHC.Driver.Session -import BasicTypes +import GHC.Types.Basic import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Bag import Util diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index a780f4688e..1e983d0e24 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -23,24 +23,24 @@ import GHC.Core.Lint import TcEvidence import GHC.Iface.Load import TcRnMonad -import SrcLoc +import GHC.Types.SrcLoc as SrcLoc import GHC.Core.TyCon import TcType import GHC.Core.Coercion.Axiom import GHC.Driver.Session -import Module +import GHC.Types.Module import Outputable import Util -import RdrName +import GHC.Types.Name.Reader import GHC.Core.DataCon ( dataConName ) import Maybes import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen ) import TcMType -import Name +import GHC.Types.Name import Panic -import VarSet +import GHC.Types.Var.Set import FV import Bag( Bag, unionBags, unitBag ) import Control.Monad diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs index f8cda0f289..42c06183f7 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -21,8 +21,8 @@ module FunDeps ( import GhcPrelude -import Name -import Var +import GHC.Types.Name +import GHC.Types.Var import GHC.Core.Class import GHC.Core.Predicate import GHC.Core.Type @@ -30,14 +30,14 @@ import TcType( transSuperClasses ) import GHC.Core.Coercion.Axiom( TypeEqn ) import GHC.Core.Unify import GHC.Core.InstEnv -import VarSet -import VarEnv +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 SrcLoc +import GHC.Types.SrcLoc import Util import Pair ( Pair(..) ) diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index d8abc88bf0..61e408e33e 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -40,7 +40,7 @@ import GhcPrelude import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) import {-# SOURCE #-} TcUnify( unifyType, unifyKind ) -import BasicTypes ( IntegralLit(..), SourceText(..) ) +import GHC.Types.Basic ( IntegralLit(..), SourceText(..) ) import FastString import GHC.Hs import TcHsSyn @@ -61,19 +61,19 @@ import GHC.Core.TyCo.Ppr ( debugPprType ) import TcType import GHC.Driver.Types import GHC.Core.Class( Class ) -import MkId( mkDictFunId ) +import GHC.Types.Id.Make( mkDictFunId ) import GHC.Core( Expr(..) ) -- For the Coercion constructor -import Id -import Name -import Var ( EvVar, tyVarName, VarBndr(..) ) +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var ( EvVar, tyVarName, VarBndr(..) ) import GHC.Core.DataCon -import VarEnv +import GHC.Types.Var.Env import PrelNames -import SrcLoc +import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import Util import Outputable -import BasicTypes ( TypeOrKind(..) ) +import GHC.Types.Basic ( TypeOrKind(..) ) import qualified GHC.LanguageExtensions as LangExt import Data.List ( sortBy ) diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 8f5af9743b..dcd78b5d71 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -13,15 +13,15 @@ module TcAnnotations ( tcAnnotations, annCtxt ) where import GhcPrelude import {-# SOURCE #-} TcSplice ( runAnnotation ) -import Module +import GHC.Types.Module import GHC.Driver.Session import Control.Monad ( when ) import GHC.Hs -import Name -import Annotations +import GHC.Types.Name +import GHC.Types.Annotations import TcRnMonad -import SrcLoc +import GHC.Types.SrcLoc import Outputable import GHC.Driver.Types diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 0dd83837e2..1b54417c85 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -28,13 +28,13 @@ import TcRnMonad import TcEnv import TcOrigin import TcEvidence -import Id( mkLocalId ) +import GHC.Types.Id( mkLocalId ) import Inst import TysWiredIn -import VarSet +import GHC.Types.Var.Set import TysPrim -import BasicTypes( Arity ) -import SrcLoc +import GHC.Types.Basic( Arity ) +import GHC.Types.SrcLoc import Outputable import Util diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index 954ee6c24d..ab89e740b4 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -19,12 +19,12 @@ module TcBackpack ( import GhcPrelude -import BasicTypes (defaultFixity, TypeOrKind(..)) +import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) import GHC.Driver.Packages import TcRnExports import GHC.Driver.Session import GHC.Hs -import RdrName +import GHC.Types.Name.Reader import TcRnMonad import TcTyDecls import GHC.Core.InstEnv @@ -39,13 +39,13 @@ import TcOrigin import GHC.Iface.Load import GHC.Rename.Names import ErrUtils -import Id -import Module -import Name -import NameEnv -import NameSet -import Avail -import SrcLoc +import GHC.Types.Id +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.SrcLoc import GHC.Driver.Types import Outputable import GHC.Core.Type @@ -53,13 +53,13 @@ import FastString import GHC.Rename.Fixity ( lookupFixityRn ) import Maybes import TcEnv -import Var +import GHC.Types.Var import GHC.Iface.Syntax import PrelNames import qualified Data.Map as Map import GHC.Driver.Finder -import UniqDSet +import GHC.Types.Unique.DSet import GHC.Types.Name.Shape import TcErrors import TcUnify diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 49b4f92ce1..26e4ade66d 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -21,7 +21,7 @@ import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) import GHC.Core (Tickish (..)) -import CostCentre (mkUserCC, CCFlavour(DeclCC)) +import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) import GHC.Driver.Session import FastString import GHC.Hs @@ -42,26 +42,26 @@ import TcType import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy) import TysPrim import TysWiredIn( mkBoxedTupleTy ) -import Id -import Var -import VarSet -import VarEnv( TidyEnv ) -import Module -import Name -import NameSet -import NameEnv -import SrcLoc +import GHC.Types.Id +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env( TidyEnv ) +import GHC.Types.Module +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 BasicTypes +import GHC.Types.Basic import Outputable import PrelNames( ipClassName ) import TcValidity (checkValidType) -import UniqFM -import UniqSet +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set import qualified GHC.LanguageExtensions as LangExt import GHC.Core.ConLike diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 7dbe32d9c0..fa24829694 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -28,17 +28,17 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking import GHC.Core.Coercion import GHC.Core -import Id( idType, mkTemplateLocals ) +import GHC.Types.Id( idType, mkTemplateLocals ) import GHC.Core.FamInstEnv ( FamInstEnvs ) import FamInst ( tcTopNormaliseNewTypeTF_maybe ) -import Var -import VarEnv( mkInScopeSet ) -import VarSet( delVarSetList ) -import OccName ( OccName ) +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.Driver.Session( DynFlags ) -import NameSet -import RdrName +import GHC.Types.Name.Set +import GHC.Types.Name.Reader import GHC.Hs.Types( HsIPName(..) ) import Pair @@ -48,7 +48,7 @@ import MonadUtils import Control.Monad import Data.Maybe ( isJust ) import Data.List ( zip4 ) -import BasicTypes +import GHC.Types.Basic import Data.Bifunctor ( bimap ) import Data.Foldable ( traverse_ ) diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index dad787b93a..c705902a10 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -44,17 +44,17 @@ import GHC.Core.Coercion ( pprCoAxiom ) import GHC.Driver.Session import FamInst import GHC.Core.FamInstEnv -import Id -import Name -import NameEnv -import NameSet -import Var -import VarEnv +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Var +import GHC.Types.Var.Env import Outputable -import SrcLoc +import GHC.Types.SrcLoc import GHC.Core.TyCon import Maybes -import BasicTypes +import GHC.Types.Basic import Bag import FastString import BooleanFormula diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs index 535f7a7769..e69ac2170d 100644 --- a/compiler/typecheck/TcDefaults.hs +++ b/compiler/typecheck/TcDefaults.hs @@ -20,7 +20,7 @@ import TcSimplify import TcValidity import TcType import PrelNames -import SrcLoc +import GHC.Types.SrcLoc import Outputable import FastString import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index d002d55f5d..40efd08652 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -43,7 +43,7 @@ import GHC.Rename.Names ( extendGlobalRdrEnvRn ) import GHC.Rename.Binds import GHC.Rename.Env import GHC.Rename.Source ( addTcgDUs ) -import Avail +import GHC.Types.Avail import GHC.Core.Unify( tcUnifyTy ) import GHC.Core.Class @@ -51,16 +51,16 @@ import GHC.Core.Type import ErrUtils import GHC.Core.DataCon import Maybes -import RdrName -import Name -import NameSet +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Name.Set as NameSet import GHC.Core.TyCon import TcType -import Var -import VarEnv -import VarSet +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set import PrelNames -import SrcLoc +import GHC.Types.SrcLoc import Util import Outputable import FastString diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs index 4ce31b8918..079414d604 100644 --- a/compiler/typecheck/TcDerivInfer.hs +++ b/compiler/typecheck/TcDerivInfer.hs @@ -16,7 +16,7 @@ module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where import GhcPrelude import Bag -import BasicTypes +import GHC.Types.Basic import GHC.Core.Class import GHC.Core.DataCon import ErrUtils @@ -44,8 +44,8 @@ import TcUnify (buildImplicationFor, checkConstraints) import TysWiredIn (typeToTypeKind) import GHC.Core.Unify (tcUnifyTy) import Util -import Var -import VarSet +import GHC.Types.Var +import GHC.Types.Var.Set import Control.Monad import Control.Monad.Trans.Class (lift) diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs index c998ea0ee9..0f72eea2e2 100644 --- a/compiler/typecheck/TcDerivUtils.hs +++ b/compiler/typecheck/TcDerivUtils.hs @@ -26,7 +26,7 @@ module TcDerivUtils ( import GhcPrelude import Bag -import BasicTypes +import GHC.Types.Basic import GHC.Core.Class import GHC.Core.DataCon import GHC.Driver.Session @@ -35,12 +35,12 @@ import GHC.Driver.Types (lookupFixity, mi_fix) import GHC.Hs import Inst import GHC.Core.InstEnv -import GHC.Iface.Load (loadInterfaceForName) -import Module (getModule) -import Name +import GHC.Iface.Load (loadInterfaceForName) +import GHC.Types.Module (getModule) +import GHC.Types.Name import Outputable import PrelNames -import SrcLoc +import GHC.Types.SrcLoc import TcGenDeriv import TcGenFunctor import TcGenGenerics @@ -52,7 +52,7 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Ppr (pprSourceTyCon) import GHC.Core.Type import Util -import VarSet +import GHC.Types.Var.Set import Control.Monad.Trans.Reader import Data.Maybe diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 98fb6a388c..01bff1db4c 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -81,9 +81,9 @@ import TcType import GHC.Iface.Load import PrelNames import TysWiredIn -import Id -import Var -import RdrName +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Name.Reader import GHC.Core.InstEnv import GHC.Core.DataCon ( DataCon ) import GHC.Core.PatSyn ( PatSyn ) @@ -92,15 +92,15 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion.Axiom import GHC.Core.Class -import Name -import NameSet -import NameEnv -import VarEnv +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Var.Env import GHC.Driver.Types import GHC.Driver.Session -import SrcLoc -import BasicTypes hiding( SuccessFlag(..) ) -import Module +import GHC.Types.SrcLoc +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.Module import Outputable import Encoding import FastString diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot index 5e9bfe2039..23278b8d34 100644 --- a/compiler/typecheck/TcEnv.hs-boot +++ b/compiler/typecheck/TcEnv.hs-boot @@ -1,7 +1,7 @@ module TcEnv where import TcRnTypes( TcM ) -import VarEnv( TidyEnv ) +import GHC.Types.Var.Env( TidyEnv ) -- Annoyingly, there's a recursion between tcInitTidyEnv -- (which does zonking and hence needs TcMType) and diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index e889940893..0fbef80ec0 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -32,7 +32,7 @@ import GHC.Core.Coercion import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) import GHC.Core.Unify ( tcMatchTys ) -import Module +import GHC.Types.Module import FamInst import GHC.Core.FamInstEnv ( flattenTys ) import Inst @@ -43,22 +43,22 @@ import GHC.Core.DataCon import TcEvidence import TcEvTerm import GHC.Hs.Binds ( PatSynBind(..) ) -import Name -import RdrName ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) +import GHC.Types.Name +import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) import PrelNames ( typeableClassName ) -import Id -import Var -import VarSet -import VarEnv -import NameSet +import GHC.Types.Id +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 BasicTypes +import GHC.Types.Basic import GHC.Core.ConLike ( ConLike(..)) import Util import FastString import Outputable -import SrcLoc +import GHC.Types.SrcLoc import GHC.Driver.Session import ListSetOps ( equivClasses ) import Maybes diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs index ca3d1b3513..74ef0ae0b4 100644 --- a/compiler/typecheck/TcEvTerm.hs +++ b/compiler/typecheck/TcEvTerm.hs @@ -10,15 +10,15 @@ import FastString import GHC.Core.Type import GHC.Core import GHC.Core.Make -import Literal ( Literal(..) ) +import GHC.Types.Literal ( Literal(..) ) import TcEvidence import GHC.Driver.Types import GHC.Driver.Session -import Name -import Module +import GHC.Types.Name +import GHC.Types.Module import GHC.Core.Utils import PrelNames -import SrcLoc +import GHC.Types.SrcLoc -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 9d2661d915..4e89219271 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -55,7 +55,7 @@ module TcEvidence ( import GhcPrelude -import Var +import GHC.Types.Var import GHC.Core.Coercion.Axiom import GHC.Core.Coercion import GHC.Core.Ppr () -- Instance OutputableBndr TyVar @@ -65,10 +65,10 @@ import GHC.Core.TyCon import GHC.Core.DataCon( DataCon, dataConWrapId ) import GHC.Core.Class( Class ) import PrelNames -import VarEnv -import VarSet +import GHC.Types.Var.Env +import GHC.Types.Var.Set import GHC.Core.Predicate -import Name +import GHC.Types.Name import Pair import GHC.Core @@ -79,9 +79,9 @@ import Util import Bag import qualified Data.Data as Data import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Data.IORef( IORef ) -import UniqSet +import GHC.Types.Unique.Set {- Note [TcCoercions] @@ -472,7 +472,7 @@ newtype EvBindMap -- let $dNum = GHC.Num.$fNumInt in -- let $dEq = GHC.Classes.$fEqInt in ... -- - -- See Note [Deterministic UniqFM] in UniqDFM for explanation why + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why -- @UniqFM@ can lead to nondeterministic order. emptyEvBindMap :: EvBindMap diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 4ddcd3d532..718f5a950b 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -32,7 +32,7 @@ import Constraint ( HoleSort(..) ) import TcHsSyn import TcRnMonad import TcUnify -import BasicTypes +import GHC.Types.Basic import Inst import TcBinds ( chooseInferredQuantifiers, tcLocalBinds ) import TcSigs ( tcUserTypeSig, tcInstSig ) @@ -50,37 +50,37 @@ import TcPat import TcMType import TcOrigin import TcType -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn -import Name -import NameEnv -import NameSet -import RdrName +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr import GHC.Core.TyCo.Subst (substTyWithInScope) import GHC.Core.Type import TcEvidence -import VarSet +import GHC.Types.Var.Set import TysWiredIn import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) import PrelNames import GHC.Driver.Session -import SrcLoc +import GHC.Types.SrcLoc import Util -import VarEnv ( emptyTidyEnv, mkInScopeSet ) +import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) import ListSetOps import Maybes import Outputable import FastString import Control.Monad import GHC.Core.Class(classTyCon) -import UniqSet ( nonDetEltsUniqSet ) +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt import Data.Function diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot index 571e707752..6c2c3bb733 100644 --- a/compiler/typecheck/TcExpr.hs-boot +++ b/compiler/typecheck/TcExpr.hs-boot @@ -1,5 +1,5 @@ module TcExpr where -import Name +import GHC.Types.Name import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) import TcRnTypes( TcM ) diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index ecad0361d3..762938c971 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -24,12 +24,12 @@ import TcEvidence import GHC.Core.TyCon import GHC.Core.TyCo.Rep -- performs delicate algorithm on types import GHC.Core.Coercion -import Var -import VarSet -import VarEnv +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env import Outputable import TcSMonad as TcS -import BasicTypes( SwapFlag(..) ) +import GHC.Types.Basic( SwapFlag(..) ) import Util import Bag diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index 40bab48fde..f050d2a992 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -46,11 +46,11 @@ import FamInst import GHC.Core.FamInstEnv import GHC.Core.Coercion import GHC.Core.Type -import ForeignCall +import GHC.Types.ForeignCall import ErrUtils -import Id -import Name -import RdrName +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Core.DataCon import GHC.Core.TyCon import TcType @@ -58,7 +58,7 @@ import PrelNames import GHC.Driver.Session import Outputable import GHC.Platform -import SrcLoc +import GHC.Types.SrcLoc import Bag import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index a9358be9cf..0a2ab47e9b 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -43,10 +43,10 @@ import GhcPrelude import TcRnMonad import GHC.Hs -import RdrName -import BasicTypes +import GHC.Types.Name.Reader +import GHC.Types.Basic import GHC.Core.DataCon -import Name +import GHC.Types.Name import Fingerprint import Encoding @@ -56,9 +56,9 @@ import FamInst import GHC.Core.FamInstEnv import PrelNames import THNames -import MkId ( coerceId ) +import GHC.Types.Id.Make ( coerceId ) import PrimOp -import SrcLoc +import GHC.Types.SrcLoc import GHC.Core.TyCon import TcEnv import TcType @@ -68,12 +68,12 @@ import TysPrim import TysWiredIn import GHC.Core.Type import GHC.Core.Class -import VarSet -import VarEnv +import GHC.Types.Var.Set +import GHC.Types.Var.Env import Util -import Var +import GHC.Types.Var import Outputable -import Lexeme +import GHC.Utils.Lexeme import FastString import Pair import Bag diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index 09f252c4bb..c326754b20 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -29,8 +29,8 @@ import FastString import GHC.Hs import Outputable import PrelNames -import RdrName -import SrcLoc +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc import State import TcGenDeriv import TcType @@ -38,9 +38,9 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.Type import Util -import Var -import VarSet -import MkId (coerceId) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id.Make (coerceId) import TysWiredIn (true_RDR, false_RDR) import Data.Maybe (catMaybes, isJust) diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index ad7375d2ec..a6193ed7c4 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -27,12 +27,12 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) import FamInst -import Module ( moduleName, moduleNameFS +import GHC.Types.Module ( moduleName, moduleNameFS , moduleUnitId, unitIdFS, getModule ) import GHC.Iface.Env ( newGlobalBinder ) -import Name hiding ( varName ) -import RdrName -import BasicTypes +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Name.Reader +import GHC.Types.Basic import TysPrim import TysWiredIn import PrelNames @@ -40,10 +40,10 @@ import TcEnv import TcRnMonad import GHC.Driver.Types import ErrUtils( Validity(..), andValid ) -import SrcLoc +import GHC.Types.SrcLoc import Bag -import VarEnv -import VarSet (elemVarSet) +import GHC.Types.Var.Env +import GHC.Types.Var.Set (elemVarSet) import Outputable import FastString import Util diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs index 08b4e7c6fc..00a1a17226 100644 --- a/compiler/typecheck/TcHoleErrors.hs +++ b/compiler/typecheck/TcHoleErrors.hs @@ -26,12 +26,12 @@ import TcEvidence import TcType import GHC.Core.Type import GHC.Core.DataCon -import Name -import RdrName ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts ) +import GHC.Types.Name +import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts ) import PrelNames ( gHC_ERR ) -import Id -import VarSet -import VarEnv +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env import Bag import GHC.Core.ConLike ( ConLike(..) ) import Util diff --git a/compiler/typecheck/TcHoleErrors.hs-boot b/compiler/typecheck/TcHoleErrors.hs-boot index a8f5b81c8c..9c5df86489 100644 --- a/compiler/typecheck/TcHoleErrors.hs-boot +++ b/compiler/typecheck/TcHoleErrors.hs-boot @@ -7,7 +7,7 @@ module TcHoleErrors where import TcRnTypes ( TcM ) import Constraint ( Ct, Implication ) import Outputable ( SDoc ) -import VarEnv ( TidyEnv ) +import GHC.Types.Var.Env ( TidyEnv ) findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct -> TcM (TidyEnv, SDoc) diff --git a/compiler/typecheck/TcHoleFitTypes.hs b/compiler/typecheck/TcHoleFitTypes.hs index 0748367f43..d27aa8fef7 100644 --- a/compiler/typecheck/TcHoleFitTypes.hs +++ b/compiler/typecheck/TcHoleFitTypes.hs @@ -11,13 +11,13 @@ import TcRnTypes import Constraint import TcType -import RdrName +import GHC.Types.Name.Reader import GHC.Hs.Doc -import Id +import GHC.Types.Id import Outputable -import Name +import GHC.Types.Name import Data.Function ( on ) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 6fd7f6f0be..41e9880fd2 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -51,8 +51,8 @@ module TcHsSyn ( import GhcPrelude import GHC.Hs -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Core.Predicate import TcRnMonad import PrelNames @@ -70,18 +70,18 @@ import GHC.Core.Coercion import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Driver.Types -import Name -import NameEnv -import Var -import VarEnv +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.Var.Env import GHC.Platform -import BasicTypes +import GHC.Types.Basic import Maybes -import SrcLoc +import GHC.Types.SrcLoc import Bag import Outputable import Util -import UniqFM +import GHC.Types.Unique.FM import GHC.Core import {-# SOURCE #-} TcSplice (runTopSplice) diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 9c578949f8..37bfda6e9f 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -90,25 +90,25 @@ import TcType import Inst ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder ) import GHC.Core.Type import TysPrim -import RdrName( lookupLocalRdrOcc ) -import Var -import VarSet +import GHC.Types.Name.Reader( lookupLocalRdrOcc ) +import GHC.Types.Var +import GHC.Types.Var.Set import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Class -import Name --- import NameSet -import VarEnv +import GHC.Types.Name +-- import GHC.Types.Name.Set +import GHC.Types.Var.Env import TysWiredIn -import BasicTypes -import SrcLoc +import GHC.Types.Basic +import GHC.Types.SrcLoc import Constants ( mAX_CTUPLE_SIZE ) import ErrUtils( MsgDoc ) -import Unique -import UniqSet +import GHC.Types.Unique +import GHC.Types.Unique.Set import Util -import UniqSupply +import GHC.Types.Unique.Supply import Outputable import FastString import PrelNames hiding ( wildCardName ) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 386f9b1646..e189c7d896 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -54,20 +54,20 @@ import GHC.Core.Coercion.Axiom import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.Class -import Var -import VarEnv -import VarSet +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set import Bag -import BasicTypes +import GHC.Types.Basic import GHC.Driver.Session import ErrUtils import FastString -import Id +import GHC.Types.Id import ListSetOps -import Name -import NameSet +import GHC.Types.Name +import GHC.Types.Name.Set import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Util import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import qualified GHC.LanguageExtensions as LangExt @@ -195,7 +195,7 @@ Instead we use a cunning trick. * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that extracts the right piece iff its argument satisfies - exprIsConApp_maybe. This is done in MkId mkDictSelId + exprIsConApp_maybe. This is done in GHC.Types.Id.Make.mkDictSelId * We make 'df' CONLIKE, so that shared uses still match; eg let d = df d1 d2 diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 4401bb7142..d0f1e0d1b1 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -11,18 +11,18 @@ module TcInteract ( #include "HsVersions.h" import GhcPrelude -import BasicTypes ( SwapFlag(..), isSwapped, - infinity, IntWithInf, intGtLimit ) +import GHC.Types.Basic ( SwapFlag(..), isSwapped, + infinity, IntWithInf, intGtLimit ) import TcCanonical import TcFlatten import TcUnify( canSolveByUnification ) -import VarSet +import GHC.Types.Var.Set import GHC.Core.Type as Type import GHC.Core.Coercion ( BlockSubstFlag(..) ) import GHC.Core.InstEnv ( DFunInstType ) import GHC.Core.Coercion.Axiom ( sfInteractTop, sfInteractInert ) -import Var +import GHC.Types.Var import TcType import PrelNames ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) @@ -48,13 +48,13 @@ import MonadUtils ( concatMapM, foldlM ) import GHC.Core import Data.List( partition, deleteFirstsBy ) -import SrcLoc -import VarEnv +import GHC.Types.SrcLoc +import GHC.Types.Var.Env import Control.Monad import Maybes( isJust ) import Pair (Pair(..)) -import Unique( hasKey ) +import GHC.Types.Unique( hasKey ) import GHC.Driver.Session import Util import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 945f42c81d..e234c5195c 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -104,7 +104,7 @@ import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Class -import Var +import GHC.Types.Var import GHC.Core.Predicate import TcOrigin @@ -112,23 +112,23 @@ import TcOrigin import TcRnMonad -- TcType, amongst others import Constraint import TcEvidence -import Id -import Name -import VarSet +import GHC.Types.Id as Id +import GHC.Types.Name +import GHC.Types.Var.Set import TysWiredIn import TysPrim -import VarEnv -import NameEnv +import GHC.Types.Var.Env +import GHC.Types.Name.Env import PrelNames import Util import Outputable import FastString import Bag import Pair -import UniqSet +import GHC.Types.Unique.Set import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt -import BasicTypes ( TypeOrKind(..) ) +import GHC.Types.Basic ( TypeOrKind(..) ) import Control.Monad import Maybes @@ -1110,7 +1110,7 @@ Note [CandidatesQTvs determinism and order] To achieve that we use deterministic sets of variables that can be converted to lists in a deterministic order. For more information - about deterministic sets see Note [Deterministic UniqFM] in UniqDFM. + about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. * Order: as well as being deterministic, we use an accumulating-parameter style for candidateQTyVarsOfType so that we @@ -1549,7 +1549,7 @@ To achieve this CandidatesQTvs is backed by deterministic sets which allows them to be later converted to a list in a deterministic order. For more information about deterministic sets see -Note [Deterministic UniqFM] in UniqDFM. +Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -} quantifyTyVars diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index e0304ec6fa..a3f2649039 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -27,7 +27,7 @@ import GhcPrelude import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) -import BasicTypes (LexicalFixity(..)) +import GHC.Types.Basic (LexicalFixity(..)) import GHC.Hs import TcRnMonad import TcEnv @@ -37,15 +37,15 @@ import TcType import TcBinds import TcUnify import TcOrigin -import Name +import GHC.Types.Name import TysWiredIn -import Id +import GHC.Types.Id import GHC.Core.TyCon import TysPrim import TcEvidence import Outputable import Util -import SrcLoc +import GHC.Types.SrcLoc -- Create chunkified tuple tybes for monad comprehensions import GHC.Core.Make diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot index 9c6b914422..ec3ada52a4 100644 --- a/compiler/typecheck/TcMatches.hs-boot +++ b/compiler/typecheck/TcMatches.hs-boot @@ -1,10 +1,10 @@ module TcMatches where -import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) -import TcEvidence( HsWrapper ) -import Name ( Name ) -import TcType ( ExpSigmaType, TcRhoType ) -import TcRnTypes( TcM ) -import SrcLoc ( Located ) +import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) +import TcEvidence ( HsWrapper ) +import GHC.Types.Name ( Name ) +import TcType ( ExpSigmaType, TcRhoType ) +import TcRnTypes ( TcM ) +import GHC.Types.SrcLoc ( Located ) import GHC.Hs.Extension ( GhcRn, GhcTcId ) tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs index 9dc137f7d9..502edc6a48 100644 --- a/compiler/typecheck/TcOrigin.hs +++ b/compiler/typecheck/TcOrigin.hs @@ -33,21 +33,21 @@ import TcType import GHC.Hs -import Id +import GHC.Types.Id import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.PatSyn -import Module -import Name -import RdrName +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Name.Reader -import SrcLoc +import GHC.Types.SrcLoc import FastString import Outputable -import BasicTypes +import GHC.Types.Basic {- ********************************************************************* * * diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 855935caba..0d3679eecd 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -28,10 +28,10 @@ import TcHsSyn import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags ) import TcRnMonad import Inst -import Id -import Var -import Name -import RdrName +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Name.Reader import TcEnv import TcMType import TcValidity( arityErr ) @@ -47,10 +47,10 @@ import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.ConLike import PrelNames -import BasicTypes hiding (SuccessFlag(..)) +import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Driver.Session -import SrcLoc -import VarSet +import GHC.Types.SrcLoc +import GHC.Types.Var.Set import Util import Outputable import qualified GHC.LanguageExtensions as LangExt @@ -674,7 +674,7 @@ and a case expression case x :: Map (Int, c) w of MapPair m -> ... -As explained by [Wrappers for data instance tycons] in MkIds.hs, the +As explained by [Wrappers for data instance tycons] in GHC.Types.Id.Make, the worker/wrapper types for MapPair are $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index a81ae283fd..c2e512df0d 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -27,19 +27,19 @@ import TcEnv import TcMType import TcHsSyn import TysPrim -import Name -import SrcLoc +import GHC.Types.Name +import GHC.Types.SrcLoc import GHC.Core.PatSyn -import NameSet +import GHC.Types.Name.Set import Panic import Outputable import FastString -import Var -import VarEnv( emptyTidyEnv, mkInScopeSet ) -import Id -import IdInfo( RecSelParent(..), setLevityInfoWithType ) +import GHC.Types.Var +import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet ) +import GHC.Types.Id +import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType ) import TcBinds -import BasicTypes +import GHC.Types.Basic import TcSimplify import TcUnify import GHC.Core.Predicate @@ -48,11 +48,11 @@ import TcType import TcEvidence import TcOrigin import BuildTyCl -import VarSet -import MkId +import GHC.Types.Var.Set +import GHC.Types.Id.Make import TcTyDecls import GHC.Core.ConLike -import FieldLabel +import GHC.Types.FieldLabel import Bag import Util import ErrUtils @@ -714,7 +714,7 @@ tcPatSynMatcher (L loc name) lpat ; let matcher_tau = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau matcher_id = mkExportedVanillaId matcher_name matcher_sigma - -- See Note [Exported LocalIds] in Id + -- See Note [Exported LocalIds] in GHC.Types.Id inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args @@ -803,7 +803,7 @@ mkPatSynBuilderId dir (L _ name) mkVisFunTys arg_tys $ pat_ty builder_id = mkExportedVanillaId builder_name builder_sigma - -- See Note [Exported LocalIds] in Id + -- See Note [Exported LocalIds] in GHC.Types.Id builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs index c85f72c157..339a13dca2 100644 --- a/compiler/typecheck/TcPluginM.hs +++ b/compiler/typecheck/TcPluginM.hs @@ -69,10 +69,10 @@ import TcMType ( TcTyVar, TcType ) import TcEnv ( TcTyThing ) import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..) , EvExpr, EvBind, mkGivenEvBind ) -import Var ( EvVar ) +import GHC.Types.Var ( EvVar ) -import Module -import Name +import GHC.Types.Module +import GHC.Types.Name import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Class @@ -80,10 +80,10 @@ import GHC.Driver.Types import Outputable import GHC.Core.Type import GHC.Core.Coercion ( BlockSubstFlag(..) ) -import Id +import GHC.Types.Id import GHC.Core.InstEnv import FastString -import Unique +import GHC.Types.Unique -- | Perform some IO, typically to interact with an external tool. diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 92df16b9c5..91ac66b972 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -71,7 +71,7 @@ import GHC.Iface.Type ( ShowForAllFlag(..) ) import GHC.Core.PatSyn( pprPatSynType ) import PrelNames import PrelInfo -import RdrName +import GHC.Types.Name.Reader import TcHsSyn import TcExpr import TcRnMonad @@ -108,17 +108,17 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Source import ErrUtils -import Id -import IdInfo( IdDetails(..) ) -import VarEnv -import Module -import UniqFM -import Name -import NameEnv -import NameSet -import Avail +import GHC.Types.Id as Id +import GHC.Types.Id.Info( IdDetails(..) ) +import GHC.Types.Var.Env +import GHC.Types.Module +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail import GHC.Core.TyCon -import SrcLoc +import GHC.Types.SrcLoc import GHC.Driver.Types import ListSetOps import Outputable @@ -126,9 +126,9 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Class -import BasicTypes hiding( SuccessFlag(..) ) +import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Core.Coercion.Axiom -import Annotations +import GHC.Types.Annotations import Data.List ( find, sortBy, sort ) import Data.Ord import FastString diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot index 7cd65195be..a867236c74 100644 --- a/compiler/typecheck/TcRnDriver.hs-boot +++ b/compiler/typecheck/TcRnDriver.hs-boot @@ -4,7 +4,7 @@ import GhcPrelude import GHC.Core.Type(TyThing) import TcRnTypes (TcM) import Outputable (SDoc) -import Name (Name) +import GHC.Types.Name (Name) checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) -> TyThing -> TyThing -> TcM () diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index fea68a4054..c7c2950e94 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -11,7 +11,7 @@ import GhcPrelude import GHC.Hs import PrelNames -import RdrName +import GHC.Types.Name.Reader import TcRnMonad import TcEnv import TcType @@ -19,22 +19,22 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) import ErrUtils -import Id -import IdInfo -import Module -import Name -import NameEnv -import NameSet -import Avail +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail import GHC.Core.TyCon -import SrcLoc +import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Types import Outputable import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn import Maybes -import UniqSet +import GHC.Types.Unique.Set import Util (capitalise) import FastString (fsLit) @@ -681,7 +681,7 @@ check_occs ie occs avails where -- Each Name specified by 'ie', paired with the OccName used to -- refer to it in the GlobalRdrEnv - -- (see Note [Representing fields in AvailInfo] in Avail). + -- (see Note [Representing fields in AvailInfo] in GHC.Types.Avail). -- -- We check for export clashes using the selector Name, but need -- the field label OccName for presenting error messages. diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index b8761fcdf1..2145b88de9 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -153,9 +153,9 @@ import TcOrigin import GHC.Hs hiding (LIE) import GHC.Driver.Types -import Module -import RdrName -import Name +import GHC.Types.Module +import GHC.Types.Name.Reader +import GHC.Types.Name import GHC.Core.Type import TcType @@ -163,24 +163,24 @@ import GHC.Core.InstEnv import GHC.Core.FamInstEnv import PrelNames -import Id -import VarSet -import VarEnv +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env import ErrUtils -import SrcLoc -import NameEnv -import NameSet +import GHC.Types.SrcLoc +import GHC.Types.Name.Env +import GHC.Types.Name.Set import Bag import Outputable -import UniqSupply +import GHC.Types.Unique.Supply import GHC.Driver.Session import FastString import Panic import Util -import Annotations -import BasicTypes( TopLevelFlag, TypeOrKind(..) ) +import GHC.Types.Annotations +import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) import Maybes -import CostCentreState +import GHC.Types.CostCentre.State import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 1f33287bb8..ab4d783143 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -91,29 +91,29 @@ import TcEvidence import GHC.Core.Type import GHC.Core.TyCon ( TyCon, tyConKind ) import GHC.Core.PatSyn ( PatSyn ) -import Id ( idType, idName ) -import FieldLabel ( FieldLabel ) +import GHC.Types.Id ( idType, idName ) +import GHC.Types.FieldLabel ( FieldLabel ) import TcType import Constraint import TcOrigin -import Annotations +import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Deltas) import IOEnv -import RdrName -import Name -import NameEnv -import NameSet -import Avail -import Var -import VarEnv -import Module -import SrcLoc -import VarSet +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Module +import GHC.Types.SrcLoc +import GHC.Types.Var.Set import ErrUtils -import UniqFM -import BasicTypes +import GHC.Types.Unique.FM +import GHC.Types.Basic import Bag import GHC.Driver.Session import Outputable @@ -121,7 +121,7 @@ import ListSetOps import Fingerprint import Util import PrelNames ( isUnboundName ) -import CostCentreState +import GHC.Types.CostCentre.State import Control.Monad (ap) import qualified Control.Monad.Fail as MonadFail diff --git a/compiler/typecheck/TcRnTypes.hs-boot b/compiler/typecheck/TcRnTypes.hs-boot index dda9f627fe..bd7bf07a47 100644 --- a/compiler/typecheck/TcRnTypes.hs-boot +++ b/compiler/typecheck/TcRnTypes.hs-boot @@ -1,7 +1,7 @@ module TcRnTypes where import TcType -import SrcLoc +import GHC.Types.SrcLoc data TcLclEnv diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index 3c3dadc49e..3e32cda356 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -29,11 +29,11 @@ import TcUnify( buildImplicationFor ) import TcEvidence( mkTcCoVarCo ) import GHC.Core.Type import GHC.Core.TyCon( isTypeFamilyTyCon ) -import Id -import Var( EvVar ) -import VarSet -import BasicTypes ( RuleName ) -import SrcLoc +import GHC.Types.Id +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 diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index fe74720796..9e934172fc 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -154,25 +154,25 @@ import GHC.Core.Class import GHC.Core.TyCon import TcErrors ( solverDepthErrorTcS ) -import Name -import Module ( HasModule, getModule ) -import RdrName ( GlobalRdrEnv, GlobalRdrElt ) +import GHC.Types.Name +import GHC.Types.Module ( HasModule, getModule ) +import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) import qualified GHC.Rename.Env as TcM -import Var -import VarEnv -import VarSet +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set import Outputable import Bag -import UniqSupply +import GHC.Types.Unique.Supply import Util import TcRnTypes import TcOrigin import Constraint import GHC.Core.Predicate -import Unique -import UniqFM -import UniqDFM +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM import Maybes import GHC.Core.Map @@ -184,7 +184,7 @@ import Data.List ( partition, mapAccumL ) #if defined(DEBUG) import Digraph -import UniqSet +import GHC.Types.Unique.Set #endif {- diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index b1ffd46978..fd91b84326 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -42,15 +42,15 @@ import TcEvidence( HsWrapper, (<.>) ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Driver.Session -import Var ( TyVar, tyVarKind ) -import Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) +import GHC.Types.Var ( TyVar, tyVarKind ) +import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import PrelNames( mkUnboundName ) -import BasicTypes -import Module( getModule ) -import Name -import NameEnv +import GHC.Types.Basic +import GHC.Types.Module( getModule ) +import GHC.Types.Name +import GHC.Types.Name.Env import Outputable -import SrcLoc +import GHC.Types.SrcLoc import Util( singleton ) import Maybes( orElse ) import Data.Maybe( mapMaybe ) diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 868be78c68..1ac4c74921 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -31,10 +31,10 @@ import GhcPrelude import Bag import GHC.Core.Class ( Class, classKey, classTyCon ) import GHC.Driver.Session -import Id ( idType, mkLocalId ) +import GHC.Types.Id ( idType, mkLocalId ) import Inst import ListSetOps -import Name +import GHC.Types.Name import Outputable import PrelInfo import PrelNames @@ -53,11 +53,11 @@ import GHC.Core.Type import TysWiredIn ( liftedRepTy ) import GHC.Core.Unify ( tcMatchTyKi ) import Util -import Var -import VarSet -import UniqSet -import BasicTypes ( IntWithInf, intGtLimit ) -import ErrUtils ( emptyMessages ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Types.Basic ( IntWithInf, intGtLimit ) +import ErrUtils ( emptyMessages ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index f0cc872d56..d6972f8ec5 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -38,15 +38,15 @@ module TcSplice( import GhcPrelude import GHC.Hs -import Annotations +import GHC.Types.Annotations import GHC.Driver.Finder -import Name +import GHC.Types.Name import TcRnMonad import TcType import Outputable import TcExpr -import SrcLoc +import GHC.Types.SrcLoc import THNames import TcUnify import TcEnv @@ -64,7 +64,7 @@ import GHC.Driver.Main -- These imports are the reason that TcSplice -- is very high up the module hierarchy import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) -import RdrName +import GHC.Types.Name.Reader import GHC.Driver.Types import GHC.ThToHs import GHC.Rename.Expr @@ -75,7 +75,7 @@ import GHC.Rename.Types import TcHsSyn import TcSimplify import GHC.Core.Type as Type -import NameSet +import GHC.Types.Name.Set import TcMType import TcHsType import GHC.IfaceToCore @@ -84,13 +84,13 @@ import FamInst import GHC.Core.FamInstEnv import GHC.Core.InstEnv as InstEnv import Inst -import NameEnv +import GHC.Types.Name.Env import PrelNames import TysWiredIn -import OccName +import GHC.Types.Name.Occurrence as OccName import GHC.Driver.Hooks -import Var -import Module +import GHC.Types.Var +import GHC.Types.Module import GHC.Iface.Load import GHC.Core.Class import GHC.Core.TyCon @@ -99,23 +99,23 @@ import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.DataCon as DataCon import TcEvidence -import Id -import IdInfo +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.HsToCore.Expr import GHC.HsToCore.Monad import GHC.Serialized import ErrUtils import Util -import Unique -import VarSet +import GHC.Types.Unique +import GHC.Types.Var.Set import Data.List ( find ) import Data.Maybe import FastString -import BasicTypes hiding( SuccessFlag(..) ) +import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) ) import Maybes( MaybeErr(..) ) import GHC.Driver.Session import Panic -import Lexeme +import GHC.Utils.Lexeme import qualified EnumSet import GHC.Driver.Plugins import Bag diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot index 8cab536a01..f6d57a7552 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot @@ -4,11 +4,11 @@ module TcSplice where import GhcPrelude -import Name +import GHC.Types.Name import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) import TcRnTypes( TcM , SpliceType ) import TcType ( ExpRhoType ) -import Annotations ( Annotation, CoreAnnTarget ) +import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) import GHC.Hs.Extension ( GhcTcId, GhcRn, GhcPs, GhcTc ) import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index e85f471432..df7200abe9 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -57,24 +57,24 @@ import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.TyCon import GHC.Core.DataCon -import Id -import Var -import VarEnv -import VarSet -import Module -import Name -import NameSet -import NameEnv +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Module +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env import Outputable import Maybes import GHC.Core.Unify import Util -import SrcLoc +import GHC.Types.SrcLoc import ListSetOps import GHC.Driver.Session -import Unique +import GHC.Types.Unique import GHC.Core.ConLike( ConLike(..) ) -import BasicTypes +import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index aa716d8f47..cd06e79b2d 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -48,25 +48,25 @@ import GHC.Driver.Types import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon -import Name -import NameEnv -import NameSet hiding (unitFV) -import RdrName ( mkVarUnqual ) -import Id -import IdInfo -import VarEnv -import VarSet +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set hiding (unitFV) +import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var.Env +import GHC.Types.Var.Set import GHC.Core.Coercion ( ltRole ) -import BasicTypes -import SrcLoc -import Unique ( mkBuiltinUnique ) +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 Module +import GHC.Types.Module import Control.Monad diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 8ea61cfa36..bc575cef66 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -198,9 +198,9 @@ import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr import GHC.Core.Class -import Var -import ForeignCall -import VarSet +import GHC.Types.Var +import GHC.Types.ForeignCall +import GHC.Types.Var.Set import GHC.Core.Coercion import GHC.Core.Type as Type import GHC.Core.Predicate @@ -210,15 +210,15 @@ import GHC.Core.TyCon -- others: import GHC.Driver.Session import GHC.Core.FVs -import Name -- hiding (varName) +import GHC.Types.Name as Name -- We use this to make dictionaries for type literals. -- Perhaps there's a better way to do this? -import NameSet -import VarEnv +import GHC.Types.Name.Set +import GHC.Types.Var.Env import PrelNames import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey , listTyCon, constraintKind ) -import BasicTypes +import GHC.Types.Basic import Util import Maybes import ListSetOps ( getNth, findDupsEq ) diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 7fdd9d9028..9dc1176cf2 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -31,7 +31,7 @@ import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon import GHC.Core.Coercion ( Role(..) ) import Constraint ( Xi ) import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) -import Name ( Name, BuiltInSyntax(..) ) +import GHC.Types.Name ( Name, BuiltInSyntax(..) ) import TysWiredIn import TysPrim ( mkTemplateAnonTyConBinders ) import PrelNames ( gHC_TYPELITS diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index d1591ed1bf..4de6e7a6d7 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -15,7 +15,7 @@ module TcTypeable(mkTypeableBinds, tyConIsTypeable) where import GhcPrelude import GHC.Platform -import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) ) +import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) import TcEnv @@ -28,16 +28,16 @@ import TysPrim ( primTyCons ) import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon , vecCountTyCon, vecElemTyCon , nilDataCon, consDataCon ) -import Name -import Id +import GHC.Types.Name +import GHC.Types.Id import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.DataCon -import Module +import GHC.Types.Module import GHC.Hs import GHC.Driver.Session import Bag -import Var ( VarBndr(..) ) +import GHC.Types.Var ( VarBndr(..) ) import GHC.Core.Map import Constants import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 6914851144..ae55f7b36c 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -55,17 +55,17 @@ import TcEvidence import Constraint import GHC.Core.Predicate import TcOrigin -import Name( isSystemName ) +import GHC.Types.Name( isSystemName ) import Inst import GHC.Core.TyCon import TysWiredIn import TysPrim( tYPE ) -import Var -import VarSet -import VarEnv +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env import ErrUtils import GHC.Driver.Session -import BasicTypes +import GHC.Types.Basic import Bag import Util import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 3f55d72c5c..289cf83225 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -55,18 +55,18 @@ import FunDeps import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) import FamInst -import Name -import VarEnv -import VarSet -import Var ( VarBndr(..), mkTyVar ) +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.Driver.Session import Util import ListSetOps -import SrcLoc +import GHC.Types.SrcLoc import Outputable -import Unique ( mkAlphaTyVarUnique ) +import GHC.Types.Unique ( mkAlphaTyVarUnique ) import Bag ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 16d7ccf37d..bedf380d29 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -64,14 +64,14 @@ module Binary import GhcPrelude -import {-# SOURCE #-} Name (Name) +import {-# SOURCE #-} GHC.Types.Name (Name) import FastString import PlainPanic -import UniqFM +import GHC.Types.Unique.FM import FastMutInt import Fingerprint -import BasicTypes -import SrcLoc +import GHC.Types.Basic +import GHC.Types.SrcLoc import Foreign import Data.Array diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs index a42bb90a1c..76d80eb305 100644 --- a/compiler/utils/BooleanFormula.hs +++ b/compiler/utils/BooleanFormula.hs @@ -24,9 +24,9 @@ import Data.Data import MonadUtils import Outputable import Binary -import SrcLoc -import Unique -import UniqSet +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.Set ---------------------------------------------------------------------- -- Boolean formula type and smart constructors diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs index e7c838508c..ad5fbf53c3 100644 --- a/compiler/utils/Digraph.hs +++ b/compiler/utils/Digraph.hs @@ -58,8 +58,8 @@ import qualified Data.Set as Set import qualified Data.Graph as G import Data.Graph hiding (Graph, Edge, transposeG, reachable) import Data.Tree -import Unique -import UniqFM +import GHC.Types.Unique +import GHC.Types.Unique.FM {- ************************************************************************ diff --git a/compiler/utils/FV.hs b/compiler/utils/FV.hs index 667d2a3966..f0a35d4100 100644 --- a/compiler/utils/FV.hs +++ b/compiler/utils/FV.hs @@ -28,8 +28,8 @@ module FV ( import GhcPrelude -import Var -import VarSet +import GHC.Types.Var +import GHC.Types.Var.Set -- | Predicate on possible free variables: returns @True@ iff the variable is -- interesting @@ -40,7 +40,7 @@ type InterestingVarFun = Var -> Bool -- 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 UniqDFM. +-- 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 @@ -54,7 +54,7 @@ type FV = InterestingVarFun -- Used for filtering sets as we build them 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 UniqDFM. + -- Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -- Note [FV naming conventions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/utils/FastStringEnv.hs b/compiler/utils/FastStringEnv.hs index 1b4af6cee7..bc151f736b 100644 --- a/compiler/utils/FastStringEnv.hs +++ b/compiler/utils/FastStringEnv.hs @@ -29,14 +29,14 @@ module FastStringEnv ( import GhcPrelude -import UniqFM -import UniqDFM +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM import Maybes import FastString -- | A non-deterministic set of FastStrings. --- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not +-- 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. @@ -82,7 +82,7 @@ filterFsEnv x y = filterUFM x y lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) -- Deterministic FastStringEnv --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need +-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need -- DFastStringEnv. type DFastStringEnv a = UniqDFM a -- Domain is FastString diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs index a165b003ba..67c362ff00 100644 --- a/compiler/utils/GraphBase.hs +++ b/compiler/utils/GraphBase.hs @@ -14,8 +14,8 @@ where import GhcPrelude -import UniqSet -import UniqFM +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM -- | A fn to check if a node is trivially colorable diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs index 70c3f7a7b3..d10b28175c 100644 --- a/compiler/utils/GraphColor.hs +++ b/compiler/utils/GraphColor.hs @@ -20,9 +20,9 @@ import GraphBase import GraphOps import GraphPpr -import Unique -import UniqFM -import UniqSet +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set import Outputable import Data.Maybe diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index c7161f0e32..a1693c6a5a 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -25,9 +25,9 @@ import GhcPrelude import GraphBase import Outputable -import Unique -import UniqSet -import UniqFM +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM import Data.List hiding (union) import Data.Maybe diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs index 2210d07273..4327ec881c 100644 --- a/compiler/utils/GraphPpr.hs +++ b/compiler/utils/GraphPpr.hs @@ -12,9 +12,9 @@ import GhcPrelude import GraphBase import Outputable -import Unique -import UniqSet -import UniqFM +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM import Data.List (mapAccumL) import Data.Maybe diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 8067123211..fd6f6722cd 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -35,7 +35,7 @@ import GhcPrelude import GHC.Driver.Session import Exception -import Module +import GHC.Types.Module import Panic import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 6f6a335ed7..c23f6ed180 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -99,8 +99,8 @@ import {-# SOURCE #-} GHC.Driver.Session , pprUserLength, pprCols , unsafeGlobalDynFlags, initSDocContext ) -import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) -import {-# SOURCE #-} OccName( OccName ) +import {-# SOURCE #-} GHC.Types.Module( UnitId, Module, ModuleName, moduleName ) +import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import BufWrite (BufHandle) import FastString diff --git a/compiler/utils/TrieMap.hs b/compiler/utils/TrieMap.hs index 53bb06c4f9..815a060a0c 100644 --- a/compiler/utils/TrieMap.hs +++ b/compiler/utils/TrieMap.hs @@ -31,9 +31,9 @@ module TrieMap( import GhcPrelude -import Literal -import UniqDFM -import Unique( Unique ) +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 @@ -198,7 +198,7 @@ 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 UniqDFM for more details on how it's made +See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how it's made deterministic. -} diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs index a2f3c687bb..20eff96c2c 100644 --- a/compiler/utils/UnVarGraph.hs +++ b/compiler/utils/UnVarGraph.hs @@ -30,12 +30,12 @@ module UnVarGraph import GhcPrelude -import Id -import VarEnv -import UniqFM +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Unique.FM import Outputable import Bag -import Unique +import GHC.Types.Unique import qualified Data.IntSet as S diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs deleted file mode 100644 index f9588e9b0b..0000000000 --- a/compiler/utils/UniqDFM.hs +++ /dev/null @@ -1,420 +0,0 @@ -{- -(c) Bartosz Nitka, Facebook, 2015 - -UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. - -Basically, the things need to be in class @Uniquable@, and we use the -@getUnique@ method to grab their @Uniques@. - -This is very similar to @UniqFM@, the major difference being that the order of -folding is not dependent on @Unique@ ordering, giving determinism. -Currently the ordering is determined by insertion order. - -See Note [Unique Determinism] in Unique for explanation why @Unique@ ordering -is not deterministic. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wall #-} - -module UniqDFM ( - -- * Unique-keyed deterministic mappings - UniqDFM, -- abstract type - - -- ** Manipulating those mappings - emptyUDFM, - unitUDFM, - addToUDFM, - addToUDFM_C, - addListToUDFM, - delFromUDFM, - delListFromUDFM, - adjustUDFM, - alterUDFM, - mapUDFM, - plusUDFM, - plusUDFM_C, - lookupUDFM, lookupUDFM_Directly, - elemUDFM, - foldUDFM, - eltsUDFM, - filterUDFM, filterUDFM_Directly, - isNullUDFM, - sizeUDFM, - intersectUDFM, udfmIntersectUFM, - intersectsUDFM, - disjointUDFM, disjointUdfmUfm, - equalKeysUDFM, - minusUDFM, - listToUDFM, - udfmMinusUFM, - partitionUDFM, - anyUDFM, allUDFM, - pprUniqDFM, pprUDFM, - - udfmToList, - udfmToUfm, - nonDetFoldUDFM, - alwaysUnsafeUfmToUdfm, - ) where - -import GhcPrelude - -import Unique ( Uniquable(..), Unique, getKey ) -import Outputable - -import qualified Data.IntMap as M -import Data.Data -import Data.Functor.Classes (Eq1 (..)) -import Data.List (sortBy) -import Data.Function (on) -import qualified Data.Semigroup as Semi -import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap) - --- Note [Deterministic UniqFM] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- A @UniqDFM@ is just like @UniqFM@ with the following additional --- property: the function `udfmToList` returns the elements in some --- deterministic order not depending on the Unique key for those elements. --- --- If the client of the map performs operations on the map in deterministic --- order then `udfmToList` returns them in deterministic order. --- --- There is an implementation cost: each element is given a serial number --- as it is added, and `udfmToList` sorts it's result by this serial --- number. So you should only use `UniqDFM` if you need the deterministic --- property. --- --- `foldUDFM` also preserves determinism. --- --- Normal @UniqFM@ when you turn it into a list will use --- Data.IntMap.toList function that returns the elements in the order of --- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with --- with a list ordered by @Uniques@. --- The order of @Uniques@ is known to be not stable across rebuilds. --- See Note [Unique Determinism] in Unique. --- --- --- There's more than one way to implement this. The implementation here tags --- every value with the insertion time that can later be used to sort the --- values when asked to convert to a list. --- --- An alternative would be to have --- --- data UniqDFM ele = UDFM (M.IntMap ele) [ele] --- --- where the list determines the order. This makes deletion tricky as we'd --- only accumulate elements in that list, but makes merging easier as you --- can just merge both structures independently. --- Deletion can probably be done in amortized fashion when the size of the --- list is twice the size of the set. - --- | A type of values tagged with insertion time -data TaggedVal val = - TaggedVal - val - {-# UNPACK #-} !Int -- ^ insertion time - deriving (Data, Functor) - -taggedFst :: TaggedVal val -> val -taggedFst (TaggedVal v _) = v - -taggedSnd :: TaggedVal val -> Int -taggedSnd (TaggedVal _ i) = i - -instance Eq val => Eq (TaggedVal val) where - (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 - --- | Type of unique deterministic finite maps -data UniqDFM ele = - UDFM - !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and - -- values are tagged with insertion time. - -- The invariant is that all the tags will - -- be distinct within a single map - {-# UNPACK #-} !Int -- Upper bound on the values' insertion - -- time. See Note [Overflow on plusUDFM] - deriving (Data, Functor) - --- | Deterministic, in O(n log n). -instance Foldable UniqDFM where - foldr = foldUDFM - --- | Deterministic, in O(n log n). -instance Traversable UniqDFM where - traverse f = fmap listToUDFM_Directly - . traverse (\(u,a) -> (u,) <$> f a) - . udfmToList - -emptyUDFM :: UniqDFM elt -emptyUDFM = UDFM M.empty 0 - -unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt -unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 - --- The new binding always goes to the right of existing ones -addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt -addToUDFM m k v = addToUDFM_Directly m (getUnique k) v - --- The new binding always goes to the right of existing ones -addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt -addToUDFM_Directly (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) - where - tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i - -- Keep the old tag, but insert the new value - -- This means that udfmToList typically returns elements - -- in the order of insertion, rather than the reverse - -addToUDFM_Directly_C - :: (elt -> elt -> elt) -- old -> new -> result - -> UniqDFM elt - -> Unique -> elt - -> UniqDFM elt -addToUDFM_Directly_C f (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) - where - tf (TaggedVal new_v _) (TaggedVal old_v old_i) - = TaggedVal (f old_v new_v) old_i - -- Flip the arguments, because M.insertWith uses (new->old->result) - -- but f needs (old->new->result) - -- Like addToUDFM_Directly, keep the old tag - -addToUDFM_C - :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result - -> UniqDFM elt -- old - -> key -> elt -- new - -> UniqDFM elt -- result -addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v - -addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt -addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) - -addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt -addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) - -addListToUDFM_Directly_C - :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt -addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v) - -delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt -delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i - -plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt -plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) - -- we will use the upper bound on the tag as a proxy for the set size, - -- to insert the smaller one into the bigger one - | i > j = insertUDFMIntoLeft_C f udfml udfmr - | otherwise = insertUDFMIntoLeft_C f udfmr udfml - --- Note [Overflow on plusUDFM] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- There are multiple ways of implementing plusUDFM. --- The main problem that needs to be solved is overlap on times of --- insertion between different keys in two maps. --- Consider: --- --- A = fromList [(a, (x, 1))] --- B = fromList [(b, (y, 1))] --- --- If you merge them naively you end up with: --- --- C = fromList [(a, (x, 1)), (b, (y, 1))] --- --- Which loses information about ordering and brings us back into --- non-deterministic world. --- --- The solution I considered before would increment the tags on one of the --- sets by the upper bound of the other set. The problem with this approach --- is that you'll run out of tags for some merge patterns. --- Say you start with A with upper bound 1, you merge A with A to get A' and --- the upper bound becomes 2. You merge A' with A' and the upper bound --- doubles again. After 64 merges you overflow. --- This solution would have the same time complexity as plusUFM, namely O(n+m). --- --- The solution I ended up with has time complexity of --- O(m log m + m * min (n+m, W)) where m is the smaller set. --- It simply inserts the elements of the smaller set into the larger --- set in the order that they were inserted into the smaller set. That's --- O(m log m) for extracting the elements from the smaller set in the --- insertion order and O(m * min(n+m, W)) to insert them into the bigger --- set. - -plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) - -- we will use the upper bound on the tag as a proxy for the set size, - -- to insert the smaller one into the bigger one - | i > j = insertUDFMIntoLeft udfml udfmr - | otherwise = insertUDFMIntoLeft udfmr udfml - -insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr - -insertUDFMIntoLeft_C - :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt -insertUDFMIntoLeft_C f udfml udfmr = - addListToUDFM_Directly_C f udfml $ udfmToList udfmr - -lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt -lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m - -lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt -lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m - -elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool -elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m - --- | Performs a deterministic fold over the UniqDFM. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). -foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a -foldUDFM k z m = foldr k z (eltsUDFM m) - --- | Performs a nondeterministic fold over the UniqDFM. --- It's O(n), same as the corresponding function on `UniqFM`. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a -nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m - -eltsUDFM :: UniqDFM elt -> [elt] -eltsUDFM (UDFM m _i) = - map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m - -filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt -filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i - -filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt -filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i - where - p' k (TaggedVal v _) = p (getUnique k) v - --- | Converts `UniqDFM` to a list, with elements in deterministic order. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). -udfmToList :: UniqDFM elt -> [(Unique, elt)] -udfmToList (UDFM m _i) = - [ (getUnique k, taggedFst v) - | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] - --- Determines whether two 'UniqDFM's contain the same keys. -equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool -equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2 - -isNullUDFM :: UniqDFM elt -> Bool -isNullUDFM (UDFM m _) = M.null m - -sizeUDFM :: UniqDFM elt -> Int -sizeUDFM (UDFM m _i) = M.size m - -intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt -intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i - -- M.intersection is left biased, that means the result will only have - -- a subset of elements from the left set, so `i` is a good upper bound. - -udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 -udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i - -- M.intersection is left biased, that means the result will only have - -- a subset of elements from the left set, so `i` is a good upper bound. - -intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool -intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) - -disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool -disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) - -disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool -disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y)) - -minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1 -minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i - -- M.difference returns a subset of a left set, so `i` is a good upper - -- bound. - -udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 -udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i - -- M.difference returns a subset of a left set, so `i` is a good upper - -- bound. - --- | Partition UniqDFM into two UniqDFMs according to the predicate -partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) -partitionUDFM p (UDFM m i) = - case M.partition (p . taggedFst) m of - (left, right) -> (UDFM left i, UDFM right i) - --- | Delete a list of elements from a UniqDFM -delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt -delListFromUDFM = foldl' delFromUDFM - --- | This allows for lossy conversion from UniqDFM to UniqFM -udfmToUfm :: UniqDFM elt -> UniqFM elt -udfmToUfm (UDFM m _i) = - listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m] - -listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt -listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM - -listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt -listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM - --- | Apply a function to a particular element -adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt -adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i - --- | The expression (alterUDFM f k map) alters value x at k, or absence --- thereof. alterUDFM can be used to insert, delete, or update a value in --- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are --- more efficient. -alterUDFM - :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqDFM elt -- old - -> key -- new - -> UniqDFM elt -- result -alterUDFM f (UDFM m i) k = - UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) - where - alterf Nothing = inject $ f Nothing - alterf (Just (TaggedVal v _)) = inject $ f (Just v) - inject Nothing = Nothing - inject (Just v) = Just $ TaggedVal v i - --- | Map a function over every value in a UniqDFM -mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 -mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i - -anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool -anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m - -allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool -allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m - -instance Semi.Semigroup (UniqDFM a) where - (<>) = plusUDFM - -instance Monoid (UniqDFM a) where - mempty = emptyUDFM - mappend = (Semi.<>) - --- This should not be used in committed code, provided for convenience to --- make ad-hoc conversions when developing -alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt -alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList - --- Output-ery - -instance Outputable a => Outputable (UniqDFM a) where - ppr ufm = pprUniqDFM ppr ufm - -pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc -pprUniqDFM ppr_elt ufm - = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr_elt elt - | (uq, elt) <- udfmToList ufm ] - -pprUDFM :: UniqDFM a -- ^ The things to be pretty printed - -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUDFM ufm pp = pp (eltsUDFM ufm) diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs deleted file mode 100644 index c2ace5787f..0000000000 --- a/compiler/utils/UniqDSet.hs +++ /dev/null @@ -1,141 +0,0 @@ --- (c) Bartosz Nitka, Facebook, 2015 - --- | --- Specialised deterministic sets, for things with @Uniques@ --- --- Based on 'UniqDFM's (as you would expect). --- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need it. --- --- Basically, the things need to be in class 'Uniquable'. - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module UniqDSet ( - -- * Unique set type - UniqDSet, -- type synonym for UniqFM a - getUniqDSet, - pprUniqDSet, - - -- ** Manipulating these sets - delOneFromUniqDSet, delListFromUniqDSet, - emptyUniqDSet, - unitUniqDSet, - mkUniqDSet, - addOneToUniqDSet, addListToUniqDSet, - unionUniqDSets, unionManyUniqDSets, - minusUniqDSet, uniqDSetMinusUniqSet, - intersectUniqDSets, uniqDSetIntersectUniqSet, - foldUniqDSet, - elementOfUniqDSet, - filterUniqDSet, - sizeUniqDSet, - isEmptyUniqDSet, - lookupUniqDSet, - uniqDSetToList, - partitionUniqDSet, - mapUniqDSet - ) where - -import GhcPrelude - -import Outputable -import UniqDFM -import UniqSet -import Unique - -import Data.Coerce -import Data.Data -import qualified Data.Semigroup as Semi - --- See Note [UniqSet invariant] in UniqSet.hs for why we want a newtype here. --- Beyond preserving invariants, we may also want to 'override' typeclass --- instances. - -newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a} - deriving (Data, Semi.Semigroup, Monoid) - -emptyUniqDSet :: UniqDSet a -emptyUniqDSet = UniqDSet emptyUDFM - -unitUniqDSet :: Uniquable a => a -> UniqDSet a -unitUniqDSet x = UniqDSet (unitUDFM x x) - -mkUniqDSet :: Uniquable a => [a] -> UniqDSet a -mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet - --- The new element always goes to the right of existing ones. -addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a -addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x) - -addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a -addListToUniqDSet = foldl' addOneToUniqDSet - -delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a -delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s - -delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a -delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s - -unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a -unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t) - -unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a -unionManyUniqDSets [] = emptyUniqDSet -unionManyUniqDSets sets = foldr1 unionUniqDSets sets - -minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a -minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t) - -uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a -uniqDSetMinusUniqSet xs ys - = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys)) - -intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a -intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t) - -uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a -uniqDSetIntersectUniqSet xs ys - = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys)) - -foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b -foldUniqDSet c n (UniqDSet s) = foldUDFM c n s - -elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool -elementOfUniqDSet k = elemUDFM k . getUniqDSet - -filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a -filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s) - -sizeUniqDSet :: UniqDSet a -> Int -sizeUniqDSet = sizeUDFM . getUniqDSet - -isEmptyUniqDSet :: UniqDSet a -> Bool -isEmptyUniqDSet = isNullUDFM . getUniqDSet - -lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a -lookupUniqDSet = lookupUDFM . getUniqDSet - -uniqDSetToList :: UniqDSet a -> [a] -uniqDSetToList = eltsUDFM . getUniqDSet - -partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) -partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet - --- See Note [UniqSet invariant] in UniqSet.hs -mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b -mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList - --- Two 'UniqDSet's are considered equal if they contain the same --- uniques. -instance Eq (UniqDSet a) where - UniqDSet a == UniqDSet b = equalKeysUDFM a b - -getUniqDSet :: UniqDSet a -> UniqDFM a -getUniqDSet = getUniqDSet' - -instance Outputable a => Outputable (UniqDSet a) where - ppr = pprUniqDSet ppr - -pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc -pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs deleted file mode 100644 index 19b506e883..0000000000 --- a/compiler/utils/UniqFM.hs +++ /dev/null @@ -1,416 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - - -UniqFM: Specialised finite maps, for things with @Uniques@. - -Basically, the things need to be in class @Uniquable@, and we use the -@getUnique@ method to grab their @Uniques@. - -(A similar thing to @UniqSet@, as opposed to @Set@.) - -The interface is based on @FiniteMap@s, but the implementation uses -@Data.IntMap@, which is both maintained and faster than the past -implementation (see commit log). - -The @UniqFM@ interface maps directly to Data.IntMap, only -``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased -and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order -of arguments of combining function. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -Wall #-} - -module UniqFM ( - -- * Unique-keyed mappings - UniqFM, -- abstract type - NonDetUniqFM(..), -- wrapper for opting into nondeterminism - - -- ** Manipulating those mappings - emptyUFM, - unitUFM, - unitDirectlyUFM, - listToUFM, - listToUFM_Directly, - listToUFM_C, - addToUFM,addToUFM_C,addToUFM_Acc, - addListToUFM,addListToUFM_C, - addToUFM_Directly, - addListToUFM_Directly, - adjustUFM, alterUFM, - adjustUFM_Directly, - delFromUFM, - delFromUFM_Directly, - delListFromUFM, - delListFromUFM_Directly, - plusUFM, - plusUFM_C, - plusUFM_CD, - plusMaybeUFM_C, - plusUFMList, - minusUFM, - intersectUFM, - intersectUFM_C, - disjointUFM, - equalKeysUFM, - nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly, - anyUFM, allUFM, seqEltsUFM, - mapUFM, mapUFM_Directly, - elemUFM, elemUFM_Directly, - filterUFM, filterUFM_Directly, partitionUFM, - sizeUFM, - isNullUFM, - lookupUFM, lookupUFM_Directly, - lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, - nonDetEltsUFM, eltsUFM, nonDetKeysUFM, - ufmToSet_Directly, - nonDetUFMToList, ufmToIntMap, - pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM - ) where - -import GhcPrelude - -import Unique ( Uniquable(..), Unique, getKey ) -import Outputable - -import qualified Data.IntMap as M -import qualified Data.IntSet as S -import Data.Data -import qualified Data.Semigroup as Semi -import Data.Functor.Classes (Eq1 (..)) - - -newtype UniqFM ele = UFM (M.IntMap ele) - deriving (Data, Eq, Functor) - -- Nondeterministic Foldable and Traversable instances are accessible through - -- use of the 'NonDetUniqFM' wrapper. - -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. - -emptyUFM :: UniqFM elt -emptyUFM = UFM M.empty - -isNullUFM :: UniqFM elt -> Bool -isNullUFM (UFM m) = M.null m - -unitUFM :: Uniquable key => key -> elt -> UniqFM elt -unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) - --- when you've got the Unique already -unitDirectlyUFM :: Unique -> elt -> UniqFM elt -unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) - -listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt -listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM - -listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt -listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM - -listToUFM_C - :: Uniquable key - => (elt -> elt -> elt) - -> [(key, elt)] - -> UniqFM elt -listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM - -addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt -addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) - -addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt -addListToUFM = foldl' (\m (k, v) -> addToUFM m k v) - -addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt -addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v) - -addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt -addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) - -addToUFM_C - :: Uniquable key - => (elt -> elt -> elt) -- old -> new -> result - -> UniqFM elt -- old - -> key -> elt -- new - -> UniqFM elt -- result --- Arguments of combining function of M.insertWith and addToUFM_C are flipped. -addToUFM_C f (UFM m) k v = - UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) - -addToUFM_Acc - :: Uniquable key - => (elt -> elts -> elts) -- Add to existing - -> (elt -> elts) -- New element - -> UniqFM elts -- old - -> key -> elt -- new - -> UniqFM elts -- result -addToUFM_Acc exi new (UFM m) k v = - UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) - -alterUFM - :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqFM elt -- old - -> key -- new - -> UniqFM elt -- result -alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) - -addListToUFM_C - :: Uniquable key - => (elt -> elt -> elt) - -> UniqFM elt -> [(key,elt)] - -> UniqFM elt -addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) - -adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt -adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) - -adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt -adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) - -delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt -delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) - -delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt -delListFromUFM = foldl' delFromUFM - -delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt -delListFromUFM_Directly = foldl' delFromUFM_Directly - -delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt -delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) - --- Bindings in right argument shadow those in the left -plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt --- M.union is left-biased, plusUFM should be right-biased. -plusUFM (UFM x) (UFM y) = UFM (M.union y x) - -- Note (M.union y x), with arguments flipped - -- M.union is left-biased, plusUFM should be right-biased. - -plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt -plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) - --- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the --- combinding function and `d1` resp. `d2` as the default value if --- there is no entry in `m1` reps. `m2`. The domain is the union of --- the domains of `m1` and `m2`. --- --- Representative example: --- --- @ --- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 --- == {A: f 1 42, B: f 2 3, C: f 23 4 } --- @ -plusUFM_CD - :: (elt -> elt -> elt) - -> UniqFM elt -- map X - -> elt -- default for X - -> UniqFM elt -- map Y - -> elt -- default for Y - -> UniqFM elt -plusUFM_CD f (UFM xm) dx (UFM ym) dy - = UFM $ M.mergeWithKey - (\_ x y -> Just (x `f` y)) - (M.map (\x -> x `f` dy)) - (M.map (\y -> dx `f` y)) - xm ym - -plusMaybeUFM_C :: (elt -> elt -> Maybe elt) - -> UniqFM elt -> UniqFM elt -> UniqFM elt -plusMaybeUFM_C f (UFM xm) (UFM ym) - = UFM $ M.mergeWithKey - (\_ x y -> x `f` y) - id - id - xm ym - -plusUFMList :: [UniqFM elt] -> UniqFM elt -plusUFMList = foldl' plusUFM emptyUFM - -minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 -minusUFM (UFM x) (UFM y) = UFM (M.difference x y) - -intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 -intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) - -intersectUFM_C - :: (elt1 -> elt2 -> elt3) - -> UniqFM elt1 - -> UniqFM elt2 - -> UniqFM elt3 -intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) - -disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool -disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y) - -foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a -foldUFM k z (UFM m) = M.foldr k z m - -mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 -mapUFM f (UFM m) = UFM (M.map f m) - -mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 -mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) - -filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt -filterUFM p (UFM m) = UFM (M.filter p m) - -filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt -filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) - -partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) -partitionUFM p (UFM m) = - case M.partition p m of - (left, right) -> (UFM left, UFM right) - -sizeUFM :: UniqFM elt -> Int -sizeUFM (UFM m) = M.size m - -elemUFM :: Uniquable key => key -> UniqFM elt -> Bool -elemUFM k (UFM m) = M.member (getKey $ getUnique k) m - -elemUFM_Directly :: Unique -> UniqFM elt -> Bool -elemUFM_Directly u (UFM m) = M.member (getKey u) m - -lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt -lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m - --- when you've got the Unique already -lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt -lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m - -lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt -lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m - -lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt -lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m - -eltsUFM :: UniqFM elt -> [elt] -eltsUFM (UFM m) = M.elems m - -ufmToSet_Directly :: UniqFM elt -> S.IntSet -ufmToSet_Directly (UFM m) = M.keysSet m - -anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool -anyUFM p (UFM m) = M.foldr ((||) . p) False m - -allUFM :: (elt -> Bool) -> UniqFM elt -> Bool -allUFM p (UFM m) = M.foldr ((&&) . p) True m - -seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> () -seqEltsUFM seqList = seqList . nonDetEltsUFM - -- It's OK to use nonDetEltsUFM here because the type guarantees that - -- the only interesting thing this function can do is to force the - -- elements. - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetEltsUFM :: UniqFM elt -> [elt] -nonDetEltsUFM (UFM m) = M.elems m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetKeysUFM :: UniqFM elt -> [Unique] -nonDetKeysUFM (UFM m) = map getUnique $ M.keys m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a -nonDetFoldUFM k z (UFM m) = M.foldr k z m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a -nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] -nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m - --- | A wrapper around 'UniqFM' with the sole purpose of informing call sites --- that the provided 'Foldable' and 'Traversable' instances are --- nondeterministic. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. --- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. -newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele } - deriving (Functor) - --- | Inherently nondeterministic. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. --- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. -instance Foldable NonDetUniqFM where - foldr f z (NonDetUniqFM (UFM m)) = foldr f z m - --- | Inherently nondeterministic. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. --- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. -instance Traversable NonDetUniqFM where - traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m - -ufmToIntMap :: UniqFM elt -> M.IntMap elt -ufmToIntMap (UFM m) = m - --- Determines whether two 'UniqFM's contain the same keys. -equalKeysUFM :: UniqFM a -> UniqFM b -> Bool -equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 - --- Instances - -instance Semi.Semigroup (UniqFM a) where - (<>) = plusUFM - -instance Monoid (UniqFM a) where - mempty = emptyUFM - mappend = (Semi.<>) - --- Output-ery - -instance Outputable a => Outputable (UniqFM a) where - ppr ufm = pprUniqFM ppr ufm - -pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc -pprUniqFM ppr_elt ufm - = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr_elt elt - | (uq, elt) <- nonDetUFMToList ufm ] - -- It's OK to use nonDetUFMToList here because we only use it for - -- pretty-printing. - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetEltsUFM. -pprUFM :: UniqFM a -- ^ The things to be pretty printed - -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUFM ufm pp = pp (nonDetEltsUFM ufm) - --- | Pretty-print a non-deterministic set. --- The order of variables is non-deterministic and for pretty-printing that --- shouldn't be a problem. --- Having this function helps contain the non-determinism created with --- nonDetUFMToList. -pprUFMWithKeys - :: UniqFM a -- ^ The things to be pretty printed - -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements - -> SDoc -- ^ 'SDoc' where the things have been pretty - -- printed -pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) - --- | Determines the pluralisation suffix appropriate for the length of a set --- in the same way that plural from Outputable does for lists. -pluralUFM :: UniqFM a -> SDoc -pluralUFM ufm - | sizeUFM ufm == 1 = empty - | otherwise = char 's' diff --git a/compiler/utils/UniqMap.hs b/compiler/utils/UniqMap.hs deleted file mode 100644 index 1bd51c2b38..0000000000 --- a/compiler/utils/UniqMap.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wall #-} - --- Like 'UniqFM', these are maps for keys which are Uniquable. --- Unlike 'UniqFM', these maps also remember their keys, which --- makes them a much better drop in replacement for 'Data.Map.Map'. --- --- Key preservation is right-biased. -module UniqMap ( - UniqMap, - emptyUniqMap, - isNullUniqMap, - unitUniqMap, - listToUniqMap, - listToUniqMap_C, - addToUniqMap, - addListToUniqMap, - addToUniqMap_C, - addToUniqMap_Acc, - alterUniqMap, - addListToUniqMap_C, - adjustUniqMap, - delFromUniqMap, - delListFromUniqMap, - plusUniqMap, - plusUniqMap_C, - plusMaybeUniqMap_C, - plusUniqMapList, - minusUniqMap, - intersectUniqMap, - disjointUniqMap, - mapUniqMap, - filterUniqMap, - partitionUniqMap, - sizeUniqMap, - elemUniqMap, - lookupUniqMap, - lookupWithDefaultUniqMap, - anyUniqMap, - allUniqMap, - -- Non-deterministic functions omitted -) where - -import GhcPrelude - -import UniqFM - -import Unique -import Outputable - -import Data.Semigroup as Semi ( Semigroup(..) ) -import Data.Coerce -import Data.Maybe -import Data.Data - --- | Maps indexed by 'Uniquable' keys -newtype UniqMap k a = UniqMap (UniqFM (k, a)) - deriving (Data, Eq, Functor) -type role UniqMap nominal representational - -instance Semigroup (UniqMap k a) where - (<>) = plusUniqMap - -instance Monoid (UniqMap k a) where - mempty = emptyUniqMap - mappend = (Semi.<>) - -instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where - ppr (UniqMap m) = - brackets $ fsep $ punctuate comma $ - [ ppr k <+> text "->" <+> ppr v - | (k, v) <- eltsUFM m ] - -liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a) -liftC f (_, v) (k', v') = (k', f v v') - -emptyUniqMap :: UniqMap k a -emptyUniqMap = UniqMap emptyUFM - -isNullUniqMap :: UniqMap k a -> Bool -isNullUniqMap (UniqMap m) = isNullUFM m - -unitUniqMap :: Uniquable k => k -> a -> UniqMap k a -unitUniqMap k v = UniqMap (unitUFM k (k, v)) - -listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a -listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs]) - -listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a -listToUniqMap_C f kvs = UniqMap $ - listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs] - -addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a -addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v) - -addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a -addListToUniqMap (UniqMap m) kvs = UniqMap $ - addListToUFM m [(k,(k,v)) | (k,v) <- kvs] - -addToUniqMap_C :: Uniquable k - => (a -> a -> a) - -> UniqMap k a - -> k - -> a - -> UniqMap k a -addToUniqMap_C f (UniqMap m) k v = UniqMap $ - addToUFM_C (liftC f) m k (k, v) - -addToUniqMap_Acc :: Uniquable k - => (b -> a -> a) - -> (b -> a) - -> UniqMap k a - -> k - -> b - -> UniqMap k a -addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $ - addToUFM_Acc (\b (k, v) -> (k, exi b v)) - (\b -> (k0, new b)) - m k0 v0 - -alterUniqMap :: Uniquable k - => (Maybe a -> Maybe a) - -> UniqMap k a - -> k - -> UniqMap k a -alterUniqMap f (UniqMap m) k = UniqMap $ - alterUFM (fmap (k,) . f . fmap snd) m k - -addListToUniqMap_C - :: Uniquable k - => (a -> a -> a) - -> UniqMap k a - -> [(k, a)] - -> UniqMap k a -addListToUniqMap_C f (UniqMap m) kvs = UniqMap $ - addListToUFM_C (liftC f) m - [(k,(k,v)) | (k,v) <- kvs] - -adjustUniqMap - :: Uniquable k - => (a -> a) - -> UniqMap k a - -> k - -> UniqMap k a -adjustUniqMap f (UniqMap m) k = UniqMap $ - adjustUFM (\(_,v) -> (k,f v)) m k - -delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a -delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k - -delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a -delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks - -plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a -plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2 - -plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a -plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ - plusUFM_C (liftC f) m1 m2 - -plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a -plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ - plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2 - -plusUniqMapList :: [UniqMap k a] -> UniqMap k a -plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs) - -minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a -minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2 - -intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a -intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2 - -disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool -disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2 - -mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b -mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance - -filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a -filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m - -partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a) -partitionUniqMap f (UniqMap m) = - coerce $ partitionUFM (f . snd) m - -sizeUniqMap :: UniqMap k a -> Int -sizeUniqMap (UniqMap m) = sizeUFM m - -elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool -elemUniqMap k (UniqMap m) = elemUFM k m - -lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a -lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k) - -lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a -lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k)) - -anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool -anyUniqMap f (UniqMap m) = anyUFM (f . snd) m - -allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool -allUniqMap f (UniqMap m) = allUFM (f . snd) m diff --git a/compiler/utils/UniqSet.hs b/compiler/utils/UniqSet.hs deleted file mode 100644 index 1c45f7485f..0000000000 --- a/compiler/utils/UniqSet.hs +++ /dev/null @@ -1,195 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1994-1998 - -\section[UniqSet]{Specialised sets, for things with @Uniques@} - -Based on @UniqFMs@ (as you would expect). - -Basically, the things need to be in class @Uniquable@. --} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module UniqSet ( - -- * Unique set type - UniqSet, -- type synonym for UniqFM a - getUniqSet, - pprUniqSet, - - -- ** Manipulating these sets - emptyUniqSet, - unitUniqSet, - mkUniqSet, - addOneToUniqSet, addListToUniqSet, - delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, - delListFromUniqSet_Directly, - unionUniqSets, unionManyUniqSets, - minusUniqSet, uniqSetMinusUFM, - intersectUniqSets, - restrictUniqSetToUFM, - uniqSetAny, uniqSetAll, - elementOfUniqSet, - elemUniqSet_Directly, - filterUniqSet, - filterUniqSet_Directly, - sizeUniqSet, - isEmptyUniqSet, - lookupUniqSet, - lookupUniqSet_Directly, - partitionUniqSet, - mapUniqSet, - unsafeUFMToUniqSet, - nonDetEltsUniqSet, - nonDetKeysUniqSet, - nonDetFoldUniqSet, - nonDetFoldUniqSet_Directly - ) where - -import GhcPrelude - -import UniqFM -import Unique -import Data.Coerce -import Outputable -import Data.Data -import qualified Data.Semigroup as Semi - --- Note [UniqSet invariant] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- UniqSet has the following invariant: --- The keys in the map are the uniques of the values --- It means that to implement mapUniqSet you have to update --- both the keys and the values. - -newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} - deriving (Data, Semi.Semigroup, Monoid) - -emptyUniqSet :: UniqSet a -emptyUniqSet = UniqSet emptyUFM - -unitUniqSet :: Uniquable a => a -> UniqSet a -unitUniqSet x = UniqSet $ unitUFM x x - -mkUniqSet :: Uniquable a => [a] -> UniqSet a -mkUniqSet = foldl' addOneToUniqSet emptyUniqSet - -addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a -addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) - -addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a -addListToUniqSet = foldl' addOneToUniqSet - -delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a -delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) - -delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a -delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) - -delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a -delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) - -delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a -delListFromUniqSet_Directly (UniqSet s) l = - UniqSet (delListFromUFM_Directly s l) - -unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a -unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) - -unionManyUniqSets :: [UniqSet a] -> UniqSet a -unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet - -minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a -minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) - -intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a -intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) - -restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a -restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) - -uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a -uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) - -elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool -elementOfUniqSet a (UniqSet s) = elemUFM a s - -elemUniqSet_Directly :: Unique -> UniqSet a -> Bool -elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s - -filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a -filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) - -filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt -filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) - -partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) -partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) - -uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool -uniqSetAny p (UniqSet s) = anyUFM p s - -uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool -uniqSetAll p (UniqSet s) = allUFM p s - -sizeUniqSet :: UniqSet a -> Int -sizeUniqSet (UniqSet s) = sizeUFM s - -isEmptyUniqSet :: UniqSet a -> Bool -isEmptyUniqSet (UniqSet s) = isNullUFM s - -lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b -lookupUniqSet (UniqSet s) k = lookupUFM s k - -lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a -lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetEltsUniqSet :: UniqSet elt -> [elt] -nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetKeysUniqSet :: UniqSet elt -> [Unique] -nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a -nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s - --- See Note [Deterministic UniqFM] to learn about nondeterminism. --- If you use this please provide a justification why it doesn't introduce --- nondeterminism. -nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a -nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s - --- See Note [UniqSet invariant] -mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b -mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet - --- Two 'UniqSet's are considered equal if they contain the same --- uniques. -instance Eq (UniqSet a) where - UniqSet a == UniqSet b = equalKeysUFM a b - -getUniqSet :: UniqSet a -> UniqFM a -getUniqSet = getUniqSet' - --- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ --- assuming, without checking, that it maps each 'Unique' to a value --- that has that 'Unique'. See Note [UniqSet invariant]. -unsafeUFMToUniqSet :: UniqFM a -> UniqSet a -unsafeUFMToUniqSet = UniqSet - -instance Outputable a => Outputable (UniqSet a) where - ppr = pprUniqSet ppr - -pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc --- It's OK to use nonDetUFMToList here because we only use it for --- pretty-printing. -pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet -- cgit v1.2.1