summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorshayne_fletcher <>2020-08-01 14:22:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-08-01 14:22:00 (GMT)
commit6de8bad023d376f720a3303dff6d088f58eb9e1f (patch)
tree951e9cd087895c8f8d8eb95bddc1bfb53f7a76f3
parentc4b56a1cfdb7c50f8a5aa3a32ec3eaf76c8f42ec (diff)
version 0.202008010.20200801
-rw-r--r--compiler/GHC/Builtin/Names.hs (renamed from compiler/prelude/PrelNames.hs)831
-rw-r--r--compiler/GHC/Builtin/PrimOps.hs (renamed from compiler/prelude/PrimOp.hs)201
-rw-r--r--compiler/GHC/Builtin/PrimOps.hs-boot5
-rw-r--r--compiler/GHC/Builtin/Types.hs (renamed from compiler/prelude/TysWiredIn.hs)580
-rw-r--r--compiler/GHC/Builtin/Types.hs-boot (renamed from compiler/prelude/TysWiredIn.hs-boot)38
-rw-r--r--compiler/GHC/Builtin/Types/Prim.hs (renamed from compiler/prelude/TysPrim.hs)237
-rw-r--r--compiler/GHC/Builtin/Uniques.hs (renamed from compiler/prelude/KnownUniques.hs)24
-rw-r--r--compiler/GHC/Builtin/Uniques.hs-boot (renamed from compiler/prelude/KnownUniques.hs-boot)12
-rw-r--r--compiler/GHC/ByteCode/Types.hs (renamed from compiler/ghci/ByteCodeTypes.hs)32
-rw-r--r--compiler/GHC/Cmm.hs267
-rw-r--r--compiler/GHC/Cmm/BlockId.hs46
-rw-r--r--compiler/GHC/Cmm/BlockId.hs-boot8
-rw-r--r--compiler/GHC/Cmm/CLabel.hs1614
-rw-r--r--compiler/GHC/Cmm/Dataflow/Block.hs323
-rw-r--r--compiler/GHC/Cmm/Dataflow/Collections.hs180
-rw-r--r--compiler/GHC/Cmm/Dataflow/Graph.hs188
-rw-r--r--compiler/GHC/Cmm/Dataflow/Label.hs145
-rw-r--r--compiler/GHC/Cmm/Expr.hs623
-rw-r--r--compiler/GHC/Cmm/MachOp.hs669
-rw-r--r--compiler/GHC/Cmm/Node.hs726
-rw-r--r--compiler/GHC/Cmm/Switch.hs503
-rw-r--r--compiler/GHC/Cmm/Type.hs (renamed from compiler/cmm/CmmType.hs)105
-rw-r--r--compiler/GHC/CmmToAsm/Config.hs46
-rw-r--r--compiler/GHC/Core.hs (renamed from compiler/coreSyn/CoreSyn.hs)511
-rw-r--r--compiler/GHC/Core/Class.hs (renamed from compiler/types/Class.hs)35
-rw-r--r--compiler/GHC/Core/Coercion.hs (renamed from compiler/types/Coercion.hs)617
-rw-r--r--compiler/GHC/Core/Coercion.hs-boot (renamed from compiler/types/Coercion.hs-boot)23
-rw-r--r--compiler/GHC/Core/Coercion/Axiom.hs (renamed from compiler/types/CoAxiom.hs)88
-rw-r--r--compiler/GHC/Core/Coercion/Opt.hs (renamed from compiler/types/OptCoercion.hs)118
-rw-r--r--compiler/GHC/Core/ConLike.hs (renamed from compiler/basicTypes/ConLike.hs)48
-rw-r--r--compiler/GHC/Core/ConLike.hs-boot9
-rw-r--r--compiler/GHC/Core/DataCon.hs (renamed from compiler/basicTypes/DataCon.hs)397
-rw-r--r--compiler/GHC/Core/DataCon.hs-boot34
-rw-r--r--compiler/GHC/Core/FVs.hs (renamed from compiler/coreSyn/CoreFVs.hs)89
-rw-r--r--compiler/GHC/Core/FamInstEnv.hs (renamed from compiler/types/FamInstEnv.hs)561
-rw-r--r--compiler/GHC/Core/InstEnv.hs (renamed from compiler/types/InstEnv.hs)85
-rw-r--r--compiler/GHC/Core/Lint.hs3344
-rw-r--r--compiler/GHC/Core/Make.hs (renamed from compiler/coreSyn/MkCore.hs)463
-rw-r--r--compiler/GHC/Core/Map.hs (renamed from compiler/coreSyn/CoreMap.hs)88
-rw-r--r--compiler/GHC/Core/Multiplicity.hs338
-rw-r--r--compiler/GHC/Core/Opt/Arity.hs (renamed from compiler/coreSyn/CoreArity.hs)507
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs (renamed from compiler/prelude/PrelRules.hs)1697
-rw-r--r--compiler/GHC/Core/Opt/Monad.hs (renamed from compiler/simplCore/CoreMonad.hs)220
-rw-r--r--compiler/GHC/Core/Opt/Monad.hs-boot (renamed from compiler/simplCore/CoreMonad.hs-boot)17
-rw-r--r--compiler/GHC/Core/Opt/OccurAnal.hs (renamed from compiler/simplCore/OccurAnal.hs)1143
-rw-r--r--compiler/GHC/Core/PatSyn.hs (renamed from compiler/basicTypes/PatSyn.hs)84
-rw-r--r--compiler/GHC/Core/PatSyn.hs-boot13
-rw-r--r--compiler/GHC/Core/Ppr.hs (renamed from compiler/coreSyn/PprCore.hs)229
-rw-r--r--compiler/GHC/Core/Predicate.hs229
-rw-r--r--compiler/GHC/Core/Seq.hs (renamed from compiler/coreSyn/CoreSeq.hs)24
-rw-r--r--compiler/GHC/Core/SimpleOpt.hs (renamed from compiler/coreSyn/CoreOpt.hs)680
-rw-r--r--compiler/GHC/Core/Stats.hs (renamed from compiler/coreSyn/CoreStats.hs)18
-rw-r--r--compiler/GHC/Core/Subst.hs (renamed from compiler/coreSyn/CoreSubst.hs)164
-rw-r--r--compiler/GHC/Core/TyCo/FVs.hs986
-rw-r--r--compiler/GHC/Core/TyCo/Ppr.hs354
-rw-r--r--compiler/GHC/Core/TyCo/Ppr.hs-boot11
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs2064
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs-boot28
-rw-r--r--compiler/GHC/Core/TyCo/Subst.hs1053
-rw-r--r--compiler/GHC/Core/TyCo/Tidy.hs235
-rw-r--r--compiler/GHC/Core/TyCon.hs (renamed from compiler/types/TyCon.hs)534
-rw-r--r--compiler/GHC/Core/TyCon.hs-boot (renamed from compiler/types/TyCon.hs-boot)7
-rw-r--r--compiler/GHC/Core/Type.hs (renamed from compiler/types/Type.hs)2311
-rw-r--r--compiler/GHC/Core/Type.hs-boot26
-rw-r--r--compiler/GHC/Core/Unfold.hs (renamed from compiler/coreSyn/CoreUnfold.hs)401
-rw-r--r--compiler/GHC/Core/Unfold.hs-boot16
-rw-r--r--compiler/GHC/Core/Unify.hs (renamed from compiler/types/Unify.hs)237
-rw-r--r--compiler/GHC/Core/UsageEnv.hs90
-rw-r--r--compiler/GHC/Core/Utils.hs (renamed from compiler/coreSyn/CoreUtils.hs)764
-rw-r--r--compiler/GHC/Core/Utils.hs-boot6
-rw-r--r--compiler/GHC/CoreToIface.hs (renamed from compiler/iface/ToIface.hs)180
-rw-r--r--compiler/GHC/CoreToIface.hs-boot18
-rw-r--r--compiler/GHC/Data/Bag.hs (renamed from compiler/utils/Bag.hs)82
-rw-r--r--compiler/GHC/Data/BooleanFormula.hs (renamed from compiler/utils/BooleanFormula.hs)16
-rw-r--r--compiler/GHC/Data/EnumSet.hs (renamed from compiler/utils/EnumSet.hs)4
-rw-r--r--compiler/GHC/Data/FastMutInt.hs (renamed from compiler/utils/FastMutInt.hs)4
-rw-r--r--compiler/GHC/Data/FastString.hs (renamed from compiler/utils/FastString.hs)309
-rw-r--r--compiler/GHC/Data/FastString/Env.hs (renamed from compiler/utils/FastStringEnv.hs)22
-rw-r--r--compiler/GHC/Data/FiniteMap.hs (renamed from compiler/utils/FiniteMap.hs)4
-rw-r--r--compiler/GHC/Data/Graph/Directed.hs (renamed from compiler/utils/Digraph.hs)24
-rw-r--r--compiler/GHC/Data/IOEnv.hs (renamed from compiler/utils/IOEnv.hs)48
-rw-r--r--compiler/GHC/Data/List/SetOps.hs (renamed from compiler/utils/ListSetOps.hs)44
-rw-r--r--compiler/GHC/Data/Maybe.hs (renamed from compiler/utils/Maybes.hs)11
-rw-r--r--compiler/GHC/Data/OrdList.hs192
-rw-r--r--compiler/GHC/Data/Pair.hs (renamed from compiler/utils/Pair.hs)20
-rw-r--r--compiler/GHC/Data/Stream.hs135
-rw-r--r--compiler/GHC/Data/StringBuffer.hs (renamed from compiler/utils/StringBuffer.hs)16
-rw-r--r--compiler/GHC/Data/TrieMap.hs (renamed from compiler/utils/TrieMap.hs)25
-rw-r--r--compiler/GHC/Driver/Backend.hs131
-rw-r--r--compiler/GHC/Driver/Backpack/Syntax.hs (renamed from compiler/backpack/BkpSyn.hs)20
-rw-r--r--compiler/GHC/Driver/CmdLine.hs (renamed from compiler/main/CmdLineParser.hs)27
-rw-r--r--compiler/GHC/Driver/Flags.hs528
-rw-r--r--compiler/GHC/Driver/Hooks.hs (renamed from compiler/main/Hooks.hs)94
-rw-r--r--compiler/GHC/Driver/Hooks.hs-boot7
-rw-r--r--compiler/GHC/Driver/Monad.hs (renamed from compiler/main/GhcMonad.hs)52
-rw-r--r--compiler/GHC/Driver/Phases.hs (renamed from compiler/main/DriverPhases.hs)38
-rw-r--r--compiler/GHC/Driver/Pipeline/Monad.hs (renamed from compiler/main/PipelineMonad.hs)44
-rw-r--r--compiler/GHC/Driver/Plugins.hs (renamed from compiler/main/Plugins.hs)71
-rw-r--r--compiler/GHC/Driver/Plugins.hs-boot (renamed from compiler/main/Plugins.hs-boot)4
-rw-r--r--compiler/GHC/Driver/Session.hs (renamed from compiler/main/DynFlags.hs)2323
-rw-r--r--compiler/GHC/Driver/Session.hs-boot15
-rw-r--r--compiler/GHC/Driver/Types.hs (renamed from compiler/main/HscTypes.hs)938
-rw-r--r--compiler/GHC/Hs.hs (renamed from compiler/hsSyn/HsSyn.hs)114
-rw-r--r--compiler/GHC/Hs/Binds.hs (renamed from compiler/hsSyn/HsBinds.hs)588
-rw-r--r--compiler/GHC/Hs/Decls.hs (renamed from compiler/hsSyn/HsDecls.hs)1418
-rw-r--r--compiler/GHC/Hs/Doc.hs (renamed from compiler/hsSyn/HsDoc.hs)20
-rw-r--r--compiler/GHC/Hs/Dump.hs (renamed from compiler/hsSyn/HsDumpAst.hs)31
-rw-r--r--compiler/GHC/Hs/Expr.hs (renamed from compiler/hsSyn/HsExpr.hs)1980
-rw-r--r--compiler/GHC/Hs/Expr.hs-boot51
-rw-r--r--compiler/GHC/Hs/Extension.hs831
-rw-r--r--compiler/GHC/Hs/ImpExp.hs (renamed from compiler/hsSyn/HsImpExp.hs)201
-rw-r--r--compiler/GHC/Hs/Instances.hs (renamed from compiler/hsSyn/HsInstances.hs)127
-rw-r--r--compiler/GHC/Hs/Lit.hs (renamed from compiler/hsSyn/HsLit.hs)99
-rw-r--r--compiler/GHC/Hs/Pat.hs (renamed from compiler/hsSyn/HsPat.hs)578
-rw-r--r--compiler/GHC/Hs/Pat.hs-boot20
-rw-r--r--compiler/GHC/Hs/Type.hs2077
-rw-r--r--compiler/GHC/Hs/Utils.hs (renamed from compiler/hsSyn/HsUtils.hs)1109
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Types.hs595
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Types.hs-boot9
-rw-r--r--compiler/GHC/Iface/Recomp/Binary.hs (renamed from compiler/iface/BinFingerprint.hs)16
-rw-r--r--compiler/GHC/Iface/Syntax.hs (renamed from compiler/iface/IfaceSyn.hs)627
-rw-r--r--compiler/GHC/Iface/Type.hs (renamed from compiler/iface/IfaceType.hs)692
-rw-r--r--compiler/GHC/Iface/Type.hs-boot17
-rw-r--r--compiler/GHC/Parser/Annotation.hs (renamed from compiler/parser/ApiAnnotation.hs)128
-rw-r--r--compiler/GHC/Parser/CharClass.hs215
-rw-r--r--compiler/GHC/Parser/Header.hs (renamed from compiler/main/HeaderInfo.hs)139
-rw-r--r--compiler/GHC/Parser/PostProcess.hs3055
-rw-r--r--compiler/GHC/Parser/PostProcess/Haddock.hs1556
-rw-r--r--compiler/GHC/Platform.hs216
-rw-r--r--compiler/GHC/Platform/ARM.hs10
-rw-r--r--compiler/GHC/Platform/ARM64.hs10
-rw-r--r--compiler/GHC/Platform/NoRegs.hs9
-rw-r--r--compiler/GHC/Platform/PPC.hs10
-rw-r--r--compiler/GHC/Platform/Profile.hs54
-rw-r--r--compiler/GHC/Platform/Reg.hs245
-rw-r--r--compiler/GHC/Platform/Reg/Class.hs32
-rw-r--r--compiler/GHC/Platform/Regs.hs113
-rw-r--r--compiler/GHC/Platform/S390X.hs10
-rw-r--r--compiler/GHC/Platform/SPARC.hs10
-rw-r--r--compiler/GHC/Platform/Ways.hs202
-rw-r--r--compiler/GHC/Platform/X86.hs10
-rw-r--r--compiler/GHC/Platform/X86_64.hs10
-rw-r--r--compiler/GHC/Prelude.hs (renamed from compiler/utils/GhcPrelude.hs)8
-rw-r--r--compiler/GHC/Runtime/Eval/Types.hs (renamed from compiler/main/InteractiveEvalTypes.hs)18
-rw-r--r--compiler/GHC/Runtime/Heap/Layout.hs544
-rw-r--r--compiler/GHC/Runtime/Interpreter/Types.hs63
-rw-r--r--compiler/GHC/Runtime/Linker/Types.hs108
-rw-r--r--compiler/GHC/Settings.hs268
-rw-r--r--compiler/GHC/Settings/Constants.hs (renamed from compiler/main/Constants.hs)19
-rw-r--r--compiler/GHC/Stg/Syntax.hs819
-rw-r--r--compiler/GHC/StgToCmm/Types.hs229
-rw-r--r--compiler/GHC/SysTools/BaseDir.hs (renamed from compiler/main/SysTools/BaseDir.hs)95
-rw-r--r--compiler/GHC/SysTools/FileCleanup.hs (renamed from compiler/main/FileCleanup.hs)18
-rw-r--r--compiler/GHC/SysTools/Terminal.hs104
-rw-r--r--compiler/GHC/Tc/Errors/Hole/FitTypes.hs143
-rw-r--r--compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot10
-rw-r--r--compiler/GHC/Tc/Types.hs1758
-rw-r--r--compiler/GHC/Tc/Types.hs-boot12
-rw-r--r--compiler/GHC/Tc/Types/Constraint.hs1853
-rw-r--r--compiler/GHC/Tc/Types/Evidence.hs (renamed from compiler/typecheck/TcEvidence.hs)266
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs661
-rw-r--r--compiler/GHC/Tc/Utils/TcType.hs (renamed from compiler/typecheck/TcType.hs)975
-rw-r--r--compiler/GHC/Tc/Utils/TcType.hs-boot (renamed from compiler/typecheck/TcType.hs-boot)4
-rw-r--r--compiler/GHC/Types/Annotations.hs (renamed from compiler/main/Annotations.hs)84
-rw-r--r--compiler/GHC/Types/Avail.hs (renamed from compiler/basicTypes/Avail.hs)24
-rw-r--r--compiler/GHC/Types/Basic.hs (renamed from compiler/basicTypes/BasicTypes.hs)539
-rw-r--r--compiler/GHC/Types/CostCentre.hs (renamed from compiler/profiling/CostCentre.hs)26
-rw-r--r--compiler/GHC/Types/CostCentre/State.hs (renamed from compiler/profiling/CostCentreState.hs)21
-rw-r--r--compiler/GHC/Types/Cpr.hs163
-rw-r--r--compiler/GHC/Types/Demand.hs (renamed from compiler/basicTypes/Demand.hs)1334
-rw-r--r--compiler/GHC/Types/FieldLabel.hs (renamed from compiler/basicTypes/FieldLabel.hs)30
-rw-r--r--compiler/GHC/Types/ForeignCall.hs (renamed from compiler/prelude/ForeignCall.hs)67
-rw-r--r--compiler/GHC/Types/Id.hs (renamed from compiler/basicTypes/Id.hs)305
-rw-r--r--compiler/GHC/Types/Id/Info.hs (renamed from compiler/basicTypes/IdInfo.hs)253
-rw-r--r--compiler/GHC/Types/Id/Info.hs-boot (renamed from compiler/basicTypes/IdInfo.hs-boot)6
-rw-r--r--compiler/GHC/Types/Id/Make.hs (renamed from compiler/basicTypes/MkId.hs)632
-rw-r--r--compiler/GHC/Types/Id/Make.hs-boot15
-rw-r--r--compiler/GHC/Types/Literal.hs (renamed from compiler/basicTypes/Literal.hs)339
-rw-r--r--compiler/GHC/Types/Name.hs (renamed from compiler/basicTypes/Name.hs)188
-rw-r--r--compiler/GHC/Types/Name.hs-boot5
-rw-r--r--compiler/GHC/Types/Name/Cache.hs (renamed from compiler/basicTypes/NameCache.hs)28
-rw-r--r--compiler/GHC/Types/Name/Env.hs (renamed from compiler/basicTypes/NameEnv.hs)63
-rw-r--r--compiler/GHC/Types/Name/Occurrence.hs (renamed from compiler/basicTypes/OccName.hs)104
-rw-r--r--compiler/GHC/Types/Name/Occurrence.hs-boot5
-rw-r--r--compiler/GHC/Types/Name/Reader.hs (renamed from compiler/basicTypes/RdrName.hs)173
-rw-r--r--compiler/GHC/Types/Name/Set.hs (renamed from compiler/basicTypes/NameSet.hs)36
-rw-r--r--compiler/GHC/Types/RepType.hs (renamed from compiler/simplStg/RepType.hs)201
-rw-r--r--compiler/GHC/Types/SrcLoc.hs (renamed from compiler/basicTypes/SrcLoc.hs)535
-rw-r--r--compiler/GHC/Types/Unique.hs (renamed from compiler/basicTypes/Unique.hs)67
-rw-r--r--compiler/GHC/Types/Unique/DFM.hs (renamed from compiler/utils/UniqDFM.hs)193
-rw-r--r--compiler/GHC/Types/Unique/DSet.hs (renamed from compiler/utils/UniqDSet.hs)39
-rw-r--r--compiler/GHC/Types/Unique/FM.hs (renamed from compiler/utils/UniqFM.hs)246
-rw-r--r--compiler/GHC/Types/Unique/Set.hs (renamed from compiler/utils/UniqSet.hs)47
-rw-r--r--compiler/GHC/Types/Unique/Supply.hs (renamed from compiler/basicTypes/UniqSupply.hs)248
-rw-r--r--compiler/GHC/Types/Var.hs (renamed from compiler/basicTypes/Var.hs)399
-rw-r--r--compiler/GHC/Types/Var.hs-boot13
-rw-r--r--compiler/GHC/Types/Var/Env.hs (renamed from compiler/basicTypes/VarEnv.hs)199
-rw-r--r--compiler/GHC/Types/Var/Set.hs (renamed from compiler/basicTypes/VarSet.hs)50
-rw-r--r--compiler/GHC/Unit.hs352
-rw-r--r--compiler/GHC/Unit/Info.hs176
-rw-r--r--compiler/GHC/Unit/Module.hs139
-rw-r--r--compiler/GHC/Unit/Module/Env.hs225
-rw-r--r--compiler/GHC/Unit/Module/Location.hs79
-rw-r--r--compiler/GHC/Unit/Module/Name.hs98
-rw-r--r--compiler/GHC/Unit/Module/Name.hs-boot6
-rw-r--r--compiler/GHC/Unit/Parser.hs63
-rw-r--r--compiler/GHC/Unit/Ppr.hs36
-rw-r--r--compiler/GHC/Unit/State.hs (renamed from compiler/main/Packages.hs)2021
-rw-r--r--compiler/GHC/Unit/State.hs-boot13
-rw-r--r--compiler/GHC/Unit/Types.hs703
-rw-r--r--compiler/GHC/Unit/Types.hs-boot18
-rw-r--r--compiler/GHC/Utils/Binary.hs (renamed from compiler/utils/Binary.hs)490
-rw-r--r--compiler/GHC/Utils/BufHandle.hs (renamed from compiler/utils/BufWrite.hs)12
-rw-r--r--compiler/GHC/Utils/CliOption.hs27
-rw-r--r--compiler/GHC/Utils/Encoding.hs (renamed from compiler/utils/Encoding.hs)180
-rw-r--r--compiler/GHC/Utils/Error.hs (renamed from compiler/main/ErrUtils.hs)533
-rw-r--r--compiler/GHC/Utils/Error.hs-boot50
-rw-r--r--compiler/GHC/Utils/Exception.hs28
-rw-r--r--compiler/GHC/Utils/FV.hs (renamed from compiler/utils/FV.hs)46
-rw-r--r--compiler/GHC/Utils/Fingerprint.hs (renamed from ghc-lib/stage0/compiler/build/Fingerprint.hs)9
-rw-r--r--compiler/GHC/Utils/IO/Unsafe.hs (renamed from compiler/utils/FastFunctions.hs)9
-rw-r--r--compiler/GHC/Utils/Json.hs (renamed from compiler/utils/Json.hs)6
-rw-r--r--compiler/GHC/Utils/Lexeme.hs (renamed from compiler/basicTypes/Lexeme.hs)14
-rw-r--r--compiler/GHC/Utils/Misc.hs (renamed from compiler/utils/Util.hs)253
-rw-r--r--compiler/GHC/Utils/Monad.hs228
-rw-r--r--compiler/GHC/Utils/Outputable.hs (renamed from compiler/utils/Outputable.hs)473
-rw-r--r--compiler/GHC/Utils/Outputable.hs-boot14
-rw-r--r--compiler/GHC/Utils/Panic.hs (renamed from compiler/utils/Panic.hs)35
-rw-r--r--compiler/GHC/Utils/Panic/Plain.hs (renamed from compiler/utils/PlainPanic.hs)29
-rw-r--r--compiler/GHC/Utils/Ppr.hs (renamed from compiler/utils/Pretty.hs)24
-rw-r--r--compiler/GHC/Utils/Ppr/Colour.hs (renamed from compiler/utils/PprColour.hs)6
-rw-r--r--compiler/GhclibHsVersions.h23
-rw-r--r--compiler/basicTypes/ConLike.hs-boot9
-rw-r--r--compiler/basicTypes/DataCon.hs-boot34
-rw-r--r--compiler/basicTypes/MkId.hs-boot15
-rw-r--r--compiler/basicTypes/Module.hs1303
-rw-r--r--compiler/basicTypes/Module.hs-boot14
-rw-r--r--compiler/basicTypes/Name.hs-boot5
-rw-r--r--compiler/basicTypes/OccName.hs-boot5
-rw-r--r--compiler/basicTypes/PatSyn.hs-boot13
-rw-r--r--compiler/cbits/cutils.c (renamed from compiler/parser/cutils.c)10
-rw-r--r--compiler/cbits/genSym.c2
-rw-r--r--compiler/coreSyn/CoreTidy.hs282
-rw-r--r--compiler/deSugar/PmExpr.hs466
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot51
-rw-r--r--compiler/hsSyn/HsExtension.hs1115
-rw-r--r--compiler/hsSyn/HsPat.hs-boot18
-rw-r--r--compiler/hsSyn/HsTypes.hs1584
-rw-r--r--compiler/hsSyn/PlaceHolder.hs70
-rw-r--r--compiler/iface/IfaceType.hs-boot15
-rw-r--r--compiler/iface/ToIface.hs-boot18
-rw-r--r--compiler/main/DynFlags.hs-boot20
-rw-r--r--compiler/main/ErrUtils.hs-boot26
-rw-r--r--compiler/main/Hooks.hs-boot7
-rw-r--r--compiler/main/PackageConfig.hs154
-rw-r--r--compiler/main/PackageConfig.hs-boot7
-rw-r--r--compiler/main/Packages.hs-boot11
-rw-r--r--compiler/main/PlatformConstants.hs17
-rw-r--r--compiler/main/SysTools/Terminal.hs153
-rw-r--r--compiler/nativeGen/NCG.h11
-rw-r--r--compiler/parser/Ctype.hs218
-rw-r--r--compiler/parser/HaddockUtils.hs34
-rw-r--r--compiler/parser/RdrHsSyn.hs2367
-rw-r--r--compiler/prelude/PrelNames.hs-boot7
-rw-r--r--compiler/prelude/PrimOp.hs-boot5
-rw-r--r--compiler/specialise/Rules.hs1280
-rw-r--r--compiler/typecheck/TcRnTypes.hs3934
-rw-r--r--compiler/typecheck/TcRnTypes.hs-boot6
-rw-r--r--compiler/types/Kind.hs97
-rw-r--r--compiler/types/TyCoRep.hs3938
-rw-r--r--compiler/types/TyCoRep.hs-boot29
-rw-r--r--compiler/types/Type.hs-boot26
-rw-r--r--compiler/utils/Exception.hs83
-rw-r--r--compiler/utils/MonadUtils.hs207
-rw-r--r--compiler/utils/OrdList.hs133
-rw-r--r--compiler/utils/Outputable.hs-boot11
-rw-r--r--compiler/utils/Platform.hs162
-rw-r--r--compiler/utils/md5.h18
-rw-r--r--ghc-lib-parser.cabal418
-rw-r--r--ghc-lib/generated/GHCConstantsHaskellExports.hs125
-rw-r--r--ghc-lib/generated/GHCConstantsHaskellType.hs134
-rw-r--r--ghc-lib/generated/GHCConstantsHaskellWrappers.hs250
-rw-r--r--ghc-lib/stage0/compiler/build/Config.hs66
-rw-r--r--ghc-lib/stage0/compiler/build/GHC/Parser.hs (renamed from ghc-lib/stage0/compiler/build/Parser.hs)10802
-rw-r--r--ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs (renamed from ghc-lib/stage0/compiler/build/Lexer.hs)1727
-rw-r--r--ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs135
-rw-r--r--ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs28
-rw-r--r--ghc-lib/stage0/compiler/build/ghc_boot_platform.h34
-rw-r--r--ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl9
-rw-r--r--ghc-lib/stage0/compiler/build/primop-code-size.hs-incl4
-rw-r--r--ghc-lib/stage0/compiler/build/primop-commutable.hs-incl16
-rw-r--r--ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl78
-rw-r--r--ghc-lib/stage0/compiler/build/primop-docs.hs-incl878
-rw-r--r--ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl8
-rw-r--r--ghc-lib/stage0/compiler/build/primop-list.hs-incl78
-rw-r--r--ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl6
-rw-r--r--ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl102
-rw-r--r--ghc-lib/stage0/compiler/build/primop-strictness.hs-incl32
-rw-r--r--ghc-lib/stage0/compiler/build/primop-tag.hs-incl2390
-rw-r--r--ghc-lib/stage0/lib/DerivedConstants.h (renamed from ghc-lib/generated/DerivedConstants.h)37
-rw-r--r--ghc-lib/stage0/lib/ghcautoconf.h (renamed from ghc-lib/generated/ghcautoconf.h)27
-rw-r--r--ghc-lib/stage0/lib/ghcplatform.h (renamed from ghc-lib/generated/ghcplatform.h)12
-rw-r--r--ghc-lib/stage0/lib/ghcversion.h (renamed from ghc-lib/generated/ghcversion.h)12
-rw-r--r--ghc-lib/stage0/lib/llvm-passes2
-rw-r--r--ghc-lib/stage0/lib/llvm-targets43
-rw-r--r--ghc-lib/stage0/lib/platformConstants261
-rw-r--r--ghc-lib/stage0/lib/settings85
-rw-r--r--ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs21
-rw-r--r--includes/CodeGen.Platform.hs222
-rw-r--r--includes/MachDeps.h12
-rw-r--r--includes/stg/MachRegs.h89
-rw-r--r--libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs16
-rw-r--r--libraries/ghc-boot-th/GHC/Lexeme.hs2
-rw-r--r--libraries/ghc-boot/GHC/BaseDir.hs77
-rw-r--r--libraries/ghc-boot/GHC/PackageDb.hs577
-rw-r--r--libraries/ghc-boot/GHC/Platform/ArchOS.hs155
-rw-r--r--libraries/ghc-boot/GHC/UniqueSubdir.hs22
-rw-r--r--libraries/ghc-boot/GHC/Unit/Database.hs703
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap.hs25
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/Closures.hs56
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc8
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc6
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc8
-rw-r--r--libraries/ghci/GHCi/BreakArray.hs8
-rw-r--r--libraries/ghci/GHCi/FFI.hsc30
-rw-r--r--libraries/ghci/GHCi/Message.hs36
-rw-r--r--libraries/ghci/GHCi/RemoteTypes.hs6
-rw-r--r--libraries/ghci/GHCi/TH/Binary.hs11
-rw-r--r--libraries/template-haskell/Language/Haskell/TH.hs10
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/LanguageExtensions.hs1
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib.hs140
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs772
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs1
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs114
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/PprLib.hs8
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs762
336 files changed, 67057 insertions, 44779 deletions
diff --git a/compiler/prelude/PrelNames.hs b/compiler/GHC/Builtin/Names.hs
index 21892f5..293c92d 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -1,7 +1,7 @@
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-\section[PrelNames]{Definitions of prelude modules and names}
+\section[GHC.Builtin.Names]{Definitions of prelude modules and names}
Nota Bene: all Names defined in here should come from the base package
@@ -63,9 +63,9 @@ This is accomplished through a combination of mechanisms:
2. The knownKeyNames (which consist of the basicKnownKeyNames from
the module, and those names reachable via the wired-in stuff from
- TysWiredIn) are used to initialise the "OrigNameCache" in
- IfaceEnv. This initialization ensures that when the type checker
- or renamer (both of which use IfaceEnv) look up an original name
+ GHC.Builtin.Types) are used to initialise the "OrigNameCache" in
+ GHC.Iface.Env. This initialization ensures that when the type checker
+ or renamer (both of which use GHC.Iface.Env) look up an original name
(i.e. a pair of a Module and an OccName) for a known-key name
they get the correct Unique.
@@ -95,22 +95,26 @@ things,
looked up in the orig-name cache)
b) The known infinite families of names are specially serialised by
- BinIface.putName, with that special treatment detected when we read back to
- ensure that we get back to the correct uniques. See Note [Symbol table
- representation of names] in BinIface and Note [How tuples work] in
- TysWiredIn.
+ GHC.Iface.Binary.putName, with that special treatment detected when we read
+ back to ensure that we get back to the correct uniques. See Note [Symbol
+ table representation of names] in GHC.Iface.Binary and Note [How tuples
+ work] in GHC.Builtin.Types.
Most of the infinite families cannot occur in source code, so mechanisms (a) and (b)
suffice to ensure that they always have the right Unique. In particular,
implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned
by the user. For those things that *can* appear in source programs,
- c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax
+ c) GHC.Iface.Env.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax
directly onto the corresponding name, rather than trying to find it in the
original-name cache.
See also Note [Built-in syntax and the OrigNameCache]
+Note that one-tuples are an exception to the rule, as they do get assigned
+known keys. See
+Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)
+in GHC.Builtin.Types.
Note [The integer library]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -139,33 +143,37 @@ 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 units] in GHC.Unit.Module. This is done in
+GHC.Unit.State.findWiredInUnits.
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-module PrelNames (
- Unique, Uniquable(..), hasKey, -- Re-exported for convenience
+module GHC.Builtin.Names
+ ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience
- -----------------------------------------------------------
- module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName
- -- (b) Uniques e.g. intTyConKey
- -- (c) Groups of classes and types
- -- (d) miscellaneous things
- -- So many that we export them all
- ) where
+ -----------------------------------------------------------
+ module GHC.Builtin.Names, -- A huge bunch of (a) Names, e.g. intTyConName
+ -- (b) Uniques e.g. intTyConKey
+ -- (c) Groups of classes and types
+ -- (d) miscellaneous things
+ -- So many that we export them all
+ )
+where
#include "GhclibHsVersions.h"
-import GhcPrelude
+import GHC.Prelude
-import Module
-import OccName
-import RdrName
-import Unique
-import Name
-import SrcLoc
-import FastString
+import GHC.Unit.Types
+import GHC.Unit.Module.Name
+import GHC.Types.Name.Occurrence
+import GHC.Types.Name.Reader
+import GHC.Types.Unique
+import GHC.Types.Name
+import GHC.Types.SrcLoc
+import GHC.Data.FastString
{-
************************************************************************
@@ -209,7 +217,7 @@ isUnboundName name = name `hasKey` unboundKey
This section tells what the compiler knows about the association of
names with uniques. These ones are the *non* wired-in ones. The
-wired in ones are defined in TysWiredIn etc.
+wired in ones are defined in GHC.Builtin.Types etc.
-}
basicKnownKeyNames :: [Name] -- See Note [Known-key names]
@@ -339,8 +347,9 @@ basicKnownKeyNames
groupWithName,
-- Strings and lists
- unpackCStringName,
- unpackCStringFoldrName, unpackCStringUtf8Name,
+ unpackCStringName, unpackCStringUtf8Name,
+ unpackCStringFoldrName, unpackCStringFoldrUtf8Name,
+ cstringLengthName,
-- Overloaded lists
isListClassName,
@@ -360,36 +369,62 @@ basicKnownKeyNames
-- Others
otherwiseIdName, inlineIdName,
eqStringName, assertName, breakpointName, breakpointCondName,
- breakpointAutoName, opaqueTyConName,
+ opaqueTyConName,
assertErrorName, traceName,
printName, fstName, sndName,
dollarName,
- -- Integer
- integerTyConName, mkIntegerName,
- integerToWord64Name, integerToInt64Name,
- word64ToIntegerName, int64ToIntegerName,
- plusIntegerName, timesIntegerName, smallIntegerName,
- wordToIntegerName,
- integerToWordName, integerToIntName, minusIntegerName,
- negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
- absIntegerName, signumIntegerName,
- leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
- compareIntegerName, quotRemIntegerName, divModIntegerName,
- quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
- floatFromIntegerName, doubleFromIntegerName,
- encodeFloatIntegerName, encodeDoubleIntegerName,
- decodeDoubleIntegerName,
- gcdIntegerName, lcmIntegerName,
- andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
- shiftLIntegerName, shiftRIntegerName, bitIntegerName,
- integerSDataConName,naturalSDataConName,
-
- -- Natural
- naturalTyConName,
- naturalFromIntegerName, naturalToIntegerName,
- plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName,
- wordToNaturalName,
+ -- ghc-bignum
+ integerFromNaturalName,
+ integerToNaturalClampName,
+ integerToWordName,
+ integerToIntName,
+ integerToWord64Name,
+ integerToInt64Name,
+ integerFromWordName,
+ integerFromWord64Name,
+ integerFromInt64Name,
+ integerAddName,
+ integerMulName,
+ integerSubName,
+ integerNegateName,
+ integerEqPrimName,
+ integerNePrimName,
+ integerLePrimName,
+ integerGtPrimName,
+ integerLtPrimName,
+ integerGePrimName,
+ integerAbsName,
+ integerSignumName,
+ integerCompareName,
+ integerQuotName,
+ integerRemName,
+ integerDivName,
+ integerModName,
+ integerDivModName,
+ integerQuotRemName,
+ integerToFloatName,
+ integerToDoubleName,
+ integerEncodeFloatName,
+ integerEncodeDoubleName,
+ integerDecodeDoubleName,
+ integerGcdName,
+ integerLcmName,
+ integerAndName,
+ integerOrName,
+ integerXorName,
+ integerComplementName,
+ integerBitName,
+ integerShiftLName,
+ integerShiftRName,
+ naturalToWordName,
+ naturalAddName,
+ naturalSubName,
+ naturalMulName,
+ naturalQuotName,
+ naturalRemName,
+ naturalQuotRemName,
+ bignatFromWordListName,
-- Float/Double
rationalToFloatName,
@@ -458,6 +493,11 @@ basicKnownKeyNames
, typeErrorVAppendDataConName
, typeErrorShowTypeDataConName
+ -- Unsafe coercion proofs
+ , unsafeEqualityProofName
+ , unsafeEqualityTyConName
+ , unsafeReflDataConName
+ , unsafeCoercePrimName
]
genericTyConNames :: [Name]
@@ -493,22 +533,26 @@ genericTyConNames = [
pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
-gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
+gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,
+ gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
- gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
- gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
+ gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,
+ gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT,
+ gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_LIST, dATA_STRING,
dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_CONC, gHC_IO, gHC_IO_Exception,
- gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
+ gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY,
- dATA_COERCE, dEBUG_TRACE :: Module
+ dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
+gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic")
+gHC_PRIM_EXCEPTION = mkPrimModule (fsLit "GHC.Prim.Exception")
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
@@ -523,12 +567,14 @@ gHC_SHOW = mkBaseModule (fsLit "GHC.Show")
gHC_READ = mkBaseModule (fsLit "GHC.Read")
gHC_NUM = mkBaseModule (fsLit "GHC.Num")
gHC_MAYBE = mkBaseModule (fsLit "GHC.Maybe")
-gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")
-gHC_NATURAL = mkBaseModule (fsLit "GHC.Natural")
+gHC_NUM_INTEGER = mkBignumModule (fsLit "GHC.Num.Integer")
+gHC_NUM_NATURAL = mkBignumModule (fsLit "GHC.Num.Natural")
+gHC_NUM_BIGNAT = mkBignumModule (fsLit "GHC.Num.BigNat")
gHC_LIST = mkBaseModule (fsLit "GHC.List")
gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple")
dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple")
dATA_EITHER = mkBaseModule (fsLit "Data.Either")
+dATA_LIST = mkBaseModule (fsLit "Data.List")
dATA_STRING = mkBaseModule (fsLit "Data.String")
dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable")
dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
@@ -536,7 +582,7 @@ gHC_CONC = mkBaseModule (fsLit "GHC.Conc")
gHC_IO = mkBaseModule (fsLit "GHC.IO")
gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")
gHC_ST = mkBaseModule (fsLit "GHC.ST")
-gHC_ARR = mkBaseModule (fsLit "GHC.Arr")
+gHC_IX = mkBaseModule (fsLit "GHC.Ix")
gHC_STABLE = mkBaseModule (fsLit "GHC.Stable")
gHC_PTR = mkBaseModule (fsLit "GHC.Ptr")
gHC_ERR = mkBaseModule (fsLit "GHC.Err")
@@ -568,6 +614,7 @@ gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats")
dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality")
dATA_COERCE = mkBaseModule (fsLit "Data.Coerce")
dEBUG_TRACE = mkBaseModule (fsLit "Debug.Trace")
+uNSAFE_COERCE = mkBaseModule (fsLit "Unsafe.Coerce")
gHC_SRCLOC :: Module
gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")
@@ -597,7 +644,7 @@ rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
mkInteractiveModule :: Int -> Module
-- (mkInteractiveMoudule 9) makes module 'interactive:M9'
-mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n))
+mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n))
pRELUDE_NAME, mAIN_NAME :: ModuleName
pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude")
@@ -608,28 +655,28 @@ dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel")
dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim")
mkPrimModule :: FastString -> Module
-mkPrimModule m = mkModule primUnitId (mkModuleNameFS m)
+mkPrimModule m = mkModule primUnit (mkModuleNameFS m)
-mkIntegerModule :: FastString -> Module
-mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m)
+mkBignumModule :: FastString -> Module
+mkBignumModule m = mkModule bignumUnit (mkModuleNameFS m)
mkBaseModule :: FastString -> Module
-mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m)
+mkBaseModule m = mkBaseModule_ (mkModuleNameFS m)
mkBaseModule_ :: ModuleName -> Module
-mkBaseModule_ m = mkModule baseUnitId m
+mkBaseModule_ m = mkModule baseUnit m
mkThisGhcModule :: FastString -> Module
-mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m)
+mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m)
mkThisGhcModule_ :: ModuleName -> Module
-mkThisGhcModule_ m = mkModule thisGhcUnitId m
+mkThisGhcModule_ m = mkModule thisGhcUnit m
mkMainModule :: FastString -> Module
-mkMainModule m = mkModule mainUnitId (mkModuleNameFS m)
+mkMainModule m = mkModule mainUnit (mkModuleNameFS m)
mkMainModule_ :: ModuleName -> Module
-mkMainModule_ m = mkModule mainUnitId m
+mkMainModule_ m = mkModule mainUnit m
{-
************************************************************************
@@ -690,20 +737,21 @@ enumFromTo_RDR = nameRdrName enumFromToName
enumFromThen_RDR = nameRdrName enumFromThenName
enumFromThenTo_RDR = nameRdrName enumFromThenToName
-ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR :: RdrName
+ratioDataCon_RDR, integerAdd_RDR, integerMul_RDR :: RdrName
ratioDataCon_RDR = nameRdrName ratioDataConName
-plusInteger_RDR = nameRdrName plusIntegerName
-timesInteger_RDR = nameRdrName timesIntegerName
+integerAdd_RDR = nameRdrName integerAddName
+integerMul_RDR = nameRdrName integerMulName
ioDataCon_RDR :: RdrName
ioDataCon_RDR = nameRdrName ioDataConName
eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR,
- unpackCStringUtf8_RDR :: RdrName
+ unpackCStringFoldrUtf8_RDR, unpackCStringUtf8_RDR :: RdrName
eqString_RDR = nameRdrName eqStringName
unpackCString_RDR = nameRdrName unpackCStringName
unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName
unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name
+unpackCStringFoldrUtf8_RDR = nameRdrName unpackCStringFoldrUtf8Name
newStablePtr_RDR :: RdrName
newStablePtr_RDR = nameRdrName newStablePtrName
@@ -724,8 +772,7 @@ toInteger_RDR = nameRdrName toIntegerName
toRational_RDR = nameRdrName toRationalName
fromIntegral_RDR = nameRdrName fromIntegralName
-stringTy_RDR, fromString_RDR :: RdrName
-stringTy_RDR = tcQual_RDR gHC_BASE (fsLit "String")
+fromString_RDR :: RdrName
fromString_RDR = nameRdrName fromStringName
fromList_RDR, fromListN_RDR, toList_RDR :: RdrName
@@ -746,11 +793,11 @@ succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ")
pred_RDR = varQual_RDR gHC_ENUM (fsLit "pred")
minBound_RDR = varQual_RDR gHC_ENUM (fsLit "minBound")
maxBound_RDR = varQual_RDR gHC_ENUM (fsLit "maxBound")
-range_RDR = varQual_RDR gHC_ARR (fsLit "range")
-inRange_RDR = varQual_RDR gHC_ARR (fsLit "inRange")
-index_RDR = varQual_RDR gHC_ARR (fsLit "index")
-unsafeIndex_RDR = varQual_RDR gHC_ARR (fsLit "unsafeIndex")
-unsafeRangeSize_RDR = varQual_RDR gHC_ARR (fsLit "unsafeRangeSize")
+range_RDR = varQual_RDR gHC_IX (fsLit "range")
+inRange_RDR = varQual_RDR gHC_IX (fsLit "inRange")
+index_RDR = varQual_RDR gHC_IX (fsLit "index")
+unsafeIndex_RDR = varQual_RDR gHC_IX (fsLit "unsafeIndex")
+unsafeRangeSize_RDR = varQual_RDR gHC_IX (fsLit "unsafeRangeSize")
readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR,
readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName
@@ -790,9 +837,6 @@ showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace")
showCommaSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showCommaSpace")
showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen")
-undefined_RDR :: RdrName
-undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
-
error_RDR :: RdrName
error_RDR = varQual_RDR gHC_ERR (fsLit "error")
@@ -996,11 +1040,14 @@ modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey
-- Base strings Strings
unpackCStringName, unpackCStringFoldrName,
- unpackCStringUtf8Name, eqStringName :: Name
+ unpackCStringUtf8Name, unpackCStringFoldrUtf8Name,
+ eqStringName, cstringLengthName :: Name
unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
+cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey
eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey
+unpackCStringFoldrUtf8Name = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey
-- The 'inline' function
inlineIdName :: Name
@@ -1074,7 +1121,7 @@ groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
-- Random PrelBase functions
fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
mapName, appendName, assertName,
- breakpointName, breakpointCondName, breakpointAutoName,
+ breakpointName, breakpointCondName,
opaqueTyConName, dollarName :: Name
dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey
otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey
@@ -1086,29 +1133,9 @@ appendName = varQual gHC_BASE (fsLit "++") appendIdKey
assertName = varQual gHC_BASE (fsLit "assert") assertIdKey
breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey
breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey
-breakpointAutoName= varQual gHC_BASE (fsLit "breakpointAuto") breakpointAutoIdKey
opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey
fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey
-breakpointJumpName :: Name
-breakpointJumpName
- = mkInternalName
- breakpointJumpIdKey
- (mkOccNameFS varName (fsLit "breakpointJump"))
- noSrcSpan
-breakpointCondJumpName :: Name
-breakpointCondJumpName
- = mkInternalName
- breakpointCondJumpIdKey
- (mkOccNameFS varName (fsLit "breakpointCondJump"))
- noSrcSpan
-breakpointAutoJumpName :: Name
-breakpointAutoJumpName
- = mkInternalName
- breakpointAutoJumpIdKey
- (mkOccNameFS varName (fsLit "breakpointAutoJump"))
- noSrcSpan
-
-- PrelTup
fstName, sndName :: Name
fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey
@@ -1121,84 +1148,125 @@ fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey
minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey
negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey
-integerTyConName, mkIntegerName, integerSDataConName,
- integerToWord64Name, integerToInt64Name,
- word64ToIntegerName, int64ToIntegerName,
- plusIntegerName, timesIntegerName, smallIntegerName,
- wordToIntegerName,
- integerToWordName, integerToIntName, minusIntegerName,
- negateIntegerName, eqIntegerPrimName, neqIntegerPrimName,
- absIntegerName, signumIntegerName,
- leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName,
- compareIntegerName, quotRemIntegerName, divModIntegerName,
- quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
- floatFromIntegerName, doubleFromIntegerName,
- encodeFloatIntegerName, encodeDoubleIntegerName,
- decodeDoubleIntegerName,
- gcdIntegerName, lcmIntegerName,
- andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
- shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name
-integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey
-integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit "S#") integerSDataConKey
-mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey
-integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey
-integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey
-word64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger") word64ToIntegerIdKey
-int64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger") int64ToIntegerIdKey
-plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey
-timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey
-smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey
-wordToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "wordToInteger") wordToIntegerIdKey
-integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") integerToWordIdKey
-integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey
-minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey
-negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey
-eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey
-neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey
-absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey
-signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey
-leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey
-gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey
-ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey
-geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey
-compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey
-quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey
-divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey
-quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey
-remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey
-divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey
-modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey
-floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey
-doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey
-encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey
-encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey
-decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey
-gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey
-lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey
-andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey
-orIntegerName = varQual gHC_INTEGER_TYPE (fsLit "orInteger") orIntegerIdKey
-xorIntegerName = varQual gHC_INTEGER_TYPE (fsLit "xorInteger") xorIntegerIdKey
-complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey
-shiftLIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger") shiftLIntegerIdKey
-shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shiftRIntegerIdKey
-bitIntegerName = varQual gHC_INTEGER_TYPE (fsLit "bitInteger") bitIntegerIdKey
-
--- GHC.Natural types
-naturalTyConName, naturalSDataConName :: Name
-naturalTyConName = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey
-naturalSDataConName = dcQual gHC_NATURAL (fsLit "NatS#") naturalSDataConKey
-
-naturalFromIntegerName :: Name
-naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey
-
-naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName,
- mkNaturalName, wordToNaturalName :: Name
-naturalToIntegerName = varQual gHC_NATURAL (fsLit "naturalToInteger") naturalToIntegerIdKey
-plusNaturalName = varQual gHC_NATURAL (fsLit "plusNatural") plusNaturalIdKey
-minusNaturalName = varQual gHC_NATURAL (fsLit "minusNatural") minusNaturalIdKey
-timesNaturalName = varQual gHC_NATURAL (fsLit "timesNatural") timesNaturalIdKey
-mkNaturalName = varQual gHC_NATURAL (fsLit "mkNatural") mkNaturalIdKey
-wordToNaturalName = varQual gHC_NATURAL (fsLit "wordToNatural#") wordToNaturalIdKey
+---------------------------------
+-- ghc-bignum
+---------------------------------
+integerFromNaturalName
+ , integerToNaturalClampName
+ , integerToWordName
+ , integerToIntName
+ , integerToWord64Name
+ , integerToInt64Name
+ , integerFromWordName
+ , integerFromWord64Name
+ , integerFromInt64Name
+ , integerAddName
+ , integerMulName
+ , integerSubName
+ , integerNegateName
+ , integerEqPrimName
+ , integerNePrimName
+ , integerLePrimName
+ , integerGtPrimName
+ , integerLtPrimName
+ , integerGePrimName
+ , integerAbsName
+ , integerSignumName
+ , integerCompareName
+ , integerQuotName
+ , integerRemName
+ , integerDivName
+ , integerModName
+ , integerDivModName
+ , integerQuotRemName
+ , integerToFloatName
+ , integerToDoubleName
+ , integerEncodeFloatName
+ , integerEncodeDoubleName
+ , integerDecodeDoubleName
+ , integerGcdName
+ , integerLcmName
+ , integerAndName
+ , integerOrName
+ , integerXorName
+ , integerComplementName
+ , integerBitName
+ , integerShiftLName
+ , integerShiftRName
+ , naturalToWordName
+ , naturalAddName
+ , naturalSubName
+ , naturalMulName
+ , naturalQuotName
+ , naturalRemName
+ , naturalQuotRemName
+ , bignatFromWordListName
+ :: Name
+
+bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name
+bnbVarQual str key = varQual gHC_NUM_BIGNAT (fsLit str) key
+bnnVarQual str key = varQual gHC_NUM_NATURAL (fsLit str) key
+bniVarQual str key = varQual gHC_NUM_INTEGER (fsLit str) key
+
+-- Types and DataCons
+bignatFromWordListName = bnbVarQual "bigNatFromWordList#" bignatFromWordListIdKey
+
+naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey
+naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey
+naturalSubName = bnnVarQual "naturalSubUnsafe" naturalSubIdKey
+naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey
+naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey
+naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey
+naturalQuotRemName = bnnVarQual "naturalQuotRem" naturalQuotRemIdKey
+
+integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey
+integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey
+integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey
+integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey
+integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey
+integerToInt64Name = bniVarQual "integerToInt64#" integerToInt64IdKey
+integerFromWordName = bniVarQual "integerFromWord#" integerFromWordIdKey
+integerFromWord64Name = bniVarQual "integerFromWord64#" integerFromWord64IdKey
+integerFromInt64Name = bniVarQual "integerFromInt64#" integerFromInt64IdKey
+integerAddName = bniVarQual "integerAdd" integerAddIdKey
+integerMulName = bniVarQual "integerMul" integerMulIdKey
+integerSubName = bniVarQual "integerSub" integerSubIdKey
+integerNegateName = bniVarQual "integerNegate" integerNegateIdKey
+integerEqPrimName = bniVarQual "integerEq#" integerEqPrimIdKey
+integerNePrimName = bniVarQual "integerNe#" integerNePrimIdKey
+integerLePrimName = bniVarQual "integerLe#" integerLePrimIdKey
+integerGtPrimName = bniVarQual "integerGt#" integerGtPrimIdKey
+integerLtPrimName = bniVarQual "integerLt#" integerLtPrimIdKey
+integerGePrimName = bniVarQual "integerGe#" integerGePrimIdKey
+integerAbsName = bniVarQual "integerAbs" integerAbsIdKey
+integerSignumName = bniVarQual "integerSignum" integerSignumIdKey
+integerCompareName = bniVarQual "integerCompare" integerCompareIdKey
+integerQuotName = bniVarQual "integerQuot" integerQuotIdKey
+integerRemName = bniVarQual "integerRem" integerRemIdKey
+integerDivName = bniVarQual "integerDiv" integerDivIdKey
+integerModName = bniVarQual "integerMod" integerModIdKey
+integerDivModName = bniVarQual "integerDivMod#" integerDivModIdKey
+integerQuotRemName = bniVarQual "integerQuotRem#" integerQuotRemIdKey
+integerToFloatName = bniVarQual "integerToFloat#" integerToFloatIdKey
+integerToDoubleName = bniVarQual "integerToDouble#" integerToDoubleIdKey
+integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey
+integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey
+integerDecodeDoubleName = bniVarQual "integerDecodeDouble#" integerDecodeDoubleIdKey
+integerGcdName = bniVarQual "integerGcd" integerGcdIdKey
+integerLcmName = bniVarQual "integerLcm" integerLcmIdKey
+integerAndName = bniVarQual "integerAnd" integerAndIdKey
+integerOrName = bniVarQual "integerOr" integerOrIdKey
+integerXorName = bniVarQual "integerXor" integerXorIdKey
+integerComplementName = bniVarQual "integerComplement" integerComplementIdKey
+integerBitName = bniVarQual "integerBit#" integerBitIdKey
+integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey
+integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey
+
+
+
+---------------------------------
+-- End of ghc-bignum
+---------------------------------
-- GHC.Real types and classes
rationalTyConName, ratioTyConName, ratioDataConName, realClassName,
@@ -1230,7 +1298,7 @@ rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDo
-- Class Ix
ixClassName :: Name
-ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
+ixClassName = clsQual gHC_IX (fsLit "Ix") ixClassKey
-- Typeable representation types
trModuleTyConName
@@ -1301,7 +1369,7 @@ mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrF
typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey
typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey
-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types)
--- See Note [Grand plan for Typeable] in TcTypeable.
+-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable.
trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey
-- Typeable KindReps for some common cases
@@ -1333,7 +1401,13 @@ typeErrorVAppendDataConName =
typeErrorShowTypeDataConName =
dcQual gHC_TYPELITS (fsLit "ShowType") typeErrorShowTypeDataConKey
-
+-- Unsafe coercion proofs
+unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,
+ unsafeReflDataConName :: Name
+unsafeEqualityProofName = varQual uNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey
+unsafeEqualityTyConName = tcQual uNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey
+unsafeReflDataConName = dcQual uNSAFE_COERCE (fsLit "UnsafeRefl") unsafeReflDataConKey
+unsafeCoercePrimName = varQual uNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey
-- Dynamic
toDynName :: Name
@@ -1505,7 +1579,7 @@ srcLocDataConName
-- plugins
pLUGINS :: Module
-pLUGINS = mkThisGhcModule (fsLit "Plugins")
+pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins")
pluginTyConName :: Name
pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey
frontendPluginTyConName :: Name
@@ -1592,17 +1666,8 @@ realFracClassKey = mkPreludeClassUnique 16
showClassKey = mkPreludeClassUnique 17
ixClassKey = mkPreludeClassUnique 18
-typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey,
- typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey
- :: Unique
+typeableClassKey :: Unique
typeableClassKey = mkPreludeClassUnique 20
-typeable1ClassKey = mkPreludeClassUnique 21
-typeable2ClassKey = mkPreludeClassUnique 22
-typeable3ClassKey = mkPreludeClassUnique 23
-typeable4ClassKey = mkPreludeClassUnique 24
-typeable5ClassKey = mkPreludeClassUnique 25
-typeable6ClassKey = mkPreludeClassUnique 26
-typeable7ClassKey = mkPreludeClassUnique 27
monadFixClassKey :: Unique
monadFixClassKey = mkPreludeClassUnique 28
@@ -1632,11 +1697,11 @@ datatypeClassKey = mkPreludeClassUnique 39
constructorClassKey = mkPreludeClassUnique 40
selectorClassKey = mkPreludeClassUnique 41
--- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in TcEvidence
+-- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence
knownNatClassNameKey :: Unique
knownNatClassNameKey = mkPreludeClassUnique 42
--- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in TcEvidence
+-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence
knownSymbolClassNameKey :: Unique
knownSymbolClassNameKey = mkPreludeClassUnique 43
@@ -1660,7 +1725,7 @@ hasFieldClassNameKey = mkPreludeClassUnique 49
---------------- Template Haskell -------------------
--- THNames.hs: USES ClassUniques 200-299
+-- GHC.Builtin.Names.TH: USES ClassUniques 200-299
-----------------------------------------------------
{-
@@ -1682,12 +1747,14 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey,
weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey,
mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey,
ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,
- stablePtrTyConKey, eqTyConKey, heqTyConKey,
- smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey :: Unique
+ stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey,
+ smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,
+ stringTyConKey :: Unique
addrPrimTyConKey = mkPreludeTyConUnique 1
arrayPrimTyConKey = mkPreludeTyConUnique 3
boolTyConKey = mkPreludeTyConUnique 4
byteArrayPrimTyConKey = mkPreludeTyConUnique 5
+stringTyConKey = mkPreludeTyConUnique 6
charPrimTyConKey = mkPreludeTyConUnique 7
charTyConKey = mkPreludeTyConUnique 8
doublePrimTyConKey = mkPreludeTyConUnique 9
@@ -1716,11 +1783,12 @@ mutableArrayPrimTyConKey = mkPreludeTyConUnique 30
mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31
orderingTyConKey = mkPreludeTyConUnique 32
mVarPrimTyConKey = mkPreludeTyConUnique 33
-ratioTyConKey = mkPreludeTyConUnique 34
-rationalTyConKey = mkPreludeTyConUnique 35
-realWorldTyConKey = mkPreludeTyConUnique 36
-stablePtrPrimTyConKey = mkPreludeTyConUnique 37
-stablePtrTyConKey = mkPreludeTyConUnique 38
+ioPortPrimTyConKey = mkPreludeTyConUnique 34
+ratioTyConKey = mkPreludeTyConUnique 35
+rationalTyConKey = mkPreludeTyConUnique 36
+realWorldTyConKey = mkPreludeTyConUnique 37
+stablePtrPrimTyConKey = mkPreludeTyConUnique 38
+stablePtrTyConKey = mkPreludeTyConUnique 39
eqTyConKey = mkPreludeTyConUnique 40
heqTyConKey = mkPreludeTyConUnique 41
arrayArrayPrimTyConKey = mkPreludeTyConUnique 42
@@ -1734,7 +1802,7 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
- eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey,
+ eqReprPrimTyConKey, eqPhantPrimTyConKey,
compactPrimTyConKey :: Unique
statePrimTyConKey = mkPreludeTyConUnique 50
stableNamePrimTyConKey = mkPreludeTyConUnique 51
@@ -1744,7 +1812,6 @@ eqReprPrimTyConKey = mkPreludeTyConUnique 54
eqPhantPrimTyConKey = mkPreludeTyConUnique 55
mutVarPrimTyConKey = mkPreludeTyConUnique 56
ioTyConKey = mkPreludeTyConUnique 57
-voidPrimTyConKey = mkPreludeTyConUnique 58
wordPrimTyConKey = mkPreludeTyConUnique 59
wordTyConKey = mkPreludeTyConUnique 60
word8PrimTyConKey = mkPreludeTyConUnique 61
@@ -1768,10 +1835,6 @@ funPtrTyConKey = mkPreludeTyConUnique 78
tVarPrimTyConKey = mkPreludeTyConUnique 79
compactPrimTyConKey = mkPreludeTyConUnique 80
--- dotnet interop
-objectTyConKey :: Unique
-objectTyConKey = mkPreludeTyConUnique 83
-
eitherTyConKey :: Unique
eitherTyConKey = mkPreludeTyConUnique 84
@@ -1905,8 +1968,22 @@ someTypeRepDataConKey = mkPreludeTyConUnique 189
typeSymbolAppendFamNameKey :: Unique
typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190
+-- Unsafe equality
+unsafeEqualityTyConKey :: Unique
+unsafeEqualityTyConKey = mkPreludeTyConUnique 191
+
+-- Linear types
+multiplicityTyConKey :: Unique
+multiplicityTyConKey = mkPreludeTyConUnique 192
+
+unrestrictedFunTyConKey :: Unique
+unrestrictedFunTyConKey = mkPreludeTyConUnique 193
+
+multMulTyConKey :: Unique
+multMulTyConKey = mkPreludeTyConUnique 194
+
---------------- Template Haskell -------------------
--- THNames.hs: USES TyConUniques 200-299
+-- GHC.Builtin.Names.TH: USES TyConUniques 200-299
-----------------------------------------------------
----------------------- SIMD ------------------------
@@ -1924,9 +2001,9 @@ typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190
-}
charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
- floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey,
+ floatDataConKey, intDataConKey, nilDataConKey,
ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
- word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey,
+ word8DataConKey, ioDataConKey, heqDataConKey,
coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique
charDataConKey = mkPreludeDataConUnique 1
@@ -1935,19 +2012,17 @@ doubleDataConKey = mkPreludeDataConUnique 3
falseDataConKey = mkPreludeDataConUnique 4
floatDataConKey = mkPreludeDataConUnique 5
intDataConKey = mkPreludeDataConUnique 6
-integerSDataConKey = mkPreludeDataConUnique 7
-nothingDataConKey = mkPreludeDataConUnique 8
-justDataConKey = mkPreludeDataConUnique 9
-eqDataConKey = mkPreludeDataConUnique 10
-nilDataConKey = mkPreludeDataConUnique 11
-ratioDataConKey = mkPreludeDataConUnique 12
-word8DataConKey = mkPreludeDataConUnique 13
-stableNameDataConKey = mkPreludeDataConUnique 14
-trueDataConKey = mkPreludeDataConUnique 15
-wordDataConKey = mkPreludeDataConUnique 16
-ioDataConKey = mkPreludeDataConUnique 17
-integerDataConKey = mkPreludeDataConUnique 18
-heqDataConKey = mkPreludeDataConUnique 19
+nothingDataConKey = mkPreludeDataConUnique 7
+justDataConKey = mkPreludeDataConUnique 8
+eqDataConKey = mkPreludeDataConUnique 9
+nilDataConKey = mkPreludeDataConUnique 10
+ratioDataConKey = mkPreludeDataConUnique 11
+word8DataConKey = mkPreludeDataConUnique 12
+stableNameDataConKey = mkPreludeDataConUnique 13
+trueDataConKey = mkPreludeDataConUnique 14
+wordDataConKey = mkPreludeDataConUnique 15
+ioDataConKey = mkPreludeDataConUnique 16
+heqDataConKey = mkPreludeDataConUnique 18
-- Generic data constructors
crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique
@@ -2036,47 +2111,66 @@ vecRepDataConKey = mkPreludeDataConUnique 71
tupleRepDataConKey = mkPreludeDataConUnique 72
sumRepDataConKey = mkPreludeDataConUnique 73
--- See Note [Wiring in RuntimeRep] in TysWiredIn
+-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types
runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique]
liftedRepDataConKey :: Unique
runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys)
- = map mkPreludeDataConUnique [74..86]
+ = map mkPreludeDataConUnique [74..88]
unliftedRepDataConKeys = vecRepDataConKey :
tupleRepDataConKey :
sumRepDataConKey :
unliftedSimpleRepDataConKeys
--- See Note [Wiring in RuntimeRep] in TysWiredIn
+-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types
-- VecCount
vecCountDataConKeys :: [Unique]
-vecCountDataConKeys = map mkPreludeDataConUnique [87..92]
+vecCountDataConKeys = map mkPreludeDataConUnique [89..94]
--- See Note [Wiring in RuntimeRep] in TysWiredIn
+-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types
-- VecElem
vecElemDataConKeys :: [Unique]
-vecElemDataConKeys = map mkPreludeDataConUnique [93..102]
+vecElemDataConKeys = map mkPreludeDataConUnique [95..104]
-- Typeable things
kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,
kindRepFunDataConKey, kindRepTYPEDataConKey,
kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey
:: Unique
-kindRepTyConAppDataConKey = mkPreludeDataConUnique 103
-kindRepVarDataConKey = mkPreludeDataConUnique 104
-kindRepAppDataConKey = mkPreludeDataConUnique 105
-kindRepFunDataConKey = mkPreludeDataConUnique 106
-kindRepTYPEDataConKey = mkPreludeDataConUnique 107
-kindRepTypeLitSDataConKey = mkPreludeDataConUnique 108
-kindRepTypeLitDDataConKey = mkPreludeDataConUnique 109
+kindRepTyConAppDataConKey = mkPreludeDataConUnique 105
+kindRepVarDataConKey = mkPreludeDataConUnique 106
+kindRepAppDataConKey = mkPreludeDataConUnique 107
+kindRepFunDataConKey = mkPreludeDataConUnique 108
+kindRepTYPEDataConKey = mkPreludeDataConUnique 109
+kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110
+kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111
typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique
-typeLitSymbolDataConKey = mkPreludeDataConUnique 110
-typeLitNatDataConKey = mkPreludeDataConUnique 111
+typeLitSymbolDataConKey = mkPreludeDataConUnique 112
+typeLitNatDataConKey = mkPreludeDataConUnique 113
+
+-- Unsafe equality
+unsafeReflDataConKey :: Unique
+unsafeReflDataConKey = mkPreludeDataConUnique 114
+
+-- Multiplicity
+
+oneDataConKey, manyDataConKey :: Unique
+oneDataConKey = mkPreludeDataConUnique 115
+manyDataConKey = mkPreludeDataConUnique 116
+
+-- ghc-bignum
+integerISDataConKey, integerINDataConKey, integerIPDataConKey,
+ naturalNSDataConKey, naturalNBDataConKey :: Unique
+integerISDataConKey = mkPreludeDataConUnique 120
+integerINDataConKey = mkPreludeDataConUnique 121
+integerIPDataConKey = mkPreludeDataConUnique 122
+naturalNSDataConKey = mkPreludeDataConUnique 123
+naturalNBDataConKey = mkPreludeDataConUnique 124
---------------- Template Haskell -------------------
--- THNames.hs: USES DataUniques 200-250
+-- GHC.Builtin.Names.TH: USES DataUniques 200-250
-----------------------------------------------------
@@ -2095,9 +2189,12 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
realWorldPrimIdKey, recConErrorIdKey,
unpackCStringUtf8IdKey, unpackCStringAppendIdKey,
- unpackCStringFoldrIdKey, unpackCStringIdKey,
+ unpackCStringFoldrIdKey, unpackCStringFoldrUtf8IdKey,
+ unpackCStringIdKey,
typeErrorIdKey, divIntIdKey, modIntIdKey,
- absentSumFieldErrorIdKey :: Unique
+ absentSumFieldErrorIdKey, cstringLengthIdKey,
+ raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey
+ :: Unique
wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders]
absentErrorIdKey = mkPreludeMiscIdUnique 1
@@ -2108,6 +2205,7 @@ errorIdKey = mkPreludeMiscIdUnique 5
foldrIdKey = mkPreludeMiscIdUnique 6
recSelErrorIdKey = mkPreludeMiscIdUnique 7
seqIdKey = mkPreludeMiscIdUnique 8
+absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9
eqStringIdKey = mkPreludeMiscIdUnique 10
noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12
@@ -2118,18 +2216,22 @@ recConErrorIdKey = mkPreludeMiscIdUnique 16
unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17
unpackCStringAppendIdKey = mkPreludeMiscIdUnique 18
unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19
+
unpackCStringIdKey = mkPreludeMiscIdUnique 20
-voidPrimIdKey = mkPreludeMiscIdUnique 21
-typeErrorIdKey = mkPreludeMiscIdUnique 22
-divIntIdKey = mkPreludeMiscIdUnique 23
-modIntIdKey = mkPreludeMiscIdUnique 24
-absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9
-
-unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,
- returnIOIdKey, newStablePtrIdKey,
+unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 21
+voidPrimIdKey = mkPreludeMiscIdUnique 22
+typeErrorIdKey = mkPreludeMiscIdUnique 23
+divIntIdKey = mkPreludeMiscIdUnique 24
+modIntIdKey = mkPreludeMiscIdUnique 25
+cstringLengthIdKey = mkPreludeMiscIdUnique 26
+raiseOverflowIdKey = mkPreludeMiscIdUnique 27
+raiseUnderflowIdKey = mkPreludeMiscIdUnique 28
+raiseDivZeroIdKey = mkPreludeMiscIdUnique 29
+
+concatIdKey, filterIdKey, zipIdKey,
+ bindIOIdKey, returnIOIdKey, newStablePtrIdKey,
printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey,
fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey :: Unique
-unsafeCoerceIdKey = mkPreludeMiscIdUnique 30
concatIdKey = mkPreludeMiscIdUnique 31
filterIdKey = mkPreludeMiscIdUnique 32
zipIdKey = mkPreludeMiscIdUnique 33
@@ -2145,63 +2247,6 @@ sndIdKey = mkPreludeMiscIdUnique 42
otherwiseIdKey = mkPreludeMiscIdUnique 43
assertIdKey = mkPreludeMiscIdUnique 44
-mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
- integerToWordIdKey, integerToIntIdKey,
- integerToWord64IdKey, integerToInt64IdKey,
- word64ToIntegerIdKey, int64ToIntegerIdKey,
- plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
- negateIntegerIdKey,
- eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey,
- leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey,
- compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
- quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey,
- floatFromIntegerIdKey, doubleFromIntegerIdKey,
- encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
- decodeDoubleIntegerIdKey,
- gcdIntegerIdKey, lcmIntegerIdKey,
- andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
- shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique
-mkIntegerIdKey = mkPreludeMiscIdUnique 60
-smallIntegerIdKey = mkPreludeMiscIdUnique 61
-integerToWordIdKey = mkPreludeMiscIdUnique 62
-integerToIntIdKey = mkPreludeMiscIdUnique 63
-integerToWord64IdKey = mkPreludeMiscIdUnique 64
-integerToInt64IdKey = mkPreludeMiscIdUnique 65
-plusIntegerIdKey = mkPreludeMiscIdUnique 66
-timesIntegerIdKey = mkPreludeMiscIdUnique 67
-minusIntegerIdKey = mkPreludeMiscIdUnique 68
-negateIntegerIdKey = mkPreludeMiscIdUnique 69
-eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70
-neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71
-absIntegerIdKey = mkPreludeMiscIdUnique 72
-signumIntegerIdKey = mkPreludeMiscIdUnique 73
-leIntegerPrimIdKey = mkPreludeMiscIdUnique 74
-gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75
-ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76
-geIntegerPrimIdKey = mkPreludeMiscIdUnique 77
-compareIntegerIdKey = mkPreludeMiscIdUnique 78
-quotIntegerIdKey = mkPreludeMiscIdUnique 79
-remIntegerIdKey = mkPreludeMiscIdUnique 80
-divIntegerIdKey = mkPreludeMiscIdUnique 81
-modIntegerIdKey = mkPreludeMiscIdUnique 82
-divModIntegerIdKey = mkPreludeMiscIdUnique 83
-quotRemIntegerIdKey = mkPreludeMiscIdUnique 84
-floatFromIntegerIdKey = mkPreludeMiscIdUnique 85
-doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86
-encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87
-encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88
-gcdIntegerIdKey = mkPreludeMiscIdUnique 89
-lcmIntegerIdKey = mkPreludeMiscIdUnique 90
-andIntegerIdKey = mkPreludeMiscIdUnique 91
-orIntegerIdKey = mkPreludeMiscIdUnique 92
-xorIntegerIdKey = mkPreludeMiscIdUnique 93
-complementIntegerIdKey = mkPreludeMiscIdUnique 94
-shiftLIntegerIdKey = mkPreludeMiscIdUnique 95
-shiftRIntegerIdKey = mkPreludeMiscIdUnique 96
-wordToIntegerIdKey = mkPreludeMiscIdUnique 97
-word64ToIntegerIdKey = mkPreludeMiscIdUnique 98
-int64ToIntegerIdKey = mkPreludeMiscIdUnique 99
-decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100
rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 101
@@ -2217,15 +2262,9 @@ runRWKey = mkPreludeMiscIdUnique 107
traceKey :: Unique
traceKey = mkPreludeMiscIdUnique 108
-breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
- breakpointJumpIdKey, breakpointCondJumpIdKey,
- breakpointAutoJumpIdKey :: Unique
+breakpointIdKey, breakpointCondIdKey :: Unique
breakpointIdKey = mkPreludeMiscIdUnique 110
breakpointCondIdKey = mkPreludeMiscIdUnique 111
-breakpointAutoIdKey = mkPreludeMiscIdUnique 112
-breakpointJumpIdKey = mkPreludeMiscIdUnique 113
-breakpointCondJumpIdKey = mkPreludeMiscIdUnique 114
-breakpointAutoJumpIdKey = mkPreludeMiscIdUnique 115
inlineIdKey, noinlineIdKey :: Unique
inlineIdKey = mkPreludeMiscIdUnique 120
@@ -2245,18 +2284,6 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique
rationalToFloatIdKey = mkPreludeMiscIdUnique 130
rationalToDoubleIdKey = mkPreludeMiscIdUnique 131
--- dotnet interop
-unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey,
- unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique
-unmarshalObjectIdKey = mkPreludeMiscIdUnique 150
-marshalObjectIdKey = mkPreludeMiscIdUnique 151
-marshalStringIdKey = mkPreludeMiscIdUnique 152
-unmarshalStringIdKey = mkPreludeMiscIdUnique 153
-checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154
-
-undefinedKey :: Unique
-undefinedKey = mkPreludeMiscIdUnique 155
-
magicDictKey :: Unique
magicDictKey = mkPreludeMiscIdUnique 156
@@ -2346,7 +2373,7 @@ proxyHashKey :: Unique
proxyHashKey = mkPreludeMiscIdUnique 502
---------------- Template Haskell -------------------
--- THNames.hs: USES IdUniques 200-499
+-- GHC.Builtin.Names.TH: USES IdUniques 200-499
-----------------------------------------------------
-- Used to make `Typeable` dictionaries
@@ -2416,18 +2443,120 @@ fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560
makeStaticKey :: Unique
makeStaticKey = mkPreludeMiscIdUnique 561
--- Natural
-naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey,
- minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey,
- naturalSDataConKey, wordToNaturalIdKey :: Unique
-naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562
-naturalToIntegerIdKey = mkPreludeMiscIdUnique 563
-plusNaturalIdKey = mkPreludeMiscIdUnique 564
-minusNaturalIdKey = mkPreludeMiscIdUnique 565
-timesNaturalIdKey = mkPreludeMiscIdUnique 566
-mkNaturalIdKey = mkPreludeMiscIdUnique 567
-naturalSDataConKey = mkPreludeMiscIdUnique 568
-wordToNaturalIdKey = mkPreludeMiscIdUnique 569
+-- Unsafe coercion proofs
+unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique
+unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570
+unsafeCoercePrimIdKey = mkPreludeMiscIdUnique 571
+
+
+------------------------------------------------------
+-- ghc-bignum uses 600-699 uniques
+------------------------------------------------------
+
+integerFromNaturalIdKey
+ , integerToNaturalClampIdKey
+ , integerToWordIdKey
+ , integerToIntIdKey
+ , integerToWord64IdKey
+ , integerToInt64IdKey
+ , integerAddIdKey
+ , integerMulIdKey
+ , integerSubIdKey
+ , integerNegateIdKey
+ , integerEqPrimIdKey
+ , integerNePrimIdKey
+ , integerLePrimIdKey
+ , integerGtPrimIdKey
+ , integerLtPrimIdKey
+ , integerGePrimIdKey
+ , integerAbsIdKey
+ , integerSignumIdKey
+ , integerCompareIdKey
+ , integerQuotIdKey
+ , integerRemIdKey
+ , integerDivIdKey
+ , integerModIdKey
+ , integerDivModIdKey
+ , integerQuotRemIdKey
+ , integerToFloatIdKey
+ , integerToDoubleIdKey
+ , integerEncodeFloatIdKey
+ , integerEncodeDoubleIdKey
+ , integerGcdIdKey
+ , integerLcmIdKey
+ , integerAndIdKey
+ , integerOrIdKey
+ , integerXorIdKey
+ , integerComplementIdKey
+ , integerBitIdKey
+ , integerShiftLIdKey
+ , integerShiftRIdKey
+ , integerFromWordIdKey
+ , integerFromWord64IdKey
+ , integerFromInt64IdKey
+ , integerDecodeDoubleIdKey
+ , naturalToWordIdKey
+ , naturalAddIdKey
+ , naturalSubIdKey
+ , naturalMulIdKey
+ , naturalQuotIdKey
+ , naturalRemIdKey
+ , naturalQuotRemIdKey
+ , bignatFromWordListIdKey
+ :: Unique
+
+integerFromNaturalIdKey = mkPreludeMiscIdUnique 600
+integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601
+integerToWordIdKey = mkPreludeMiscIdUnique 602
+integerToIntIdKey = mkPreludeMiscIdUnique 603
+integerToWord64IdKey = mkPreludeMiscIdUnique 604
+integerToInt64IdKey = mkPreludeMiscIdUnique 605
+integerAddIdKey = mkPreludeMiscIdUnique 606
+integerMulIdKey = mkPreludeMiscIdUnique 607
+integerSubIdKey = mkPreludeMiscIdUnique 608
+integerNegateIdKey = mkPreludeMiscIdUnique 609
+integerEqPrimIdKey = mkPreludeMiscIdUnique 610
+integerNePrimIdKey = mkPreludeMiscIdUnique 611
+integerLePrimIdKey = mkPreludeMiscIdUnique 612
+integerGtPrimIdKey = mkPreludeMiscIdUnique 613
+integerLtPrimIdKey = mkPreludeMiscIdUnique 614
+integerGePrimIdKey = mkPreludeMiscIdUnique 615
+integerAbsIdKey = mkPreludeMiscIdUnique 616
+integerSignumIdKey = mkPreludeMiscIdUnique 617
+integerCompareIdKey = mkPreludeMiscIdUnique 618
+integerQuotIdKey = mkPreludeMiscIdUnique 619
+integerRemIdKey = mkPreludeMiscIdUnique 620
+integerDivIdKey = mkPreludeMiscIdUnique 621
+integerModIdKey = mkPreludeMiscIdUnique 622
+integerDivModIdKey = mkPreludeMiscIdUnique 623
+integerQuotRemIdKey = mkPreludeMiscIdUnique 624
+integerToFloatIdKey = mkPreludeMiscIdUnique 625
+integerToDoubleIdKey = mkPreludeMiscIdUnique 626
+integerEncodeFloatIdKey = mkPreludeMiscIdUnique 627
+integerEncodeDoubleIdKey = mkPreludeMiscIdUnique 628
+integerGcdIdKey = mkPreludeMiscIdUnique 629
+integerLcmIdKey = mkPreludeMiscIdUnique 630
+integerAndIdKey = mkPreludeMiscIdUnique 631
+integerOrIdKey = mkPreludeMiscIdUnique 632
+integerXorIdKey = mkPreludeMiscIdUnique 633
+integerComplementIdKey = mkPreludeMiscIdUnique 634
+integerBitIdKey = mkPreludeMiscIdUnique 635
+integerShiftLIdKey = mkPreludeMiscIdUnique 636
+integerShiftRIdKey = mkPreludeMiscIdUnique 637
+integerFromWordIdKey = mkPreludeMiscIdUnique 638
+integerFromWord64IdKey = mkPreludeMiscIdUnique 639
+integerFromInt64IdKey = mkPreludeMiscIdUnique 640
+integerDecodeDoubleIdKey = mkPreludeMiscIdUnique 641
+
+naturalToWordIdKey = mkPreludeMiscIdUnique 650
+naturalAddIdKey = mkPreludeMiscIdUnique 651
+naturalSubIdKey = mkPreludeMiscIdUnique 652
+naturalMulIdKey = mkPreludeMiscIdUnique 653
+naturalQuotIdKey = mkPreludeMiscIdUnique 654
+naturalRemIdKey = mkPreludeMiscIdUnique 655
+naturalQuotRemIdKey = mkPreludeMiscIdUnique 656
+
+bignatFromWordListIdKey = mkPreludeMiscIdUnique 670
{-
************************************************************************
@@ -2472,7 +2601,7 @@ standardClassKeys = derivableClassKeys ++ numericClassKeys
{-
@derivableClassKeys@ is also used in checking \tr{deriving} constructs
-(@TcDeriv@).
+(@GHC.Tc.Deriv@).
-}
derivableClassKeys :: [Unique]
diff --git a/compiler/prelude/PrimOp.hs b/compiler/GHC/Builtin/PrimOps.hs
index 6168dc7..b2501b7 100644
--- a/compiler/prelude/PrimOp.hs
+++ b/compiler/GHC/Builtin/PrimOps.hs
@@ -6,12 +6,9 @@
{-# LANGUAGE CPP #-}
--- The default is a bit too low for the quite large primOpInfo definition
-{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
-
-module PrimOp (
+module GHC.Builtin.PrimOps (
PrimOp(..), PrimOpVecCat(..), allThePrimOps,
- primOpType, primOpSig,
+ primOpType, primOpSig, primOpResultType,
primOpTag, maxPrimOpTag, primOpOcc,
primOpWrapperId,
@@ -19,7 +16,7 @@ module PrimOp (
primOpOutOfLine, primOpCodeSize,
primOpOkForSpeculation, primOpOkForSideEffects,
- primOpIsCheap, primOpFixity,
+ primOpIsCheap, primOpFixity, primOpDocs,
getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..),
@@ -28,28 +25,28 @@ module PrimOp (
#include "GhclibHsVersions.h"
-import GhcPrelude
-
-import TysPrim
-import TysWiredIn
-
-import CmmType
-import Demand
-import Id ( Id, mkVanillaGlobalWithInfo )
-import IdInfo ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) )
-import Name
-import PrelNames ( gHC_PRIMOPWRAPPERS )
-import TyCon ( TyCon, isPrimTyCon, PrimRep(..) )
-import Type
-import RepType ( typePrimRep1, tyConPrimRep1 )
-import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..),
- SourceText(..) )
-import SrcLoc ( wiredInSrcSpan )
-import ForeignCall ( CLabelString )
-import Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique )
-import Outputable
-import FastString
-import Module ( UnitId )
+import GHC.Prelude
+
+import GHC.Builtin.Types.Prim
+import GHC.Builtin.Types
+
+import GHC.Cmm.Type
+import GHC.Types.Demand
+import GHC.Types.Id ( Id, mkVanillaGlobalWithInfo )
+import GHC.Types.Id.Info ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) )
+import GHC.Types.Name
+import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS )
+import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) )
+import GHC.Core.Type
+import GHC.Types.RepType ( typePrimRep1, tyConPrimRep1 )
+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.Unit ( Unit )
+import GHC.Utils.Outputable
+import GHC.Data.FastString
{-
************************************************************************
@@ -167,6 +164,19 @@ primOpFixity :: PrimOp -> Maybe Fixity
{-
************************************************************************
* *
+\subsubsection{Docs}
+* *
+************************************************************************
+
+See Note [GHC.Prim Docs]
+-}
+
+primOpDocs :: [(String, String)]
+#include "primop-docs.hs-incl"
+
+{-
+************************************************************************
+* *
\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}
* *
************************************************************************
@@ -326,7 +336,7 @@ Note [Checking versus non-checking primops]
It is important that a non-checking primop never be transformed in a way that
would cause it to bottom. Doing so would violate Core's let/app invariant
- (see Note [CoreSyn let/app invariant] in CoreSyn) which is critical to
+ (see Note [Core let/app invariant] in GHC.Core) which is critical to
the simplifier's ability to float without fear of changing program meaning.
@@ -349,7 +359,7 @@ data dependencies of the state token to enforce write-effect ordering
* NB1: if you inline unsafePerformIO, you may end up with
side-effecting ops whose 'state' output is discarded.
- And programmers may do that by hand; see Trac #9390.
+ And programmers may do that by hand; see #9390.
That is why we (conservatively) do not discard write-effecting
primops even if both their state and result is discarded.
@@ -366,7 +376,7 @@ data dependencies of the state token to enforce write-effect ordering
---------- can_fail ----------------------------
A primop "can_fail" if it can fail with an *unchecked* exception on
some elements of its input domain. Main examples:
- division (fails on zero demoninator)
+ division (fails on zero denominator)
array indexing (fails if the index is out of bounds)
An "unchecked exception" is one that is an outright error, (not
@@ -393,13 +403,13 @@ Duplicate YES NO
Arguably you should be able to discard this, since the
returned stat token is not used, but that relies on NEVER
inlining unsafePerformIO, and programmers sometimes write
- this kind of stuff by hand (Trac #9390). So we (conservatively)
+ this kind of stuff by hand (#9390). So we (conservatively)
never discard a has_side_effects primop.
However, it's fine to discard a can_fail primop. For example
case (indexIntArray# a i) of _ -> True
We can discard indexIntArray#; it has can_fail, but not
- has_side_effects; see Trac #5658 which was all about this.
+ has_side_effects; see #5658 which was all about this.
Notice that indexIntArray# is (in a more general handling of
effects) read effect, but we don't care about that here, and
treat read effects as *not* has_side_effects.
@@ -443,21 +453,21 @@ Duplicate YES NO
just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get
something like this
p = case readMutVar# s v of
- (# s', r #) -> (S# s', r)
+ (# s', r #) -> (State# s', r)
s' = case p of (s', r) -> s'
r = case p of (s', r) -> r
(All these bindings are boxed.) If we inline p at its two call
sites, we get a catastrophe: because the read is performed once when
s' is demanded, and once when 'r' is demanded, which may be much
- later. Utterly wrong. Trac #3207 is real example of this happening.
+ later. Utterly wrong. #3207 is real example of this happening.
However, it's fine to duplicate a can_fail primop. That is really
the only difference between can_fail and has_side_effects.
Note [Implementation: how can_fail/has_side_effects affect transformations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-How do we ensure that that floating/duplication/discarding are done right
+How do we ensure that floating/duplication/discarding are done right
in the simplifier?
Two main predicates on primpops test these flags:
@@ -486,7 +496,7 @@ primOpCanFail :: PrimOp -> Bool
primOpOkForSpeculation :: PrimOp -> Bool
-- See Note [PrimOp can_fail and has_side_effects]
- -- See comments with CoreUtils.exprOkForSpeculation
+ -- See comments with GHC.Core.Utils.exprOkForSpeculation
-- primOpOkForSpeculation => primOpOkForSideEffects
primOpOkForSpeculation op
= primOpOkForSideEffects op
@@ -501,7 +511,8 @@ primOpOkForSideEffects op
{-
Note [primOpIsCheap]
~~~~~~~~~~~~~~~~~~~~
-@primOpIsCheap@, as used in \tr{SimplUtils.hs}. For now (HACK
+
+@primOpIsCheap@, as used in GHC.Core.Opt.Simplify.Utils. For now (HACK
WARNING), we just borrow some other predicates for a
what-should-be-good-enough test. "Cheap" means willing to call it more
than once, and/or push it inside a lambda. The latter could change the
@@ -538,7 +549,7 @@ primOpIsCheap op = primOpOkForSpeculation op
primOpCodeSize
~~~~~~~~~~~~~~
Gives an indication of the code size of a primop, for the purposes of
-calculating unfolding sizes; see CoreUnfold.sizeExpr.
+calculating unfolding sizes; see GHC.Core.Unfold.sizeExpr.
-}
primOpCodeSize :: PrimOp -> Int
@@ -546,7 +557,7 @@ primOpCodeSize :: PrimOp -> Int
primOpCodeSizeDefault :: Int
primOpCodeSizeDefault = 1
- -- CoreUnfold.primOpSize already takes into account primOpOutOfLine
+ -- GHC.Core.Unfold.primOpSize already takes into account primOpOutOfLine
-- and adds some further costs for the args in that case.
primOpCodeSizeForeignCall :: Int
@@ -568,7 +579,15 @@ primOpType op
Compare _occ ty -> compare_fun_ty ty
GenPrimOp _occ tyvars arg_tys res_ty ->
- mkSpecForAllTys tyvars (mkFunTys arg_tys res_ty)
+ mkSpecForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)
+
+primOpResultType :: PrimOp -> Type
+primOpResultType op
+ = case primOpInfo op of
+ Dyadic _occ ty -> ty
+ Monadic _occ ty -> ty
+ Compare _occ _ty -> intPrimTy
+ GenPrimOp _occ _tyvars _arg_tys res_ty -> res_ty
primOpOcc :: PrimOp -> OccName
primOpOcc op = case primOpInfo op of
@@ -579,33 +598,85 @@ primOpOcc op = case primOpInfo op of
{- Note [Primop wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~
-Previously hasNoBinding would claim that PrimOpIds didn't have a curried
-function definition. This caused quite some trouble as we would be forced to
-eta expand unsaturated primop applications very late in the Core pipeline. Not
-only would this produce unnecessary thunks, but it would also result in nasty
-inconsistencies in CAFfy-ness determinations (see #16846 and
-Note [CAFfyness inconsistencies due to late eta expansion] in TidyPgm).
-
-However, it was quite unnecessary for hasNoBinding to claim this; primops in
-fact *do* have curried definitions which are found in GHC.PrimopWrappers, which
-is auto-generated by utils/genprimops from prelude/primops.txt.pp. These wrappers
-are standard Haskell functions mirroring the types of the primops they wrap.
-For instance, in the case of plusInt# we would have:
+
+To support (limited) use of primops in GHCi genprimopcode generates the
+GHC.PrimopWrappers module. This module contains a "primop wrapper"
+binding for each primop. These are standard Haskell functions mirroring the
+types of the primops they wrap. For instance, in the case of plusInt# we would
+have:
module GHC.PrimopWrappers where
import GHC.Prim as P
+
+ plusInt# :: Int# -> Int# -> Int#
plusInt# a b = P.plusInt# a b
-We now take advantage of these curried definitions by letting hasNoBinding
-claim that PrimOpIds have a curried definition and then rewrite any unsaturated
-PrimOpId applications that we find during CoreToStg as applications of the
-associated wrapper (e.g. `GHC.Prim.plusInt# 3#` will get rewritten to
-`GHC.PrimopWrappers.plusInt# 3#`).` The Id of the wrapper for a primop can be
-found using 'PrimOp.primOpWrapperId'.
+The Id for the wrapper of a primop can be found using
+'GHC.Builtin.PrimOp.primOpWrapperId'. However, GHCi does not use this mechanism
+to link primops; it rather does a rather hacky symbol lookup (see
+GHC.ByteCode.Linker.primopToCLabel). TODO: Perhaps this should be changed?
+
+Note that these wrappers aren't *quite*
+as expressive as their unwrapped breathern in that they may exhibit less levity
+polymorphism. For instance, consider the case of mkWeakNoFinalizer# which has
+type:
+
+ mkWeakNoFinalizer# :: forall (r :: RuntimeRep) (k :: TYPE r) (v :: Type).
+ k -> v
+ -> State# RealWorld
+ -> (# State# RealWorld, Weak# v #)
+
+Naively we could generate a wrapper of the form,
+
+
+ mkWeakNoFinalizer# k v s = GHC.Prim.mkWeakNoFinalizer# k v s
+
+However, this would require that 'k' bind the levity-polymorphic key,
+which is disallowed by our levity polymorphism validity checks (see Note
+[Levity polymorphism invariants] in GHC.Core). Consequently, we give the
+wrapper the simpler, less polymorphic type
+
+ mkWeakNoFinalizer# :: forall (k :: Type) (v :: Type).
+ k -> v
+ -> State# RealWorld
+ -> (# State# RealWorld, Weak# v #)
+
+This simplification tends to be good enough for GHCi uses given that there are
+few levity polymorphic primops and we do little simplification on interpreted
+code anyways.
+
+TODO: This behavior is actually wrong; a program becomes ill-typed upon
+replacing a real primop occurrence with one of its wrapper due to the fact that
+the former has an additional type binder. Hmmm....
+
+Note [Eta expanding primops]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+STG requires that primop applications be saturated. This makes code generation
+significantly simpler since otherwise we would need to define a calling
+convention for curried applications that can accomodate levity polymorphism.
+
+To ensure saturation, CorePrep eta expands expand all primop applications as
+described in Note [Eta expansion of hasNoBinding things in CorePrep] in
+GHC.Core.Prep.
+
+Historical Note:
+
+For a short period around GHC 8.8 we rewrote unsaturated primop applications to
+rather use the primop's wrapper (see Note [Primop wrappers] in
+GHC.Builtin.PrimOps) instead of eta expansion. This was because at the time
+CoreTidy would try to predict the CAFfyness of bindings that would be produced
+by CorePrep for inclusion in interface files. Eta expanding during CorePrep
+proved to be very difficult to predict, leading to nasty inconsistencies in
+CAFfyness determinations (see #16846).
-Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's
-used by GHCi, which does not implement primops direct at all.
+Thankfully, we now no longer try to predict CAFfyness but rather compute it on
+GHC STG (see Note [SRTs] in GHC.Cmm.Info.Build) and inject it into the interface
+file after code generation (see TODO: Refer to whatever falls out of #18096).
+This is much simpler and avoids the potential for inconsistency, allowing us to
+return to the somewhat simpler eta expansion approach for unsaturated primops.
+See #18079.
-}
-- | Returns the 'Id' of the wrapper associated with the given 'PrimOp'.
@@ -676,9 +747,9 @@ commutableOp :: PrimOp -> Bool
-- Utils:
dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type
-dyadic_fun_ty ty = mkFunTys [ty, ty] ty
-monadic_fun_ty ty = mkFunTy ty ty
-compare_fun_ty ty = mkFunTys [ty, ty] intPrimTy
+dyadic_fun_ty ty = mkVisFunTysMany [ty, ty] ty
+monadic_fun_ty ty = mkVisFunTyMany ty ty
+compare_fun_ty ty = mkVisFunTysMany [ty, ty] intPrimTy
-- Output stuff:
@@ -693,7 +764,7 @@ pprPrimOp other_op = pprOccName (primOpOcc other_op)
************************************************************************
-}
-data PrimCall = PrimCall CLabelString UnitId
+data PrimCall = PrimCall CLabelString Unit
instance Outputable PrimCall where
ppr (PrimCall lbl pkgId)
diff --git a/compiler/GHC/Builtin/PrimOps.hs-boot b/compiler/GHC/Builtin/PrimOps.hs-boot
new file mode 100644
index 0000000..506e8bc
--- /dev/null
+++ b/compiler/GHC/Builtin/PrimOps.hs-boot
@@ -0,0 +1,5 @@
+module GHC.Builtin.PrimOps where
+
+import GHC.Prelude ()
+
+data PrimOp
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/GHC/Builtin/Types.hs
index 620fd30..1955757 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -1,22 +1,22 @@
{-
(c) The GRASP Project, Glasgow University, 1994-1998
-\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types}
+Wired-in knowledge about {\em non-primitive} types
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
-- | This module is about types that can be defined in Haskell, but which
--- must be wired into the compiler nonetheless. C.f module TysPrim
-module TysWiredIn (
+-- must be wired into the compiler nonetheless. C.f module "GHC.Builtin.Types.Prim"
+module GHC.Builtin.Types (
-- * Helper functions defined here
- mkWiredInTyConName, -- This is used in TcTypeNats to define the
+ mkWiredInTyConName, -- This is used in GHC.Builtin.Types.Literals to define the
-- built-in functions for evaluation.
- mkWiredInIdName, -- used in MkId
-
- mkFunKind, mkForAllKind,
+ mkWiredInIdName, -- used in GHC.Types.Id.Make
-- * All wired in things
wiredInTyCons, isBuiltInOcc_maybe,
@@ -39,7 +39,7 @@ module TysWiredIn (
-- * Char
charTyCon, charDataCon, charTyCon_RDR,
- charTy, stringTy, charTyConName,
+ charTy, stringTy, charTyConName, stringTyCon_RDR,
-- * Double
doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,
@@ -70,11 +70,12 @@ module TysWiredIn (
justDataCon, justDataConName, promotedJustDataCon,
-- * Tuples
- mkTupleTy, mkBoxedTupleTy,
- tupleTyCon, tupleDataCon, tupleTyConName,
+ mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,
+ tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,
promotedTupleDataCon,
unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,
pairTyCon,
+ unboxedUnitTy,
unboxedUnitTyCon, unboxedUnitDataCon,
unboxedTupleKind, unboxedSumKind,
@@ -86,13 +87,17 @@ module TysWiredIn (
-- * Any
anyTyCon, anyTy, anyTypeOfKind,
+ -- * Recovery TyCon
+ makeRecoveryTyCon,
+
-- * Sums
mkSumTy, sumTyCon, sumDataCon,
-- * Kinds
typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
- isLiftedTypeKindTyConName, liftedTypeKind, constraintKind,
- liftedTypeKindTyCon, constraintKindTyCon,
+ isLiftedTypeKindTyConName, liftedTypeKind,
+ typeToTypeKind, constraintKind,
+ liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName,
liftedTypeKindTyConName,
-- * Equality predicates
@@ -107,9 +112,11 @@ module TysWiredIn (
vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,
- liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy,
- int16RepDataConTy, word16RepDataConTy,
- wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy,
+ liftedRepDataConTy, unliftedRepDataConTy,
+ intRepDataConTy,
+ int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,
+ wordRepDataConTy,
+ word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,
addrRepDataConTy,
floatRepDataConTy, doubleRepDataConTy,
@@ -119,47 +126,64 @@ module TysWiredIn (
int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,
word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,
- doubleElemRepDataConTy
+
+ doubleElemRepDataConTy,
+
+ -- * Multiplicity and friends
+ multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy,
+ multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy,
+ oneDataConTyCon, manyDataConTyCon,
+ multMulTyCon,
+
+ unrestrictedFunTyCon, unrestrictedFunTyConName,
+
+ -- * Bignum
+ integerTy, integerTyCon, integerTyConName,
+ integerISDataCon, integerISDataConName,
+ integerIPDataCon, integerIPDataConName,
+ integerINDataCon, integerINDataConName,
+ naturalTy, naturalTyCon, naturalTyConName,
+ naturalNSDataCon, naturalNSDataConName,
+ naturalNBDataCon, naturalNBDataConName
) where
#include "GhclibHsVersions.h"
-#include "MachDeps.h"
-import GhcPrelude
+import GHC.Prelude
-import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId )
+import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId )
-- friends:
-import PrelNames
-import TysPrim
-import {-# SOURCE #-} KnownUniques
+import GHC.Builtin.Names
+import GHC.Builtin.Types.Prim
+import {-# SOURCE #-} GHC.Builtin.Uniques
-- others:
-import CoAxiom
-import Id
-import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
-import Module ( Module )
-import Type
-import RepType
-import DataCon
-import {-# SOURCE #-} ConLike
-import TyCon
-import Class ( Class, mkClass )
-import RdrName
-import Name
-import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )
-import NameSet ( NameSet, mkNameSet, elemNameSet )
-import BasicTypes ( Arity, Boxity(..), TupleSort(..), ConTagZ,
- SourceText(..) )
-import ForeignCall
-import SrcLoc ( noSrcSpan )
-import Unique
+import GHC.Core.Coercion.Axiom
+import GHC.Types.Id
+import GHC.Types.Var (VarBndr (Bndr))
+import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
+import GHC.Unit.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 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
-import Util
-import BooleanFormula ( mkAnd )
+import GHC.Data.FastString
+import GHC.Utils.Outputable
+import GHC.Utils.Misc
+import GHC.Data.BooleanFormula ( mkAnd )
import qualified Data.ByteString.Char8 as BS
@@ -181,6 +205,8 @@ kept in sync with each other. The rule is this: use the order as declared
in GHC.Types. All places where such lists exist should contain a reference
to this Note, so a search for this Note's name should find all the lists.
+See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType.
+
************************************************************************
* *
\subsection{Wired in type constructors}
@@ -188,10 +214,10 @@ to this Note, so a search for this Note's name should find all the lists.
************************************************************************
If you change which things are wired in, make sure you change their
-names in PrelNames, so they use wTcQual, wDataQual, etc
+names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc
-}
--- This list is used only to define PrelInfo.wiredInThings. That in turn
+-- This list is used only to define GHC.Builtin.Utils.wiredInThings. That in turn
-- is used to initialise the name environment carried around by the renamer.
-- This means that if we look up the name of a TyCon (or its implicit binders)
-- that occurs in this list that name will be assigned the wired-in key we
@@ -206,7 +232,7 @@ names in PrelNames, so they use wTcQual, wDataQual, etc
-- See also Note [Known-key names]
wiredInTyCons :: [TyCon]
-wiredInTyCons = [ -- Units are not treated like other tuples, because then
+wiredInTyCons = [ -- Units are not treated like other tuples, because they
-- are defined in GHC.Base, and there's only a few of them. We
-- put them in wiredInTyCons so that they will pre-populate
-- the name cache, so the parser in isBuiltInOcc_maybe doesn't
@@ -216,6 +242,7 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because then
, anyTyCon
, boolTyCon
, charTyCon
+ , stringTyCon
, doubleTyCon
, floatTyCon
, intTyCon
@@ -234,6 +261,9 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because then
, vecElemTyCon
, constraintKindTyCon
, liftedTypeKindTyCon
+ , multiplicityTyCon
+ , naturalTyCon
+ , integerTyCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -259,6 +289,27 @@ eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConK
eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon
eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId
+{- Note [eqTyCon (~) is built-in syntax]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The (~) type operator used in equality constraints (a~b) is considered built-in
+syntax. This has a few consequences:
+
+* The user is not allowed to define their own type constructors with this name:
+
+ ghci> class a ~ b
+ <interactive>:1:1: error: Illegal binding of built-in syntax: ~
+
+* Writing (a ~ b) does not require enabling -XTypeOperators. It does, however,
+ require -XGADTs or -XTypeFamilies.
+
+* The (~) type operator is always in scope. It doesn't need to be imported,
+ and it cannot be hidden.
+
+* We have a bunch of special cases in the compiler to arrange all of the above.
+
+There's no particular reason for (~) to be special, but fixing this would be a
+breaking change.
+-}
eqTyCon_RDR :: RdrName
eqTyCon_RDR = nameRdrName eqTyConName
@@ -275,11 +326,12 @@ coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercib
coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon
coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId
-charTyConName, charDataConName, intTyConName, intDataConName :: Name
-charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon
-charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon
-intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon
-intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon
+charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name
+charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon
+charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon
+stringTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "String") stringTyConKey stringTyCon
+intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon
+intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon
boolTyConName, falseDataConName, trueDataConName :: Name
boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon
@@ -353,7 +405,7 @@ It has these properties:
* If (Any k) is the type of a value, it must be a /lifted/ value. So
if we have (Any @(TYPE rr)) then rr must be 'LiftedRep. See
- Note [TYPE and RuntimeRep] in TysPrim. This is a convenient
+ Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. This is a convenient
invariant, and makes isUnliftedTyCon well-defined; otherwise what
would (isUnliftedTyCon Any) be?
@@ -399,6 +451,29 @@ anyTy = mkTyConTy anyTyCon
anyTypeOfKind :: Kind -> Type
anyTypeOfKind kind = mkTyConApp anyTyCon [kind]
+-- | Make a fake, recovery 'TyCon' from an existing one.
+-- Used when recovering from errors in type declarations
+makeRecoveryTyCon :: TyCon -> TyCon
+makeRecoveryTyCon tc
+ = mkTcTyCon (tyConName tc)
+ bndrs res_kind
+ noTcTyConScopedTyVars
+ True -- Fully generalised
+ flavour -- Keep old flavour
+ where
+ flavour = tyConFlavour tc
+ [kv] = mkTemplateKindVars [liftedTypeKind]
+ (bndrs, res_kind)
+ = case flavour of
+ PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv)
+ _ -> (tyConBinders tc, tyConResKind tc)
+ -- For data types we have already validated their kind, so it
+ -- makes sense to keep it. For promoted data constructors we haven't,
+ -- so we recover with kind (forall k. k). Otherwise consider
+ -- data T a where { MkT :: Show a => T a }
+ -- If T is for some reason invalid, we don't want to fall over
+ -- at (promoted) use-sites of MkT.
+
-- Kinds
typeNatKindConName, typeSymbolKindConName :: Name
typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat") typeNatKindConNameKey typeNatKindCon
@@ -410,6 +485,20 @@ constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constr
liftedTypeKindTyConName :: Name
liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon
+multiplicityTyConName :: Name
+multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")
+ multiplicityTyConKey multiplicityTyCon
+
+oneDataConName, manyDataConName :: Name
+oneDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon
+manyDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon
+ -- It feels wrong to have One and Many be BuiltInSyntax. But otherwise,
+ -- `Many`, in particular, is considered out of scope unless an appropriate
+ -- file is open. The problem with this is that `Many` appears implicitly in
+ -- types every time there is an `(->)`, hence out-of-scope errors get
+ -- reported. Making them built-in make it so that they are always considered in
+ -- scope.
+
runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name
runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon
vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon
@@ -420,19 +509,13 @@ sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") s
runtimeRepSimpleDataConNames :: [Name]
runtimeRepSimpleDataConNames
= zipWith3Lazy mk_special_dc_name
- [ fsLit "LiftedRep"
- , fsLit "UnliftedRep"
+ [ fsLit "LiftedRep", fsLit "UnliftedRep"
, fsLit "IntRep"
+ , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep"
, fsLit "WordRep"
- , fsLit "Int8Rep"
- , fsLit "Int16Rep"
- , fsLit "Int64Rep"
- , fsLit "Word8Rep"
- , fsLit "Word16Rep"
- , fsLit "Word64Rep"
+ , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep"
, fsLit "AddrRep"
- , fsLit "FloatRep"
- , fsLit "DoubleRep"
+ , fsLit "FloatRep", fsLit "DoubleRep"
]
runtimeRepSimpleDataConKeys
runtimeRepSimpleDataCons
@@ -464,13 +547,14 @@ vecElemDataConNames = zipWith3Lazy mk_special_dc_name
mk_special_dc_name :: FastString -> Unique -> DataCon -> Name
mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc
-boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
+boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR,
intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName
boolTyCon_RDR = nameRdrName boolTyConName
false_RDR = nameRdrName falseDataConName
true_RDR = nameRdrName trueDataConName
intTyCon_RDR = nameRdrName intTyConName
charTyCon_RDR = nameRdrName charTyConName
+stringTyCon_RDR = nameRdrName stringTyConName
intDataCon_RDR = nameRdrName intDataConName
listTyCon_RDR = nameRdrName listTyConName
consDataCon_RDR = nameRdrName consDataConName
@@ -488,7 +572,7 @@ consDataCon_RDR = nameRdrName consDataConName
pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon name cType tyvars cons
= mkAlgTyCon name
- (mkAnonTyConBinders tyvars)
+ (mkAnonTyConBinders VisArg tyvars)
liftedTypeKind
(map (const Representational) tyvars)
cType
@@ -498,16 +582,20 @@ pcTyCon name cType tyvars cons
False -- Not in GADT syntax
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
-pcDataCon n univs = pcDataConWithFixity False n univs
+pcDataCon n univs tys = pcDataConW n univs (map linear tys)
+
+pcDataConW :: Name -> [TyVar] -> [Scaled Type] -> TyCon -> DataCon
+pcDataConW n univs tys = pcDataConWithFixity False n univs
[] -- no ex_tvs
univs -- the univs are precisely the user-written tyvars
+ tys
pcDataConWithFixity :: Bool -- ^ declared infix?
-> Name -- ^ datacon name
-> [TyVar] -- ^ univ tyvars
-> [TyCoVar] -- ^ ex tycovars
-> [TyCoVar] -- ^ user-written tycovars
- -> [Type] -- ^ args
+ -> [Scaled Type] -- ^ args
-> TyCon
-> DataCon
pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n))
@@ -521,9 +609,16 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (n
pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo
-> [TyVar] -> [TyCoVar] -> [TyCoVar]
- -> [Type] -> TyCon -> DataCon
+ -> [Scaled Type] -> TyCon -> DataCon
-- The Name should be in the DataName name space; it's the name
-- of the DataCon itself.
+--
+-- IMPORTANT NOTE:
+-- if you try to wire-in a /GADT/ data constructor you will
+-- find it hard (we did). You will need wrapper and worker
+-- Names, a DataConBoxer, DataConRep, EqSpec, etc.
+-- Try hard not to wire-in GADT data types. You will live
+-- to regret doing so (we do).
pcDataConWithFixity' declared_infix dc_name wrk_key rri
tyvars ex_tyvars user_tyvars arg_tys tycon
@@ -540,7 +635,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri
(map (const no_bang) arg_tys)
[] -- No labelled fields
tyvars ex_tyvars
- (mkTyCoVarBinders Specified user_tyvars)
+ (mkTyVarBinders SpecifiedSpec user_tyvars)
[] -- No equality spec
[] -- No theta
arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
@@ -572,7 +667,7 @@ mkDataConWorkerName data_con wrk_key =
pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon
pcSpecialDataCon dc_name arg_tys tycon rri
= pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri
- [] [] [] arg_tys tycon
+ [] [] [] (map linear arg_tys) tycon
{-
************************************************************************
@@ -593,20 +688,14 @@ typeNatKind = mkTyConTy typeNatKindCon
typeSymbolKind = mkTyConTy typeSymbolKindCon
constraintKindTyCon :: TyCon
+-- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon!
constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
-liftedTypeKind, constraintKind :: Kind
+liftedTypeKind, typeToTypeKind, constraintKind :: Kind
liftedTypeKind = tYPE liftedRepTy
+typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind
constraintKind = mkTyConApp constraintKindTyCon []
--- mkFunKind and mkForAllKind are defined here
--- solely so that TyCon can use them via a SOURCE import
-mkFunKind :: Kind -> Kind -> Kind
-mkFunKind = mkFunTy
-
-mkForAllKind :: TyCoVar -> ArgFlag -> Kind -> Kind
-mkForAllKind = mkForAllTy
-
{-
************************************************************************
* *
@@ -614,7 +703,7 @@ mkForAllKind = mkForAllTy
* *
************************************************************************
-Note [How tuples work] See also Note [Known-key names] in PrelNames
+Note [How tuples work] See also Note [Known-key names] in GHC.Builtin.Names
~~~~~~~~~~~~~~~~~~~~~~
* There are three families of tuple TyCons and corresponding
DataCons, expressed by the type BasicTypes.TupleSort:
@@ -640,7 +729,7 @@ Note [How tuples work] See also Note [Known-key names] in PrelNames
- Given constraints: the superclasses automatically become available
- Wanted constraints: there is a built-in instance
instance (c1,c2) => (c1,c2)
- See TcInteract.matchCTuple
+ See GHC.Tc.Solver.Interact.matchCTuple
- Currently just go up to 62; beyond that
you have to use manual nesting
- Their OccNames look like (%,,,%), so they can easily be
@@ -648,12 +737,12 @@ Note [How tuples work] See also Note [Known-key names] in PrelNames
pretty-print saturated constraint tuples with round parens;
see BasicTypes.tupleParens.
-* In quite a lot of places things are restrcted just to
+* In quite a lot of places things are restricted just to
BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish
E.g. tupleTyCon has a Boxity argument
* When looking up an OccName in the original-name cache
- (IfaceEnv.lookupOrigNameCache), we spot the tuple OccName to make sure
+ (GHC.Iface.Env.lookupOrigNameCache), we spot the tuple OccName to make sure
we get the right wired-in name. This guy can't tell the difference
between BoxedTuple and ConstraintTuple (same OccName!), so tuples
are not serialised into interface files using OccNames at all.
@@ -661,16 +750,16 @@ Note [How tuples work] See also Note [Known-key names] in PrelNames
* Serialization to interface files works via the usual mechanism for known-key
things: instead of serializing the OccName we just serialize the key. During
deserialization we lookup the Name associated with the unique with the logic
- in KnownUniques. See Note [Symbol table representation of names] for details.
+ in GHC.Builtin.Uniques. See Note [Symbol table representation of names] for details.
Note [One-tuples]
~~~~~~~~~~~~~~~~~
GHC supports both boxed and unboxed one-tuples:
- Unboxed one-tuples are sometimes useful when returning a
single value after CPR analysis
- - A boxed one-tuple is used by DsUtils.mkSelectorBinds, when
+ - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when
there is just one binder
-Basically it keeps everythig uniform.
+Basically it keeps everything uniform.
However the /naming/ of the type/data constructors for one-tuples is a
bit odd:
@@ -679,15 +768,51 @@ bit odd:
1-tuples: ??
0-tuples: () ()#
-Zero-tuples have used up the logical name. So we use 'Unit' and 'Unit#'
+Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#'
for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations:
data () = ()
- data Unit a = Unit a
+ data Solo a = Solo a
data (a,b) = (a,b)
-NB (Feb 16): for /constraint/ one-tuples I have 'Unit%' but no class
-decl in GHC.Classes, so I think this part may not work properly. But
-it's unused I think.
+There is no way to write a boxed one-tuple in Haskell using tuple syntax.
+They can, however, be written using other methods:
+
+1. They can be written directly by importing them from GHC.Tuple.
+2. They can be generated by way of Template Haskell or in `deriving` code.
+
+There is nothing special about one-tuples in Core; in particular, they have no
+custom pretty-printing, just using `Solo`.
+
+Note that there is *not* a unary constraint tuple, unlike for other forms of
+tuples. See [Ignore unary constraint tuples] in GHC.Tc.Gen.HsType for more
+details.
+
+See also Note [Flattening one-tuples] in GHC.Core.Make and
+Note [Don't flatten tuples from HsSyn] in GHC.Core.Make.
+
+-----
+-- Wrinkle: Make boxed one-tuple names have known keys
+-----
+
+We make boxed one-tuple names have known keys so that `data Solo a = Solo a`,
+defined in GHC.Tuple, will be used when one-tuples are spliced in through
+Template Haskell. This program (from #18097) crucially relies on this:
+
+ case $( tupE [ [| "ok" |] ] ) of Solo x -> putStrLn x
+
+Unless Solo has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an
+ExplicitTuple of length 1) will not match the type of Solo (an ordinary
+data constructor used in a pattern). Making Solo known-key allows GHC to make
+this connection.
+
+Unlike Solo, every other tuple is /not/ known-key
+(see Note [Infinite families of known-key names] in GHC.Builtin.Names). The
+main reason for this exception is that other tuples are written with special
+syntax, and as a result, they are renamed using a special `isBuiltInOcc_maybe`
+function (see Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache).
+In contrast, Solo is just an ordinary data type with no special syntax, so it
+doesn't really make sense to handle it in `isBuiltInOcc_maybe`. Making Solo
+known-key is the next-best way to teach the internals of the compiler about it.
-}
-- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names
@@ -708,9 +833,12 @@ isBuiltInOcc_maybe occ =
"~" -> Just eqTyConName
-- function tycon
- "->" -> Just funTyConName
+ "FUN" -> Just funTyConName
+ "->" -> Just unrestrictedFunTyConName
-- boxed tuple data/tycon
+ -- We deliberately exclude Solo (the boxed 1-tuple).
+ -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)
"()" -> Just $ tup_name Boxed 0
_ | Just rest <- "(" `BS.stripPrefix` name
, (commas, rest') <- BS.span (==',') rest
@@ -719,7 +847,7 @@ isBuiltInOcc_maybe occ =
-- unboxed tuple data/tycon
"(##)" -> Just $ tup_name Unboxed 0
- "Unit#" -> Just $ tup_name Unboxed 1
+ "Solo#" -> Just $ tup_name Unboxed 1
_ | Just rest <- "(#" `BS.stripPrefix` name
, (commas, rest') <- BS.span (==',') rest
, "#)" <- rest'
@@ -742,7 +870,7 @@ isBuiltInOcc_maybe occ =
in Just $ dataConName $ sumDataCon alt arity
_ -> Nothing
where
- name = fastStringToByteString $ occNameFS occ
+ name = bytesFS $ occNameFS occ
choose_ns :: Name -> Name -> Name
choose_ns tc dc
@@ -763,19 +891,23 @@ mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar)
mkCTupleOcc :: NameSpace -> Arity -> OccName
mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)
+mkTupleStr :: Boxity -> Arity -> String
+mkTupleStr Boxed = mkBoxedTupleStr
+mkTupleStr Unboxed = mkUnboxedTupleStr
+
mkBoxedTupleStr :: Arity -> String
mkBoxedTupleStr 0 = "()"
-mkBoxedTupleStr 1 = "Unit" -- See Note [One-tuples]
+mkBoxedTupleStr 1 = "Solo" -- See Note [One-tuples]
mkBoxedTupleStr ar = '(' : commas ar ++ ")"
mkUnboxedTupleStr :: Arity -> String
mkUnboxedTupleStr 0 = "(##)"
-mkUnboxedTupleStr 1 = "Unit#" -- See Note [One-tuples]
+mkUnboxedTupleStr 1 = "Solo#" -- See Note [One-tuples]
mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)"
mkConstraintTupleStr :: Arity -> String
mkConstraintTupleStr 0 = "(%%)"
-mkConstraintTupleStr 1 = "Unit%" -- See Note [One-tuples]
+mkConstraintTupleStr 1 = "Solo%" -- See Note [One-tuples]
mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)"
commas :: Arity -> String
@@ -836,6 +968,9 @@ tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one
tupleDataCon Boxed i = snd (boxedTupleArr ! i)
tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)
+tupleDataConName :: Boxity -> Arity -> Name
+tupleDataConName sort i = dataConName (tupleDataCon sort i)
+
boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)
boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]]
unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]
@@ -858,7 +993,7 @@ mk_tuple Boxed arity = (tycon, tuple_con)
tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con
BoxedTuple flavour
- tc_binders = mkTemplateAnonTyConBinders (nOfThem arity liftedTypeKind)
+ tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind)
tc_res_kind = liftedTypeKind
tc_arity = arity
flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name)
@@ -881,9 +1016,9 @@ mk_tuple Unboxed arity = (tycon, tuple_con)
tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con
UnboxedTuple flavour
- -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+ -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
-- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> #
- tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy)
+ tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)
(\ks -> map tYPE ks)
tc_res_kind = unboxedTupleKind rr_tys
@@ -919,6 +1054,9 @@ unitDataConId = dataConWorkId unitDataCon
pairTyCon :: TyCon
pairTyCon = tupleTyCon Boxed 2
+unboxedUnitTy :: Type
+unboxedUnitTy = mkTyConApp unboxedUnitTyCon []
+
unboxedUnitTyCon :: TyCon
unboxedUnitTyCon = tupleTyCon Unboxed 0
@@ -1003,7 +1141,7 @@ mk_sum arity = (tycon, sum_cons)
-- Unboxed sums are currently not Typeable due to efficiency concerns. See #13276.
rep_name = Nothing -- Just $ mkPrelTyConRepName tc_name
- tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy)
+ tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)
(\ks -> map tYPE ks)
tyvars = binderVars tc_binders
@@ -1038,7 +1176,7 @@ mk_sum arity = (tycon, sum_cons)
* *
********************************************************************* -}
--- See Note [The equality types story] in TysPrim
+-- See Note [The equality types story] in GHC.Builtin.Types.Prim
-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)
--
-- It's tempting to put functional dependencies on (~~), but it's not
@@ -1057,7 +1195,7 @@ eqSCSelId, heqSCSelId, coercibleSCSelId :: Id
rhs klass
(mkPrelTyConRepName eqTyConName)
klass = mk_class tycon sc_pred sc_sel_id
- datacon = pcDataCon eqDataConName tvs [sc_pred] tycon
+ datacon = pcDataConW eqDataConName tvs [unrestricted sc_pred] tycon
-- Kind: forall k. k -> k -> Constraint
binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])
@@ -1075,7 +1213,7 @@ eqSCSelId, heqSCSelId, coercibleSCSelId :: Id
rhs klass
(mkPrelTyConRepName heqTyConName)
klass = mk_class tycon sc_pred sc_sel_id
- datacon = pcDataCon heqDataConName tvs [sc_pred] tycon
+ datacon = pcDataConW heqDataConName tvs [unrestricted sc_pred] tycon
-- Kind: forall k1 k2. k1 -> k2 -> Constraint
binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id
@@ -1093,7 +1231,7 @@ eqSCSelId, heqSCSelId, coercibleSCSelId :: Id
rhs klass
(mkPrelTyConRepName coercibleTyConName)
klass = mk_class tycon sc_pred sc_sel_id
- datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon
+ datacon = pcDataConW coercibleDataConName tvs [unrestricted sc_pred] tycon
-- Kind: forall k. k -> k -> Constraint
binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])
@@ -1113,16 +1251,77 @@ mk_class tycon sc_pred sc_sel_id
{- *********************************************************************
* *
+ Multiplicity Polymorphism
+* *
+********************************************************************* -}
+
+{- Multiplicity polymorphism is implemented very similarly to levity
+ polymorphism. We write in the multiplicity kind and the One and Many
+ types which can appear in user programs. These are defined properly in GHC.Types.
+
+data Multiplicity = One | Many
+-}
+
+multiplicityTy :: Type
+multiplicityTy = mkTyConTy multiplicityTyCon
+
+multiplicityTyCon :: TyCon
+multiplicityTyCon = pcTyCon multiplicityTyConName Nothing []
+ [oneDataCon, manyDataCon]
+
+oneDataCon, manyDataCon :: DataCon
+oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon
+manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon
+
+oneDataConTy, manyDataConTy :: Type
+oneDataConTy = mkTyConTy oneDataConTyCon
+manyDataConTy = mkTyConTy manyDataConTyCon
+
+oneDataConTyCon, manyDataConTyCon :: TyCon
+oneDataConTyCon = promoteDataCon oneDataCon
+manyDataConTyCon = promoteDataCon manyDataCon
+
+multMulTyConName :: Name
+multMulTyConName =
+ mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon
+
+multMulTyCon :: TyCon
+multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing
+ (BuiltInSynFamTyCon trivialBuiltInFamily)
+ Nothing
+ NotInjective
+ where
+ binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy]
+
+unrestrictedFunTy :: Type
+unrestrictedFunTy = functionWithMultiplicity manyDataConTy
+
+unrestrictedFunTyCon :: TyCon
+unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] unrestrictedFunTy
+ where arrowKind = mkTyConKind binders liftedTypeKind
+ -- See also funTyCon
+ binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)
+ , Bndr runtimeRep2TyVar (NamedTCB Inferred)
+ ]
+ ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty
+ , tYPE runtimeRep2Ty
+ ]
+
+unrestrictedFunTyConName :: Name
+unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") unrestrictedFunTyConKey unrestrictedFunTyCon
+
+{- *********************************************************************
+* *
Kinds and RuntimeRep
* *
********************************************************************* -}
-- For information about the usage of the following type,
--- see Note [TYPE and RuntimeRep] in module TysPrim
+-- see Note [TYPE and RuntimeRep] in module GHC.Builtin.Types.Prim
runtimeRepTy :: Type
runtimeRepTy = mkTyConTy runtimeRepTyCon
--- Type synonyms; see Note [TYPE and RuntimeRep] in TysPrim
+-- Type synonyms; see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim
-- type Type = tYPE 'LiftedRep
liftedTypeKindTyCon :: TyCon
liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName
@@ -1140,6 +1339,7 @@ vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon
runtimeRepTyCon
(RuntimeRep prim_rep_fun)
where
+ -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType
prim_rep_fun [count, elem]
| VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count)
, VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem)
@@ -1154,6 +1354,7 @@ tupleRepDataCon :: DataCon
tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ]
runtimeRepTyCon (RuntimeRep prim_rep_fun)
where
+ -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType
prim_rep_fun [rr_ty_list]
= concatMap (runtimeRepPrimRep doc) rr_tys
where
@@ -1169,6 +1370,7 @@ sumRepDataCon :: DataCon
sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ]
runtimeRepTyCon (RuntimeRep prim_rep_fun)
where
+ -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType
prim_rep_fun [rr_ty_list]
= map slotPrimRep (ubxSumRepType prim_repss)
where
@@ -1182,12 +1384,19 @@ sumRepDataConTyCon :: TyCon
sumRepDataConTyCon = promoteDataCon sumRepDataCon
-- See Note [Wiring in RuntimeRep]
+-- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType
runtimeRepSimpleDataCons :: [DataCon]
liftedRepDataCon :: DataCon
runtimeRepSimpleDataCons@(liftedRepDataCon : _)
= zipWithLazy mk_runtime_rep_dc
- [ LiftedRep, UnliftedRep, IntRep, WordRep, Int8Rep, Int16Rep, Int64Rep
- , Word8Rep, Word16Rep, Word64Rep, AddrRep, FloatRep, DoubleRep ]
+ [ LiftedRep, UnliftedRep
+ , IntRep
+ , Int8Rep, Int16Rep, Int32Rep, Int64Rep
+ , WordRep
+ , Word8Rep, Word16Rep, Word32Rep, Word64Rep
+ , AddrRep
+ , FloatRep, DoubleRep
+ ]
runtimeRepSimpleDataConNames
where
mk_runtime_rep_dc primrep name
@@ -1195,13 +1404,20 @@ runtimeRepSimpleDataCons@(liftedRepDataCon : _)
-- See Note [Wiring in RuntimeRep]
liftedRepDataConTy, unliftedRepDataConTy,
- intRepDataConTy, int8RepDataConTy, int16RepDataConTy, wordRepDataConTy, int64RepDataConTy,
- word8RepDataConTy, word16RepDataConTy, word64RepDataConTy, addrRepDataConTy,
+ intRepDataConTy,
+ int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,
+ wordRepDataConTy,
+ word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,
+ addrRepDataConTy,
floatRepDataConTy, doubleRepDataConTy :: Type
[liftedRepDataConTy, unliftedRepDataConTy,
- intRepDataConTy, wordRepDataConTy, int8RepDataConTy, int16RepDataConTy, int64RepDataConTy,
- word8RepDataConTy, word16RepDataConTy, word64RepDataConTy,
- addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy]
+ intRepDataConTy,
+ int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,
+ wordRepDataConTy,
+ word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,
+ addrRepDataConTy,
+ floatRepDataConTy, doubleRepDataConTy
+ ]
= map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons
vecCountTyCon :: TyCon
@@ -1278,7 +1494,7 @@ boxing_constr_env
{- Note [Boxing primitive types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a handful of primitive types (Int, Char, Word, Flaot, Double),
+For a handful of primitive types (Int, Char, Word, Float, Double),
we can readily box and an unboxed version (Int#, Char# etc) using
the corresponding data constructor. This is useful in a couple
of places, notably let-floating -}
@@ -1296,7 +1512,15 @@ charDataCon :: DataCon
charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
stringTy :: Type
-stringTy = mkListTy charTy -- convenience only
+stringTy = mkTyConApp stringTyCon []
+
+stringTyCon :: TyCon
+-- We have this wired-in so that Haskell literal strings
+-- get type String (in hsLitType), which in turn influences
+-- inferred types and error messages
+stringTyCon = buildSynTyCon stringTyConName
+ [] liftedTypeKind []
+ (mkListTy charTy)
intTy :: Type
intTy = mkTyConTy intTyCon
@@ -1449,13 +1673,9 @@ mkListTy :: Type -> Type
mkListTy ty = mkTyConApp listTyCon [ty]
listTyCon :: TyCon
-listTyCon =
- buildAlgTyCon listTyConName alpha_tyvar [Representational]
- Nothing []
- (mkDataTyConRhs [nilDataCon, consDataCon])
- False
- (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName)
+listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon]
+-- See also Note [Empty lists] in GHC.Hs.Expr.
nilDataCon :: DataCon
nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
@@ -1463,7 +1683,7 @@ consDataCon :: DataCon
consDataCon = pcDataConWithFixity True {- Declared infix -}
consDataConName
alpha_tyvar [] alpha_tyvar
- [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
+ (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) listTyCon
-- Interesting: polymorphic recursion would help here.
-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
-- gets the over-specific type (Type -> Type)
@@ -1529,15 +1749,24 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}.
-}
-- | Make a tuple type. The list of types should /not/ include any
--- RuntimeRep specifications.
+-- RuntimeRep specifications. Boxed 1-tuples are flattened.
+-- See Note [One-tuples]
mkTupleTy :: Boxity -> [Type] -> Type
-- Special case for *boxed* 1-tuples, which are represented by the type itself
mkTupleTy Boxed [ty] = ty
-mkTupleTy Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys
-mkTupleTy Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys))
- (map getRuntimeRep tys ++ tys)
+mkTupleTy boxity tys = mkTupleTy1 boxity tys
+
+-- | Make a tuple type. The list of types should /not/ include any
+-- RuntimeRep specifications. Boxed 1-tuples are *not* flattened.
+-- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn]
+-- in "GHC.Core.Make"
+mkTupleTy1 :: Boxity -> [Type] -> Type
+mkTupleTy1 Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys
+mkTupleTy1 Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys))
+ (map getRuntimeRep tys ++ tys)
-- | Build the type of a small tuple that holds the specified type of thing
+-- Flattens 1-tuples. See Note [One-tuples].
mkBoxedTupleTy :: [Type] -> Type
mkBoxedTupleTy tys = mkTupleTy Boxed tys
@@ -1613,3 +1842,98 @@ extractPromotedList tys = go tys
| otherwise
= pprPanic "extractPromotedList" (ppr tys)
+
+
+
+---------------------------------------
+-- ghc-bignum
+---------------------------------------
+
+integerTyConName
+ , integerISDataConName
+ , integerIPDataConName
+ , integerINDataConName
+ :: Name
+integerTyConName
+ = mkWiredInTyConName
+ UserSyntax
+ gHC_NUM_INTEGER
+ (fsLit "Integer")
+ integerTyConKey
+ integerTyCon
+integerISDataConName
+ = mkWiredInDataConName
+ UserSyntax
+ gHC_NUM_INTEGER
+ (fsLit "IS")
+ integerISDataConKey
+ integerISDataCon
+integerIPDataConName
+ = mkWiredInDataConName
+ UserSyntax
+ gHC_NUM_INTEGER
+ (fsLit "IP")
+ integerIPDataConKey
+ integerIPDataCon
+integerINDataConName
+ = mkWiredInDataConName
+ UserSyntax
+ gHC_NUM_INTEGER
+ (fsLit "IN")
+ integerINDataConKey
+ integerINDataCon
+
+integerTy :: Type
+integerTy = mkTyConTy integerTyCon
+
+integerTyCon :: TyCon
+integerTyCon = pcTyCon integerTyConName Nothing []
+ [integerISDataCon, integerIPDataCon, integerINDataCon]
+
+integerISDataCon :: DataCon
+integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon
+
+integerIPDataCon :: DataCon
+integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon
+
+integerINDataCon :: DataCon
+integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon
+
+naturalTyConName
+ , naturalNSDataConName
+ , naturalNBDataConName
+ :: Name
+naturalTyConName
+ = mkWiredInTyConName
+ UserSyntax
+ gHC_NUM_NATURAL
+ (fsLit "Natural")
+ naturalTyConKey
+ naturalTyCon
+naturalNSDataConName
+ = mkWiredInDataConName
+ UserSyntax
+ gHC_NUM_NATURAL
+ (fsLit "NS")
+ naturalNSDataConKey
+ naturalNSDataCon
+naturalNBDataConName
+ = mkWiredInDataConName
+ UserSyntax
+ gHC_NUM_NATURAL
+ (fsLit "NB")
+ naturalNBDataConKey
+ naturalNBDataCon
+
+naturalTy :: Type
+naturalTy = mkTyConTy naturalTyCon
+
+naturalTyCon :: TyCon
+naturalTyCon = pcTyCon naturalTyConName Nothing []
+ [naturalNSDataCon, naturalNBDataCon]
+
+naturalNSDataCon :: DataCon
+naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon
+
+naturalNBDataCon :: DataCon
+naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon
diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/GHC/Builtin/Types.hs-boot
index 1481a75..792faf9 100644
--- a/compiler/prelude/TysWiredIn.hs-boot
+++ b/compiler/GHC/Builtin/Types.hs-boot
@@ -1,12 +1,10 @@
-module TysWiredIn where
+module GHC.Builtin.Types where
-import Var( TyVar, ArgFlag )
-import {-# SOURCE #-} TyCon ( TyCon )
-import {-# SOURCE #-} TyCoRep (Type, Kind)
+import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )
+import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind)
-
-mkFunKind :: Kind -> Kind -> Kind
-mkForAllKind :: TyVar -> ArgFlag -> Kind -> Kind
+import GHC.Types.Basic (Arity, TupleSort)
+import GHC.Types.Name (Name)
listTyCon :: TyCon
typeNatKind, typeSymbolKind :: Type
@@ -17,6 +15,8 @@ coercibleTyCon, heqTyCon :: TyCon
unitTy :: Type
liftedTypeKind :: Kind
+liftedTypeKindTyCon :: TyCon
+
constraintKind :: Kind
runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon
@@ -24,10 +24,13 @@ runtimeRepTy :: Type
liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon
-liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy,
- int16RepDataConTy, word16RepDataConTy,
- wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy,
- addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type
+liftedRepDataConTy, unliftedRepDataConTy,
+ intRepDataConTy,
+ int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,
+ wordRepDataConTy,
+ word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,
+ addrRepDataConTy,
+ floatRepDataConTy, doubleRepDataConTy :: Type
vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
vec64DataConTy :: Type
@@ -40,3 +43,16 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
anyTypeOfKind :: Kind -> Type
unboxedTupleKind :: [Type] -> Type
mkPromotedListTy :: Type -> [Type] -> Type
+
+multiplicityTyCon :: TyCon
+multiplicityTy :: Type
+oneDataConTy :: Type
+oneDataConTyCon :: TyCon
+manyDataConTy :: Type
+manyDataConTyCon :: TyCon
+unrestrictedFunTyCon :: TyCon
+multMulTyCon :: TyCon
+
+tupleTyConName :: TupleSort -> Arity -> Name
+
+integerTy, naturalTy :: Type
diff --git a/compiler/prelude/TysPrim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index 159eeae..e68db40 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -2,18 +2,19 @@
(c) The AQUA Project, Glasgow University, 1994-1998
-\section[TysPrim]{Wired-in knowledge about primitive types}
+Wired-in knowledge about primitive types
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | This module defines TyCons that can't be expressed in Haskell.
--- They are all, therefore, wired-in TyCons. C.f module TysWiredIn
-module TysPrim(
- mkPrimTyConName, -- For implicit parameters in TysWiredIn only
+-- They are all, therefore, wired-in TyCons. C.f module "GHC.Builtin.Types"
+module GHC.Builtin.Types.Prim(
+ mkPrimTyConName, -- For implicit parameters in GHC.Builtin.Types only
mkTemplateKindVars, mkTemplateTyVars, mkTemplateTyVarsFrom,
- mkTemplateKiTyVars,
+ mkTemplateKiTyVars, mkTemplateKiTyVar,
mkTemplateTyConBinders, mkTemplateKindTyConBinders,
mkTemplateAnonTyConBinders,
@@ -25,12 +26,15 @@ module TysPrim(
runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty,
openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar,
+ multiplicityTyVar,
+
-- Kind constructors...
tYPETyCon, tYPETyConName,
-- Kinds
tYPE, primRepToRuntimeRep,
+ functionWithMultiplicity,
funTyCon, funTyConName,
unexposedPrimTyCons, exposedPrimTyCons, primTyCons,
@@ -41,7 +45,6 @@ module TysPrim(
floatPrimTyCon, floatPrimTy, floatPrimTyConName,
doublePrimTyCon, doublePrimTy, doublePrimTyConName,
- voidPrimTyCon, voidPrimTy,
statePrimTyCon, mkStatePrimTy,
realWorldTyCon, realWorldTy, realWorldStatePrimTy,
@@ -58,6 +61,7 @@ module TysPrim(
mutVarPrimTyCon, mkMutVarPrimTy,
mVarPrimTyCon, mkMVarPrimTy,
+ ioPortPrimTyCon, mkIOPortPrimTy,
tVarPrimTyCon, mkTVarPrimTy,
stablePtrPrimTyCon, mkStablePtrPrimTy,
stableNamePrimTyCon, mkStableNamePrimTy,
@@ -81,6 +85,7 @@ module TysPrim(
eqPrimTyCon, -- ty1 ~# ty2
eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational)
eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom)
+ equalityTyCon,
-- * SIMD
#include "primop-vector-tys-exports.hs-incl"
@@ -88,14 +93,16 @@ module TysPrim(
#include "GhclibHsVersions.h"
-import GhcPrelude
+import GHC.Prelude
-import {-# SOURCE #-} TysWiredIn
+import {-# SOURCE #-} GHC.Builtin.Types
( runtimeRepTy, unboxedTupleKind, liftedTypeKind
, vecRepDataConTyCon, tupleRepDataConTyCon
- , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy
- , int16RepDataConTy, word16RepDataConTy
- , wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy
+ , liftedRepDataConTy, unliftedRepDataConTy
+ , intRepDataConTy
+ , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy
+ , wordRepDataConTy
+ , word16RepDataConTy, word8RepDataConTy, word32RepDataConTy, word64RepDataConTy
, addrRepDataConTy
, floatRepDataConTy, doubleRepDataConTy
, vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy
@@ -104,18 +111,18 @@ import {-# SOURCE #-} TysWiredIn
, int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy
, word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy
, doubleElemRepDataConTy
- , mkPromotedListTy )
-
-import Var ( TyVar, VarBndr(Bndr), mkTyVar )
-import Name
-import TyCon
-import SrcLoc
-import Unique
-import PrelNames
-import FastString
-import Outputable
-import TyCoRep -- Doesn't need special access, but this is easier to avoid
- -- import loops which show up if you import Type instead
+ , mkPromotedListTy, multiplicityTy )
+
+import GHC.Types.Var ( TyVar, mkTyVar )
+import GHC.Types.Name
+import GHC.Core.TyCon
+import GHC.Types.SrcLoc
+import GHC.Types.Unique
+import GHC.Builtin.Names
+import GHC.Data.FastString
+import GHC.Utils.Outputable
+import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid
+ -- import loops which show up if you import Type instead
import Data.Char
@@ -130,10 +137,10 @@ import Data.Char
primTyCons :: [TyCon]
primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons
--- | Primitive 'TyCon's that are defined in "GHC.Prim" but not exposed.
+-- | Primitive 'TyCon's that are defined in GHC.Prim but not exposed.
-- It's important to keep these separate as we don't want users to be able to
--- write them (see Trac #15209) or see them in GHCi's @:browse@ output
--- (see Trac #12023).
+-- write them (see #15209) or see them in GHCi's @:browse@ output
+-- (see #12023).
unexposedPrimTyCons :: [TyCon]
unexposedPrimTyCons
= [ eqPrimTyCon
@@ -141,7 +148,7 @@ unexposedPrimTyCons
, eqPhantPrimTyCon
]
--- | Primitive 'TyCon's that are defined in, and exported from, "GHC.Prim".
+-- | Primitive 'TyCon's that are defined in, and exported from, GHC.Prim.
exposedPrimTyCons :: [TyCon]
exposedPrimTyCons
= [ addrPrimTyCon
@@ -164,6 +171,7 @@ exposedPrimTyCons
, mutableArrayArrayPrimTyCon
, smallMutableArrayPrimTyCon
, mVarPrimTyCon
+ , ioPortPrimTyCon
, tVarPrimTyCon
, mutVarPrimTyCon
, realWorldTyCon
@@ -171,7 +179,6 @@ exposedPrimTyCons
, stableNamePrimTyCon
, compactPrimTyCon
, statePrimTyCon
- , voidPrimTyCon
, proxyPrimTyCon
, threadIdPrimTyCon
, wordPrimTyCon
@@ -200,7 +207,7 @@ mkBuiltInPrimTc fs unique tycon
BuiltInSyntax
-charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon
int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon
@@ -216,7 +223,6 @@ addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPr
floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon
doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
-voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon
proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon
eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon
eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
@@ -224,13 +230,14 @@ eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKe
realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
-arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon
+arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon
smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon
mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon
mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon
mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon
smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon
mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon
+ioPortPrimTyConName = mkPrimTc (fsLit "IOPort#") ioPortPrimTyConKey ioPortPrimTyCon
mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon
tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon
stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
@@ -251,14 +258,15 @@ alphaTyVars is a list of type variables for use in templates:
["a", "b", ..., "z", "t1", "t2", ... ]
-}
+mkTemplateKindVar :: Kind -> TyVar
+mkTemplateKindVar = mkTyVar (mk_tv_name 0 "k")
+
mkTemplateKindVars :: [Kind] -> [TyVar]
-- k0 with unique (mkAlphaTyVarUnique 0)
-- k1 with unique (mkAlphaTyVarUnique 1)
-- ... etc
-mkTemplateKindVars [kind]
- = [mkTyVar (mk_tv_name 0 "k") kind]
- -- Special case for one kind: just "k"
-
+mkTemplateKindVars [kind] = [mkTemplateKindVar kind]
+ -- Special case for one kind: just "k"
mkTemplateKindVars kinds
= [ mkTyVar (mk_tv_name u ('k' : show u)) kind
| (kind, u) <- kinds `zip` [0..] ]
@@ -307,7 +315,7 @@ mkTemplateKiTyVars
-> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm]
-- Example: if you want the tyvars for
-- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah
--- call mkTemplateKiTyVars [RuntimeRep] (\[r]. [TYPE r, *)
+-- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, *])
mkTemplateKiTyVars kind_var_kinds mk_arg_kinds
= kv_bndrs ++ tv_bndrs
where
@@ -315,15 +323,30 @@ mkTemplateKiTyVars kind_var_kinds mk_arg_kinds
anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs)
tv_bndrs = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds
+mkTemplateKiTyVar
+ :: Kind -- [k1, .., kn] Kind of kind-forall'd var
+ -> (Kind -> [Kind]) -- Arg is kv1:k1
+ -- Result is anon arg kinds [ak1, .., akm]
+ -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm]
+-- Example: if you want the tyvars for
+-- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah
+-- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, *])
+mkTemplateKiTyVar kind mk_arg_kinds
+ = kv_bndr : tv_bndrs
+ where
+ kv_bndr = mkTemplateKindVar kind
+ anon_kinds = mk_arg_kinds (mkTyVarTy kv_bndr)
+ tv_bndrs = mkTemplateTyVarsFrom 1 anon_kinds
+
mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder]
-- Makes named, Specified binders
mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds]
mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder]
-mkTemplateAnonTyConBinders kinds = map mkAnonTyConBinder (mkTemplateTyVars kinds)
+mkTemplateAnonTyConBinders kinds = mkAnonTyConBinders VisArg (mkTemplateTyVars kinds)
mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder]
-mkTemplateAnonTyConBindersFrom n kinds = map mkAnonTyConBinder (mkTemplateTyVarsFrom n kinds)
+mkTemplateAnonTyConBindersFrom n kinds = mkAnonTyConBinders VisArg (mkTemplateTyVarsFrom n kinds)
alphaTyVars :: [TyVar]
alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind
@@ -356,6 +379,8 @@ runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar
runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar
openAlphaTyVar, openBetaTyVar :: TyVar
+-- alpha :: TYPE r1
+-- beta :: TYPE r2
[openAlphaTyVar,openBetaTyVar]
= mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty]
@@ -363,6 +388,9 @@ openAlphaTy, openBetaTy :: Type
openAlphaTy = mkTyVarTy openAlphaTyVar
openBetaTy = mkTyVarTy openBetaTyVar
+multiplicityTyVar :: TyVar
+multiplicityTyVar = mkTemplateTyVars (repeat multiplicityTy) !! 13 -- selects 'n'
+
{-
************************************************************************
* *
@@ -372,20 +400,35 @@ openBetaTy = mkTyVarTy openBetaTyVar
-}
funTyConName :: Name
-funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon
+funTyConName = mkPrimTyConName (fsLit "FUN") funTyConKey funTyCon
--- | The @(->)@ type constructor.
+-- | The @FUN@ type constructor.
--
-- @
--- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).
+-- FUN :: forall {m :: Multiplicity} {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.
-- TYPE rep1 -> TYPE rep2 -> *
-- @
+--
+-- The runtime representations quantification is left inferred. This
+-- means they cannot be specified with @-XTypeApplications@.
+--
+-- This is a deliberate choice to allow future extensions to the
+-- function arrow. To allow visible application a type synonym can be
+-- defined:
+--
+-- @
+-- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).
+-- TYPE rep1 -> TYPE rep2 -> Type
+-- type Arr = FUN
+-- @
+--
funTyCon :: TyCon
funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm
where
- tc_bndrs = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)
- , Bndr runtimeRep2TyVar (NamedTCB Inferred)
- ]
+ -- See also unrestrictedFunTyCon
+ tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar
+ , mkNamedTyConBinder Inferred runtimeRep1TyVar
+ , mkNamedTyConBinder Inferred runtimeRep2TyVar ]
++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty
, tYPE runtimeRep2Ty
]
@@ -424,12 +467,12 @@ So for example:
We abbreviate '*' specially:
type * = TYPE 'LiftedRep
-The 'rr' parameter tells us how the value is represented at runime.
+The 'rr' parameter tells us how the value is represented at runtime.
Generally speaking, you can't be polymorphic in 'rr'. E.g
f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a]
f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ...
-This is no good: we could not generate code code for 'f', because the
+This is no good: we could not generate code for 'f', because the
calling convention for 'f' varies depending on whether the argument is
a a Int, Int#, or Float#. (You could imagine generating specialised
code, one for each instantiation of 'rr', but we don't do that.)
@@ -440,13 +483,13 @@ generator never has to manipulate a value of type 'a :: TYPE rr'.
* error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a
Code generator never has to manipulate the return value.
-* unsafeCoerce#, defined in MkId.unsafeCoerceId:
+* unsafeCoerce#, defined in Desugar.mkUnsafeCoercePair:
Always inlined to be a no-op
unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2).
a -> b
-* Unboxed tuples, and unboxed sums, defined in TysWiredIn
+* Unboxed tuples, and unboxed sums, defined in GHC.Builtin.Types
Always inlined, and hence specialised to the call site
(#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2).
@@ -454,14 +497,14 @@ generator never has to manipulate a value of type 'a :: TYPE rr'.
Note [PrimRep and kindPrimRep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As part of its source code, in TyCon, GHC has
+As part of its source code, in GHC.Core.TyCon, GHC has
data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc...
Notice that
* RuntimeRep is part of the syntax tree of the program being compiled
(defined in a library: ghc-prim:GHC.Types)
* PrimRep is part of GHC's source code.
- (defined in TyCon)
+ (defined in GHC.Core.TyCon)
We need to get from one to the other; that is what kindPrimRep does.
Suppose we have a value
@@ -490,7 +533,7 @@ tYPETyCon = mkKindTyCon tYPETyConName
-- ... and now their names
-- If you edit these, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+-- See Note [GHC Formalism] in GHC.Core.Lint
tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon
mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
@@ -508,10 +551,14 @@ mkPrimTcName built_in_syntax occ key tycon
tYPE :: Type -> Type
tYPE rr = TyConApp tYPETyCon [rr]
+-- Given a Multiplicity, applies FUN to it.
+functionWithMultiplicity :: Type -> Type
+functionWithMultiplicity mul = TyConApp funTyCon [mul]
+
{-
************************************************************************
* *
-\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)}
+ Basic primitive types (@Char#@, @Int#@, etc.)
* *
************************************************************************
-}
@@ -534,10 +581,12 @@ primRepToRuntimeRep rep = case rep of
IntRep -> intRepDataConTy
Int8Rep -> int8RepDataConTy
Int16Rep -> int16RepDataConTy
- WordRep -> wordRepDataConTy
+ Int32Rep -> int32RepDataConTy
Int64Rep -> int64RepDataConTy
+ WordRep -> wordRepDataConTy
Word8Rep -> word8RepDataConTy
Word16Rep -> word16RepDataConTy
+ Word32Rep -> word32RepDataConTy
Word64Rep -> word64RepDataConTy
AddrRep -> addrRepDataConTy
FloatRep -> floatRepDataConTy
@@ -592,7 +641,7 @@ int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName Int16Rep
int32PrimTy :: Type
int32PrimTy = mkTyConTy int32PrimTyCon
int32PrimTyCon :: TyCon
-int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName IntRep
+int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName Int32Rep
int64PrimTy :: Type
int64PrimTy = mkTyConTy int64PrimTyCon
@@ -617,7 +666,7 @@ word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName Word16Rep
word32PrimTy :: Type
word32PrimTy = mkTyConTy word32PrimTyCon
word32PrimTyCon :: TyCon
-word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName WordRep
+word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName Word32Rep
word64PrimTy :: Type
word64PrimTy = mkTyConTy word64PrimTyCon
@@ -642,7 +691,7 @@ doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep
{-
************************************************************************
* *
-\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)}
+ The @State#@ type (and @_RealWorld@ types)
* *
************************************************************************
@@ -680,15 +729,15 @@ Let's take these one at a time:
--------------------------
This is The Type Of Equality in GHC. It classifies nominal coercions.
This type is used in the solver for recording equality constraints.
-It responds "yes" to Type.isEqPred and classifies as an EqPred in
+It responds "yes" to Type.isEqPrimPred and classifies as an EqPred in
Type.classifyPredType.
All wanted constraints of this type are built with coercion holes.
-(See Note [Coercion holes] in TyCoRep.) But see also
-Note [Deferred errors for coercion holes] in TcErrors to see how
+(See Note [Coercion holes] in GHC.Core.TyCo.Rep.) But see also
+Note [Deferred errors for coercion holes] in GHC.Tc.Errors to see how
equality constraints are deferred.
-Within GHC, ~# is called eqPrimTyCon, and it is defined in TysPrim.
+Within GHC, ~# is called eqPrimTyCon, and it is defined in GHC.Builtin.Types.Prim.
--------------------------
@@ -709,7 +758,7 @@ Here's what's unusual about it:
solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the
context. (Normally, it waits to learn more, just in case the given
influences what happens next.) See Note [Naturally coherent classes]
- in TcInteract.
+ in GHC.Tc.Solver.Interact.
* It always terminates. That is, in the UndecidableInstances checks, we
don't worry if a (~~) constraint is too big, as we know that solving
@@ -718,11 +767,11 @@ Here's what's unusual about it:
On the other hand, this behaves just like any class w.r.t. eager superclass
unpacking in the solver. So a lifted equality given quickly becomes an unlifted
equality given. This is good, because the solver knows all about unlifted
-equalities. There is some special-casing in TcInteract.matchClassInst to
+equalities. There is some special-casing in GHC.Tc.Solver.Interact.matchClassInst to
pretend that there is an instance of this class, as we can't write the instance
in Haskell.
-Within GHC, ~~ is called heqTyCon, and it is defined in TysWiredIn.
+Within GHC, ~~ is called heqTyCon, and it is defined in GHC.Builtin.Types.
--------------------------
@@ -738,7 +787,7 @@ It is an almost-ordinary class defined as if by
* In addition (~) is magical syntax, as ~ is a reserved symbol.
It cannot be exported or imported.
-Within GHC, ~ is called eqTyCon, and it is defined in TysWiredIn.
+Within GHC, ~ is called eqTyCon, and it is defined in GHC.Builtin.Types.
Historical note: prior to July 18 (~) was defined as a
more-ordinary class with (~~) as a superclass. But that made it
@@ -762,7 +811,7 @@ The is the representational analogue of ~#. This is the type of representational
equalities that the solver works on. All wanted constraints of this type are
built with coercion holes.
-Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in TysPrim.
+Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in GHC.Builtin.Types.Prim.
--------------------------
@@ -780,7 +829,7 @@ split required that both types be fully wired-in. Instead of doing this,
I just got rid of HCoercible, as I'm not sure who would use it, anyway.
Within GHC, Coercible is called coercibleTyCon, and it is defined in
-TysWiredIn.
+GHC.Builtin.Types.
--------------------------
@@ -842,22 +891,16 @@ realWorldStatePrimTy :: Type
realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld
-- Note: the ``state-pairing'' types are not truly primitive,
--- so they are defined in \tr{TysWiredIn.hs}, not here.
-
+-- so they are defined in \tr{GHC.Builtin.Types}, not here.
-voidPrimTy :: Type
-voidPrimTy = TyConApp voidPrimTyCon []
-
-voidPrimTyCon :: TyCon
-voidPrimTyCon = pcPrimTyCon voidPrimTyConName [] VoidRep
mkProxyPrimTy :: Type -> Type -> Type
mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]
proxyPrimTyCon :: TyCon
-proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nominal]
+proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Phantom]
where
- -- Kind: forall k. k -> Void#
+ -- Kind: forall k. k -> TYPE (Tuple '[])
binders = mkTemplateTyConBinders [liftedTypeKind] id
res_kind = unboxedTupleKind []
@@ -873,7 +916,7 @@ eqPrimTyCon :: TyCon -- The representation type for equality predicates
-- See Note [The equality types story]
eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles
where
- -- Kind :: forall k1 k2. k1 -> k2 -> Void#
+ -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[])
binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id
res_kind = unboxedTupleKind []
roles = [Nominal, Nominal, Nominal, Nominal]
@@ -884,7 +927,7 @@ eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles
eqReprPrimTyCon :: TyCon -- See Note [The equality types story]
eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles
where
- -- Kind :: forall k1 k2. k1 -> k2 -> Void#
+ -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[])
binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id
res_kind = unboxedTupleKind []
roles = [Nominal, Nominal, Representational, Representational]
@@ -895,11 +938,17 @@ eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles
eqPhantPrimTyCon :: TyCon
eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles
where
- -- Kind :: forall k1 k2. k1 -> k2 -> Void#
+ -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[])
binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id
res_kind = unboxedTupleKind []
roles = [Nominal, Nominal, Phantom, Phantom]
+-- | Given a Role, what TyCon is the type of equality predicates at that role?
+equalityTyCon :: Role -> TyCon
+equalityTyCon Nominal = eqPrimTyCon
+equalityTyCon Representational = eqReprPrimTyCon
+equalityTyCon Phantom = eqPhantPrimTyCon
+
{- *********************************************************************
* *
The primitive array types
@@ -951,6 +1000,21 @@ mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt]
{-
************************************************************************
* *
+\subsection[TysPrim-io-port-var]{The synchronizing I/O Port type}
+* *
+************************************************************************
+-}
+
+ioPortPrimTyCon :: TyCon
+ioPortPrimTyCon = pcPrimTyCon ioPortPrimTyConName [Nominal, Representational] UnliftedRep
+
+mkIOPortPrimTy :: Type -> Type -> Type
+mkIOPortPrimTy s elt = TyConApp ioPortPrimTyCon [s, elt]
+
+{-
+************************************************************************
+* *
+ The synchronizing variable type
\subsection[TysPrim-synch-var]{The synchronizing variable type}
* *
************************************************************************
@@ -965,7 +1029,7 @@ mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt]
{-
************************************************************************
* *
-\subsection[TysPrim-stm-var]{The transactional variable type}
+ The transactional variable type
* *
************************************************************************
-}
@@ -979,7 +1043,7 @@ mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt]
{-
************************************************************************
* *
-\subsection[TysPrim-stable-ptrs]{The stable-pointer type}
+ The stable-pointer type
* *
************************************************************************
-}
@@ -993,7 +1057,7 @@ mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty]
{-
************************************************************************
* *
-\subsection[TysPrim-stable-names]{The stable-name type}
+ The stable-name type
* *
************************************************************************
-}
@@ -1007,7 +1071,7 @@ mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]
{-
************************************************************************
* *
-\subsection[TysPrim-compact-nfdata]{The Compact NFData (CNF) type}
+ The Compact NFData (CNF) type
* *
************************************************************************
-}
@@ -1021,11 +1085,14 @@ compactPrimTy = mkTyConTy compactPrimTyCon
{-
************************************************************************
* *
-\subsection[TysPrim-BCOs]{The ``bytecode object'' type}
+ The ``bytecode object'' type
* *
************************************************************************
-}
+-- Unlike most other primitive types, BCO is lifted. This is because in
+-- general a BCO may be a thunk for the reasons given in Note [Updatable CAF
+-- BCOs] in GHCi.CreateBCO.
bcoPrimTy :: Type
bcoPrimTy = mkTyConTy bcoPrimTyCon
bcoPrimTyCon :: TyCon
@@ -1034,7 +1101,7 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep
{-
************************************************************************
* *
-\subsection[TysPrim-Weak]{The ``weak pointer'' type}
+ The ``weak pointer'' type
* *
************************************************************************
-}
@@ -1048,7 +1115,7 @@ mkWeakPrimTy v = TyConApp weakPrimTyCon [v]
{-
************************************************************************
* *
-\subsection[TysPrim-thread-ids]{The ``thread id'' type}
+ The ``thread id'' type
* *
************************************************************************
diff --git a/compiler/prelude/KnownUniques.hs b/compiler/GHC/Builtin/Uniques.hs
index 3710db3..d724832 100644
--- a/compiler/prelude/KnownUniques.hs
+++ b/compiler/GHC/Builtin/Uniques.hs
@@ -7,7 +7,7 @@
-- names] for details.
--
-module KnownUniques
+module GHC.Builtin.Uniques
( -- * Looking up known-key names
knownUniqueName
@@ -26,17 +26,17 @@ module KnownUniques
#include "GhclibHsVersions.h"
-import GhcPrelude
+import GHC.Prelude
-import TysWiredIn
-import TyCon
-import DataCon
-import Id
-import BasicTypes
-import Outputable
-import Unique
-import Name
-import Util
+import GHC.Builtin.Types
+import GHC.Core.TyCon
+import GHC.Core.DataCon
+import GHC.Types.Id
+import GHC.Types.Basic
+import GHC.Utils.Outputable
+import GHC.Types.Unique
+import GHC.Types.Name
+import GHC.Utils.Misc
import Data.Bits
import Data.Maybe
@@ -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/GHC/Builtin/Uniques.hs-boot
index b217c84..3e24cd5 100644
--- a/compiler/prelude/KnownUniques.hs-boot
+++ b/compiler/GHC/Builtin/Uniques.hs-boot
@@ -1,11 +1,11 @@
-module KnownUniques where
+module GHC.Builtin.Uniques where
-import GhcPrelude
-import Unique
-import Name
-import BasicTypes
+import GHC.Prelude
+import GHC.Types.Unique
+import GHC.Types.Name
+import GHC.Types.Basic
--- Needed by TysWiredIn
+-- Needed by GHC.Builtin.Types
knownUniqueName :: Unique -> Maybe Name
mkSumTyConUnique :: Arity -> Unique
diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/GHC/ByteCode/Types.hs
index 0c0c34a..296f886 100644
--- a/compiler/ghci/ByteCodeTypes.hs
+++ b/compiler/GHC/ByteCode/Types.hs
@@ -4,7 +4,7 @@
--
-- | Bytecode assembler types
-module ByteCodeTypes
+module GHC.ByteCode.Types
( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)
, UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
, ItblEnv, ItblPtr(..)
@@ -13,17 +13,17 @@ module ByteCodeTypes
, CCostCentre
) where
-import GhcPrelude
+import GHC.Prelude
-import FastString
-import Id
-import Name
-import NameEnv
-import Outputable
-import PrimOp
+import GHC.Data.FastString
+import GHC.Types.Id
+import GHC.Types.Name
+import GHC.Types.Name.Env
+import GHC.Utils.Outputable
+import GHC.Builtin.PrimOps
import SizedSeq
-import Type
-import SrcLoc
+import GHC.Core.Type
+import GHC.Types.SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
import GHCi.FFI
@@ -114,7 +114,7 @@ data CgBreakInfo
{ cgb_vars :: [Maybe (Id,Word16)]
, cgb_resty :: Type
}
--- See Note [Syncing breakpoint info] in compiler/main/InteractiveEval.hs
+-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
-- Not a real NFData instance because we can't rnf Id or Type
seqCgBreakInfo :: CgBreakInfo -> ()
@@ -154,6 +154,7 @@ data ModBreaks
-- ^ An array giving the names of the free variables at each breakpoint.
, modBreaks_decls :: !(Array BreakIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
+ -- See Note [Field modBreaks_decls]
, modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre))
-- ^ Array pointing to cost centre for each breakpoint
, modBreaks_breakInfo :: IntMap CgBreakInfo
@@ -180,3 +181,12 @@ emptyModBreaks = ModBreaks
, modBreaks_ccs = array (0,-1) []
, modBreaks_breakInfo = IntMap.empty
}
+
+{-
+Note [Field modBreaks_decls]
+~~~~~~~~~~~~~~~~~~~~~~
+A value of eg ["foo", "bar", "baz"] in a `modBreaks_decls` field means:
+The breakpoint is in the function called "baz" that is declared in a `let`
+or `where` clause of a declaration called "bar", which itself is declared
+in a `let` or `where` clause of the top-level function called "foo".
+-}
diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs
new file mode 100644
index 0000000..6f69525
--- /dev/null
+++ b/compiler/GHC/Cmm.hs
@@ -0,0 +1,267 @@
+-- Cmm representations using Hoopl's Graph CmmNode e x.
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+
+module GHC.Cmm (
+ -- * Cmm top-level datatypes
+ CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
+ CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
+ CmmGraph, GenCmmGraph(..),
+ CmmBlock, RawCmmDecl,
+ Section(..), SectionType(..),
+ GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),
+ SectionProtection(..), sectionProtection,
+
+ -- ** Blocks containing lists
+ GenBasicBlock(..), blockId,
+ ListGraph(..), pprBBlock,
+
+ -- * Info Tables
+ CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
+ ClosureTypeInfo(..),
+ ProfilingInfo(..), ConstrDescription,
+
+ -- * Statements, expressions and types
+ module GHC.Cmm.Node,
+ module GHC.Cmm.Expr,
+ ) where
+
+import GHC.Prelude
+
+import GHC.Types.Id
+import GHC.Types.CostCentre
+import GHC.Cmm.CLabel
+import GHC.Cmm.BlockId
+import GHC.Cmm.Node
+import GHC.Runtime.Heap.Layout
+import GHC.Cmm.Expr
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Utils.Outputable
+import Data.ByteString (ByteString)
+
+-----------------------------------------------------------------------------
+-- Cmm, GenCmm
+-----------------------------------------------------------------------------
+
+-- A CmmProgram is a list of CmmGroups
+-- A CmmGroup is a list of top-level declarations
+
+-- When object-splitting is on, each group is compiled into a separate
+-- .o file. So typically we put closely related stuff in a CmmGroup.
+-- Section-splitting follows suit and makes one .text subsection for each
+-- CmmGroup.
+
+type CmmProgram = [CmmGroup]
+
+type GenCmmGroup d h g = [GenCmmDecl d h g]
+-- | Cmm group before SRT generation
+type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
+-- | Cmm group with SRTs
+type CmmGroupSRTs = GenCmmGroup RawCmmStatics CmmTopInfo CmmGraph
+-- | "Raw" cmm group (TODO (osa): not sure what that means)
+type RawCmmGroup = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
+
+-----------------------------------------------------------------------------
+-- CmmDecl, GenCmmDecl
+-----------------------------------------------------------------------------
+
+-- GenCmmDecl is abstracted over
+-- d, the type of static data elements in CmmData
+-- h, the static info preceding the code of a CmmProc
+-- g, the control-flow graph of a CmmProc
+--
+-- We expect there to be two main instances of this type:
+-- (a) C--, i.e. populated with various C-- constructs
+-- (b) Native code, populated with data/instructions
+
+-- | A top-level chunk, abstracted over the type of the contents of
+-- the basic blocks (Cmm or instructions are the likely instantiations).
+data GenCmmDecl d h g
+ = CmmProc -- A procedure
+ h -- Extra header such as the info table
+ CLabel -- Entry label
+ [GlobalReg] -- Registers live on entry. Note that the set of live
+ -- registers will be correct in generated C-- code, but
+ -- not in hand-written C-- code. However,
+ -- splitAtProcPoints calculates correct liveness
+ -- information for CmmProcs.
+ g -- Control-flow graph for the procedure's code
+
+ | CmmData -- Static data
+ Section
+ d
+
+type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
+type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
+
+type RawCmmDecl
+ = GenCmmDecl
+ RawCmmStatics
+ (LabelMap RawCmmStatics)
+ CmmGraph
+
+-----------------------------------------------------------------------------
+-- Graphs
+-----------------------------------------------------------------------------
+
+type CmmGraph = GenCmmGraph CmmNode
+data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
+type CmmBlock = Block CmmNode C C
+
+-----------------------------------------------------------------------------
+-- Info Tables
+-----------------------------------------------------------------------------
+
+-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains
+-- the extra info (beyond the executable code) that belongs to that CmmDecl.
+data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable
+ , stack_info :: CmmStackInfo }
+
+topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
+topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
+topInfoTable _ = Nothing
+
+data CmmStackInfo
+ = StackInfo {
+ arg_space :: ByteOff,
+ -- number of bytes of arguments on the stack on entry to the
+ -- the proc. This is filled in by GHC.StgToCmm.codeGen, and
+ -- used by the stack allocator later.
+ do_layout :: Bool
+ -- Do automatic stack layout for this proc. This is
+ -- True for all code generated by the code generator,
+ -- but is occasionally False for hand-written Cmm where
+ -- we want to do the stack manipulation manually.
+ }
+
+-- | Info table as a haskell data type
+data CmmInfoTable
+ = CmmInfoTable {
+ cit_lbl :: CLabel, -- Info table label
+ cit_rep :: SMRep,
+ cit_prof :: ProfilingInfo,
+ cit_srt :: Maybe CLabel, -- empty, or a closure address
+ cit_clo :: Maybe (Id, CostCentreStack)
+ -- Just (id,ccs) <=> build a static closure later
+ -- Nothing <=> don't build a static closure
+ --
+ -- Static closures for FUNs and THUNKs are *not* generated by
+ -- the code generator, because we might want to add SRT
+ -- entries to them later (for FUNs at least; THUNKs are
+ -- treated the same for consistency). See Note [SRTs] in
+ -- GHC.Cmm.Info.Build, in particular the [FUN] optimisation.
+ --
+ -- This is strictly speaking not a part of the info table that
+ -- will be finally generated, but it's the only convenient
+ -- place to convey this information from the code generator to
+ -- where we build the static closures in
+ -- GHC.Cmm.Info.Build.doSRTs.
+ }
+
+data ProfilingInfo
+ = NoProfilingInfo
+ | ProfilingInfo ByteString ByteString -- closure_type, closure_desc
+
+-----------------------------------------------------------------------------
+-- Static Data
+-----------------------------------------------------------------------------
+
+data SectionType
+ = Text
+ | Data
+ | ReadOnlyData
+ | RelocatableReadOnlyData
+ | UninitialisedData
+ | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned
+ | CString
+ | OtherSection String
+ deriving (Show)
+
+data SectionProtection
+ = ReadWriteSection
+ | ReadOnlySection
+ | WriteProtectedSection -- See Note [Relocatable Read-Only Data]
+ deriving (Eq)
+
+-- | Should a data in this section be considered constant at runtime
+sectionProtection :: Section -> SectionProtection
+sectionProtection (Section t _) = case t of
+ Text -> ReadOnlySection
+ ReadOnlyData -> ReadOnlySection
+ RelocatableReadOnlyData -> WriteProtectedSection
+ ReadOnlyData16 -> ReadOnlySection
+ CString -> ReadOnlySection
+ Data -> ReadWriteSection
+ UninitialisedData -> ReadWriteSection
+ (OtherSection _) -> ReadWriteSection
+
+{-
+Note [Relocatable Read-Only Data]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Relocatable data are only read-only after relocation at the start of the
+program. They should be writable from the source code until then. Failure to
+do so would end up in segfaults at execution when using linkers that do not
+enforce writability of those sections, such as the gold linker.
+-}
+
+data Section = Section SectionType CLabel
+
+data CmmStatic
+ = CmmStaticLit CmmLit
+ -- ^ a literal value, size given by cmmLitRep of the literal.
+ | CmmUninitialised Int
+ -- ^ uninitialised data, N bytes long
+ | CmmString ByteString
+ -- ^ string of 8-bit values only, not zero terminated.
+ | CmmFileEmbed FilePath
+ -- ^ an embedded binary file
+
+-- Static data before SRT generation
+data GenCmmStatics (rawOnly :: Bool) where
+ CmmStatics
+ :: CLabel -- Label of statics
+ -> CmmInfoTable
+ -> CostCentreStack
+ -> [CmmLit] -- Payload
+ -> GenCmmStatics 'False
+
+ -- | Static data, after SRTs are generated
+ CmmStaticsRaw
+ :: CLabel -- Label of statics
+ -> [CmmStatic] -- The static data itself
+ -> GenCmmStatics a
+
+type CmmStatics = GenCmmStatics 'False
+type RawCmmStatics = GenCmmStatics 'True
+
+-- -----------------------------------------------------------------------------
+-- Basic blocks consisting of lists
+
+-- These are used by the LLVM and NCG backends, when populating Cmm
+-- with lists of instructions.
+
+data GenBasicBlock i = BasicBlock BlockId [i]
+
+-- | The branch block id is that of the first block in
+-- the branch, which is that branch's entry point
+blockId :: GenBasicBlock i -> BlockId
+blockId (BasicBlock blk_id _ ) = blk_id
+
+newtype ListGraph i = ListGraph [GenBasicBlock i]
+
+instance Outputable instr => Outputable (ListGraph instr) where
+ ppr (ListGraph blocks) = vcat (map ppr blocks)
+
+instance Outputable instr => Outputable (GenBasicBlock instr) where
+ ppr = pprBBlock
+
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+ hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+
diff --git a/compiler/GHC/Cmm/BlockId.hs b/compiler/GHC/Cmm/BlockId.hs
new file mode 100644
index 0000000..e6396c8
--- /dev/null
+++ b/compiler/GHC/Cmm/BlockId.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{- BlockId module should probably go away completely, being superseded by Label -}
+module GHC.Cmm.BlockId
+ ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+ , newBlockId
+ , blockLbl, infoTblLbl
+ ) where
+
+import GHC.Prelude
+
+import GHC.Cmm.CLabel
+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)
+
+----------------------------------------------------------------
+--- Block Ids, their environments, and their sets
+
+{- Note [Unique BlockId]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Although a 'BlockId' is a local label, for reasons of implementation,
+'BlockId's must be unique within an entire compilation unit. The reason
+is that each local label is mapped to an assembly-language label, and in
+most assembly languages allow, a label is visible throughout the entire
+compilation unit in which it appears.
+-}
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId
+mkBlockId unique = mkHooplLabel $ getKey unique
+
+newBlockId :: MonadUnique m => m BlockId
+newBlockId = mkBlockId <$> getUniqueM
+
+blockLbl :: BlockId -> CLabel
+blockLbl label = mkLocalBlockLabel (getUnique label)
+
+infoTblLbl :: BlockId -> CLabel
+infoTblLbl label
+ = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
diff --git a/compiler/GHC/Cmm/BlockId.hs-boot b/compiler/GHC/Cmm/BlockId.hs-boot
new file mode 100644
index 0000000..4588ce1
--- /dev/null
+++ b/compiler/GHC/Cmm/BlockId.hs-boot
@@ -0,0 +1,8 @@
+module GHC.Cmm.BlockId (BlockId, mkBlockId) where
+
+import GHC.Cmm.Dataflow.Label (Label)
+import GHC.Types.Unique (Unique)
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
new file mode 100644
index 0000000..db5c153
--- /dev/null
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -0,0 +1,1614 @@
+-----------------------------------------------------------------------------
+--
+-- Object-file symbols (called CLabel for histerical raisins).
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
+module GHC.Cmm.CLabel (
+ CLabel, -- abstract type
+ NeedExternDecl (..),
+ ForeignLabelSource(..),
+ pprDebugCLabel,
+
+ mkClosureLabel,
+ mkSRTLabel,
+ mkInfoTableLabel,
+ mkEntryLabel,
+ mkRednCountsLabel,
+ mkConInfoTableLabel,
+ mkApEntryLabel,
+ mkApInfoTableLabel,
+ mkClosureTableLabel,
+ mkBytesLabel,
+
+ mkLocalBlockLabel,
+ mkLocalClosureLabel,
+ mkLocalInfoTableLabel,
+ mkLocalClosureTableLabel,
+
+ mkBlockInfoTableLabel,
+
+ mkBitmapLabel,
+ mkStringLitLabel,
+
+ mkAsmTempLabel,
+ mkAsmTempDerivedLabel,
+ mkAsmTempEndLabel,
+ mkAsmTempDieLabel,
+
+ mkDirty_MUT_VAR_Label,
+ mkNonmovingWriteBarrierEnabledLabel,
+ mkUpdInfoLabel,
+ mkBHUpdInfoLabel,
+ mkIndStaticInfoLabel,
+ mkMainCapabilityLabel,
+ mkMAP_FROZEN_CLEAN_infoLabel,
+ mkMAP_FROZEN_DIRTY_infoLabel,
+ mkMAP_DIRTY_infoLabel,
+ mkSMAP_FROZEN_CLEAN_infoLabel,
+ mkSMAP_FROZEN_DIRTY_infoLabel,
+ mkSMAP_DIRTY_infoLabel,
+ mkBadAlignmentLabel,
+ mkArrWords_infoLabel,
+ mkSRTInfoLabel,
+
+ mkTopTickyCtrLabel,
+ mkCAFBlackHoleInfoTableLabel,
+ mkRtsPrimOpLabel,
+ mkRtsSlowFastTickyCtrLabel,
+
+ mkSelectorInfoLabel,
+ mkSelectorEntryLabel,
+
+ mkCmmInfoLabel,
+ mkCmmEntryLabel,
+ mkCmmRetInfoLabel,
+ mkCmmRetLabel,
+ mkCmmCodeLabel,
+ mkCmmDataLabel,
+ mkRtsCmmDataLabel,
+ mkCmmClosureLabel,
+
+ mkRtsApFastLabel,
+
+ mkPrimCallLabel,
+
+ mkForeignLabel,
+ addLabelSize,
+
+ foreignLabelStdcallInfo,
+ isBytesLabel,
+ isForeignLabel,
+ isSomeRODataLabel,
+ isStaticClosureLabel,
+ mkCCLabel, mkCCSLabel,
+
+ DynamicLinkerLabelInfo(..),
+ mkDynamicLinkerLabel,
+ dynamicLinkerLabelInfo,
+
+ mkPicBaseLabel,
+ mkDeadStripPreventer,
+
+ mkHpcTicksLabel,
+
+ -- * Predicates
+ hasCAF,
+ needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
+ isMathFun,
+ isCFunctionLabel, isGcPtrLabel, labelDynamic,
+ isLocalCLabel, mayRedirectTo,
+
+ -- * Conversions
+ toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
+
+ pprCLabel, pprCLabel_LLVM, pprCLabel_NCG,
+ isInfoTableLabel,
+ isConInfoTableLabel,
+ isIdLabel, isTickyLabel
+ ) where
+
+#include "GhclibHsVersions.h"
+
+import GHC.Prelude
+
+import GHC.Types.Id.Info
+import GHC.Types.Basic
+import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId)
+import GHC.Unit
+import GHC.Types.Name
+import GHC.Types.Unique
+import GHC.Builtin.PrimOps
+import GHC.Types.CostCentre
+import GHC.Utils.Outputable
+import GHC.Data.FastString
+import GHC.Driver.Session
+import GHC.Driver.Backend
+import GHC.Platform
+import GHC.Types.Unique.Set
+import GHC.Utils.Misc
+import GHC.Core.Ppr ( {- instances -} )
+import GHC.CmmToAsm.Config
+
+-- -----------------------------------------------------------------------------
+-- The CLabel type
+
+{- |
+ 'CLabel' is an abstract type that supports the following operations:
+
+ - Pretty printing
+
+ - In a C file, does it need to be declared before use? (i.e. is it
+ guaranteed to be already in scope in the places we need to refer to it?)
+
+ - If it needs to be declared, what type (code or data) should it be
+ declared to have?
+
+ - Is it visible outside this object file or not?
+
+ - Is it "dynamic" (see details below)
+
+ - Eq and Ord, so that we can make sets of CLabels (currently only
+ used in outputting C as far as I can tell, to avoid generating
+ more than one declaration for any given label).
+
+ - Converting an info table label into an entry label.
+
+ CLabel usage is a bit messy in GHC as they are used in a number of different
+ contexts:
+
+ - By the C-- AST to identify labels
+
+ - By the unregisterised C code generator (\"PprC\") for naming functions (hence
+ the name 'CLabel')
+
+ - By the native and LLVM code generators to identify labels
+
+ For extra fun, each of these uses a slightly different subset of constructors
+ (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and
+ LLVM backends).
+
+ In general, we use 'IdLabel' to represent Haskell things early in the
+ pipeline. However, later optimization passes will often represent blocks they
+ create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the
+ label.
+-}
+
+data CLabel
+ = -- | A label related to the definition of a particular Id or Con in a .hs file.
+ IdLabel
+ Name
+ CafInfo
+ IdLabelInfo -- ^ encodes the suffix of the label
+
+ -- | A label from a .cmm file that is not associated with a .hs level Id.
+ | CmmLabel
+ UnitId -- ^ what package the label belongs to.
+ NeedExternDecl -- ^ does the label need an "extern .." declaration
+ FastString -- ^ identifier giving the prefix of the label
+ CmmLabelInfo -- ^ encodes the suffix of the label
+
+ -- | A label with a baked-in \/ algorithmically generated name that definitely
+ -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so
+ -- If it doesn't have an algorithmically generated name then use a CmmLabel
+ -- instead and give it an appropriate UnitId argument.
+ | RtsLabel
+ RtsLabelInfo
+
+ -- | A label associated with a block. These aren't visible outside of the
+ -- compilation unit in which they are defined. These are generally used to
+ -- name blocks produced by Cmm-to-Cmm passes and the native code generator,
+ -- where we don't have a 'Name' to associate the label to and therefore can't
+ -- use 'IdLabel'.
+ | LocalBlockLabel
+ {-# UNPACK #-} !Unique
+
+ -- | A 'C' (or otherwise foreign) label.
+ --
+ | ForeignLabel
+ FastString -- ^ name of the imported label.
+
+ (Maybe Int) -- ^ possible '@n' suffix for stdcall functions
+ -- When generating C, the '@n' suffix is omitted, but when
+ -- generating assembler we must add it to the label.
+
+ ForeignLabelSource -- ^ what package the foreign label is in.
+
+ FunctionOrData
+
+ -- | Local temporary label used for native (or LLVM) code generation; must not
+ -- appear outside of these contexts. Use primarily for debug information
+ | AsmTempLabel
+ {-# UNPACK #-} !Unique
+
+ -- | A label \"derived\" from another 'CLabel' by the addition of a suffix.
+ -- Must not occur outside of the NCG or LLVM code generators.
+ | AsmTempDerivedLabel
+ CLabel
+ FastString -- ^ suffix
+
+ | StringLitLabel
+ {-# UNPACK #-} !Unique
+
+ | CC_Label CostCentre
+ | CCS_Label CostCentreStack
+
+
+ -- | These labels are generated and used inside the NCG only.
+ -- They are special variants of a label used for dynamic linking
+ -- see module "GHC.CmmToAsm.PIC" for details.
+ | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel
+
+ -- | This label is generated and used inside the NCG only.
+ -- It is used as a base for PIC calculations on some platforms.
+ -- It takes the form of a local numeric assembler label '1'; and
+ -- is pretty-printed as 1b, referring to the previous definition
+ -- of 1: in the assembler source file.
+ | PicBaseLabel
+
+ -- | A label before an info table to prevent excessive dead-stripping on darwin
+ | DeadStripPreventer CLabel
+
+
+ -- | Per-module table of tick locations
+ | HpcTicksLabel Module
+
+ -- | Static reference table
+ | SRTLabel
+ {-# UNPACK #-} !Unique
+
+ -- | A bitmap (function or case return)
+ | LargeBitmapLabel
+ {-# UNPACK #-} !Unique
+
+ deriving Eq
+
+isIdLabel :: CLabel -> Bool
+isIdLabel IdLabel{} = True
+isIdLabel _ = False
+
+-- Used in SRT analysis. See Note [Ticky labels in SRT analysis] in
+-- GHC.Cmm.Info.Build.
+isTickyLabel :: CLabel -> Bool
+isTickyLabel (IdLabel _ _ RednCounts) = True
+isTickyLabel _ = False
+
+-- | Indicate if "GHC.CmmToC" has to generate an extern declaration for the
+-- label (e.g. "extern StgWordArray(foo)"). The type is fixed to StgWordArray.
+--
+-- Symbols from the RTS don't need "extern" declarations because they are
+-- exposed via "includes/Stg.h" with the appropriate type. See 'needsCDecl'.
+--
+-- The fixed StgWordArray type led to "conflicting types" issues with user
+-- provided Cmm files (not in the RTS) that declare data of another type (#15467
+-- and test for #17920). Hence the Cmm parser considers that labels in data
+-- sections don't need the "extern" declaration (just add one explicitly if you
+-- need it).
+--
+-- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes
+-- for why extern declaration are needed at all.
+newtype NeedExternDecl
+ = NeedExternDecl Bool
+ deriving (Ord,Eq)
+
+-- This is laborious, but necessary. We can't derive Ord because
+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
+-- implementation. See Note [No Ord for Unique]
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+instance Ord CLabel where
+ compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =
+ compare a1 a2 `thenCmp`
+ compare b1 b2 `thenCmp`
+ compare c1 c2
+ compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =
+ compare a1 a2 `thenCmp`
+ compare b1 b2 `thenCmp`
+ compare c1 c2 `thenCmp`
+ compare d1 d2
+ compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
+ compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2
+ compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
+ compare a1 a2 `thenCmp`
+ compare b1 b2 `thenCmp`
+ compare c1 c2 `thenCmp`
+ compare d1 d2
+ compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2
+ compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =
+ compare a1 a2 `thenCmp`
+ compare b1 b2
+ compare (StringLitLabel u1) (StringLitLabel u2) =
+ nonDetCmpUnique u1 u2
+ compare (CC_Label a1) (CC_Label a2) =
+ compare a1 a2
+ compare (CCS_Label a1) (CCS_Label a2) =
+ compare a1 a2
+ compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =
+ compare a1 a2 `thenCmp`
+ compare b1 b2
+ compare PicBaseLabel PicBaseLabel = EQ
+ compare (DeadStripPreventer a1) (DeadStripPreventer a2) =
+ compare a1 a2
+ compare (HpcTicksLabel a1) (HpcTicksLabel a2) =
+ compare a1 a2
+ compare (SRTLabel u1) (SRTLabel u2) =
+ nonDetCmpUnique u1 u2
+ compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =
+ nonDetCmpUnique u1 u2
+ compare IdLabel{} _ = LT
+ compare _ IdLabel{} = GT
+ compare CmmLabel{} _ = LT
+ compare _ CmmLabel{} = GT
+ compare RtsLabel{} _ = LT
+ compare _ RtsLabel{} = GT
+ compare LocalBlockLabel{} _ = LT
+ compare _ LocalBlockLabel{} = GT
+ compare ForeignLabel{} _ = LT
+ compare _ ForeignLabel{} = GT
+ compare AsmTempLabel{} _ = LT
+ compare _ AsmTempLabel{} = GT
+ compare AsmTempDerivedLabel{} _ = LT
+ compare _ AsmTempDerivedLabel{} = GT
+ compare StringLitLabel{} _ = LT
+ compare _ StringLitLabel{} = GT
+ compare CC_Label{} _ = LT
+ compare _ CC_Label{} = GT
+ compare CCS_Label{} _ = LT
+ compare _ CCS_Label{} = GT
+ compare DynamicLinkerLabel{} _ = LT
+ compare _ DynamicLinkerLabel{} = GT
+ compare PicBaseLabel{} _ = LT
+ compare _ PicBaseLabel{} = GT
+ compare DeadStripPreventer{} _ = LT
+ compare _ DeadStripPreventer{} = GT
+ compare HpcTicksLabel{} _ = LT
+ compare _ HpcTicksLabel{} = GT
+ compare SRTLabel{} _ = LT
+ compare _ SRTLabel{} = GT
+
+-- | Record where a foreign label is stored.
+data ForeignLabelSource
+
+ -- | Label is in a named package
+ = ForeignLabelInPackage Unit
+
+ -- | Label is in some external, system package that doesn't also
+ -- contain compiled Haskell code, and is not associated with any .hi files.
+ -- We don't have to worry about Haskell code being inlined from
+ -- external packages. It is safe to treat the RTS package as "external".
+ | ForeignLabelInExternalPackage
+
+ -- | Label is in the package currently being compiled.
+ -- This is only used for creating hacky tmp labels during code generation.
+ -- Don't use it in any code that might be inlined across a package boundary
+ -- (ie, core code) else the information will be wrong relative to the
+ -- destination module.
+ | ForeignLabelInThisPackage
+
+ deriving (Eq, Ord)
+
+
+-- | For debugging problems with the CLabel representation.
+-- We can't make a Show instance for CLabel because lots of its components don't have instances.
+-- The regular Outputable instance only shows the label name, and not its other info.
+--
+pprDebugCLabel :: Platform -> CLabel -> SDoc
+pprDebugCLabel platform lbl
+ = case lbl of
+ IdLabel _ _ info-> pprCLabel_other platform lbl
+ <> (parens $ text "IdLabel"
+ <> whenPprDebug (text ":" <> text (show info)))
+ CmmLabel pkg _ext _name _info
+ -> pprCLabel_other platform lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
+
+ RtsLabel{} -> pprCLabel_other platform lbl <> (parens $ text "RtsLabel")
+
+ ForeignLabel _name mSuffix src funOrData
+ -> pprCLabel_other platform lbl <> (parens $ text "ForeignLabel"
+ <+> ppr mSuffix
+ <+> ppr src
+ <+> ppr funOrData)
+
+ _ -> pprCLabel_other platform lbl <> (parens $ text "other CLabel")
+
+
+data IdLabelInfo
+ = Closure -- ^ Label for closure
+ | InfoTable -- ^ Info tables for closures; always read-only
+ | Entry -- ^ Entry point
+ | Slow -- ^ Slow entry point
+
+ | LocalInfoTable -- ^ Like InfoTable but not externally visible
+ | LocalEntry -- ^ Like Entry but not externally visible
+
+ | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id
+
+ | ConEntry -- ^ Constructor entry point
+ | ConInfoTable -- ^ Corresponding info table
+
+ | ClosureTable -- ^ Table of closures for Enum tycons
+
+ | Bytes -- ^ Content of a string literal. See
+ -- Note [Bytes label].
+ | BlockInfoTable -- ^ Like LocalInfoTable but for a proc-point block
+ -- instead of a closure entry-point.
+ -- See Note [Proc-point local block entry-point].
+
+ deriving (Eq, Ord, Show)
+
+
+data RtsLabelInfo
+ = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- ^ Selector thunks
+ | RtsSelectorEntry Bool{-updatable-} Int{-offset-}
+
+ | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks
+ | RtsApEntry Bool{-updatable-} Int{-arity-}
+
+ | RtsPrimOp PrimOp
+ | RtsApFast FastString -- ^ _fast versions of generic apply
+ | RtsSlowFastTickyCtr String
+
+ deriving (Eq, Ord)
+ -- NOTE: Eq on PtrString compares the pointer only, so this isn't
+ -- a real equality.
+
+
+-- | What type of Cmm label we're dealing with.
+-- Determines the suffix appended to the name when a CLabel.CmmLabel
+-- is pretty printed.
+data CmmLabelInfo
+ = CmmInfo -- ^ misc rts info tables, suffix _info
+ | CmmEntry -- ^ misc rts entry points, suffix _entry
+ | CmmRetInfo -- ^ misc rts ret info tables, suffix _info
+ | CmmRet -- ^ misc rts return points, suffix _ret
+ | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure
+ | CmmCode -- ^ misc rts code
+ | CmmClosure -- ^ closures eg CHARLIKE_closure
+ | CmmPrimCall -- ^ a prim call to some hand written Cmm code
+ deriving (Eq, Ord)
+
+data DynamicLinkerLabelInfo
+ = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt
+ | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo
+ | GotSymbolPtr -- ELF: foo@got
+ | GotSymbolOffset -- ELF: foo@gotoff
+
+ deriving (Eq, Ord)
+
+
+-- -----------------------------------------------------------------------------
+-- Constructing CLabels
+-- -----------------------------------------------------------------------------
+
+-- Constructing IdLabels
+-- These are always local:
+
+mkSRTLabel :: Unique -> CLabel
+mkSRTLabel u = SRTLabel u
+
+mkRednCountsLabel :: Name -> CLabel
+mkRednCountsLabel name = IdLabel name NoCafRefs RednCounts -- Note [ticky for LNE]
+
+-- These have local & (possibly) external variants:
+mkLocalClosureLabel :: Name -> CafInfo -> CLabel
+mkLocalInfoTableLabel :: Name -> CafInfo -> CLabel
+mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel
+mkLocalClosureLabel !name !c = IdLabel name c Closure
+mkLocalInfoTableLabel name c = IdLabel name c LocalInfoTable
+mkLocalClosureTableLabel name c = IdLabel name c ClosureTable
+
+mkClosureLabel :: Name -> CafInfo -> CLabel
+mkInfoTableLabel :: Name -> CafInfo -> CLabel
+mkEntryLabel :: Name -> CafInfo -> CLabel
+mkClosureTableLabel :: Name -> CafInfo -> CLabel
+mkConInfoTableLabel :: Name -> CafInfo -> CLabel
+mkBytesLabel :: Name -> CLabel
+mkClosureLabel name c = IdLabel name c Closure
+mkInfoTableLabel name c = IdLabel name c InfoTable
+mkEntryLabel name c = IdLabel name c Entry
+mkClosureTableLabel name c = IdLabel name c ClosureTable
+mkConInfoTableLabel name c = IdLabel name c ConInfoTable
+mkBytesLabel name = IdLabel name NoCafRefs Bytes
+
+mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel
+mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable
+ -- See Note [Proc-point local block entry-point].
+
+-- Constructing Cmm Labels
+mkDirty_MUT_VAR_Label,
+ mkNonmovingWriteBarrierEnabledLabel,
+ mkUpdInfoLabel,
+ mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
+ mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,
+ mkMAP_DIRTY_infoLabel,
+ mkArrWords_infoLabel,
+ mkTopTickyCtrLabel,
+ mkCAFBlackHoleInfoTableLabel,
+ mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,
+ mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel
+mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
+mkNonmovingWriteBarrierEnabledLabel
+ = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData
+mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo
+mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo
+mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo
+mkMainCapabilityLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "MainCapability") CmmData
+mkMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkTopTickyCtrLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "top_ct") CmmData
+mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_CAF_BLACKHOLE") CmmInfo
+mkArrWords_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_ARR_WORDS") CmmInfo
+mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry
+
+mkSRTInfoLabel :: Int -> CLabel
+mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo
+ where
+ lbl =
+ case n of
+ 1 -> fsLit "stg_SRT_1"
+ 2 -> fsLit "stg_SRT_2"
+ 3 -> fsLit "stg_SRT_3"
+ 4 -> fsLit "stg_SRT_4"
+ 5 -> fsLit "stg_SRT_5"
+ 6 -> fsLit "stg_SRT_6"
+ 7 -> fsLit "stg_SRT_7"
+ 8 -> fsLit "stg_SRT_8"
+ 9 -> fsLit "stg_SRT_9"
+ 10 -> fsLit "stg_SRT_10"
+ 11 -> fsLit "stg_SRT_11"
+ 12 -> fsLit "stg_SRT_12"
+ 13 -> fsLit "stg_SRT_13"
+ 14 -> fsLit "stg_SRT_14"
+ 15 -> fsLit "stg_SRT_15"
+ 16 -> fsLit "stg_SRT_16"
+ _ -> panic "mkSRTInfoLabel"
+
+-----
+mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
+ mkCmmCodeLabel, mkCmmClosureLabel
+ :: UnitId -> FastString -> CLabel
+
+mkCmmDataLabel :: UnitId -> NeedExternDecl -> FastString -> CLabel
+mkRtsCmmDataLabel :: FastString -> CLabel
+
+mkCmmInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmInfo
+mkCmmEntryLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmEntry
+mkCmmRetInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRetInfo
+mkCmmRetLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRet
+mkCmmCodeLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmCode
+mkCmmClosureLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmClosure
+mkCmmDataLabel pkg ext str = CmmLabel pkg ext str CmmData
+mkRtsCmmDataLabel str = CmmLabel rtsUnitId (NeedExternDecl False) str CmmData
+ -- RTS symbols don't need "GHC.CmmToC" to
+ -- generate \"extern\" declaration (they are
+ -- exposed via includes/Stg.h)
+
+mkLocalBlockLabel :: Unique -> CLabel
+mkLocalBlockLabel u = LocalBlockLabel u
+
+-- Constructing RtsLabels
+mkRtsPrimOpLabel :: PrimOp -> CLabel
+mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
+
+mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel
+mkSelectorInfoLabel platform upd offset =
+ ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))
+ RtsLabel (RtsSelectorInfoTable upd offset)
+
+mkSelectorEntryLabel :: Platform -> Bool -> Int -> CLabel
+mkSelectorEntryLabel platform upd offset =
+ ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))
+ RtsLabel (RtsSelectorEntry upd offset)
+
+mkApInfoTableLabel :: Platform -> Bool -> Int -> CLabel
+mkApInfoTableLabel platform upd arity =
+ ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))
+ RtsLabel (RtsApInfoTable upd arity)
+
+mkApEntryLabel :: Platform -> Bool -> Int -> CLabel
+mkApEntryLabel platform upd arity =
+ ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))
+ RtsLabel (RtsApEntry upd arity)
+
+
+-- A call to some primitive hand written Cmm code
+mkPrimCallLabel :: PrimCall -> CLabel
+mkPrimCallLabel (PrimCall str pkg)
+ = CmmLabel (toUnitId pkg) (NeedExternDecl True) str CmmPrimCall
+
+
+-- Constructing ForeignLabels
+
+-- | Make a foreign label
+mkForeignLabel
+ :: FastString -- name
+ -> Maybe Int -- size prefix
+ -> ForeignLabelSource -- what package it's in
+ -> FunctionOrData
+ -> CLabel
+
+mkForeignLabel = ForeignLabel
+
+
+-- | Update the label size field in a ForeignLabel
+addLabelSize :: CLabel -> Int -> CLabel
+addLabelSize (ForeignLabel str _ src fod) sz
+ = ForeignLabel str (Just sz) src fod
+addLabelSize label _
+ = label
+
+-- | Whether label is a top-level string literal
+isBytesLabel :: CLabel -> Bool
+isBytesLabel (IdLabel _ _ Bytes) = True
+isBytesLabel _lbl = False
+
+-- | Whether label is a non-haskell label (defined in C code)
+isForeignLabel :: CLabel -> Bool
+isForeignLabel (ForeignLabel _ _ _ _) = True
+isForeignLabel _lbl = False
+
+-- | Whether label is a static closure label (can come from haskell or cmm)
+isStaticClosureLabel :: CLabel -> Bool
+-- Closure defined in haskell (.hs)
+isStaticClosureLabel (IdLabel _ _ Closure) = True
+-- Closure defined in cmm
+isStaticClosureLabel (CmmLabel _ _ _ CmmClosure) = True
+isStaticClosureLabel _lbl = False
+
+-- | Whether label is a .rodata label
+isSomeRODataLabel :: CLabel -> Bool
+-- info table defined in haskell (.hs)
+isSomeRODataLabel (IdLabel _ _ ClosureTable) = True
+isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True
+isSomeRODataLabel (IdLabel _ _ InfoTable) = True
+isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
+isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
+-- info table defined in cmm (.cmm)
+isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True
+isSomeRODataLabel _lbl = False
+
+-- | Whether label is points to some kind of info table
+isInfoTableLabel :: CLabel -> Bool
+isInfoTableLabel (IdLabel _ _ InfoTable) = True
+isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True
+isInfoTableLabel (IdLabel _ _ ConInfoTable) = True
+isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True
+isInfoTableLabel _ = False
+
+-- | Whether label is points to constructor info table
+isConInfoTableLabel :: CLabel -> Bool
+isConInfoTableLabel (IdLabel _ _ ConInfoTable) = True
+isConInfoTableLabel _ = False
+
+-- | Get the label size field from a ForeignLabel
+foreignLabelStdcallInfo :: CLabel -> Maybe Int
+foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
+foreignLabelStdcallInfo _lbl = Nothing
+
+
+-- Constructing Large*Labels
+mkBitmapLabel :: Unique -> CLabel
+mkBitmapLabel uniq = LargeBitmapLabel uniq
+
+-- Constructing Cost Center Labels
+mkCCLabel :: CostCentre -> CLabel
+mkCCSLabel :: CostCentreStack -> CLabel
+mkCCLabel cc = CC_Label cc
+mkCCSLabel ccs = CCS_Label ccs
+
+mkRtsApFastLabel :: FastString -> CLabel
+mkRtsApFastLabel str = RtsLabel (RtsApFast str)
+
+mkRtsSlowFastTickyCtrLabel :: String -> CLabel
+mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)
+
+
+-- Constructing Code Coverage Labels
+mkHpcTicksLabel :: Module -> CLabel
+mkHpcTicksLabel = HpcTicksLabel
+
+
+-- Constructing labels used for dynamic linking
+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
+mkDynamicLinkerLabel = DynamicLinkerLabel
+
+dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)
+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)
+dynamicLinkerLabelInfo _ = Nothing
+
+mkPicBaseLabel :: CLabel
+mkPicBaseLabel = PicBaseLabel
+
+
+-- Constructing miscellaneous other labels
+mkDeadStripPreventer :: CLabel -> CLabel
+mkDeadStripPreventer lbl = DeadStripPreventer lbl
+
+mkStringLitLabel :: Unique -> CLabel
+mkStringLitLabel = StringLitLabel
+
+mkAsmTempLabel :: Uniquable a => a -> CLabel
+mkAsmTempLabel a = AsmTempLabel (getUnique a)
+
+mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel
+mkAsmTempDerivedLabel = AsmTempDerivedLabel
+
+mkAsmTempEndLabel :: CLabel -> CLabel
+mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end")
+
+-- | Construct a label for a DWARF Debug Information Entity (DIE)
+-- describing another symbol.
+mkAsmTempDieLabel :: CLabel -> CLabel
+mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")
+
+-- -----------------------------------------------------------------------------
+-- Convert between different kinds of label
+
+toClosureLbl :: Platform -> CLabel -> CLabel
+toClosureLbl platform lbl = case lbl of
+ IdLabel n c _ -> IdLabel n c Closure
+ CmmLabel m ext str _ -> CmmLabel m ext str CmmClosure
+ _ -> pprPanic "toClosureLbl" (pprCLabel_other platform lbl)
+
+toSlowEntryLbl :: Platform -> CLabel -> CLabel
+toSlowEntryLbl platform lbl = case lbl of
+ IdLabel n _ BlockInfoTable -> pprPanic "toSlowEntryLbl" (ppr n)
+ IdLabel n c _ -> IdLabel n c Slow
+ _ -> pprPanic "toSlowEntryLbl" (pprCLabel_other platform lbl)
+
+toEntryLbl :: Platform -> CLabel -> CLabel
+toEntryLbl platform lbl = case lbl of
+ IdLabel n c LocalInfoTable -> IdLabel n c LocalEntry
+ IdLabel n c ConInfoTable -> IdLabel n c ConEntry
+ IdLabel n _ BlockInfoTable -> mkLocalBlockLabel (nameUnique n)
+ -- See Note [Proc-point local block entry-point].
+ IdLabel n c _ -> IdLabel n c Entry
+ CmmLabel m ext str CmmInfo -> CmmLabel m ext str CmmEntry
+ CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet
+ _ -> pprPanic "toEntryLbl" (pprCLabel_other platform lbl)
+
+toInfoLbl :: Platform -> CLabel -> CLabel
+toInfoLbl platform lbl = case lbl of
+ IdLabel n c LocalEntry -> IdLabel n c LocalInfoTable
+ IdLabel n c ConEntry -> IdLabel n c ConInfoTable
+ IdLabel n c _ -> IdLabel n c InfoTable
+ CmmLabel m ext str CmmEntry -> CmmLabel m ext str CmmInfo
+ CmmLabel m ext str CmmRet -> CmmLabel m ext str CmmRetInfo
+ _ -> pprPanic "CLabel.toInfoLbl" (pprCLabel_other platform lbl)
+
+hasHaskellName :: CLabel -> Maybe Name
+hasHaskellName (IdLabel n _ _) = Just n
+hasHaskellName _ = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel's referent itself refer to a CAF?
+hasCAF :: CLabel -> Bool
+hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE]
+hasCAF (IdLabel _ MayHaveCafRefs _) = True
+hasCAF _ = False
+
+-- Note [ticky for LNE]
+-- ~~~~~~~~~~~~~~~~~~~~~
+
+-- Until 14 Feb 2013, every ticky counter was associated with a
+-- closure. Thus, ticky labels used IdLabel. It is odd that
+-- GHC.Cmm.Info.Build.cafTransfers would consider such a ticky label
+-- reason to add the name to the CAFEnv (and thus eventually the SRT),
+-- but it was harmless because the ticky was only used if the closure
+-- was also.
+--
+-- Since we now have ticky counters for LNEs, it is no longer the case
+-- that every ticky counter has an actual closure. So I changed the
+-- generation of ticky counters' CLabels to not result in their
+-- associated id ending up in the SRT.
+--
+-- NB IdLabel is still appropriate for ticky ids (as opposed to
+-- CmmLabel) because the LNE's counter is still related to an .hs Id,
+-- that Id just isn't for a proper closure.
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel need declaring before use or not?
+--
+-- See wiki:commentary/compiler/backends/ppr-c#prototypes
+
+needsCDecl :: CLabel -> Bool
+ -- False <=> it's pre-declared; don't bother
+ -- don't bother declaring Bitmap labels, we always make sure
+ -- they are defined before use.
+needsCDecl (SRTLabel _) = True
+needsCDecl (LargeBitmapLabel _) = False
+needsCDecl (IdLabel _ _ _) = True
+needsCDecl (LocalBlockLabel _) = True
+
+needsCDecl (StringLitLabel _) = False
+needsCDecl (AsmTempLabel _) = False
+needsCDecl (AsmTempDerivedLabel _ _) = False
+needsCDecl (RtsLabel _) = False
+
+needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _)
+ -- local labels mustn't have it
+ | not external = False
+
+ -- Prototypes for labels defined in the runtime system are imported
+ -- into HC files via includes/Stg.h.
+ | pkgId == rtsUnitId = False
+
+ -- For other labels we inline one into the HC file directly.
+ | otherwise = True
+
+needsCDecl l@(ForeignLabel{}) = not (isMathFun l)
+needsCDecl (CC_Label _) = True
+needsCDecl (CCS_Label _) = True
+needsCDecl (HpcTicksLabel _) = True
+needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel"
+needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel"
+needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer"
+
+-- | If a label is a local block label then return just its 'BlockId', otherwise
+-- 'Nothing'.
+maybeLocalBlockLabel :: CLabel -> Maybe BlockId
+maybeLocalBlockLabel (LocalBlockLabel uq) = Just $ mkBlockId uq
+maybeLocalBlockLabel _ = Nothing
+
+
+-- | Check whether a label corresponds to a C function that has
+-- a prototype in a system header somewhere, or is built-in
+-- to the C compiler. For these labels we avoid generating our
+-- own C prototypes.
+isMathFun :: CLabel -> Bool
+isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs
+isMathFun _ = False
+
+math_funs :: UniqSet FastString
+math_funs = mkUniqSet [
+ -- _ISOC99_SOURCE
+ (fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"),
+ (fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"),
+ (fsLit "asin"), (fsLit "asinf"), (fsLit "asinl"),
+ (fsLit "asinh"), (fsLit "asinhf"), (fsLit "asinhl"),
+ (fsLit "atan"), (fsLit "atanf"), (fsLit "atanl"),
+ (fsLit "atan2"), (fsLit "atan2f"), (fsLit "atan2l"),
+ (fsLit "atanh"), (fsLit "atanhf"), (fsLit "atanhl"),
+ (fsLit "cbrt"), (fsLit "cbrtf"), (fsLit "cbrtl"),
+ (fsLit "ceil"), (fsLit "ceilf"), (fsLit "ceill"),
+ (fsLit "copysign"), (fsLit "copysignf"), (fsLit "copysignl"),
+ (fsLit "cos"), (fsLit "cosf"), (fsLit "cosl"),
+ (fsLit "cosh"), (fsLit "coshf"), (fsLit "coshl"),
+ (fsLit "erf"), (fsLit "erff"), (fsLit "erfl"),
+ (fsLit "erfc"), (fsLit "erfcf"), (fsLit "erfcl"),
+ (fsLit "exp"), (fsLit "expf"), (fsLit "expl"),
+ (fsLit "exp2"), (fsLit "exp2f"), (fsLit "exp2l"),
+ (fsLit "expm1"), (fsLit "expm1f"), (fsLit "expm1l"),
+ (fsLit "fabs"), (fsLit "fabsf"), (fsLit "fabsl"),
+ (fsLit "fdim"), (fsLit "fdimf"), (fsLit "fdiml"),
+ (fsLit "floor"), (fsLit "floorf"), (fsLit "floorl"),
+ (fsLit "fma"), (fsLit "fmaf"), (fsLit "fmal"),
+ (fsLit "fmax"), (fsLit "fmaxf"), (fsLit "fmaxl"),
+ (fsLit "fmin"), (fsLit "fminf"), (fsLit "fminl"),
+ (fsLit "fmod"), (fsLit "fmodf"), (fsLit "fmodl"),
+ (fsLit "frexp"), (fsLit "frexpf"), (fsLit "frexpl"),
+ (fsLit "hypot"), (fsLit "hypotf"), (fsLit "hypotl"),
+ (fsLit "ilogb"), (fsLit "ilogbf"), (fsLit "ilogbl"),
+ (fsLit "ldexp"), (fsLit "ldexpf"), (fsLit "ldexpl"),
+ (fsLit "lgamma"), (fsLit "lgammaf"), (fsLit "lgammal"),
+ (fsLit "llrint"), (fsLit "llrintf"), (fsLit "llrintl"),
+ (fsLit "llround"), (fsLit "llroundf"), (fsLit "llroundl"),
+ (fsLit "log"), (fsLit "logf"), (fsLit "logl"),
+ (fsLit "log10l"), (fsLit "log10"), (fsLit "log10f"),
+ (fsLit "log1pl"), (fsLit "log1p"), (fsLit "log1pf"),
+ (fsLit "log2"), (fsLit "log2f"), (fsLit "log2l"),
+ (fsLit "logb"), (fsLit "logbf"), (fsLit "logbl"),
+ (fsLit "lrint"), (fsLit "lrintf"), (fsLit "lrintl"),
+ (fsLit "lround"), (fsLit "lroundf"), (fsLit "lroundl"),
+ (fsLit "modf"), (fsLit "modff"), (fsLit "modfl"),
+ (fsLit "nan"), (fsLit "nanf"), (fsLit "nanl"),
+ (fsLit "nearbyint"), (fsLit "nearbyintf"), (fsLit "nearbyintl"),
+ (fsLit "nextafter"), (fsLit "nextafterf"), (fsLit "nextafterl"),
+ (fsLit "nexttoward"), (fsLit "nexttowardf"), (fsLit "nexttowardl"),
+ (fsLit "pow"), (fsLit "powf"), (fsLit "powl"),
+ (fsLit "remainder"), (fsLit "remainderf"), (fsLit "remainderl"),
+ (fsLit "remquo"), (fsLit "remquof"), (fsLit "remquol"),
+ (fsLit "rint"), (fsLit "rintf"), (fsLit "rintl"),
+ (fsLit "round"), (fsLit "roundf"), (fsLit "roundl"),
+ (fsLit "scalbln"), (fsLit "scalblnf"), (fsLit "scalblnl"),
+ (fsLit "scalbn"), (fsLit "scalbnf"), (fsLit "scalbnl"),
+ (fsLit "sin"), (fsLit "sinf"), (fsLit "sinl"),
+ (fsLit "sinh"), (fsLit "sinhf"), (fsLit "sinhl"),
+ (fsLit "sqrt"), (fsLit "sqrtf"), (fsLit "sqrtl"),
+ (fsLit "tan"), (fsLit "tanf"), (fsLit "tanl"),
+ (fsLit "tanh"), (fsLit "tanhf"), (fsLit "tanhl"),
+ (fsLit "tgamma"), (fsLit "tgammaf"), (fsLit "tgammal"),
+ (fsLit "trunc"), (fsLit "truncf"), (fsLit "truncl"),
+ -- ISO C 99 also defines these function-like macros in math.h:
+ -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater,
+ -- isgreaterequal, isless, islessequal, islessgreater, isunordered
+
+ -- additional symbols from _BSD_SOURCE
+ (fsLit "drem"), (fsLit "dremf"), (fsLit "dreml"),
+ (fsLit "finite"), (fsLit "finitef"), (fsLit "finitel"),
+ (fsLit "gamma"), (fsLit "gammaf"), (fsLit "gammal"),
+ (fsLit "isinf"), (fsLit "isinff"), (fsLit "isinfl"),
+ (fsLit "isnan"), (fsLit "isnanf"), (fsLit "isnanl"),
+ (fsLit "j0"), (fsLit "j0f"), (fsLit "j0l"),
+ (fsLit "j1"), (fsLit "j1f"), (fsLit "j1l"),
+ (fsLit "jn"), (fsLit "jnf"), (fsLit "jnl"),
+ (fsLit "lgamma_r"), (fsLit "lgammaf_r"), (fsLit "lgammal_r"),
+ (fsLit "scalb"), (fsLit "scalbf"), (fsLit "scalbl"),
+ (fsLit "significand"), (fsLit "significandf"), (fsLit "significandl"),
+ (fsLit "y0"), (fsLit "y0f"), (fsLit "y0l"),
+ (fsLit "y1"), (fsLit "y1f"), (fsLit "y1l"),
+ (fsLit "yn"), (fsLit "ynf"), (fsLit "ynl"),
+
+ -- These functions are described in IEEE Std 754-2008 -
+ -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661
+ (fsLit "nextup"), (fsLit "nextupf"), (fsLit "nextupl"),
+ (fsLit "nextdown"), (fsLit "nextdownf"), (fsLit "nextdownl")
+ ]
+
+-- -----------------------------------------------------------------------------
+-- | Is a CLabel visible outside this object file or not?
+-- From the point of view of the code generator, a name is
+-- externally visible if it has to be declared as exported
+-- in the .o file's symbol table; that is, made non-static.
+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
+externallyVisibleCLabel (StringLitLabel _) = False
+externallyVisibleCLabel (AsmTempLabel _) = False
+externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False
+externallyVisibleCLabel (RtsLabel _) = True
+externallyVisibleCLabel (LocalBlockLabel _) = False
+externallyVisibleCLabel (CmmLabel _ _ _ _) = True
+externallyVisibleCLabel (ForeignLabel{}) = True
+externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info
+externallyVisibleCLabel (CC_Label _) = True
+externallyVisibleCLabel (CCS_Label _) = True
+externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
+externallyVisibleCLabel (HpcTicksLabel _) = True
+externallyVisibleCLabel (LargeBitmapLabel _) = False
+externallyVisibleCLabel (SRTLabel _) = False
+externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
+externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
+
+externallyVisibleIdLabel :: IdLabelInfo -> Bool
+externallyVisibleIdLabel LocalInfoTable = False
+externallyVisibleIdLabel LocalEntry = False
+externallyVisibleIdLabel BlockInfoTable = False
+externallyVisibleIdLabel _ = True
+
+-- -----------------------------------------------------------------------------
+-- Finding the "type" of a CLabel
+
+-- For generating correct types in label declarations:
+
+data CLabelType
+ = CodeLabel -- Address of some executable instructions
+ | DataLabel -- Address of data, not a GC ptr
+ | GcPtrLabel -- Address of a (presumably static) GC object
+
+isCFunctionLabel :: CLabel -> Bool
+isCFunctionLabel lbl = case labelType lbl of
+ CodeLabel -> True
+ _other -> False
+
+isGcPtrLabel :: CLabel -> Bool
+isGcPtrLabel lbl = case labelType lbl of
+ GcPtrLabel -> True
+ _other -> False
+
+
+-- | Work out the general type of data at the address of this label
+-- whether it be code, data, or static GC object.
+labelType :: CLabel -> CLabelType
+labelType (IdLabel _ _ info) = idInfoLabelType info
+labelType (CmmLabel _ _ _ CmmData) = DataLabel
+labelType (CmmLabel _ _ _ CmmClosure) = GcPtrLabel
+labelType (CmmLabel _ _ _ CmmCode) = CodeLabel
+labelType (CmmLabel _ _ _ CmmInfo) = DataLabel
+labelType (CmmLabel _ _ _ CmmEntry) = CodeLabel
+labelType (CmmLabel _ _ _ CmmPrimCall) = CodeLabel
+labelType (CmmLabel _ _ _ CmmRetInfo) = DataLabel
+labelType (CmmLabel _ _ _ CmmRet) = CodeLabel
+labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
+labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel
+labelType (RtsLabel (RtsApFast _)) = CodeLabel
+labelType (RtsLabel _) = DataLabel
+labelType (LocalBlockLabel _) = CodeLabel
+labelType (SRTLabel _) = DataLabel
+labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
+labelType (ForeignLabel _ _ _ IsData) = DataLabel
+labelType (AsmTempLabel _) = panic "labelType(AsmTempLabel)"
+labelType (AsmTempDerivedLabel _ _) = panic "labelType(AsmTempDerivedLabel)"
+labelType (StringLitLabel _) = DataLabel
+labelType (CC_Label _) = DataLabel
+labelType (CCS_Label _) = DataLabel
+labelType (DynamicLinkerLabel _ _) = DataLabel -- Is this right?
+labelType PicBaseLabel = DataLabel
+labelType (DeadStripPreventer _) = DataLabel
+labelType (HpcTicksLabel _) = DataLabel
+labelType (LargeBitmapLabel _) = DataLabel
+
+idInfoLabelType :: IdLabelInfo -> CLabelType
+idInfoLabelType info =
+ case info of
+ InfoTable -> DataLabel
+ LocalInfoTable -> DataLabel
+ BlockInfoTable -> DataLabel
+ Closure -> GcPtrLabel
+ ConInfoTable -> DataLabel
+ ClosureTable -> DataLabel
+ RednCounts -> DataLabel
+ Bytes -> DataLabel
+ _ -> CodeLabel
+
+
+-- -----------------------------------------------------------------------------
+
+-- | Is a 'CLabel' defined in the current module being compiled?
+--
+-- Sometimes we can optimise references within a compilation unit in ways that
+-- we couldn't for inter-module references. This provides a conservative
+-- estimate of whether a 'CLabel' lives in the current module.
+isLocalCLabel :: Module -> CLabel -> Bool
+isLocalCLabel this_mod lbl =
+ case lbl of
+ IdLabel name _ _
+ | isInternalName name -> True
+ | otherwise -> nameModule name == this_mod
+ LocalBlockLabel _ -> True
+ _ -> False
+
+-- -----------------------------------------------------------------------------
+
+-- | Does a 'CLabel' need dynamic linkage?
+--
+-- When referring to data in code, we need to know whether
+-- that data resides in a DLL or not. [Win32 only.]
+-- @labelDynamic@ returns @True@ if the label is located
+-- in a DLL, be it a data reference or not.
+labelDynamic :: NCGConfig -> Module -> CLabel -> Bool
+labelDynamic config this_mod lbl =
+ case lbl of
+ -- is the RTS in a DLL or not?
+ RtsLabel _ ->
+ externalDynamicRefs && (this_pkg /= rtsUnit)
+
+ IdLabel n _ _ ->
+ externalDynamicRefs && isDynLinkName platform this_mod n
+
+ -- When compiling in the "dyn" way, each package is to be linked into
+ -- its own shared library.
+ CmmLabel pkg _ _ _
+ | os == OSMinGW32 -> externalDynamicRefs && (toUnitId this_pkg /= pkg)
+ | otherwise -> externalDynamicRefs
+
+ LocalBlockLabel _ -> False
+
+ ForeignLabel _ _ source _ ->
+ if os == OSMinGW32
+ then case source of
+ -- Foreign label is in some un-named foreign package (or DLL).
+ ForeignLabelInExternalPackage -> True
+
+ -- Foreign label is linked into the same package as the
+ -- source file currently being compiled.
+ ForeignLabelInThisPackage -> False
+
+ -- Foreign label is in some named package.
+ -- When compiling in the "dyn" way, each package is to be
+ -- linked into its own DLL.
+ ForeignLabelInPackage pkgId ->
+ externalDynamicRefs && (this_pkg /= pkgId)
+
+ else -- On Mac OS X and on ELF platforms, false positives are OK,
+ -- so we claim that all foreign imports come from dynamic
+ -- libraries
+ True
+
+ CC_Label cc ->
+ externalDynamicRefs && not (ccFromThisModule cc this_mod)
+
+ -- CCS_Label always contains a CostCentre defined in the current module
+ CCS_Label _ -> False
+
+ HpcTicksLabel m ->
+ externalDynamicRefs && this_mod /= m
+
+ -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
+ _ -> False
+ where
+ externalDynamicRefs = ncgExternalDynamicRefs config
+ platform = ncgPlatform config
+ os = platformOS platform
+ this_pkg = moduleUnit this_mod
+
+
+-----------------------------------------------------------------------------
+-- Printing out CLabels.
+
+{-
+Convention:
+
+ <name>_<type>
+
+where <name> is <Module>_<name> for external names and <unique> for
+internal names. <type> is one of the following:
+
+ info Info table
+ srt Static reference table
+ entry Entry code (function, closure)
+ slow Slow entry code (if any)
+ ret Direct return address
+ vtbl Vector table
+ <n>_alt Case alternative (tag n)
+ dflt Default case alternative
+ btm Large bitmap vector
+ closure Static closure
+ con_entry Dynamic Constructor entry code
+ con_info Dynamic Constructor info table
+ static_entry Static Constructor entry code
+ static_info Static Constructor info table
+ sel_info Selector info table
+ sel_entry Selector entry code
+ cc Cost centre
+ ccs Cost centre stack
+
+Many of these distinctions are only for documentation reasons. For
+example, _ret is only distinguished from _entry to make it easy to
+tell whether a code fragment is a return point or a closure/function
+entry.
+
+Note [Closure and info labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a function 'foo, we have:
+ foo_info : Points to the info table describing foo's closure
+ (and entry code for foo with tables next to code)
+ foo_closure : Static (no-free-var) closure only:
+ points to the statically-allocated closure
+
+For a data constructor (such as Just or Nothing), we have:
+ Just_con_info: Info table for the data constructor itself
+ the first word of a heap-allocated Just
+ Just_info: Info table for the *worker function*, an
+ ordinary Haskell function of arity 1 that
+ allocates a (Just x) box:
+ Just = \x -> Just x
+ Just_closure: The closure for this worker
+
+ Nothing_closure: a statically allocated closure for Nothing
+ Nothing_static_info: info table for Nothing_closure
+
+All these must be exported symbol, EXCEPT Just_info. We don't need to
+export this because in other modules we either have
+ * A reference to 'Just'; use Just_closure
+ * A saturated call 'Just x'; allocate using Just_con_info
+Not exporting these Just_info labels reduces the number of symbols
+somewhat.
+
+Note [Bytes label]
+~~~~~~~~~~~~~~~~~~
+For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which
+points to a static data block containing the content of the literal.
+
+Note [Proc-point local block entry-points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A label for a proc-point local block entry-point has no "_entry" suffix. With
+`infoTblLbl` we derive an info table label from a proc-point block ID. If
+we convert such an info table label into an entry label we must produce
+the label without an "_entry" suffix. So an info table label records
+the fact that it was derived from a block ID in `IdLabelInfo` as
+`BlockInfoTable`.
+
+The info table label and the local block label are both local labels
+and are not externally visible.
+-}
+
+instance Outputable CLabel where
+ ppr lbl = sdocWithDynFlags (\dflags -> pprCLabel (backend dflags) (targetPlatform dflags) lbl)
+
+pprCLabel :: Backend -> Platform -> CLabel -> SDoc
+pprCLabel bcknd platform lbl =
+ case bcknd of
+ NCG -> pprCLabel_NCG platform lbl
+ LLVM -> pprCLabel_LLVM platform lbl
+ _ -> pprCLabel_other platform lbl
+
+pprCLabel_LLVM :: Platform -> CLabel -> SDoc
+pprCLabel_LLVM = pprCLabel_NCG
+
+pprCLabel_NCG :: Platform -> CLabel -> SDoc
+pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
+ let
+ -- some platform (e.g. Darwin) require a leading "_" for exported asm
+ -- symbols
+ maybe_underscore :: SDoc -> SDoc
+ maybe_underscore doc =
+ if platformLeadingUnderscore platform
+ then pp_cSEP <> doc
+ else doc
+
+ in case lbl of
+ LocalBlockLabel u
+ -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+
+ AsmTempLabel u
+ -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+
+ AsmTempDerivedLabel l suf
+ -> ptext (asmTempLabelPrefix platform)
+ <> case l of AsmTempLabel u -> pprUniqueAlways u
+ LocalBlockLabel u -> pprUniqueAlways u
+ _other -> pprCLabel_NCG platform l
+ <> ftext suf
+
+ DynamicLinkerLabel info lbl
+ -> pprDynamicLinkerAsmLabel platform info lbl
+
+ PicBaseLabel
+ -> text "1b"
+
+ DeadStripPreventer lbl
+ ->
+ {-
+ `lbl` can be temp one but we need to ensure that dsp label will stay
+ in the final binary so we prepend non-temp prefix ("dsp_") and
+ optional `_` (underscore) because this is how you mark non-temp symbols
+ on some platforms (Darwin)
+ -}
+ maybe_underscore $ text "dsp_" <> pprCLabel_NCG platform lbl <> text "_dsp"
+
+ StringLitLabel u
+ -> pprUniqueAlways u <> ptext (sLit "_str")
+
+ ForeignLabel fs (Just sz) _ _
+ | asmStyle sty
+ , OSMinGW32 <- platformOS platform
+ -> -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
+ -- (The C compiler does this itself).
+ maybe_underscore $ ftext fs <> char '@' <> int sz
+
+ _ | asmStyle sty -> maybe_underscore $ pprCLabel_common platform lbl
+ | otherwise -> pprCLabel_common platform lbl
+
+pprCLabel_other :: Platform -> CLabel -> SDoc
+pprCLabel_other platform lbl =
+ case lbl of
+ LocalBlockLabel u
+ -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+
+ AsmTempLabel u
+ | not (platformUnregisterised platform)
+ -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+
+ lbl -> pprCLabel_common platform lbl
+
+
+pprCLabel_common :: Platform -> CLabel -> SDoc
+pprCLabel_common platform = \case
+ (StringLitLabel u) -> pprUniqueAlways u <> text "_str"
+ (SRTLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"
+ (LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore platform
+ <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
+ -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')
+ -- until that gets resolved we'll just force them to start
+ -- with a letter so the label will be legal assembly code.
+
+ (CmmLabel _ _ str CmmCode) -> ftext str
+ (CmmLabel _ _ str CmmData) -> ftext str
+ (CmmLabel _ _ str CmmPrimCall) -> ftext str
+
+ (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
+
+ (RtsLabel (RtsApFast str)) -> ftext str <> text "_fast"
+
+ (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) ->
+ hcat [text "stg_sel_", text (show offset),
+ ptext (if upd_reqd
+ then (sLit "_upd_info")
+ else (sLit "_noupd_info"))
+ ]
+
+ (RtsLabel (RtsSelectorEntry upd_reqd offset)) ->
+ hcat [text "stg_sel_", text (show offset),
+ ptext (if upd_reqd
+ then (sLit "_upd_entry")
+ else (sLit "_noupd_entry"))
+ ]
+
+ (RtsLabel (RtsApInfoTable upd_reqd arity)) ->
+ hcat [text "stg_ap_", text (show arity),
+ ptext (if upd_reqd
+ then (sLit "_upd_info")
+ else (sLit "_noupd_info"))
+ ]
+
+ (RtsLabel (RtsApEntry upd_reqd arity)) ->
+ hcat [text "stg_ap_", text (show arity),
+ ptext (if upd_reqd
+ then (sLit "_upd_entry")
+ else (sLit "_noupd_entry"))
+ ]
+
+ (CmmLabel _ _ fs CmmInfo) -> ftext fs <> text "_info"
+ (CmmLabel _ _ fs CmmEntry) -> ftext fs <> text "_entry"
+ (CmmLabel _ _ fs CmmRetInfo) -> ftext fs <> text "_info"
+ (CmmLabel _ _ fs CmmRet) -> ftext fs <> text "_ret"
+ (CmmLabel _ _ fs CmmClosure) -> ftext fs <> text "_closure"
+
+ (RtsLabel (RtsPrimOp primop)) -> text "stg_" <> ppr primop
+ (RtsLabel (RtsSlowFastTickyCtr pat)) ->
+ text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
+
+ (ForeignLabel str _ _ _) -> ftext str
+
+ (IdLabel name _cafs flavor) -> internalNamePrefix platform name <> ppr name <> ppIdFlavor flavor
+
+ (CC_Label cc) -> ppr cc
+ (CCS_Label ccs) -> ppr ccs
+ (HpcTicksLabel mod) -> text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
+
+ (AsmTempLabel {}) -> panic "pprCLabel_common AsmTempLabel"
+ (AsmTempDerivedLabel {}) -> panic "pprCLabel_common AsmTempDerivedLabel"
+ (DynamicLinkerLabel {}) -> panic "pprCLabel_common DynamicLinkerLabel"
+ (PicBaseLabel {}) -> panic "pprCLabel_common PicBaseLabel"
+ (DeadStripPreventer {}) -> panic "pprCLabel_common DeadStripPreventer"
+
+ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor x = pp_cSEP <> text
+ (case x of
+ Closure -> "closure"
+ InfoTable -> "info"
+ LocalInfoTable -> "info"
+ Entry -> "entry"
+ LocalEntry -> "entry"
+ Slow -> "slow"
+ RednCounts -> "ct"
+ ConEntry -> "con_entry"
+ ConInfoTable -> "con_info"
+ ClosureTable -> "closure_tbl"
+ Bytes -> "bytes"
+ BlockInfoTable -> "info"
+ )
+
+
+pp_cSEP :: SDoc
+pp_cSEP = char '_'
+
+
+instance Outputable ForeignLabelSource where
+ ppr fs
+ = case fs of
+ ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId
+ ForeignLabelInThisPackage -> parens $ text "this package"
+ ForeignLabelInExternalPackage -> parens $ text "external package"
+
+internalNamePrefix :: Platform -> Name -> SDoc
+internalNamePrefix platform name = getPprStyle $ \ sty ->
+ if asmStyle sty && isRandomGenerated then
+ ptext (asmTempLabelPrefix platform)
+ else
+ empty
+ where
+ isRandomGenerated = not $ isExternalName name
+
+tempLabelPrefixOrUnderscore :: Platform -> SDoc
+tempLabelPrefixOrUnderscore platform =
+ getPprStyle $ \ sty ->
+ if asmStyle sty then
+ ptext (asmTempLabelPrefix platform)
+ else
+ char '_'
+
+-- -----------------------------------------------------------------------------
+-- Machine-dependent knowledge about labels.
+
+asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels
+asmTempLabelPrefix platform = case platformOS platform of
+ OSDarwin -> sLit "L"
+ OSAIX -> sLit "__L" -- follow IBM XL C's convention
+ _ -> sLit ".L"
+
+pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc
+pprDynamicLinkerAsmLabel platform dllInfo lbl =
+ case platformOS platform of
+ OSDarwin
+ | platformArch platform == ArchX86_64 ->
+ case dllInfo of
+ CodeStub -> char 'L' <> ppLbl <> text "$stub"
+ SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr"
+ GotSymbolPtr -> ppLbl <> text "@GOTPCREL"
+ GotSymbolOffset -> ppLbl
+ | otherwise ->
+ case dllInfo of
+ CodeStub -> char 'L' <> ppLbl <> text "$stub"
+ SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr"
+ _ -> panic "pprDynamicLinkerAsmLabel"
+
+ OSAIX ->
+ case dllInfo of
+ SymbolPtr -> text "LC.." <> ppLbl -- GCC's naming convention
+ _ -> panic "pprDynamicLinkerAsmLabel"
+
+ _ | osElfTarget (platformOS platform) -> elfLabel
+
+ OSMinGW32 ->
+ case dllInfo of
+ SymbolPtr -> text "__imp_" <> ppLbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
+
+ _ -> panic "pprDynamicLinkerAsmLabel"
+ where
+ ppLbl = pprCLabel_NCG platform lbl
+ elfLabel
+ | platformArch platform == ArchPPC
+ = case dllInfo of
+ CodeStub -> -- See Note [.LCTOC1 in PPC PIC code]
+ ppLbl <> text "+32768@plt"
+ SymbolPtr -> text ".LC_" <> ppLbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
+
+ | platformArch platform == ArchX86_64
+ = case dllInfo of
+ CodeStub -> ppLbl <> text "@plt"
+ GotSymbolPtr -> ppLbl <> text "@gotpcrel"
+ GotSymbolOffset -> ppLbl
+ SymbolPtr -> text ".LC_" <> ppLbl
+
+ | platformArch platform == ArchPPC_64 ELF_V1
+ || platformArch platform == ArchPPC_64 ELF_V2
+ = case dllInfo of
+ GotSymbolPtr -> text ".LC_" <> ppLbl <> text "@toc"
+ GotSymbolOffset -> ppLbl
+ SymbolPtr -> text ".LC_" <> ppLbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
+
+ | otherwise
+ = case dllInfo of
+ CodeStub -> ppLbl <> text "@plt"
+ SymbolPtr -> text ".LC_" <> ppLbl
+ GotSymbolPtr -> ppLbl <> text "@got"
+ GotSymbolOffset -> ppLbl <> text "@gotoff"
+
+-- Figure out whether `symbol` may serve as an alias
+-- to `target` within one compilation unit.
+--
+-- This is true if any of these holds:
+-- * `target` is a module-internal haskell name.
+-- * `target` is an exported name, but comes from the same
+-- module as `symbol`
+--
+-- These are sufficient conditions for establishing e.g. a
+-- GNU assembly alias ('.equiv' directive). Sadly, there is
+-- no such thing as an alias to an imported symbol (conf.
+-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)
+-- See note [emit-time elimination of static indirections].
+--
+-- Precondition is that both labels represent the
+-- same semantic value.
+
+mayRedirectTo :: CLabel -> CLabel -> Bool
+mayRedirectTo symbol target
+ | Just nam <- haskellName
+ , staticClosureLabel
+ , isExternalName nam
+ , Just mod <- nameModule_maybe nam
+ , Just anam <- hasHaskellName symbol
+ , Just amod <- nameModule_maybe anam
+ = amod == mod
+
+ | Just nam <- haskellName
+ , staticClosureLabel
+ , isInternalName nam
+ = True
+
+ | otherwise = False
+ where staticClosureLabel = isStaticClosureLabel target
+ haskellName = hasHaskellName target
+
+
+{-
+Note [emit-time elimination of static indirections]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As described in #15155, certain static values are representationally
+equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).
+
+ newtype A = A Int
+ {-# NOINLINE a #-}
+ a = A 42
+
+a1_rYB :: Int
+[GblId, Caf=NoCafRefs, Unf=OtherCon []]
+a1_rYB = GHC.Types.I# 42#
+
+a [InlPrag=NOINLINE] :: A
+[GblId, Unf=OtherCon []]
+a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)
+
+Formerly we created static indirections for these (IND_STATIC), which
+consist of a statically allocated forwarding closure that contains
+the (possibly tagged) indirectee. (See CMM/assembly below.)
+This approach is suboptimal for two reasons:
+ (a) they occupy extra space,
+ (b) they need to be entered in order to obtain the indirectee,
+ thus they cannot be tagged.
+
+Fortunately there is a common case where static indirections can be
+eliminated while emitting assembly (native or LLVM), viz. when the
+indirectee is in the same module (object file) as the symbol that
+points to it. In this case an assembly-level identification can
+be created ('.equiv' directive), and as such the same object will
+be assigned two names in the symbol table. Any of the identified
+symbols can be referenced by a tagged pointer.
+
+Currently the 'mayRedirectTo' predicate will
+give a clue whether a label can be equated with another, already
+emitted, label (which can in turn be an alias). The general mechanics
+is that we identify data (IND_STATIC closures) that are amenable
+to aliasing while pretty-printing of assembly output, and emit the
+'.equiv' directive instead of static data in such a case.
+
+Here is a sketch how the output is massaged:
+
+ Consider
+newtype A = A Int
+{-# NOINLINE a #-}
+a = A 42 -- I# 42# is the indirectee
+ -- 'a' is exported
+
+ results in STG
+
+a1_rXq :: GHC.Types.Int
+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
+ CCS_DONT_CARE GHC.Types.I#! [42#];
+
+T15155.a [InlPrag=NOINLINE] :: T15155.A
+[GblId, Unf=OtherCon []] =
+ CAF_ccs \ u [] a1_rXq;
+
+ and CMM
+
+[section ""data" . a1_rXq_closure" {
+ a1_rXq_closure:
+ const GHC.Types.I#_con_info;
+ const 42;
+ }]
+
+[section ""data" . T15155.a_closure" {
+ T15155.a_closure:
+ const stg_IND_STATIC_info;
+ const a1_rXq_closure+1;
+ const 0;
+ const 0;
+ }]
+
+The emitted assembly is
+
+#### INDIRECTEE
+a1_rXq_closure: -- module local haskell value
+ .quad GHC.Types.I#_con_info -- an Int
+ .quad 42
+
+#### BEFORE
+.globl T15155.a_closure -- exported newtype wrapped value
+T15155.a_closure:
+ .quad stg_IND_STATIC_info -- the closure info
+ .quad a1_rXq_closure+1 -- indirectee ('+1' being the tag)
+ .quad 0
+ .quad 0
+
+#### AFTER
+.globl T15155.a_closure -- exported newtype wrapped value
+.equiv a1_rXq_closure,T15155.a_closure -- both are shared
+
+The transformation is performed because
+ T15155.a_closure `mayRedirectTo` a1_rXq_closure+1
+returns True.
+-}
diff --git a/compiler/GHC/Cmm/Dataflow/Block.hs b/compiler/GHC/Cmm/Dataflow/Block.hs
new file mode 100644
index 0000000..f3876e2
--- /dev/null
+++ b/compiler/GHC/Cmm/Dataflow/Block.hs
@@ -0,0 +1,323 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+module GHC.Cmm.Dataflow.Block
+ ( Extensibility (..)
+ , O
+ , C
+ , MaybeO(..)
+ , IndexedCO
+ , Block(..)
+ , blockAppend
+ , blockCons
+ , blockFromList
+ , blockJoin
+ , blockJoinHead
+ , blockJoinTail
+ , blockSnoc
+ , blockSplit
+ , blockSplitHead
+ , blockSplitTail
+ , blockToList
+ , emptyBlock
+ , firstNode
+ , foldBlockNodesB
+ , foldBlockNodesB3
+ , foldBlockNodesF
+ , isEmptyBlock
+ , lastNode
+ , mapBlock
+ , mapBlock'
+ , mapBlock3'
+ , replaceFirstNode
+ , replaceLastNode
+ ) where
+
+import GHC.Prelude
+
+-- -----------------------------------------------------------------------------
+-- Shapes: Open and Closed
+
+-- | Used at the type level to indicate "open" vs "closed" structure.
+data Extensibility
+ -- | An "open" structure with a unique, unnamed control-flow edge flowing in
+ -- or out. \"Fallthrough\" and concatenation are permitted at an open point.
+ = Open
+ -- | A "closed" structure which supports control transfer only through the use
+ -- of named labels---no "fallthrough" is permitted. The number of control-flow
+ -- edges is unconstrained.
+ | Closed
+
+type O = 'Open
+type C = 'Closed
+
+-- | Either type indexed by closed/open using type families
+type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k
+type instance IndexedCO C a _b = a
+type instance IndexedCO O _a b = b
+
+-- | Maybe type indexed by open/closed
+data MaybeO ex t where
+ JustO :: t -> MaybeO O t
+ NothingO :: MaybeO C t
+
+deriving instance Functor (MaybeO ex)
+
+-- -----------------------------------------------------------------------------
+-- The Block type
+
+-- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C).
+-- Open at the entry means single entry, mutatis mutandis for exit.
+-- A closed/closed block is a /basic/ block and can't be extended further.
+-- Clients should avoid manipulating blocks and should stick to either nodes
+-- or graphs.
+data Block n e x where
+ BlockCO :: n C O -> Block n O O -> Block n C O
+ BlockCC :: n C O -> Block n O O -> n O C -> Block n C C
+ BlockOC :: Block n O O -> n O C -> Block n O C
+
+ BNil :: Block n O O
+ BMiddle :: n O O -> Block n O O
+ BCat :: Block n O O -> Block n O O -> Block n O O
+ BSnoc :: Block n O O -> n O O -> Block n O O
+ BCons :: n O O -> Block n O O -> Block n O O
+
+
+-- -----------------------------------------------------------------------------
+-- Simple operations on Blocks
+
+-- Predicates
+
+isEmptyBlock :: Block n e x -> Bool
+isEmptyBlock BNil = True
+isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r
+isEmptyBlock _ = False
+
+
+-- Building
+
+emptyBlock :: Block n O O
+emptyBlock = BNil
+
+blockCons :: n O O -> Block n O x -> Block n O x
+blockCons n b = case b of
+ BlockOC b l -> (BlockOC $! (n `blockCons` b)) l
+ BNil{} -> BMiddle n
+ BMiddle{} -> n `BCons` b
+ BCat{} -> n `BCons` b
+ BSnoc{} -> n `BCons` b
+ BCons{} -> n `BCons` b
+
+blockSnoc :: Block n e O -> n O O -> Block n e O
+blockSnoc b n = case b of
+ BlockCO f b -> BlockCO f $! (b `blockSnoc` n)
+ BNil{} -> BMiddle n
+ BMiddle{} -> b `BSnoc` n
+ BCat{} -> b `BSnoc` n
+ BSnoc{} -> b `BSnoc` n
+ BCons{} -> b `BSnoc` n
+
+blockJoinHead :: n C O -> Block n O x -> Block n C x
+blockJoinHead f (BlockOC b l) = BlockCC f b l
+blockJoinHead f b = BlockCO f BNil `cat` b
+
+blockJoinTail :: Block n e O -> n O C -> Block n e C
+blockJoinTail (BlockCO f b) t = BlockCC f b t
+blockJoinTail b t = b `cat` BlockOC BNil t
+
+blockJoin :: n C O -> Block n O O -> n O C -> Block n C C
+blockJoin f b t = BlockCC f b t
+
+blockAppend :: Block n e O -> Block n O x -> Block n e x
+blockAppend = cat
+
+
+-- Taking apart
+
+firstNode :: Block n C x -> n C O
+firstNode (BlockCO n _) = n
+firstNode (BlockCC n _ _) = n
+
+lastNode :: Block n x C -> n O C
+lastNode (BlockOC _ n) = n
+lastNode (BlockCC _ _ n) = n
+
+blockSplitHead :: Block n C x -> (n C O, Block n O x)
+blockSplitHead (BlockCO n b) = (n, b)
+blockSplitHead (BlockCC n b t) = (n, BlockOC b t)
+
+blockSplitTail :: Block n e C -> (Block n e O, n O C)
+blockSplitTail (BlockOC b n) = (b, n)
+blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
+
+-- | Split a closed block into its entry node, open middle block, and
+-- exit node.
+blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
+blockSplit (BlockCC f b t) = (f, b, t)
+
+blockToList :: Block n O O -> [n O O]
+blockToList b = go b []
+ where go :: Block n O O -> [n O O] -> [n O O]
+ go BNil r = r
+ go (BMiddle n) r = n : r
+ go (BCat b1 b2) r = go b1 $! go b2 r
+ go (BSnoc b1 n) r = go b1 (n:r)
+ go (BCons n b1) r = n : go b1 r
+
+blockFromList :: [n O O] -> Block n O O
+blockFromList = foldr BCons BNil
+
+-- Modifying
+
+replaceFirstNode :: Block n C x -> n C O -> Block n C x
+replaceFirstNode (BlockCO _ b) f = BlockCO f b
+replaceFirstNode (BlockCC _ b n) f = BlockCC f b n
+
+replaceLastNode :: Block n x C -> n O C -> Block n x C
+replaceLastNode (BlockOC b _) n = BlockOC b n
+replaceLastNode (BlockCC l b _) n = BlockCC l b n
+
+-- -----------------------------------------------------------------------------
+-- General concatenation
+
+cat :: Block n e O -> Block n O x -> Block n e x
+cat x y = case x of
+ BNil -> y
+
+ BlockCO l b1 -> case y of
+ BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n
+ BNil -> x
+ BMiddle _ -> BlockCO l $! (b1 `cat` y)
+ BCat{} -> BlockCO l $! (b1 `cat` y)
+ BSnoc{} -> BlockCO l $! (b1 `cat` y)
+ BCons{} -> BlockCO l $! (b1 `cat` y)
+
+ BMiddle n -> case y of
+ BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+ BNil -> x
+ BMiddle{} -> BCons n y
+ BCat{} -> BCons n y
+ BSnoc{} -> BCons n y
+ BCons{} -> BCons n y
+
+ BCat{} -> case y of
+ BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2
+ BNil -> x
+ BMiddle n -> BSnoc x n
+ BCat{} -> BCat x y
+ BSnoc{} -> BCat x y
+ BCons{} -> BCat x y
+
+ BSnoc{} -> case y of
+ BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+ BNil -> x
+ BMiddle n -> BSnoc x n
+ BCat{} -> BCat x y
+ BSnoc{} -> BCat x y
+ BCons{} -> BCat x y
+
+
+ BCons{} -> case y of
+ BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+ BNil -> x
+ BMiddle n -> BSnoc x n
+ BCat{} -> BCat x y
+ BSnoc{} -> BCat x y
+ BCons{} -> BCat x y
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping
+
+-- | map a function over the nodes of a 'Block'
+mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
+mapBlock f (BlockCO n b ) = BlockCO (f n) (mapBlock f b)
+mapBlock f (BlockOC b n) = BlockOC (mapBlock f b) (f n)
+mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)
+mapBlock _ BNil = BNil
+mapBlock f (BMiddle n) = BMiddle (f n)
+mapBlock f (BCat b1 b2) = BCat (mapBlock f b1) (mapBlock f b2)
+mapBlock f (BSnoc b n) = BSnoc (mapBlock f b) (f n)
+mapBlock f (BCons n b) = BCons (f n) (mapBlock f b)
+
+-- | A strict 'mapBlock'
+mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)
+mapBlock' f = mapBlock3' (f, f, f)
+
+-- | map over a block, with different functions to apply to first nodes,
+-- middle nodes and last nodes respectively. The map is strict.
+--
+mapBlock3' :: forall n n' e x .
+ ( n C O -> n' C O
+ , n O O -> n' O O,
+ n O C -> n' O C)
+ -> Block n e x -> Block n' e x
+mapBlock3' (f, m, l) b = go b
+ where go :: forall e x . Block n e x -> Block n' e x
+ go (BlockOC b y) = (BlockOC $! go b) $! l y
+ go (BlockCO x b) = (BlockCO $! f x) $! (go b)
+ go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)
+ go BNil = BNil
+ go (BMiddle n) = BMiddle $! m n
+ go (BCat x y) = (BCat $! go x) $! (go y)
+ go (BSnoc x n) = (BSnoc $! go x) $! (m n)
+ go (BCons n x) = (BCons $! m n) $! (go x)
+
+-- -----------------------------------------------------------------------------
+-- Folding
+
+
+-- | Fold a function over every node in a block, forward or backward.
+-- The fold function must be polymorphic in the shape of the nodes.
+foldBlockNodesF3 :: forall n a b c .
+ ( n C O -> a -> b
+ , n O O -> b -> b
+ , n O C -> b -> c)
+ -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
+foldBlockNodesF :: forall n a .
+ (forall e x . n e x -> a -> a)
+ -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
+foldBlockNodesB3 :: forall n a b c .
+ ( n C O -> b -> c
+ , n O O -> b -> b
+ , n O C -> a -> b)
+ -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
+foldBlockNodesB :: forall n a .
+ (forall e x . n e x -> a -> a)
+ -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
+
+foldBlockNodesF3 (ff, fm, fl) = block
+ where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
+ block (BlockCO f b ) = ff f `cat` block b
+ block (BlockCC f b l) = ff f `cat` block b `cat` fl l
+ block (BlockOC b l) = block b `cat` fl l
+ block BNil = id
+ block (BMiddle node) = fm node
+ block (b1 `BCat` b2) = block b1 `cat` block b2
+ block (b1 `BSnoc` n) = block b1 `cat` fm n
+ block (n `BCons` b2) = fm n `cat` block b2
+ cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
+ cat f f' = f' . f
+
+foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
+
+foldBlockNodesB3 (ff, fm, fl) = block
+ where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
+ block (BlockCO f b ) = ff f `cat` block b
+ block (BlockCC f b l) = ff f `cat` block b `cat` fl l
+ block (BlockOC b l) = block b `cat` fl l
+ block BNil = id
+ block (BMiddle node) = fm node
+ block (b1 `BCat` b2) = block b1 `cat` block b2
+ block (b1 `BSnoc` n) = block b1 `cat` fm n
+ block (n `BCons` b2) = fm n `cat` block b2
+ cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
+ cat f f' = f . f'
+
+foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
+
diff --git a/compiler/GHC/Cmm/Dataflow/Collections.hs b/compiler/GHC/Cmm/Dataflow/Collections.hs
new file mode 100644
index 0000000..1fb8f5d
--- /dev/null
+++ b/compiler/GHC/Cmm/Dataflow/Collections.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module GHC.Cmm.Dataflow.Collections
+ ( IsSet(..)
+ , setInsertList, setDeleteList, setUnions
+ , IsMap(..)
+ , mapInsertList, mapDeleteList, mapUnions
+ , UniqueMap, UniqueSet
+ ) where
+
+import GHC.Prelude
+
+import qualified Data.IntMap.Strict as M
+import qualified Data.IntSet as S
+
+import Data.List (foldl1')
+
+class IsSet set where
+ type ElemOf set
+
+ setNull :: set -> Bool
+ setSize :: set -> Int
+ setMember :: ElemOf set -> set -> Bool
+
+ setEmpty :: set
+ setSingleton :: ElemOf set -> set
+ setInsert :: ElemOf set -> set -> set
+ setDelete :: ElemOf set -> set -> set
+
+ setUnion :: set -> set -> set
+ setDifference :: set -> set -> set
+ setIntersection :: set -> set -> set
+ setIsSubsetOf :: set -> set -> Bool
+ setFilter :: (ElemOf set -> Bool) -> set -> set
+
+ setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
+ setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
+
+ setElems :: set -> [ElemOf set]
+ setFromList :: [ElemOf set] -> set
+
+-- Helper functions for IsSet class
+setInsertList :: IsSet set => [ElemOf set] -> set -> set
+setInsertList keys set = foldl' (flip setInsert) set keys
+
+setDeleteList :: IsSet set => [ElemOf set] -> set -> set
+setDeleteList keys set = foldl' (flip setDelete) set keys
+
+setUnions :: IsSet set => [set] -> set
+setUnions [] = setEmpty
+setUnions sets = foldl1' setUnion sets
+
+
+class IsMap map where
+ type KeyOf map
+
+ mapNull :: map a -> Bool
+ mapSize :: map a -> Int
+ mapMember :: KeyOf map -> map a -> Bool
+ mapLookup :: KeyOf map -> map a -> Maybe a
+ mapFindWithDefault :: a -> KeyOf map -> map a -> a
+
+ mapEmpty :: map a
+ mapSingleton :: KeyOf map -> a -> map a
+ mapInsert :: KeyOf map -> a -> map a -> map a
+ mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
+ mapDelete :: KeyOf map -> map a -> map a
+ mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
+ mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a
+
+ mapUnion :: map a -> map a -> map a
+ mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
+ mapDifference :: map a -> map a -> map a
+ mapIntersection :: map a -> map a -> map a
+ mapIsSubmapOf :: Eq a => map a -> map a -> Bool
+
+ mapMap :: (a -> b) -> map a -> map b
+ mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
+ mapFoldl :: (b -> a -> b) -> b -> map a -> b
+ mapFoldr :: (a -> b -> b) -> b -> map a -> b
+ mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
+ mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m
+ mapFilter :: (a -> Bool) -> map a -> map a
+ mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a
+
+
+ mapElems :: map a -> [a]
+ mapKeys :: map a -> [KeyOf map]
+ mapToList :: map a -> [(KeyOf map, a)]
+ mapFromList :: [(KeyOf map, a)] -> map a
+ mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a
+
+-- Helper functions for IsMap class
+mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a
+mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs
+
+mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a
+mapDeleteList keys map = foldl' (flip mapDelete) map keys
+
+mapUnions :: IsMap map => [map a] -> map a
+mapUnions [] = mapEmpty
+mapUnions maps = foldl1' mapUnion maps
+
+-----------------------------------------------------------------------------
+-- Basic instances
+-----------------------------------------------------------------------------
+
+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)
+
+instance IsSet UniqueSet where
+ type ElemOf UniqueSet = Int
+
+ setNull (US s) = S.null s
+ setSize (US s) = S.size s
+ setMember k (US s) = S.member k s
+
+ setEmpty = US S.empty
+ setSingleton k = US (S.singleton k)
+ setInsert k (US s) = US (S.insert k s)
+ setDelete k (US s) = US (S.delete k s)
+
+ setUnion (US x) (US y) = US (S.union x y)
+ setDifference (US x) (US y) = US (S.difference x y)
+ setIntersection (US x) (US y) = US (S.intersection x y)
+ setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
+ setFilter f (US s) = US (S.filter f s)
+
+ setFoldl k z (US s) = S.foldl' k z s
+ setFoldr k z (US s) = S.foldr k z s
+
+ setElems (US s) = S.elems s
+ setFromList ks = US (S.fromList ks)
+
+newtype UniqueMap v = UM (M.IntMap v)
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap UniqueMap where
+ type KeyOf UniqueMap = Int
+
+ mapNull (UM m) = M.null m
+ mapSize (UM m) = M.size m
+ mapMember k (UM m) = M.member k m
+ mapLookup k (UM m) = M.lookup k m
+ mapFindWithDefault def k (UM m) = M.findWithDefault def k m
+
+ mapEmpty = UM M.empty
+ mapSingleton k v = UM (M.singleton k v)
+ mapInsert k v (UM m) = UM (M.insert k v m)
+ mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
+ mapDelete k (UM m) = UM (M.delete k m)
+ mapAlter f k (UM m) = UM (M.alter f k m)
+ mapAdjust f k (UM m) = UM (M.adjust f k m)
+
+ mapUnion (UM x) (UM y) = UM (M.union x y)
+ mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
+ mapDifference (UM x) (UM y) = UM (M.difference x y)
+ mapIntersection (UM x) (UM y) = UM (M.intersection x y)
+ mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
+
+ mapMap f (UM m) = UM (M.map f m)
+ mapMapWithKey f (UM m) = UM (M.mapWithKey f m)
+ mapFoldl k z (UM m) = M.foldl' k z m
+ mapFoldr k z (UM m) = M.foldr k z m
+ mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
+ mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m
+ {-# INLINEABLE mapFilter #-}
+ mapFilter f (UM m) = UM (M.filter f m)
+ {-# INLINEABLE mapFilterWithKey #-}
+ mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)
+
+ mapElems (UM m) = M.elems m
+ mapKeys (UM m) = M.keys m
+ {-# INLINEABLE mapToList #-}
+ mapToList (UM m) = M.toList m
+ mapFromList assocs = UM (M.fromList assocs)
+ mapFromListWith f assocs = UM (M.fromListWith f assocs)
diff --git a/compiler/GHC/Cmm/Dataflow/Graph.hs b/compiler/GHC/Cmm/Dataflow/Graph.hs
new file mode 100644
index 0000000..3fbdae8
--- /dev/null
+++ b/compiler/GHC/Cmm/Dataflow/Graph.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module GHC.Cmm.Dataflow.Graph
+ ( Body
+ , Graph
+ , Graph'(..)
+ , NonLocal(..)
+ , addBlock
+ , bodyList
+ , emptyBody
+ , labelsDefined
+ , mapGraph
+ , mapGraphBlocks
+ , revPostorderFrom
+ ) where
+
+
+import GHC.Prelude
+import GHC.Utils.Misc
+
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Collections
+
+import Data.Kind
+
+-- | A (possibly empty) collection of closed/closed blocks
+type Body n = LabelMap (Block n C C)
+
+-- | @Body@ abstracted over @block@
+type Body' block (n :: Extensibility -> Extensibility -> Type) = LabelMap (block n C C)
+
+-------------------------------
+-- | Gives access to the anchor points for
+-- nonlocal edges as well as the edges themselves
+class NonLocal thing where
+ entryLabel :: thing C x -> Label -- ^ The label of a first node or block
+ successors :: thing e C -> [Label] -- ^ Gives control-flow successors
+
+instance NonLocal n => NonLocal (Block n) where
+ entryLabel (BlockCO f _) = entryLabel f
+ entryLabel (BlockCC f _ _) = entryLabel f
+
+ successors (BlockOC _ n) = successors n
+ successors (BlockCC _ _ n) = successors n
+
+
+emptyBody :: Body' block n
+emptyBody = mapEmpty
+
+bodyList :: Body' block n -> [(Label,block n C C)]
+bodyList body = mapToList body
+
+addBlock
+ :: (NonLocal block, HasDebugCallStack)
+ => block C C -> LabelMap (block C C) -> LabelMap (block C C)
+addBlock block body = mapAlter add lbl body
+ where
+ lbl = entryLabel block
+ add Nothing = Just block
+ add _ = error $ "duplicate label " ++ show lbl ++ " in graph"
+
+
+-- ---------------------------------------------------------------------------
+-- Graph
+
+-- | A control-flow graph, which may take any of four shapes (O/O,
+-- O/C, C/O, C/C). A graph open at the entry has a single,
+-- distinguished, anonymous entry point; if a graph is closed at the
+-- entry, its entry point(s) are supplied by a context.
+type Graph = Graph' Block
+
+-- | @Graph'@ is abstracted over the block type, so that we can build
+-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
+-- needs this).
+data Graph' block (n :: Extensibility -> Extensibility -> Type) e x where
+ GNil :: Graph' block n O O
+ GUnit :: block n O O -> Graph' block n O O
+ GMany :: MaybeO e (block n O C)
+ -> Body' block n
+ -> MaybeO x (block n C O)
+ -> Graph' block n e x
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping over graphs
+
+-- | Maps over all nodes in a graph.
+mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
+mapGraph f = mapGraphBlocks (mapBlock f)
+
+-- | Function 'mapGraphBlocks' enables a change of representation of blocks,
+-- nodes, or both. It lifts a polymorphic block transform into a polymorphic
+-- graph transform. When the block representation stabilizes, a similar
+-- function should be provided for blocks.
+mapGraphBlocks :: forall block n block' n' e x .
+ (forall e x . block n e x -> block' n' e x)
+ -> (Graph' block n e x -> Graph' block' n' e x)
+
+mapGraphBlocks f = map
+ where map :: Graph' block n e x -> Graph' block' n' e x
+ map GNil = GNil
+ map (GUnit b) = GUnit (f b)
+ map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
+
+-- -----------------------------------------------------------------------------
+-- Extracting Labels from graphs
+
+labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
+ -> LabelSet
+labelsDefined GNil = setEmpty
+labelsDefined (GUnit{}) = setEmpty
+labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
+ where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet
+ addEntry labels label _ = setInsert label labels
+ exitLabel :: MaybeO x (block n C O) -> LabelSet
+ exitLabel NothingO = setEmpty
+ exitLabel (JustO b) = setSingleton (entryLabel b)
+
+
+----------------------------------------------------------------
+
+-- | Returns a list of blocks reachable from the provided Labels in the reverse
+-- postorder.
+--
+-- This is the most important traversal over this data structure. It drops
+-- unreachable code and puts blocks in an order that is good for solving forward
+-- dataflow problems quickly. The reverse order is good for solving backward
+-- dataflow problems quickly. The forward order is also reasonably good for
+-- emitting instructions, except that it will not usually exploit Forrest
+-- Baskett's trick of eliminating the unconditional branch from a loop. For
+-- that you would need a more serious analysis, probably based on dominators, to
+-- identify loop headers.
+--
+-- For forward analyses we want reverse postorder visitation, consider:
+-- @
+-- A -> [B,C]
+-- B -> D
+-- C -> D
+-- @
+-- Postorder: [D, C, B, A] (or [D, B, C, A])
+-- Reverse postorder: [A, B, C, D] (or [A, C, B, D])
+-- This matters for, e.g., forward analysis, because we want to analyze *both*
+-- B and C before we analyze D.
+revPostorderFrom
+ :: forall block. (NonLocal block)
+ => LabelMap (block C C) -> Label -> [block C C]
+revPostorderFrom graph start = go start_worklist setEmpty []
+ where
+ start_worklist = lookup_for_descend start Nil
+
+ -- To compute the postorder we need to "visit" a block (mark as done)
+ -- *after* visiting all its successors. So we need to know whether we
+ -- already processed all successors of each block (and @NonLocal@ allows
+ -- arbitrary many successors). So we use an explicit stack with an extra bit
+ -- of information:
+ -- * @ConsTodo@ means to explore the block if it wasn't visited before
+ -- * @ConsMark@ means that all successors were already done and we can add
+ -- the block to the result.
+ --
+ -- NOTE: We add blocks to the result list in postorder, but we *prepend*
+ -- them (i.e., we use @(:)@), which means that the final list is in reverse
+ -- postorder.
+ go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
+ go Nil !_ !result = result
+ go (ConsMark block rest) !wip_or_done !result =
+ go rest wip_or_done (block : result)
+ go (ConsTodo block rest) !wip_or_done !result
+ | entryLabel block `setMember` wip_or_done = go rest wip_or_done result
+ | otherwise =
+ let new_worklist =
+ foldr lookup_for_descend
+ (ConsMark block rest)
+ (successors block)
+ in go new_worklist (setInsert (entryLabel block) wip_or_done) result
+
+ lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
+ lookup_for_descend label wl
+ | Just b <- mapLookup label graph = ConsTodo b wl
+ | otherwise =
+ error $ "Label that doesn't have a block?! " ++ show label
+
+data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil
diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs
new file mode 100644
index 0000000..a63cc63
--- /dev/null
+++ b/compiler/GHC/Cmm/Dataflow/Label.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module GHC.Cmm.Dataflow.Label
+ ( Label
+ , LabelMap
+ , LabelSet
+ , FactBase
+ , lookupFact
+ , mkHooplLabel
+ ) where
+
+import GHC.Prelude
+
+import GHC.Utils.Outputable
+
+-- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
+import GHC.Cmm.Dataflow.Collections
+
+import GHC.Types.Unique (Uniquable(..))
+import GHC.Data.TrieMap
+
+
+-----------------------------------------------------------------------------
+-- Label
+-----------------------------------------------------------------------------
+
+newtype Label = Label { lblToUnique :: Int }
+ deriving (Eq, Ord)
+
+mkHooplLabel :: Int -> Label
+mkHooplLabel = Label
+
+instance Show Label where
+ show (Label n) = "L" ++ show n
+
+instance Uniquable Label where
+ getUnique label = getUnique (lblToUnique label)
+
+instance Outputable Label where
+ ppr label = ppr (getUnique label)
+
+-----------------------------------------------------------------------------
+-- LabelSet
+
+newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)
+
+instance IsSet LabelSet where
+ type ElemOf LabelSet = Label
+
+ setNull (LS s) = setNull s
+ setSize (LS s) = setSize s
+ setMember (Label k) (LS s) = setMember k s
+
+ setEmpty = LS setEmpty
+ setSingleton (Label k) = LS (setSingleton k)
+ setInsert (Label k) (LS s) = LS (setInsert k s)
+ setDelete (Label k) (LS s) = LS (setDelete k s)
+
+ setUnion (LS x) (LS y) = LS (setUnion x y)
+ setDifference (LS x) (LS y) = LS (setDifference x y)
+ setIntersection (LS x) (LS y) = LS (setIntersection x y)
+ setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
+ setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)
+ setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
+ setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
+
+ setElems (LS s) = map mkHooplLabel (setElems s)
+ setFromList ks = LS (setFromList (map lblToUnique ks))
+
+-----------------------------------------------------------------------------
+-- LabelMap
+
+newtype LabelMap v = LM (UniqueMap v)
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap LabelMap where
+ type KeyOf LabelMap = Label
+
+ mapNull (LM m) = mapNull m
+ mapSize (LM m) = mapSize m
+ mapMember (Label k) (LM m) = mapMember k m
+ mapLookup (Label k) (LM m) = mapLookup k m
+ mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
+
+ mapEmpty = LM mapEmpty
+ mapSingleton (Label k) v = LM (mapSingleton k v)
+ mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
+ mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
+ mapDelete (Label k) (LM m) = LM (mapDelete k m)
+ mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
+ mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)
+
+ mapUnion (LM x) (LM y) = LM (mapUnion x y)
+ mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
+ mapDifference (LM x) (LM y) = LM (mapDifference x y)
+ mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
+ mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
+
+ mapMap f (LM m) = LM (mapMap f m)
+ mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
+ mapFoldl k z (LM m) = mapFoldl k z m
+ mapFoldr k z (LM m) = mapFoldr k z m
+ mapFoldlWithKey k z (LM m) =
+ mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
+ mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
+ {-# INLINEABLE mapFilter #-}
+ mapFilter f (LM m) = LM (mapFilter f m)
+ {-# INLINEABLE mapFilterWithKey #-}
+ mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
+
+ mapElems (LM m) = mapElems m
+ mapKeys (LM m) = map mkHooplLabel (mapKeys m)
+ {-# INLINEABLE mapToList #-}
+ mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
+ mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
+ mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
+
+-----------------------------------------------------------------------------
+-- Instances
+
+instance Outputable LabelSet where
+ ppr = ppr . setElems
+
+instance Outputable a => Outputable (LabelMap a) where
+ ppr = ppr . mapToList
+
+instance TrieMap LabelMap where
+ type Key LabelMap = Label
+ emptyTM = mapEmpty
+ lookupTM k m = mapLookup k m
+ alterTM k f m = mapAlter f k m
+ foldTM k m z = mapFoldr k z m
+ mapTM f m = mapMap f m
+
+-----------------------------------------------------------------------------
+-- FactBase
+
+type FactBase f = LabelMap f
+
+lookupFact :: Label -> FactBase f -> Maybe f
+lookupFact = mapLookup
diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs
new file mode 100644
index 0000000..43d6734
--- /dev/null
+++ b/compiler/GHC/Cmm/Expr.hs
@@ -0,0 +1,623 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module GHC.Cmm.Expr
+ ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr
+ , CmmReg(..), cmmRegType, cmmRegWidth
+ , CmmLit(..), cmmLitType
+ , LocalReg(..), localRegType
+ , GlobalReg(..), isArgReg, globalRegType
+ , spReg, hpReg, spLimReg, hpLimReg, nodeReg
+ , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
+ , node, baseReg
+ , VGcPtr(..)
+
+ , DefinerOfRegs, UserOfRegs
+ , foldRegsDefd, foldRegsUsed
+ , foldLocalRegsDefd, foldLocalRegsUsed
+
+ , RegSet, LocalRegSet, GlobalRegSet
+ , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
+ , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
+ , regSetToList
+
+ , Area(..)
+ , module GHC.Cmm.MachOp
+ , module GHC.Cmm.Type
+ )
+where
+
+import GHC.Prelude
+
+import GHC.Platform
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Cmm.MachOp
+import GHC.Cmm.Type
+import GHC.Driver.Session
+import GHC.Utils.Outputable (panic)
+import GHC.Types.Unique
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf)
+
+-----------------------------------------------------------------------------
+-- CmmExpr
+-- An expression. Expressions have no side effects.
+-----------------------------------------------------------------------------
+
+data CmmExpr
+ = CmmLit CmmLit -- Literal
+ | CmmLoad !CmmExpr !CmmType -- Read memory location
+ | CmmReg !CmmReg -- Contents of register
+ | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.)
+ | CmmStackSlot Area {-# UNPACK #-} !Int
+ -- addressing expression of a stack slot
+ -- See Note [CmmStackSlot aliasing]
+ | CmmRegOff !CmmReg Int
+ -- CmmRegOff reg i
+ -- ** is shorthand only, meaning **
+ -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
+ -- where rep = typeWidth (cmmRegType reg)
+
+instance Eq CmmExpr where -- Equality ignores the types
+ CmmLit l1 == CmmLit l2 = l1==l2
+ CmmLoad e1 _ == CmmLoad e2 _ = e1==e2
+ CmmReg r1 == CmmReg r2 = r1==r2
+ CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2
+ CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2
+ CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
+ _e1 == _e2 = False
+
+data CmmReg
+ = CmmLocal {-# UNPACK #-} !LocalReg
+ | CmmGlobal GlobalReg
+ deriving( Eq, Ord )
+
+-- | A stack area is either the stack slot where a variable is spilled
+-- or the stack space where function arguments and results are passed.
+data Area
+ = Old -- See Note [Old Area]
+ | Young {-# UNPACK #-} !BlockId -- Invariant: must be a continuation BlockId
+ -- See Note [Continuation BlockId] in GHC.Cmm.Node.
+ deriving (Eq, Ord)
+
+{- Note [Old Area]
+~~~~~~~~~~~~~~~~~~
+There is a single call area 'Old', allocated at the extreme old
+end of the stack frame (ie just younger than the return address)
+which holds:
+ * incoming (overflow) parameters,
+ * outgoing (overflow) parameter to tail calls,
+ * outgoing (overflow) result values
+ * the update frame (if any)
+
+Its size is the max of all these requirements. On entry, the stack
+pointer will point to the youngest incoming parameter, which is not
+necessarily at the young end of the Old area.
+
+End of note -}
+
+
+{- Note [CmmStackSlot aliasing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When do two CmmStackSlots alias?
+
+ - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M
+ - T[old+N] aliases with U[old+M] only if the areas actually overlap
+
+Or more informally, different Areas may overlap with each other.
+
+An alternative semantics, that we previously had, was that different
+Areas do not overlap. The problem that lead to redefining the
+semantics of stack areas is described below.
+
+e.g. if we had
+
+ x = Sp[old + 8]
+ y = Sp[old + 16]
+
+ Sp[young(L) + 8] = L
+ Sp[young(L) + 16] = y
+ Sp[young(L) + 24] = x
+ call f() returns to L
+
+if areas semantically do not overlap, then we might optimise this to
+
+ Sp[young(L) + 8] = L
+ Sp[young(L) + 16] = Sp[old + 8]
+ Sp[young(L) + 24] = Sp[old + 16]
+ call f() returns to L
+
+and now young(L) cannot be allocated at the same place as old, and we
+are doomed to use more stack.
+
+ - old+8 conflicts with young(L)+8
+ - old+16 conflicts with young(L)+16 and young(L)+8
+
+so young(L)+8 == old+24 and we get
+
+ Sp[-8] = L
+ Sp[-16] = Sp[8]
+ Sp[-24] = Sp[0]
+ Sp -= 24
+ call f() returns to L
+
+However, if areas are defined to be "possibly overlapping" in the
+semantics, then we cannot commute any loads/stores of old with
+young(L), and we will be able to re-use both old+8 and old+16 for
+young(L).
+
+ x = Sp[8]
+ y = Sp[0]
+
+ Sp[8] = L
+ Sp[0] = y
+ Sp[-8] = x
+ Sp = Sp - 8
+ call f() returns to L
+
+Now, the assignments of y go away,
+
+ x = Sp[8]
+ Sp[8] = L
+ Sp[-8] = x
+ Sp = Sp - 8
+ call f() returns to L
+-}
+
+data CmmLit
+ = CmmInt !Integer Width
+ -- Interpretation: the 2's complement representation of the value
+ -- is truncated to the specified size. This is easier than trying
+ -- to keep the value within range, because we don't know whether
+ -- it will be used as a signed or unsigned value (the CmmType doesn't
+ -- distinguish between signed & unsigned).
+ | CmmFloat Rational Width
+ | CmmVec [CmmLit] -- Vector literal
+ | CmmLabel CLabel -- Address of label
+ | CmmLabelOff CLabel Int -- Address of label + byte offset
+
+ -- Due to limitations in the C backend, the following
+ -- MUST ONLY be used inside the info table indicated by label2
+ -- (label2 must be the info label), and label1 must be an
+ -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
+ -- Don't use it at all unless tablesNextToCode.
+ -- It is also used inside the NCG during when generating
+ -- position-independent code.
+ | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset
+ -- In an expression, the width just has the effect of MO_SS_Conv
+ -- from wordWidth to the desired width.
+ --
+ -- In a static literal, the supported Widths depend on the
+ -- architecture: wordWidth is supported on all
+ -- architectures. Additionally W32 is supported on x86_64 when
+ -- using the small memory model.
+
+ | CmmBlock {-# UNPACK #-} !BlockId -- Code label
+ -- Invariant: must be a continuation BlockId
+ -- See Note [Continuation BlockId] in GHC.Cmm.Node.
+
+ | CmmHighStackMark -- A late-bound constant that stands for the max
+ -- #bytes of stack space used during a procedure.
+ -- During the stack-layout pass, CmmHighStackMark
+ -- is replaced by a CmmInt for the actual number
+ -- of bytes used
+ deriving Eq
+
+cmmExprType :: Platform -> CmmExpr -> CmmType
+cmmExprType platform = \case
+ (CmmLit lit) -> cmmLitType platform lit
+ (CmmLoad _ rep) -> rep
+ (CmmReg reg) -> cmmRegType platform reg
+ (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)
+ (CmmRegOff reg _) -> cmmRegType platform reg
+ (CmmStackSlot _ _) -> bWord platform -- an address
+ -- Careful though: what is stored at the stack slot may be bigger than
+ -- an address
+
+cmmLitType :: Platform -> CmmLit -> CmmType
+cmmLitType platform = \case
+ (CmmInt _ width) -> cmmBits width
+ (CmmFloat _ width) -> cmmFloat width
+ (CmmVec []) -> panic "cmmLitType: CmmVec []"
+ (CmmVec (l:ls)) -> let ty = cmmLitType platform l
+ in if all (`cmmEqType` ty) (map (cmmLitType platform) ls)
+ then cmmVec (1+length ls) ty
+ else panic "cmmLitType: CmmVec"
+ (CmmLabel lbl) -> cmmLabelType platform lbl
+ (CmmLabelOff lbl _) -> cmmLabelType platform lbl
+ (CmmLabelDiffOff _ _ _ width) -> cmmBits width
+ (CmmBlock _) -> bWord platform
+ (CmmHighStackMark) -> bWord platform
+
+cmmLabelType :: Platform -> CLabel -> CmmType
+cmmLabelType platform lbl
+ | isGcPtrLabel lbl = gcWord platform
+ | otherwise = bWord platform
+
+cmmExprWidth :: Platform -> CmmExpr -> Width
+cmmExprWidth platform e = typeWidth (cmmExprType platform e)
+
+-- | Returns an alignment in bytes of a CmmExpr when it's a statically
+-- known integer constant, otherwise returns an alignment of 1 byte.
+-- The caller is responsible for using with a sensible CmmExpr
+-- argument.
+cmmExprAlignment :: CmmExpr -> Alignment
+cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)
+cmmExprAlignment _ = mkAlignment 1
+--------
+--- Negation for conditional branches
+
+maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
+maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
+ return (CmmMachOp op' args)
+maybeInvertCmmExpr _ = Nothing
+
+-----------------------------------------------------------------------------
+-- Local registers
+-----------------------------------------------------------------------------
+
+data LocalReg
+ = LocalReg {-# UNPACK #-} !Unique CmmType
+ -- ^ Parameters:
+ -- 1. Identifier
+ -- 2. Type
+
+instance Eq LocalReg where
+ (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
+instance Ord LocalReg where
+ compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2
+
+instance Uniquable LocalReg where
+ getUnique (LocalReg uniq _) = uniq
+
+cmmRegType :: Platform -> CmmReg -> CmmType
+cmmRegType _ (CmmLocal reg) = localRegType reg
+cmmRegType platform (CmmGlobal reg) = globalRegType platform reg
+
+cmmRegWidth :: Platform -> CmmReg -> Width
+cmmRegWidth platform = typeWidth . cmmRegType platform
+
+localRegType :: LocalReg -> CmmType
+localRegType (LocalReg _ rep) = rep
+
+-----------------------------------------------------------------------------
+-- Register-use information for expressions and other types
+-----------------------------------------------------------------------------
+
+-- | Sets of registers
+
+-- These are used for dataflow facts, and a common operation is taking
+-- the union of two RegSets and then asking whether the union is the
+-- same as one of the inputs. UniqSet isn't good here, because
+-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
+-- Sets.
+
+type RegSet r = Set r
+type LocalRegSet = RegSet LocalReg
+type GlobalRegSet = RegSet GlobalReg
+
+emptyRegSet :: RegSet r
+nullRegSet :: RegSet r -> Bool
+elemRegSet :: Ord r => r -> RegSet r -> Bool
+extendRegSet :: Ord r => RegSet r -> r -> RegSet r
+deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r
+mkRegSet :: Ord r => [r] -> RegSet r
+minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r
+sizeRegSet :: RegSet r -> Int
+regSetToList :: RegSet r -> [r]
+
+emptyRegSet = Set.empty
+nullRegSet = Set.null
+elemRegSet = Set.member
+extendRegSet = flip Set.insert
+deleteFromRegSet = flip Set.delete
+mkRegSet = Set.fromList
+minusRegSet = Set.difference
+plusRegSet = Set.union
+timesRegSet = Set.intersection
+sizeRegSet = Set.size
+regSetToList = Set.toList
+
+class Ord r => UserOfRegs r a where
+ foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b
+
+foldLocalRegsUsed :: UserOfRegs LocalReg a
+ => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+foldLocalRegsUsed = foldRegsUsed
+
+class Ord r => DefinerOfRegs r a where
+ foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b
+
+foldLocalRegsDefd :: DefinerOfRegs LocalReg a
+ => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+foldLocalRegsDefd = foldRegsDefd
+
+instance UserOfRegs LocalReg CmmReg where
+ foldRegsUsed _ f z (CmmLocal reg) = f z reg
+ foldRegsUsed _ _ z (CmmGlobal _) = z
+
+instance DefinerOfRegs LocalReg CmmReg where
+ foldRegsDefd _ f z (CmmLocal reg) = f z reg
+ foldRegsDefd _ _ z (CmmGlobal _) = z
+
+instance UserOfRegs GlobalReg CmmReg where
+ foldRegsUsed _ _ z (CmmLocal _) = z
+ foldRegsUsed _ f z (CmmGlobal reg) = f z reg
+
+instance DefinerOfRegs GlobalReg CmmReg where
+ foldRegsDefd _ _ z (CmmLocal _) = z
+ foldRegsDefd _ f z (CmmGlobal reg) = f z reg
+
+instance Ord r => UserOfRegs r r where
+ foldRegsUsed _ f z r = f z r
+
+instance Ord r => DefinerOfRegs r r where
+ foldRegsDefd _ f z r = f z r
+
+instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
+ -- The (Ord r) in the context is necessary here
+ -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance
+ foldRegsUsed dflags f !z e = expr z e
+ where expr z (CmmLit _) = z
+ expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr
+ expr z (CmmReg r) = foldRegsUsed dflags f z r
+ expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs
+ expr z (CmmRegOff r _) = foldRegsUsed dflags f z r
+ expr z (CmmStackSlot _ _) = z
+
+instance UserOfRegs r a => UserOfRegs r [a] where
+ foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as
+ {-# INLINABLE foldRegsUsed #-}
+
+instance DefinerOfRegs r a => DefinerOfRegs r [a] where
+ foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as
+ {-# INLINABLE foldRegsDefd #-}
+
+-----------------------------------------------------------------------------
+-- Global STG registers
+-----------------------------------------------------------------------------
+
+data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
+
+-----------------------------------------------------------------------------
+-- Global STG registers
+-----------------------------------------------------------------------------
+{-
+Note [Overlapping global registers]
+
+The backend might not faithfully implement the abstraction of the STG
+machine with independent registers for different values of type
+GlobalReg. Specifically, certain pairs of registers (r1, r2) may
+overlap in the sense that a store to r1 invalidates the value in r2,
+and vice versa.
+
+Currently this occurs only on the x86_64 architecture where FloatReg n
+and DoubleReg n are assigned the same microarchitectural register, in
+order to allow functions to receive more Float# or Double# arguments
+in registers (as opposed to on the stack).
+
+There are no specific rules about which registers might overlap with
+which other registers, but presumably it's safe to assume that nothing
+will overlap with special registers like Sp or BaseReg.
+
+Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap
+on a particular platform. The instance Eq GlobalReg is syntactic
+equality of STG registers and does not take overlap into
+account. However it is still used in UserOfRegs/DefinerOfRegs and
+there are likely still bugs there, beware!
+-}
+
+data GlobalReg
+ -- Argument and return registers
+ = VanillaReg -- pointers, unboxed ints and chars
+ {-# UNPACK #-} !Int -- its number
+ VGcPtr
+
+ | FloatReg -- single-precision floating-point registers
+ {-# UNPACK #-} !Int -- its number
+
+ | DoubleReg -- double-precision floating-point registers
+ {-# UNPACK #-} !Int -- its number
+
+ | LongReg -- long int registers (64-bit, really)
+ {-# UNPACK #-} !Int -- its number
+
+ | XmmReg -- 128-bit SIMD vector register
+ {-# UNPACK #-} !Int -- its number
+
+ | YmmReg -- 256-bit SIMD vector register
+ {-# UNPACK #-} !Int -- its number
+
+ | ZmmReg -- 512-bit SIMD vector register
+ {-# UNPACK #-} !Int -- its number
+
+ -- STG registers
+ | Sp -- Stack ptr; points to last occupied stack location.
+ | SpLim -- Stack limit
+ | Hp -- Heap ptr; points to last occupied heap location.
+ | HpLim -- Heap limit register
+ | CCCS -- Current cost-centre stack
+ | CurrentTSO -- pointer to current thread's TSO
+ | CurrentNursery -- pointer to allocation area
+ | HpAlloc -- allocation count for heap check failure
+
+ -- We keep the address of some commonly-called
+ -- functions in the register table, to keep code
+ -- size down:
+ | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
+ | GCEnter1 -- stg_gc_enter_1
+ | GCFun -- stg_gc_fun
+
+ -- Base offset for the register table, used for accessing registers
+ -- which do not have real registers assigned to them. This register
+ -- will only appear after we have expanded GlobalReg into memory accesses
+ -- (where necessary) in the native code generator.
+ | BaseReg
+
+ -- The register used by the platform for the C stack pointer. This is
+ -- a break in the STG abstraction used exclusively to setup stack unwinding
+ -- information.
+ | MachSp
+
+ -- The is a dummy register used to indicate to the stack unwinder where
+ -- a routine would return to.
+ | UnwindReturnReg
+
+ -- Base Register for PIC (position-independent code) calculations
+ -- Only used inside the native code generator. It's exact meaning differs
+ -- from platform to platform (see module PositionIndependentCode).
+ | PicBaseReg
+
+ deriving( Show )
+
+instance Eq GlobalReg where
+ VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
+ FloatReg i == FloatReg j = i==j
+ DoubleReg i == DoubleReg j = i==j
+ LongReg i == LongReg j = i==j
+ -- NOTE: XMM, YMM, ZMM registers actually are the same registers
+ -- at least with respect to store at YMM i and then read from XMM i
+ -- and similarly for ZMM etc.
+ XmmReg i == XmmReg j = i==j
+ YmmReg i == YmmReg j = i==j
+ ZmmReg i == ZmmReg j = i==j
+ Sp == Sp = True
+ SpLim == SpLim = True
+ Hp == Hp = True
+ HpLim == HpLim = True
+ CCCS == CCCS = True
+ CurrentTSO == CurrentTSO = True
+ CurrentNursery == CurrentNursery = True
+ HpAlloc == HpAlloc = True
+ EagerBlackholeInfo == EagerBlackholeInfo = True
+ GCEnter1 == GCEnter1 = True
+ GCFun == GCFun = True
+ BaseReg == BaseReg = True
+ MachSp == MachSp = True
+ UnwindReturnReg == UnwindReturnReg = True
+ PicBaseReg == PicBaseReg = True
+ _r1 == _r2 = False
+
+instance Ord GlobalReg where
+ compare (VanillaReg i _) (VanillaReg j _) = compare i j
+ -- Ignore type when seeking clashes
+ compare (FloatReg i) (FloatReg j) = compare i j
+ compare (DoubleReg i) (DoubleReg j) = compare i j
+ compare (LongReg i) (LongReg j) = compare i j
+ compare (XmmReg i) (XmmReg j) = compare i j
+ compare (YmmReg i) (YmmReg j) = compare i j
+ compare (ZmmReg i) (ZmmReg j) = compare i j
+ compare Sp Sp = EQ
+ compare SpLim SpLim = EQ
+ compare Hp Hp = EQ
+ compare HpLim HpLim = EQ
+ compare CCCS CCCS = EQ
+ compare CurrentTSO CurrentTSO = EQ
+ compare CurrentNursery CurrentNursery = EQ
+ compare HpAlloc HpAlloc = EQ
+ compare EagerBlackholeInfo EagerBlackholeInfo = EQ
+ compare GCEnter1 GCEnter1 = EQ
+ compare GCFun GCFun = EQ
+ compare BaseReg BaseReg = EQ
+ compare MachSp MachSp = EQ
+ compare UnwindReturnReg UnwindReturnReg = EQ
+ compare PicBaseReg PicBaseReg = EQ
+ compare (VanillaReg _ _) _ = LT
+ compare _ (VanillaReg _ _) = GT
+ compare (FloatReg _) _ = LT
+ compare _ (FloatReg _) = GT
+ compare (DoubleReg _) _ = LT
+ compare _ (DoubleReg _) = GT
+ compare (LongReg _) _ = LT
+ compare _ (LongReg _) = GT
+ compare (XmmReg _) _ = LT
+ compare _ (XmmReg _) = GT
+ compare (YmmReg _) _ = LT
+ compare _ (YmmReg _) = GT
+ compare (ZmmReg _) _ = LT
+ compare _ (ZmmReg _) = GT
+ compare Sp _ = LT
+ compare _ Sp = GT
+ compare SpLim _ = LT
+ compare _ SpLim = GT
+ compare Hp _ = LT
+ compare _ Hp = GT
+ compare HpLim _ = LT
+ compare _ HpLim = GT
+ compare CCCS _ = LT
+ compare _ CCCS = GT
+ compare CurrentTSO _ = LT
+ compare _ CurrentTSO = GT
+ compare CurrentNursery _ = LT
+ compare _ CurrentNursery = GT
+ compare HpAlloc _ = LT
+ compare _ HpAlloc = GT
+ compare GCEnter1 _ = LT
+ compare _ GCEnter1 = GT
+ compare GCFun _ = LT
+ compare _ GCFun = GT
+ compare BaseReg _ = LT
+ compare _ BaseReg = GT
+ compare MachSp _ = LT
+ compare _ MachSp = GT
+ compare UnwindReturnReg _ = LT
+ compare _ UnwindReturnReg = GT
+ compare EagerBlackholeInfo _ = LT
+ compare _ EagerBlackholeInfo = GT
+
+-- convenient aliases
+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
+ currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg
+baseReg = CmmGlobal BaseReg
+spReg = CmmGlobal Sp
+hpReg = CmmGlobal Hp
+hpLimReg = CmmGlobal HpLim
+spLimReg = CmmGlobal SpLim
+nodeReg = CmmGlobal node
+currentTSOReg = CmmGlobal CurrentTSO
+currentNurseryReg = CmmGlobal CurrentNursery
+hpAllocReg = CmmGlobal HpAlloc
+cccsReg = CmmGlobal CCCS
+
+node :: GlobalReg
+node = VanillaReg 1 VGcPtr
+
+globalRegType :: Platform -> GlobalReg -> CmmType
+globalRegType platform = \case
+ (VanillaReg _ VGcPtr) -> gcWord platform
+ (VanillaReg _ VNonGcPtr) -> bWord platform
+ (FloatReg _) -> cmmFloat W32
+ (DoubleReg _) -> cmmFloat W64
+ (LongReg _) -> cmmBits W64
+ -- TODO: improve the internal model of SIMD/vectorized registers
+ -- the right design SHOULd improve handling of float and double code too.
+ -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim
+ (XmmReg _) -> cmmVec 4 (cmmBits W32)
+ (YmmReg _) -> cmmVec 8 (cmmBits W32)
+ (ZmmReg _) -> cmmVec 16 (cmmBits W32)
+
+ Hp -> gcWord platform -- The initialiser for all
+ -- dynamically allocated closures
+ _ -> bWord platform
+
+isArgReg :: GlobalReg -> Bool
+isArgReg (VanillaReg {}) = True
+isArgReg (FloatReg {}) = True
+isArgReg (DoubleReg {}) = True
+isArgReg (LongReg {}) = True
+isArgReg (XmmReg {}) = True
+isArgReg (YmmReg {}) = True
+isArgReg (ZmmReg {}) = True
+isArgReg _ = False
diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs
new file mode 100644
index 0000000..077f663
--- /dev/null
+++ b/compiler/GHC/Cmm/MachOp.hs
@@ -0,0 +1,669 @@
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.Cmm.MachOp
+ ( MachOp(..)
+ , pprMachOp, isCommutableMachOp, isAssociativeMachOp
+ , isComparisonMachOp, maybeIntComparison, machOpResultType
+ , machOpArgReps, maybeInvertComparison, isFloatComparison
+
+ -- MachOp builders
+ , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+ , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+ , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+ , mo_wordULe, mo_wordUGt, mo_wordULt
+ , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot
+ , mo_wordShl, mo_wordSShr, mo_wordUShr
+ , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+ , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord
+ , mo_u_32ToWord, mo_s_32ToWord
+ , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
+
+ -- CallishMachOp
+ , CallishMachOp(..), callishMachOpHints
+ , pprCallishMachOp
+ , machOpMemcpyishAlign
+
+ -- Atomic read-modify-write
+ , AtomicMachOp(..)
+ )
+where
+
+import GHC.Prelude
+
+import GHC.Platform
+import GHC.Cmm.Type
+import GHC.Utils.Outputable
+
+-----------------------------------------------------------------------------
+-- MachOp
+-----------------------------------------------------------------------------
+
+{- |
+Machine-level primops; ones which we can reasonably delegate to the
+native code generators to handle.
+
+Most operations are parameterised by the 'Width' that they operate on.
+Some operations have separate signed and unsigned versions, and float
+and integer versions.
+-}
+
+data MachOp
+ -- Integer operations (insensitive to signed/unsigned)
+ = MO_Add Width
+ | MO_Sub Width
+ | MO_Eq Width
+ | MO_Ne Width
+ | MO_Mul Width -- low word of multiply
+
+ -- Signed multiply/divide
+ | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows
+ | MO_S_Quot Width -- signed / (same semantics as IntQuotOp)
+ | MO_S_Rem Width -- signed % (same semantics as IntRemOp)
+ | MO_S_Neg Width -- unary -
+
+ -- Unsigned multiply/divide
+ | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows
+ | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp)
+ | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp)
+
+ -- Signed comparisons
+ | MO_S_Ge Width
+ | MO_S_Le Width
+ | MO_S_Gt Width
+ | MO_S_Lt Width
+
+ -- Unsigned comparisons
+ | MO_U_Ge Width
+ | MO_U_Le Width
+ | MO_U_Gt Width
+ | MO_U_Lt Width
+
+ -- Floating point arithmetic
+ | MO_F_Add Width
+ | MO_F_Sub Width
+ | MO_F_Neg Width -- unary -
+ | MO_F_Mul Width
+ | MO_F_Quot Width
+
+ -- Floating point comparison
+ | MO_F_Eq Width
+ | MO_F_Ne Width
+ | MO_F_Ge Width
+ | MO_F_Le Width
+ | MO_F_Gt Width
+ | MO_F_Lt Width
+
+ -- Bitwise operations. Not all of these may be supported
+ -- at all sizes, and only integral Widths are valid.
+ | MO_And Width
+ | MO_Or Width
+ | MO_Xor Width
+ | MO_Not Width
+ | MO_Shl Width
+ | MO_U_Shr Width -- unsigned shift right
+ | MO_S_Shr Width -- signed shift right
+
+ -- Conversions. Some of these will be NOPs.
+ -- Floating-point conversions use the signed variant.
+ | MO_SF_Conv Width Width -- Signed int -> Float
+ | MO_FS_Conv Width Width -- Float -> Signed int
+ | MO_SS_Conv Width Width -- Signed int -> Signed int
+ | MO_UU_Conv Width Width -- unsigned int -> unsigned int
+ | MO_XX_Conv Width Width -- int -> int; puts no requirements on the
+ -- contents of upper bits when extending;
+ -- narrowing is simply truncation; the only
+ -- expectation is that we can recover the
+ -- original value by applying the opposite
+ -- MO_XX_Conv, e.g.,
+ -- MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)
+ -- is equivalent to just x.
+ | MO_FF_Conv Width Width -- Float -> Float
+
+ -- Vector element insertion and extraction operations
+ | MO_V_Insert Length Width -- Insert scalar into vector
+ | MO_V_Extract Length Width -- Extract scalar from vector
+
+ -- Integer vector operations
+ | MO_V_Add Length Width
+ | MO_V_Sub Length Width
+ | MO_V_Mul Length Width
+
+ -- Signed vector multiply/divide
+ | MO_VS_Quot Length Width
+ | MO_VS_Rem Length Width
+ | MO_VS_Neg Length Width
+
+ -- Unsigned vector multiply/divide
+ | MO_VU_Quot Length Width
+ | MO_VU_Rem Length Width
+
+ -- Floating point vector element insertion and extraction operations
+ | MO_VF_Insert Length Width -- Insert scalar into vector
+ | MO_VF_Extract Length Width -- Extract scalar from vector
+
+ -- Floating point vector operations
+ | MO_VF_Add Length Width
+ | MO_VF_Sub Length Width
+ | MO_VF_Neg Length Width -- unary negation
+ | MO_VF_Mul Length Width
+ | MO_VF_Quot Length Width
+
+ -- Alignment check (for -falignment-sanitisation)
+ | MO_AlignmentCheck Int Width
+ deriving (Eq, Show)
+
+pprMachOp :: MachOp -> SDoc
+pprMachOp mo = text (show mo)
+
+
+
+-- -----------------------------------------------------------------------------
+-- Some common MachReps
+
+-- A 'wordRep' is a machine word on the target architecture
+-- Specifically, it is the size of an Int#, Word#, Addr#
+-- and the unit of allocation on the stack and the heap
+-- Any pointer is also guaranteed to be a wordRep.
+
+mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+ , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+ , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+ , mo_wordULe, mo_wordUGt, mo_wordULt
+ , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
+ , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
+ , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
+ :: Platform -> MachOp
+
+mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+ , mo_32To8, mo_32To16
+ :: MachOp
+
+mo_wordAdd platform = MO_Add (wordWidth platform)
+mo_wordSub platform = MO_Sub (wordWidth platform)
+mo_wordEq platform = MO_Eq (wordWidth platform)
+mo_wordNe platform = MO_Ne (wordWidth platform)
+mo_wordMul platform = MO_Mul (wordWidth platform)
+mo_wordSQuot platform = MO_S_Quot (wordWidth platform)
+mo_wordSRem platform = MO_S_Rem (wordWidth platform)
+mo_wordSNeg platform = MO_S_Neg (wordWidth platform)
+mo_wordUQuot platform = MO_U_Quot (wordWidth platform)
+mo_wordURem platform = MO_U_Rem (wordWidth platform)
+
+mo_wordSGe platform = MO_S_Ge (wordWidth platform)
+mo_wordSLe platform = MO_S_Le (wordWidth platform)
+mo_wordSGt platform = MO_S_Gt (wordWidth platform)
+mo_wordSLt platform = MO_S_Lt (wordWidth platform)
+
+mo_wordUGe platform = MO_U_Ge (wordWidth platform)
+mo_wordULe platform = MO_U_Le (wordWidth platform)
+mo_wordUGt platform = MO_U_Gt (wordWidth platform)
+mo_wordULt platform = MO_U_Lt (wordWidth platform)
+
+mo_wordAnd platform = MO_And (wordWidth platform)
+mo_wordOr platform = MO_Or (wordWidth platform)
+mo_wordXor platform = MO_Xor (wordWidth platform)
+mo_wordNot platform = MO_Not (wordWidth platform)
+mo_wordShl platform = MO_Shl (wordWidth platform)
+mo_wordSShr platform = MO_S_Shr (wordWidth platform)
+mo_wordUShr platform = MO_U_Shr (wordWidth platform)
+
+mo_u_8To32 = MO_UU_Conv W8 W32
+mo_s_8To32 = MO_SS_Conv W8 W32
+mo_u_16To32 = MO_UU_Conv W16 W32
+mo_s_16To32 = MO_SS_Conv W16 W32
+
+mo_u_8ToWord platform = MO_UU_Conv W8 (wordWidth platform)
+mo_s_8ToWord platform = MO_SS_Conv W8 (wordWidth platform)
+mo_u_16ToWord platform = MO_UU_Conv W16 (wordWidth platform)
+mo_s_16ToWord platform = MO_SS_Conv W16 (wordWidth platform)
+mo_s_32ToWord platform = MO_SS_Conv W32 (wordWidth platform)
+mo_u_32ToWord platform = MO_UU_Conv W32 (wordWidth platform)
+
+mo_WordTo8 platform = MO_UU_Conv (wordWidth platform) W8
+mo_WordTo16 platform = MO_UU_Conv (wordWidth platform) W16
+mo_WordTo32 platform = MO_UU_Conv (wordWidth platform) W32
+mo_WordTo64 platform = MO_UU_Conv (wordWidth platform) W64
+
+mo_32To8 = MO_UU_Conv W32 W8
+mo_32To16 = MO_UU_Conv W32 W16
+
+
+-- ----------------------------------------------------------------------------
+-- isCommutableMachOp
+
+{- |
+Returns 'True' if the MachOp has commutable arguments. This is used
+in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'. This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isCommutableMachOp :: MachOp -> Bool
+isCommutableMachOp mop =
+ case mop of
+ MO_Add _ -> True
+ MO_Eq _ -> True
+ MO_Ne _ -> True
+ MO_Mul _ -> True
+ MO_S_MulMayOflo _ -> True
+ MO_U_MulMayOflo _ -> True
+ MO_And _ -> True
+ MO_Or _ -> True
+ MO_Xor _ -> True
+ MO_F_Add _ -> True
+ MO_F_Mul _ -> True
+ _other -> False
+
+-- ----------------------------------------------------------------------------
+-- isAssociativeMachOp
+
+{- |
+Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)
+This is used in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'. This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isAssociativeMachOp :: MachOp -> Bool
+isAssociativeMachOp mop =
+ case mop of
+ MO_Add {} -> True -- NB: does not include
+ MO_Mul {} -> True -- floatint point!
+ MO_And {} -> True
+ MO_Or {} -> True
+ MO_Xor {} -> True
+ _other -> False
+
+
+-- ----------------------------------------------------------------------------
+-- isComparisonMachOp
+
+{- |
+Returns 'True' if the MachOp is a comparison.
+
+If in doubt, return False. This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isComparisonMachOp :: MachOp -> Bool
+isComparisonMachOp mop =
+ case mop of
+ MO_Eq _ -> True
+ MO_Ne _ -> True
+ MO_S_Ge _ -> True
+ MO_S_Le _ -> True
+ MO_S_Gt _ -> True
+ MO_S_Lt _ -> True
+ MO_U_Ge _ -> True
+ MO_U_Le _ -> True
+ MO_U_Gt _ -> True
+ MO_U_Lt _ -> True
+ MO_F_Eq {} -> True
+ MO_F_Ne {} -> True
+ MO_F_Ge {} -> True
+ MO_F_Le {} -> True
+ MO_F_Gt {} -> True
+ MO_F_Lt {} -> True
+ _other -> False
+
+{- |
+Returns @Just w@ if the operation is an integer comparison with width
+@w@, or @Nothing@ otherwise.
+-}
+maybeIntComparison :: MachOp -> Maybe Width
+maybeIntComparison mop =
+ case mop of
+ MO_Eq w -> Just w
+ MO_Ne w -> Just w
+ MO_S_Ge w -> Just w
+ MO_S_Le w -> Just w
+ MO_S_Gt w -> Just w
+ MO_S_Lt w -> Just w
+ MO_U_Ge w -> Just w
+ MO_U_Le w -> Just w
+ MO_U_Gt w -> Just w
+ MO_U_Lt w -> Just w
+ _ -> Nothing
+
+isFloatComparison :: MachOp -> Bool
+isFloatComparison mop =
+ case mop of
+ MO_F_Eq {} -> True
+ MO_F_Ne {} -> True
+ MO_F_Ge {} -> True
+ MO_F_Le {} -> True
+ MO_F_Gt {} -> True
+ MO_F_Lt {} -> True
+ _other -> False
+
+-- -----------------------------------------------------------------------------
+-- Inverting conditions
+
+-- Sometimes it's useful to be able to invert the sense of a
+-- condition. Not all conditional tests are invertible: in
+-- particular, floating point conditionals cannot be inverted, because
+-- there exist floating-point values which return False for both senses
+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).
+
+maybeInvertComparison :: MachOp -> Maybe MachOp
+maybeInvertComparison op
+ = case op of -- None of these Just cases include floating point
+ MO_Eq r -> Just (MO_Ne r)
+ MO_Ne r -> Just (MO_Eq r)
+ MO_U_Lt r -> Just (MO_U_Ge r)
+ MO_U_Gt r -> Just (MO_U_Le r)
+ MO_U_Le r -> Just (MO_U_Gt r)
+ MO_U_Ge r -> Just (MO_U_Lt r)
+ MO_S_Lt r -> Just (MO_S_Ge r)
+ MO_S_Gt r -> Just (MO_S_Le r)
+ MO_S_Le r -> Just (MO_S_Gt r)
+ MO_S_Ge r -> Just (MO_S_Lt r)
+ _other -> Nothing
+
+-- ----------------------------------------------------------------------------
+-- machOpResultType
+
+{- |
+Returns the MachRep of the result of a MachOp.
+-}
+machOpResultType :: Platform -> MachOp -> [CmmType] -> CmmType
+machOpResultType platform mop tys =
+ case mop of
+ MO_Add {} -> ty1 -- Preserve GC-ptr-hood
+ MO_Sub {} -> ty1 -- of first arg
+ MO_Mul r -> cmmBits r
+ MO_S_MulMayOflo r -> cmmBits r
+ MO_S_Quot r -> cmmBits r
+ MO_S_Rem r -> cmmBits r
+ MO_S_Neg r -> cmmBits r
+ MO_U_MulMayOflo r -> cmmBits r
+ MO_U_Quot r -> cmmBits r
+ MO_U_Rem r -> cmmBits r
+
+ MO_Eq {} -> comparisonResultRep platform
+ MO_Ne {} -> comparisonResultRep platform
+ MO_S_Ge {} -> comparisonResultRep platform
+ MO_S_Le {} -> comparisonResultRep platform
+ MO_S_Gt {} -> comparisonResultRep platform
+ MO_S_Lt {} -> comparisonResultRep platform
+
+ MO_U_Ge {} -> comparisonResultRep platform
+ MO_U_Le {} -> comparisonResultRep platform
+ MO_U_Gt {} -> comparisonResultRep platform
+ MO_U_Lt {} -> comparisonResultRep platform
+
+ MO_F_Add r -> cmmFloat r
+ MO_F_Sub r -> cmmFloat r
+ MO_F_Mul r -> cmmFloat r
+ MO_F_Quot r -> cmmFloat r
+ MO_F_Neg r -> cmmFloat r
+ MO_F_Eq {} -> comparisonResultRep platform
+ MO_F_Ne {} -> comparisonResultRep platform
+ MO_F_Ge {} -> comparisonResultRep platform
+ MO_F_Le {} -> comparisonResultRep platform
+ MO_F_Gt {} -> comparisonResultRep platform
+ MO_F_Lt {} -> comparisonResultRep platform
+
+ MO_And {} -> ty1 -- Used for pointer masking
+ MO_Or {} -> ty1
+ MO_Xor {} -> ty1
+ MO_Not r -> cmmBits r
+ MO_Shl r -> cmmBits r
+ MO_U_Shr r -> cmmBits r
+ MO_S_Shr r -> cmmBits r
+
+ MO_SS_Conv _ to -> cmmBits to
+ MO_UU_Conv _ to -> cmmBits to
+ MO_XX_Conv _ to -> cmmBits to
+ MO_FS_Conv _ to -> cmmBits to
+ MO_SF_Conv _ to -> cmmFloat to
+ MO_FF_Conv _ to -> cmmFloat to
+
+ MO_V_Insert l w -> cmmVec l (cmmBits w)
+ MO_V_Extract _ w -> cmmBits w
+
+ MO_V_Add l w -> cmmVec l (cmmBits w)
+ MO_V_Sub l w -> cmmVec l (cmmBits w)
+ MO_V_Mul l w -> cmmVec l (cmmBits w)
+
+ MO_VS_Quot l w -> cmmVec l (cmmBits w)
+ MO_VS_Rem l w -> cmmVec l (cmmBits w)
+ MO_VS_Neg l w -> cmmVec l (cmmBits w)
+
+ MO_VU_Quot l w -> cmmVec l (cmmBits w)
+ MO_VU_Rem l w -> cmmVec l (cmmBits w)
+
+ MO_VF_Insert l w -> cmmVec l (cmmFloat w)
+ MO_VF_Extract _ w -> cmmFloat w
+
+ MO_VF_Add l w -> cmmVec l (cmmFloat w)
+ MO_VF_Sub l w -> cmmVec l (cmmFloat w)
+ MO_VF_Mul l w -> cmmVec l (cmmFloat w)
+ MO_VF_Quot l w -> cmmVec l (cmmFloat w)
+ MO_VF_Neg l w -> cmmVec l (cmmFloat w)
+
+ MO_AlignmentCheck _ _ -> ty1
+ where
+ (ty1:_) = tys
+
+comparisonResultRep :: Platform -> CmmType
+comparisonResultRep = bWord -- is it?
+
+
+-- -----------------------------------------------------------------------------
+-- machOpArgReps
+
+-- | This function is used for debugging only: we can check whether an
+-- application of a MachOp is "type-correct" by checking that the MachReps of
+-- its arguments are the same as the MachOp expects. This is used when
+-- linting a CmmExpr.
+
+machOpArgReps :: Platform -> MachOp -> [Width]
+machOpArgReps platform op =
+ case op of
+ MO_Add r -> [r,r]
+ MO_Sub r -> [r,r]
+ MO_Eq r -> [r,r]
+ MO_Ne r -> [r,r]
+ MO_Mul r -> [r,r]
+ MO_S_MulMayOflo r -> [r,r]
+ MO_S_Quot r -> [r,r]
+ MO_S_Rem r -> [r,r]
+ MO_S_Neg r -> [r]
+ MO_U_MulMayOflo r -> [r,r]
+ MO_U_Quot r -> [r,r]
+ MO_U_Rem r -> [r,r]
+
+ MO_S_Ge r -> [r,r]
+ MO_S_Le r -> [r,r]
+ MO_S_Gt r -> [r,r]
+ MO_S_Lt r -> [r,r]
+
+ MO_U_Ge r -> [r,r]
+ MO_U_Le r -> [r,r]
+ MO_U_Gt r -> [r,r]
+ MO_U_Lt r -> [r,r]
+
+ MO_F_Add r -> [r,r]
+ MO_F_Sub r -> [r,r]
+ MO_F_Mul r -> [r,r]
+ MO_F_Quot r -> [r,r]
+ MO_F_Neg r -> [r]
+ MO_F_Eq r -> [r,r]
+ MO_F_Ne r -> [r,r]
+ MO_F_Ge r -> [r,r]
+ MO_F_Le r -> [r,r]
+ MO_F_Gt r -> [r,r]
+ MO_F_Lt r -> [r,r]
+
+ MO_And r -> [r,r]
+ MO_Or r -> [r,r]
+ MO_Xor r -> [r,r]
+ MO_Not r -> [r]
+ MO_Shl r -> [r, wordWidth platform]
+ MO_U_Shr r -> [r, wordWidth platform]
+ MO_S_Shr r -> [r, wordWidth platform]
+
+ MO_SS_Conv from _ -> [from]
+ MO_UU_Conv from _ -> [from]
+ MO_XX_Conv from _ -> [from]
+ MO_SF_Conv from _ -> [from]
+ MO_FS_Conv from _ -> [from]
+ MO_FF_Conv from _ -> [from]
+
+ MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform]
+ MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth platform]
+
+ MO_V_Add _ r -> [r,r]
+ MO_V_Sub _ r -> [r,r]
+ MO_V_Mul _ r -> [r,r]
+
+ MO_VS_Quot _ r -> [r,r]
+ MO_VS_Rem _ r -> [r,r]
+ MO_VS_Neg _ r -> [r]
+
+ MO_VU_Quot _ r -> [r,r]
+ MO_VU_Rem _ r -> [r,r]
+
+ MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform]
+ MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth platform]
+
+ MO_VF_Add _ r -> [r,r]
+ MO_VF_Sub _ r -> [r,r]
+ MO_VF_Mul _ r -> [r,r]
+ MO_VF_Quot _ r -> [r,r]
+ MO_VF_Neg _ r -> [r]
+
+ MO_AlignmentCheck _ r -> [r]
+
+-----------------------------------------------------------------------------
+-- CallishMachOp
+-----------------------------------------------------------------------------
+
+-- CallishMachOps tend to be implemented by foreign calls in some backends,
+-- so we separate them out. In Cmm, these can only occur in a
+-- statement position, in contrast to an ordinary MachOp which can occur
+-- anywhere in an expression.
+data CallishMachOp
+ = MO_F64_Pwr
+ | MO_F64_Sin
+ | MO_F64_Cos
+ | MO_F64_Tan
+ | MO_F64_Sinh
+ | MO_F64_Cosh
+ | MO_F64_Tanh
+ | MO_F64_Asin
+ | MO_F64_Acos
+ | MO_F64_Atan
+ | MO_F64_Asinh
+ | MO_F64_Acosh
+ | MO_F64_Atanh
+ | MO_F64_Log
+ | MO_F64_Log1P
+ | MO_F64_Exp
+ | MO_F64_ExpM1
+ | MO_F64_Fabs
+ | MO_F64_Sqrt
+ | MO_F32_Pwr
+ | MO_F32_Sin
+ | MO_F32_Cos
+ | MO_F32_Tan
+ | MO_F32_Sinh
+ | MO_F32_Cosh
+ | MO_F32_Tanh
+ | MO_F32_Asin
+ | MO_F32_Acos
+ | MO_F32_Atan
+ | MO_F32_Asinh
+ | MO_F32_Acosh
+ | MO_F32_Atanh
+ | MO_F32_Log
+ | MO_F32_Log1P
+ | MO_F32_Exp
+ | MO_F32_ExpM1
+ | MO_F32_Fabs
+ | MO_F32_Sqrt
+
+ | MO_UF_Conv Width
+
+ | MO_S_Mul2 Width
+ | MO_S_QuotRem Width
+ | MO_U_QuotRem Width
+ | MO_U_QuotRem2 Width
+ | MO_Add2 Width
+ | MO_AddWordC Width
+ | MO_SubWordC Width
+ | MO_AddIntC Width
+ | MO_SubIntC Width
+ | MO_U_Mul2 Width
+
+ | MO_ReadBarrier
+ | MO_WriteBarrier
+ | MO_Touch -- Keep variables live (when using interior pointers)
+
+ -- Prefetch
+ | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not
+ -- program behavior.
+ -- the Int can be 0-3. Needs to be known at compile time
+ -- to interact with code generation correctly.
+ -- TODO: add support for prefetch WRITES,
+ -- currently only exposes prefetch reads, which
+ -- would the majority of use cases in ghc anyways
+
+
+ -- These three MachOps are parameterised by the known alignment
+ -- of the destination and source (for memcpy/memmove) pointers.
+ -- This information may be used for optimisation in backends.
+ | MO_Memcpy Int
+ | MO_Memset Int
+ | MO_Memmove Int
+ | MO_Memcmp Int
+
+ | MO_PopCnt Width
+ | MO_Pdep Width
+ | MO_Pext Width
+ | MO_Clz Width
+ | MO_Ctz Width
+
+ | MO_BSwap Width
+ | MO_BRev Width
+
+ -- Atomic read-modify-write.
+ | MO_AtomicRMW Width AtomicMachOp
+ | MO_AtomicRead Width
+ | MO_AtomicWrite Width
+ | MO_Cmpxchg Width
+ -- Should be an AtomicRMW variant eventually.
+ -- Sequential consistent.
+ | MO_Xchg Width
+ deriving (Eq, Show)
+
+-- | The operation to perform atomically.
+data AtomicMachOp =
+ AMO_Add
+ | AMO_Sub
+ | AMO_And
+ | AMO_Nand
+ | AMO_Or
+ | AMO_Xor
+ deriving (Eq, Show)
+
+pprCallishMachOp :: CallishMachOp -> SDoc
+pprCallishMachOp mo = text (show mo)
+
+callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])
+callishMachOpHints op = case op of
+ MO_Memcpy _ -> ([], [AddrHint,AddrHint,NoHint])
+ MO_Memset _ -> ([], [AddrHint,NoHint,NoHint])
+ MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])
+ MO_Memcmp _ -> ([], [AddrHint, AddrHint, NoHint])
+ _ -> ([],[])
+ -- empty lists indicate NoHint
+
+-- | The alignment of a 'memcpy'-ish operation.
+machOpMemcpyishAlign :: CallishMachOp -> Maybe Int
+machOpMemcpyishAlign op = case op of
+ MO_Memcpy align -> Just align
+ MO_Memset align -> Just align
+ MO_Memmove align -> Just align
+ MO_Memcmp align -> Just align
+ _ -> Nothing
diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs
new file mode 100644
index 0000000..31a3d14
--- /dev/null
+++ b/compiler/GHC/Cmm/Node.hs
@@ -0,0 +1,726 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+-- CmmNode type for representation using Hoopl graphs.
+
+module GHC.Cmm.Node (
+ CmmNode(..), CmmFormal, CmmActual, CmmTickish,
+ UpdFrameOffset, Convention(..),
+ ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
+ CmmReturnInfo(..),
+ mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
+ mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,
+
+ -- * Tick scopes
+ CmmTickScope(..), isTickSubScope, combineTickScopes,
+ ) where
+
+import GHC.Prelude hiding (succ)
+
+import GHC.Platform.Regs
+import GHC.Cmm.Expr
+import GHC.Cmm.Switch
+import GHC.Driver.Session
+import GHC.Data.FastString
+import GHC.Types.ForeignCall
+import GHC.Utils.Outputable
+import GHC.Runtime.Heap.Layout
+import GHC.Core (Tickish)
+import qualified GHC.Types.Unique as U
+
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Label
+import Data.Maybe
+import Data.List (tails,sortBy)
+import GHC.Types.Unique (nonDetCmpUnique)
+import GHC.Utils.Misc
+
+
+------------------------
+-- CmmNode
+
+#define ULabel {-# UNPACK #-} !Label
+
+data CmmNode e x where
+ CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
+
+ CmmComment :: FastString -> CmmNode O O
+
+ -- Tick annotation, covering Cmm code in our tick scope. We only
+ -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
+ -- See Note [CmmTick scoping details]
+ CmmTick :: !CmmTickish -> CmmNode O O
+
+ -- Unwind pseudo-instruction, encoding stack unwinding
+ -- instructions for a debugger. This describes how to reconstruct
+ -- the "old" value of a register if we want to navigate the stack
+ -- up one frame. Having unwind information for @Sp@ will allow the
+ -- debugger to "walk" the stack.
+ --
+ -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
+ CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
+
+ CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
+ -- Assign to register
+
+ CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
+ -- Assign to memory location. Size is
+ -- given by cmmExprType of the rhs.
+
+ CmmUnsafeForeignCall :: -- An unsafe foreign call;
+ -- see Note [Foreign calls]
+ -- Like a "fat machine instruction"; can occur
+ -- in the middle of a block
+ ForeignTarget -> -- call target
+ [CmmFormal] -> -- zero or more results
+ [CmmActual] -> -- zero or more arguments
+ CmmNode O O
+ -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
+ -- See Note [Unsafe foreign calls clobber caller-save registers]
+ --
+ -- Invariant: the arguments and the ForeignTarget must not
+ -- mention any registers for which GHC.Platform.callerSaves
+ -- is True. See Note [Register Parameter Passing].
+
+ CmmBranch :: ULabel -> CmmNode O C
+ -- Goto another block in the same procedure
+
+ CmmCondBranch :: { -- conditional branch
+ cml_pred :: CmmExpr,
+ cml_true, cml_false :: ULabel,
+ cml_likely :: Maybe Bool -- likely result of the conditional,
+ -- if known
+ } -> CmmNode O C
+
+ CmmSwitch
+ :: CmmExpr -- Scrutinee, of some integral type
+ -> SwitchTargets -- Cases. See [Note SwitchTargets]
+ -> CmmNode O C
+
+ CmmCall :: { -- A native call or tail call
+ cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
+
+ cml_cont :: Maybe Label,
+ -- Label of continuation (Nothing for return or tail call)
+ --
+ -- Note [Continuation BlockIds]: these BlockIds are called
+ -- Continuation BlockIds, and are the only BlockIds that can
+ -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
+ -- (CmmStackSlot (Young b) _).
+
+ cml_args_regs :: [GlobalReg],
+ -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
+ -- to the call. This is essential information for the
+ -- native code generator's register allocator; without
+ -- knowing which GlobalRegs are live it has to assume that
+ -- they are all live. This list should only include
+ -- GlobalRegs that are mapped to real machine registers on
+ -- the target platform.
+
+ cml_args :: ByteOff,
+ -- Byte offset, from the *old* end of the Area associated with
+ -- the Label (if cml_cont = Nothing, then Old area), of
+ -- youngest outgoing arg. Set the stack pointer to this before
+ -- transferring control.
+ -- (NB: an update frame might also have been stored in the Old
+ -- area, but it'll be in an older part than the args.)
+
+ cml_ret_args :: ByteOff,
+ -- For calls *only*, the byte offset for youngest returned value
+ -- This is really needed at the *return* point rather than here
+ -- at the call, but in practice it's convenient to record it here.
+
+ cml_ret_off :: ByteOff
+ -- For calls *only*, the byte offset of the base of the frame that
+ -- must be described by the info table for the return point.
+ -- The older words are an update frames, which have their own
+ -- info-table and layout information
+
+ -- From a liveness point of view, the stack words older than
+ -- cml_ret_off are treated as live, even if the sequel of
+ -- the call goes into a loop.
+ } -> CmmNode O C
+
+ CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
+ -- Always the last node of a block
+ tgt :: ForeignTarget, -- call target and convention
+ res :: [CmmFormal], -- zero or more results
+ args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing]
+ succ :: ULabel, -- Label of continuation
+ ret_args :: ByteOff, -- same as cml_ret_args
+ ret_off :: ByteOff, -- same as cml_ret_off
+ intrbl:: Bool -- whether or not the call is interruptible
+ } -> CmmNode O C
+
+{- Note [Foreign calls]
+~~~~~~~~~~~~~~~~~~~~~~~
+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
+a CmmForeignCall call is used for *safe* foreign calls.
+
+Unsafe ones are mostly easy: think of them as a "fat machine
+instruction". In particular, they do *not* kill all live registers,
+just the registers they return to (there was a bit of code in GHC that
+conservatively assumed otherwise.) However, see [Register parameter passing].
+
+Safe ones are trickier. A safe foreign call
+ r = f(x)
+ultimately expands to
+ push "return address" -- Never used to return to;
+ -- just points an info table
+ save registers into TSO
+ call suspendThread
+ r = f(x) -- Make the call
+ call resumeThread
+ restore registers
+ pop "return address"
+We cannot "lower" a safe foreign call to this sequence of Cmms, because
+after we've saved Sp all the Cmm optimiser's assumptions are broken.
+
+Note that a safe foreign call needs an info table.
+
+So Safe Foreign Calls must remain as last nodes until the stack is
+made manifest in GHC.Cmm.LayoutStack, where they are lowered into the above
+sequence.
+-}
+
+{- Note [Unsafe foreign calls clobber caller-save registers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A foreign call is defined to clobber any GlobalRegs that are mapped to
+caller-saves machine registers (according to the prevailing C ABI).
+GHC.StgToCmm.Utils.callerSaves tells you which GlobalRegs are caller-saves.
+
+This is a design choice that makes it easier to generate code later.
+We could instead choose to say that foreign calls do *not* clobber
+caller-saves regs, but then we would have to figure out which regs
+were live across the call later and insert some saves/restores.
+
+Furthermore when we generate code we never have any GlobalRegs live
+across a call, because they are always copied-in to LocalRegs and
+copied-out again before making a call/jump. So all we have to do is
+avoid any code motion that would make a caller-saves GlobalReg live
+across a foreign call during subsequent optimisations.
+-}
+
+{- Note [Register parameter passing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On certain architectures, some registers are utilized for parameter
+passing in the C calling convention. For example, in x86-64 Linux
+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
+argument passing. These are registers R3-R6, which our generated
+code may also be using; as a result, it's necessary to save these
+values before doing a foreign call. This is done during initial
+code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils. However,
+one result of doing this is that the contents of these registers
+may mysteriously change if referenced inside the arguments. This
+is dangerous, so you'll need to disable inlining much in the same
+way is done in GHC.Cmm.Opt currently. We should fix this!
+-}
+
+---------------------------------------------
+-- Eq instance of CmmNode
+
+deriving instance Eq (CmmNode e x)
+
+----------------------------------------------
+-- Hoopl instances of CmmNode
+
+instance NonLocal CmmNode where
+ entryLabel (CmmEntry l _) = l
+
+ successors (CmmBranch l) = [l]
+ successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
+ successors (CmmSwitch _ ids) = switchTargetsToList ids
+ successors (CmmCall {cml_cont=l}) = maybeToList l
+ successors (CmmForeignCall {succ=l}) = [l]
+
+
+--------------------------------------------------
+-- Various helper types
+
+type CmmActual = CmmExpr
+type CmmFormal = LocalReg
+
+type UpdFrameOffset = ByteOff
+
+-- | A convention maps a list of values (function arguments or return
+-- values) to registers or stack locations.
+data Convention
+ = NativeDirectCall
+ -- ^ top-level Haskell functions use @NativeDirectCall@, which
+ -- maps arguments to registers starting with R2, according to
+ -- how many registers are available on the platform. This
+ -- convention ignores R1, because for a top-level function call
+ -- the function closure is implicit, and doesn't need to be passed.
+ | NativeNodeCall
+ -- ^ non-top-level Haskell functions, which pass the address of
+ -- the function closure in R1 (regardless of whether R1 is a
+ -- real register or not), and the rest of the arguments in
+ -- registers or on the stack.
+ | NativeReturn
+ -- ^ a native return. The convention for returns depends on
+ -- how many values are returned: for just one value returned,
+ -- the appropriate register is used (R1, F1, etc.). regardless
+ -- of whether it is a real register or not. For multiple
+ -- values returned, they are mapped to registers or the stack.
+ | Slow
+ -- ^ Slow entry points: all args pushed on the stack
+ | GC
+ -- ^ Entry to the garbage collector: uses the node reg!
+ -- (TODO: I don't think we need this --SDM)
+ deriving( Eq )
+
+data ForeignConvention
+ = ForeignConvention
+ CCallConv -- Which foreign-call convention
+ [ForeignHint] -- Extra info about the args
+ [ForeignHint] -- Extra info about the result
+ CmmReturnInfo
+ deriving Eq
+
+data CmmReturnInfo
+ = CmmMayReturn
+ | CmmNeverReturns
+ deriving ( Eq )
+
+data ForeignTarget -- The target of a foreign call
+ = ForeignTarget -- A foreign procedure
+ CmmExpr -- Its address
+ ForeignConvention -- Its calling convention
+ | PrimTarget -- A possibly-side-effecting machine operation
+ CallishMachOp -- Which one
+ deriving Eq
+
+foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
+foreignTargetHints target
+ = ( res_hints ++ repeat NoHint
+ , arg_hints ++ repeat NoHint )
+ where
+ (res_hints, arg_hints) =
+ case target of
+ PrimTarget op -> callishMachOpHints op
+ ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
+ (res_hints, arg_hints)
+
+--------------------------------------------------
+-- Instances of register and slot users / definers
+
+instance UserOfRegs LocalReg (CmmNode e x) where
+ foldRegsUsed dflags f !z n = case n of
+ CmmAssign _ expr -> fold f z expr
+ CmmStore addr rval -> fold f (fold f z addr) rval
+ CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+ CmmCondBranch expr _ _ _ -> fold f z expr
+ CmmSwitch expr _ -> fold f z expr
+ CmmCall {cml_target=tgt} -> fold f z tgt
+ CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+ _ -> z
+ where fold :: forall a b. UserOfRegs LocalReg a
+ => (b -> LocalReg -> b) -> b -> a -> b
+ fold f z n = foldRegsUsed dflags f z n
+
+instance UserOfRegs GlobalReg (CmmNode e x) where
+ foldRegsUsed dflags f !z n = case n of
+ CmmAssign _ expr -> fold f z expr
+ CmmStore addr rval -> fold f (fold f z addr) rval
+ CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+ CmmCondBranch expr _ _ _ -> fold f z expr
+ CmmSwitch expr _ -> fold f z expr
+ CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
+ CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+ _ -> z
+ where fold :: forall a b. UserOfRegs GlobalReg a
+ => (b -> GlobalReg -> b) -> b -> a -> b
+ fold f z n = foldRegsUsed dflags f z n
+
+instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
+ -- The (Ord r) in the context is necessary here
+ -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance
+ foldRegsUsed _ _ !z (PrimTarget _) = z
+ foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e
+
+instance DefinerOfRegs LocalReg (CmmNode e x) where
+ foldRegsDefd dflags f !z n = case n of
+ CmmAssign lhs _ -> fold f z lhs
+ CmmUnsafeForeignCall _ fs _ -> fold f z fs
+ CmmForeignCall {res=res} -> fold f z res
+ _ -> z
+ where fold :: forall a b. DefinerOfRegs LocalReg a
+ => (b -> LocalReg -> b) -> b -> a -> b
+ fold f z n = foldRegsDefd dflags f z n
+
+instance DefinerOfRegs GlobalReg (CmmNode e x) where
+ foldRegsDefd dflags f !z n = case n of
+ CmmAssign lhs _ -> fold f z lhs
+ CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt)
+ CmmCall {} -> fold f z activeRegs
+ CmmForeignCall {} -> fold f z activeRegs
+ -- See Note [Safe foreign calls clobber STG registers]
+ _ -> z
+ where fold :: forall a b. DefinerOfRegs GlobalReg a
+ => (b -> GlobalReg -> b) -> b -> a -> b
+ fold f z n = foldRegsDefd dflags f z n
+
+ platform = targetPlatform dflags
+ activeRegs = activeStgRegs platform
+ activeCallerSavesRegs = filter (callerSaves platform) activeRegs
+
+ foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
+ foreignTargetRegs _ = activeCallerSavesRegs
+
+-- Note [Safe foreign calls clobber STG registers]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- During stack layout phase every safe foreign call is expanded into a block
+-- that contains unsafe foreign call (instead of safe foreign call) and ends
+-- with a normal call (See Note [Foreign calls]). This means that we must
+-- treat safe foreign call as if it was a normal call (because eventually it
+-- will be). This is important if we try to run sinking pass before stack
+-- layout phase. Consider this example of what might go wrong (this is cmm
+-- code from stablename001 test). Here is code after common block elimination
+-- (before stack layout):
+--
+-- c1q6:
+-- _s1pf::P64 = R1;
+-- _c1q8::I64 = performMajorGC;
+-- I64[(young<c1q9> + 8)] = c1q9;
+-- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...)
+-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+-- c1q9:
+-- I64[(young<c1qb> + 8)] = c1qb;
+-- R1 = _s1pc::P64;
+-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- If we run sinking pass now (still before stack layout) we will get this:
+--
+-- c1q6:
+-- I64[(young<c1q9> + 8)] = c1q9;
+-- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...)
+-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+-- c1q9:
+-- I64[(young<c1qb> + 8)] = c1qb;
+-- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call
+-- R1 = _s1pc::P64;
+-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
+-- safe call to performMajorGC will be turned into:
+--
+-- c1q6:
+-- _s1pc::P64 = P64[Sp + 8];
+-- I64[Sp - 8] = c1q9;
+-- Sp = Sp - 8;
+-- I64[I64[CurrentTSO + 24] + 16] = Sp;
+-- P64[CurrentNursery + 8] = Hp + 8;
+-- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,]
+-- result hints: [PtrHint] suspendThread(BaseReg, 0);
+-- call "ccall" arg hints: [] result hints: [] performMajorGC();
+-- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint]
+-- result hints: [PtrHint] resumeThread(_u1qI::I64);
+-- BaseReg = _u1qJ::I64;
+-- _u1qK::P64 = CurrentTSO;
+-- _u1qL::P64 = I64[_u1qK::P64 + 24];
+-- Sp = I64[_u1qL::P64 + 16];
+-- SpLim = _u1qL::P64 + 192;
+-- HpAlloc = 0;
+-- Hp = I64[CurrentNursery + 8] - 8;
+-- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
+-- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
+-- c1q9:
+-- I64[(young<c1qb> + 8)] = c1qb;
+-- _s1pf::P64 = R1; <------ INCORRECT!
+-- R1 = _s1pc::P64;
+-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
+-- call is clearly incorrect. This is what would happen if we assumed that
+-- safe foreign call has the same semantics as unsafe foreign call. To prevent
+-- this we need to treat safe foreign call as if was normal call.
+
+-----------------------------------
+-- mapping Expr in GHC.Cmm.Node
+
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
+mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
+mapForeignTarget _ m@(PrimTarget _) = m
+
+wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
+-- Take a transformer on expressions and apply it recursively.
+-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
+-- then uses f to rewrite the resulting expression
+wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
+wrapRecExp f e = f e
+
+mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExp _ f@(CmmEntry{}) = f
+mapExp _ m@(CmmComment _) = m
+mapExp _ m@(CmmTick _) = m
+mapExp f (CmmUnwind regs) = CmmUnwind (map (fmap (fmap f)) regs)
+mapExp f (CmmAssign r e) = CmmAssign r (f e)
+mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
+mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
+mapExp _ l@(CmmBranch _) = l
+mapExp f (CmmCondBranch e ti fi l) = CmmCondBranch (f e) ti fi l
+mapExp f (CmmSwitch e ids) = CmmSwitch (f e) ids
+mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
+mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
+
+mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExpDeep f = mapExp $ wrapRecExp f
+
+------------------------------------------------------------------------
+-- mapping Expr in GHC.Cmm.Node, but not performing allocation if no changes
+
+mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
+mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
+mapForeignTargetM _ (PrimTarget _) = Nothing
+
+wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
+-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
+-- then gives f a chance to rewrite the resulting expression
+wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es)
+wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
+wrapRecExpM f e = f e
+
+mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpM _ (CmmEntry{}) = Nothing
+mapExpM _ (CmmComment _) = Nothing
+mapExpM _ (CmmTick _) = Nothing
+mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs
+mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
+mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
+mapExpM _ (CmmBranch _) = Nothing
+mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e
+mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e
+mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
+mapExpM f (CmmUnsafeForeignCall tgt fs as)
+ = case mapForeignTargetM f tgt of
+ Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
+ Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
+mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
+ = case mapForeignTargetM f tgt of
+ Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
+ Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
+
+-- share as much as possible
+mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
+mapListM f xs = let (b, r) = mapListT f xs
+ in if b then Just r else Nothing
+
+mapListJ :: (a -> Maybe a) -> [a] -> [a]
+mapListJ f xs = snd (mapListT f xs)
+
+mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
+mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
+ where g (_, y, Nothing) (True, ys) = (True, y:ys)
+ g (_, _, Just y) (True, ys) = (True, y:ys)
+ g (ys', _, Nothing) (False, _) = (False, ys')
+ g (_, _, Just y) (False, ys) = (True, y:ys)
+
+mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpDeepM f = mapExpM $ wrapRecExpM f
+
+-----------------------------------
+-- folding Expr in GHC.Cmm.Node
+
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
+foldExpForeignTarget _ (PrimTarget _) z = z
+
+-- Take a folder on expressions and apply it recursively.
+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
+-- itself, delegating all the other CmmExpr forms to 'f'.
+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
+wrapRecExpf f e z = f e z
+
+foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExp _ (CmmEntry {}) z = z
+foldExp _ (CmmComment {}) z = z
+foldExp _ (CmmTick {}) z = z
+foldExp f (CmmUnwind xs) z = foldr (maybe id f) z (map snd xs)
+foldExp f (CmmAssign _ e) z = f e z
+foldExp f (CmmStore addr e) z = f addr $ f e z
+foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
+foldExp _ (CmmBranch _) z = z
+foldExp f (CmmCondBranch e _ _ _) z = f e z
+foldExp f (CmmSwitch e _) z = f e z
+foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
+
+foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExpDeep f = foldExp (wrapRecExpf f)
+
+-- -----------------------------------------------------------------------------
+
+mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
+mapSuccessors f (CmmBranch bid) = CmmBranch (f bid)
+mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
+mapSuccessors f (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets f ids)
+mapSuccessors _ n = n
+
+mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C
+ -> (CmmNode O C, [a])
+mapCollectSuccessors f (CmmBranch bid)
+ = let (bid', acc) = f bid in (CmmBranch bid', [acc])
+mapCollectSuccessors f (CmmCondBranch p y n l)
+ = let (bidt, acct) = f y
+ (bidf, accf) = f n
+ in (CmmCondBranch p bidt bidf l, [accf, acct])
+mapCollectSuccessors f (CmmSwitch e ids)
+ = let lbls = switchTargetsToList ids :: [Label]
+ lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)
+ in ( CmmSwitch e
+ (mapSwitchTargets
+ (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)
+ , map snd (mapElems lblMap)
+ )
+mapCollectSuccessors _ n = (n, [])
+
+-- -----------------------------------------------------------------------------
+
+-- | Tickish in Cmm context (annotations only)
+type CmmTickish = Tickish ()
+
+-- | Tick scope identifier, allowing us to reason about what
+-- annotations in a Cmm block should scope over. We especially take
+-- care to allow optimisations to reorganise blocks without losing
+-- tick association in the process.
+data CmmTickScope
+ = GlobalScope
+ -- ^ The global scope is the "root" of the scope graph. Every
+ -- scope is a sub-scope of the global scope. It doesn't make sense
+ -- to add ticks to this scope. On the other hand, this means that
+ -- setting this scope on a block means no ticks apply to it.
+
+ | SubScope !U.Unique CmmTickScope
+ -- ^ Constructs a new sub-scope to an existing scope. This allows
+ -- us to translate Core-style scoping rules (see @tickishScoped@)
+ -- into the Cmm world. Suppose the following code:
+ --
+ -- tick<1> case ... of
+ -- A -> tick<2> ...
+ -- B -> tick<3> ...
+ --
+ -- We want the top-level tick annotation to apply to blocks
+ -- generated for the A and B alternatives. We can achieve that by
+ -- generating tick<1> into a block with scope a, while the code
+ -- for alternatives A and B gets generated into sub-scopes a/b and
+ -- a/c respectively.
+
+ | CombinedScope CmmTickScope CmmTickScope
+ -- ^ A combined scope scopes over everything that the two given
+ -- scopes cover. It is therefore a sub-scope of either scope. This
+ -- is required for optimisations. Consider common block elimination:
+ --
+ -- A -> tick<2> case ... of
+ -- C -> [common]
+ -- B -> tick<3> case ... of
+ -- D -> [common]
+ --
+ -- We will generate code for the C and D alternatives, and figure
+ -- out afterwards that it's actually common code. Scoping rules
+ -- dictate that the resulting common block needs to be covered by
+ -- both tick<2> and tick<3>, therefore we need to construct a
+ -- scope that is a child to *both* scope. Now we can do that - if
+ -- we assign the scopes a/c and b/d to the common-ed up blocks,
+ -- the new block could have a combined tick scope a/c+b/d, which
+ -- both tick<2> and tick<3> apply to.
+
+-- Note [CmmTick scoping details]:
+--
+-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the
+-- same block. Note that as a result of this, optimisations making
+-- tick scopes more specific can *reduce* the amount of code a tick
+-- scopes over. Fixing this would require a separate @CmmTickScope@
+-- field for @CmmTick@. Right now we do not do this simply because I
+-- couldn't find an example where it actually mattered -- multiple
+-- blocks within the same scope generally jump to each other, which
+-- prevents common block elimination from happening in the first
+-- place. But this is no strong reason, so if Cmm optimisations become
+-- more involved in future this might have to be revisited.
+
+-- | Output all scope paths.
+scopeToPaths :: CmmTickScope -> [[U.Unique]]
+scopeToPaths GlobalScope = [[]]
+scopeToPaths (SubScope u s) = map (u:) (scopeToPaths s)
+scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2
+
+-- | Returns the head uniques of the scopes. This is based on the
+-- assumption that the @Unique@ of @SubScope@ identifies the
+-- underlying super-scope. Used for efficient equality and comparison,
+-- see below.
+scopeUniques :: CmmTickScope -> [U.Unique]
+scopeUniques GlobalScope = []
+scopeUniques (SubScope u _) = [u]
+scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2
+
+-- Equality and order is based on the head uniques defined above. We
+-- take care to short-cut the (extremely) common cases.
+instance Eq CmmTickScope where
+ GlobalScope == GlobalScope = True
+ GlobalScope == _ = False
+ _ == GlobalScope = False
+ (SubScope u _) == (SubScope u' _) = u == u'
+ (SubScope _ _) == _ = False
+ _ == (SubScope _ _) = False
+ scope == scope' =
+ sortBy nonDetCmpUnique (scopeUniques scope) ==
+ sortBy nonDetCmpUnique (scopeUniques scope')
+ -- This is still deterministic because
+ -- the order is the same for equal lists
+
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
+instance Ord CmmTickScope where
+ compare GlobalScope GlobalScope = EQ
+ compare GlobalScope _ = LT
+ compare _ GlobalScope = GT
+ compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'
+ compare scope scope' = cmpList nonDetCmpUnique
+ (sortBy nonDetCmpUnique $ scopeUniques scope)
+ (sortBy nonDetCmpUnique $ scopeUniques scope')
+
+instance Outputable CmmTickScope where
+ ppr GlobalScope = text "global"
+ ppr (SubScope us GlobalScope)
+ = ppr us
+ ppr (SubScope us s) = ppr s <> char '/' <> ppr us
+ ppr combined = parens $ hcat $ punctuate (char '+') $
+ map (hcat . punctuate (char '/') . map ppr . reverse) $
+ scopeToPaths combined
+
+-- | Checks whether two tick scopes are sub-scopes of each other. True
+-- if the two scopes are equal.
+isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
+isTickSubScope = cmp
+ where cmp _ GlobalScope = True
+ cmp GlobalScope _ = False
+ cmp (CombinedScope s1 s2) s' = cmp s1 s' && cmp s2 s'
+ cmp s (CombinedScope s1' s2') = cmp s s1' || cmp s s2'
+ cmp (SubScope u s) s'@(SubScope u' _) = u == u' || cmp s s'
+
+-- | Combine two tick scopes. The new scope should be sub-scope of
+-- both parameters. We simplify automatically if one tick scope is a
+-- sub-scope of the other already.
+combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
+combineTickScopes s1 s2
+ | s1 `isTickSubScope` s2 = s1
+ | s2 `isTickSubScope` s1 = s2
+ | otherwise = CombinedScope s1 s2
diff --git a/compiler/GHC/Cmm/Switch.hs b/compiler/GHC/Cmm/Switch.hs
new file mode 100644
index 0000000..ee0d5a0
--- /dev/null
+++ b/compiler/GHC/Cmm/Switch.hs
@@ -0,0 +1,503 @@
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+module GHC.Cmm.Switch (
+ SwitchTargets,
+ mkSwitchTargets,
+ switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,
+ mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,
+ switchTargetsToList, eqSwitchTargetWith,
+
+ SwitchPlan(..),
+ backendSupportsSwitch,
+ createSwitchPlan,
+ ) where
+
+import GHC.Prelude
+
+import GHC.Utils.Outputable
+import GHC.Driver.Backend
+import GHC.Cmm.Dataflow.Label (Label)
+
+import Data.Maybe
+import Data.List (groupBy)
+import Data.Function (on)
+import qualified Data.Map as M
+
+-- Note [Cmm Switches, the general plan]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Compiling a high-level switch statement, as it comes out of a STG case
+-- expression, for example, allows for a surprising amount of design decisions.
+-- Therefore, we cleanly separated this from the Stg → Cmm transformation, as
+-- well as from the actual code generation.
+--
+-- The overall plan is:
+-- * The Stg → Cmm transformation creates a single `SwitchTargets` in
+-- emitSwitch and emitCmmLitSwitch in GHC.StgToCmm.Utils.
+-- At this stage, they are unsuitable for code generation.
+-- * A dedicated Cmm transformation (GHC.Cmm.Switch.Implement) replaces these
+-- switch statements with code that is suitable for code generation, i.e.
+-- a nice balanced tree of decisions with dense jump tables in the leafs.
+-- The actual planning of this tree is performed in pure code in createSwitchPlan
+-- in this module. See Note [createSwitchPlan].
+-- * The actual code generation will not do any further processing and
+-- implement each CmmSwitch with a jump tables.
+--
+-- When compiling to LLVM or C, GHC.Cmm.Switch.Implement leaves the switch
+-- statements alone, as we can turn a SwitchTargets value into a nice
+-- switch-statement in LLVM resp. C, and leave the rest to the compiler.
+--
+-- See Note [GHC.Cmm.Switch vs. GHC.Cmm.Switch.Implement] why the two module are
+-- separated.
+
+-----------------------------------------------------------------------------
+-- Note [Magic Constants in GHC.Cmm.Switch]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- There are a lot of heuristics here that depend on magic values where it is
+-- hard to determine the "best" value (for whatever that means). These are the
+-- magic values:
+
+-- | Number of consecutive default values allowed in a jump table. If there are
+-- more of them, the jump tables are split.
+--
+-- Currently 7, as it costs 7 words of additional code when a jump table is
+-- split (at least on x64, determined experimentally).
+maxJumpTableHole :: Integer
+maxJumpTableHole = 7
+
+-- | Minimum size of a jump table. If the number is smaller, the switch is
+-- implemented using conditionals.
+-- Currently 5, because an if-then-else tree of 4 values is nice and compact.
+minJumpTableSize :: Int
+minJumpTableSize = 5
+
+-- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset].
+minJumpTableOffset :: Integer
+minJumpTableOffset = 2
+
+
+-----------------------------------------------------------------------------
+-- Switch Targets
+
+-- Note [SwitchTargets]
+-- ~~~~~~~~~~~~~~~~~~~~
+--
+-- The branches of a switch are stored in a SwitchTargets, which consists of an
+-- (optional) default jump target, and a map from values to jump targets.
+--
+-- If the default jump target is absent, the behaviour of the switch outside the
+-- values of the map is undefined.
+--
+-- We use an Integer for the keys the map so that it can be used in switches on
+-- unsigned as well as signed integers.
+--
+-- The map may be empty (we prune out-of-range branches here, so it could be us
+-- emptying it).
+--
+-- Before code generation, the table needs to be brought into a form where all
+-- entries are non-negative, so that it can be compiled into a jump table.
+-- See switchTargetsToTable.
+
+
+-- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch'
+-- value, and knows whether the value is signed, the possible range, an
+-- optional default value and a map from values to jump labels.
+data SwitchTargets =
+ SwitchTargets
+ Bool -- Signed values
+ (Integer, Integer) -- Range
+ (Maybe Label) -- Default value
+ (M.Map Integer Label) -- The branches
+ deriving (Show, Eq)
+
+-- | The smart constructor mkSwitchTargets normalises the map a bit:
+-- * No entries outside the range
+-- * No entries equal to the default
+-- * No default if all elements have explicit values
+mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets
+mkSwitchTargets signed range@(lo,hi) mbdef ids
+ = SwitchTargets signed range mbdef' ids'
+ where
+ ids' = dropDefault $ restrict ids
+ mbdef' | defaultNeeded = mbdef
+ | otherwise = Nothing
+
+ -- Drop entries outside the range, if there is a range
+ restrict = restrictMap (lo,hi)
+
+ -- Drop entries that equal the default, if there is a default
+ dropDefault | Just l <- mbdef = M.filter (/= l)
+ | otherwise = id
+
+ -- Check if the default is still needed
+ defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1
+
+
+-- | Changes all labels mentioned in the SwitchTargets value
+mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets
+mapSwitchTargets f (SwitchTargets signed range mbdef branches)
+ = SwitchTargets signed range (fmap f mbdef) (fmap f branches)
+
+-- | Returns the list of non-default branches of the SwitchTargets value
+switchTargetsCases :: SwitchTargets -> [(Integer, Label)]
+switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches
+
+-- | Return the default label of the SwitchTargets value
+switchTargetsDefault :: SwitchTargets -> Maybe Label
+switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef
+
+-- | Return the range of the SwitchTargets value
+switchTargetsRange :: SwitchTargets -> (Integer, Integer)
+switchTargetsRange (SwitchTargets _ range _ _) = range
+
+-- | Return whether this is used for a signed value
+switchTargetsSigned :: SwitchTargets -> Bool
+switchTargetsSigned (SwitchTargets signed _ _ _) = signed
+
+-- | switchTargetsToTable creates a dense jump table, usable for code generation.
+--
+-- Also returns an offset to add to the value; the list is 0-based on the
+-- result of that addition.
+--
+-- The conversion from Integer to Int is a bit of a wart, as the actual
+-- scrutinee might be an unsigned word, but it just works, due to wrap-around
+-- arithmetic (as verified by the CmmSwitchTest test case).
+switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label])
+switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches)
+ = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ])
+ where
+ labelFor i = case M.lookup i branches of Just l -> Just l
+ Nothing -> mbdef
+ start | lo >= 0 && lo < minJumpTableOffset = 0 -- See Note [Jump Table Offset]
+ | otherwise = lo
+
+-- Note [Jump Table Offset]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Usually, the code for a jump table starting at x will first subtract x from
+-- the value, to avoid a large amount of empty entries. But if x is very small,
+-- the extra entries are no worse than the subtraction in terms of code size, and
+-- not having to do the subtraction is quicker.
+--
+-- I.e. instead of
+-- _u20N:
+-- leaq -1(%r14),%rax
+-- jmp *_n20R(,%rax,8)
+-- _n20R:
+-- .quad _c20p
+-- .quad _c20q
+-- do
+-- _u20N:
+-- jmp *_n20Q(,%r14,8)
+--
+-- _n20Q:
+-- .quad 0
+-- .quad _c20p
+-- .quad _c20q
+-- .quad _c20r
+
+-- | The list of all labels occurring in the SwitchTargets value.
+switchTargetsToList :: SwitchTargets -> [Label]
+switchTargetsToList (SwitchTargets _ _ mbdef branches)
+ = maybeToList mbdef ++ M.elems branches
+
+-- | Groups cases with equal targets, suitable for pretty-printing to a
+-- c-like switch statement with fall-through semantics.
+switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)
+switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)
+ where
+ groups = map (\xs -> (map fst xs, snd (head xs))) $
+ groupBy ((==) `on` snd) $
+ M.toList branches
+
+-- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim"
+eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool
+eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) =
+ signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2)
+ where
+ goMB Nothing Nothing = True
+ goMB (Just l1) (Just l2) = l1 `eq` l2
+ goMB _ _ = False
+ goList [] [] = True
+ goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2
+ goList _ _ = False
+
+-----------------------------------------------------------------------------
+-- Code generation for Switches
+
+
+-- | A SwitchPlan abstractly describes how a Switch statement ought to be
+-- implemented. See Note [createSwitchPlan]
+data SwitchPlan
+ = Unconditionally Label
+ | IfEqual Integer Label SwitchPlan
+ | IfLT Bool Integer SwitchPlan SwitchPlan
+ | JumpTable SwitchTargets
+ deriving Show
+--
+-- Note [createSwitchPlan]
+-- ~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- A SwitchPlan describes how a Switch statement is to be broken down into
+-- smaller pieces suitable for code generation.
+--
+-- createSwitchPlan creates such a switch plan, in these steps:
+-- 1. It splits the switch statement at segments of non-default values that
+-- are too large. See splitAtHoles and Note [Magic Constants in GHC.Cmm.Switch]
+-- 2. Too small jump tables should be avoided, so we break up smaller pieces
+-- in breakTooSmall.
+-- 3. We fill in the segments between those pieces with a jump to the default
+-- label (if there is one), returning a SeparatedList in mkFlatSwitchPlan
+-- 4. We find and replace two less-than branches by a single equal-to-test in
+-- findSingleValues
+-- 5. The thus collected pieces are assembled to a balanced binary tree.
+
+{-
+ Note [Two alts + default]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Discussion and a bit more info at #14644
+
+When dealing with a switch of the form:
+switch(e) {
+ case 1: goto l1;
+ case 3000: goto l2;
+ default: goto ldef;
+}
+
+If we treat it as a sparse jump table we would generate:
+
+if (e > 3000) //Check if value is outside of the jump table.
+ goto ldef;
+else {
+ if (e < 3000) { //Compare to upper value
+ if(e != 1) //Compare to remaining value
+ goto ldef;
+ else
+ goto l2;
+ }
+ else
+ goto l1;
+}
+
+Instead we special case this to :
+
+if (e==1) goto l1;
+else if (e==3000) goto l2;
+else goto l3;
+
+This means we have:
+* Less comparisons for: 1,<3000
+* Unchanged for 3000
+* One more for >3000
+
+This improves code in a few ways:
+* One comparison less means smaller code which helps with cache.
+* It exchanges a taken jump for two jumps no taken in the >range case.
+ Jumps not taken are cheaper (See Agner guides) making this about as fast.
+* For all other cases the first range check is removed making it faster.
+
+The end result is that the change is not measurably slower for the case
+>3000 and faster for the other cases.
+
+This makes running this kind of match in an inner loop cheaper by 10-20%
+depending on the data.
+In nofib this improves wheel-sieve1 by 4-9% depending on problem
+size.
+
+We could also add a second conditional jump after the comparison to
+keep the range check like this:
+ cmp 3000, rArgument
+ jg <default>
+ je <branch 2>
+While this is fairly cheap it made no big difference for the >3000 case
+and slowed down all other cases making it not worthwhile.
+-}
+
+
+-- | Does the backend support switch out of the box? Then leave this to the
+-- backend!
+backendSupportsSwitch :: Backend -> Bool
+backendSupportsSwitch ViaC = True
+backendSupportsSwitch LLVM = True
+backendSupportsSwitch _ = False
+
+-- | This function creates a SwitchPlan from a SwitchTargets value, breaking it
+-- down into smaller pieces suitable for code generation.
+createSwitchPlan :: SwitchTargets -> SwitchPlan
+-- Lets do the common case of a singleton map quickly and efficiently (#10677)
+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)
+ | [(x, l)] <- M.toList m
+ = IfEqual x l (Unconditionally defLabel)
+-- And another common case, matching "booleans"
+createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m)
+ | [(x1, l1), (_x2,l2)] <- M.toAscList m
+ --Checking If |range| = 2 is enough if we have two unique literals
+ , hi - lo == 1
+ = IfEqual x1 l1 (Unconditionally l2)
+-- See Note [Two alts + default]
+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)
+ | [(x1, l1), (x2,l2)] <- M.toAscList m
+ = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel))
+createSwitchPlan (SwitchTargets signed range mbdef m) =
+ -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $
+ plan
+ where
+ pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m
+ flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces
+ plan = buildTree signed $ flatPlan
+
+
+---
+--- Step 1: Splitting at large holes
+---
+splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a]
+splitAtHoles _ m | M.null m = []
+splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles
+ where
+ holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m))
+ nonHoles = reassocTuples lo holes hi
+
+ (lo,_) = M.findMin m
+ (hi,_) = M.findMax m
+
+---
+--- Step 2: Avoid small jump tables
+---
+-- We do not want jump tables below a certain size. This breaks them up
+-- (into singleton maps, for now).
+breakTooSmall :: M.Map Integer a -> [M.Map Integer a]
+breakTooSmall m
+ | M.size m > minJumpTableSize = [m]
+ | otherwise = [M.singleton k v | (k,v) <- M.toList m]
+
+---
+--- Step 3: Fill in the blanks
+---
+
+-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every
+-- two entries, dividing the range.
+-- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if
+-- the expression is < n, and plan2 otherwise.
+
+type FlatSwitchPlan = SeparatedList Integer SwitchPlan
+
+mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan
+
+-- If we have no default (i.e. undefined where there is no entry), we can
+-- branch at the minimum of each map
+mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty
+mkFlatSwitchPlan signed Nothing _ (m:ms)
+ = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ])
+
+-- If we have a default, we have to interleave segments that jump
+-- to the default between the maps
+mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps)
+ where
+ go (lo,hi) []
+ | lo > hi = []
+ | otherwise = [(lo, Unconditionally l)]
+ go (lo,hi) (m:ms)
+ | lo < min
+ = (lo, Unconditionally l) : go (min,hi) (m:ms)
+ | lo == min
+ = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms
+ | otherwise
+ = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min)
+ where
+ min = fst (M.findMin m)
+ max = fst (M.findMax m)
+
+
+mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan
+mkLeafPlan signed mbdef m
+ | [(_,l)] <- M.toList m -- singleton map
+ = Unconditionally l
+ | otherwise
+ = JumpTable $ mkSwitchTargets signed (min,max) mbdef m
+ where
+ min = fst (M.findMin m)
+ max = fst (M.findMax m)
+
+---
+--- Step 4: Reduce the number of branches using ==
+---
+
+-- A sequence of three unconditional jumps, with the outer two pointing to the
+-- same value and the bounds off by exactly one can be improved
+findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan
+findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs)
+ | l == l3 && i + 1 == i'
+ = findSingleValues (IfEqual i l2 (Unconditionally l), xs)
+findSingleValues (p, (i,p'):xs)
+ = (p,i) `consSL` findSingleValues (p', xs)
+findSingleValues (p, [])
+ = (p, [])
+
+---
+--- Step 5: Actually build the tree
+---
+
+-- Build a balanced tree from a separated list
+buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan
+buildTree _ (p,[]) = p
+buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2)
+ where
+ (sl1, m, sl2) = divideSL sl
+
+
+
+--
+-- Utility data type: Non-empty lists with extra markers in between each
+-- element:
+--
+
+type SeparatedList b a = (a, [(b,a)])
+
+consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a
+consSL (a, b) (a', xs) = (a, (b,a'):xs)
+
+divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a)
+divideSL (_,[]) = error "divideSL: Singleton SeparatedList"
+divideSL (p,xs) = ((p, xs1), m, (p', xs2))
+ where
+ (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs
+
+--
+-- Other Utilities
+--
+
+restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b
+restrictMap (lo,hi) m = mid
+ where (_, mid_hi) = M.split (lo-1) m
+ (mid, _) = M.split (hi+1) mid_hi
+
+-- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)]
+reassocTuples :: a -> [(a,a)] -> a -> [(a,a)]
+reassocTuples initial [] last
+ = [(initial,last)]
+reassocTuples initial ((a,b):tuples) last
+ = (initial,a) : reassocTuples b tuples last
+
+-- Note [GHC.Cmm.Switch vs. GHC.Cmm.Switch.Implement]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- I (Joachim) separated the two somewhat closely related modules
+--
+-- - GHC.Cmm.Switch, which provides the CmmSwitchTargets type and contains the strategy
+-- for implementing a Cmm switch (createSwitchPlan), and
+-- - GHC.Cmm.Switch.Implement, which contains the actual Cmm graph modification,
+--
+-- for these reasons:
+--
+-- * GHC.Cmm.Switch is very low in the dependency tree, i.e. does not depend on any
+-- GHC specific modules at all (with the exception of Output and
+-- GHC.Cmm.Dataflow (Literal)).
+-- * GHC.Cmm.Switch.Implement is the Cmm transformation and hence very high in
+-- the dependency tree.
+-- * GHC.Cmm.Switch provides the CmmSwitchTargets data type, which is abstract, but
+-- used in GHC.Cmm.Node.
+-- * Because GHC.Cmm.Switch is low in the dependency tree, the separation allows
+-- for more parallelism when building GHC.
+-- * The interaction between the modules is very explicit and easy to
+-- understand, due to the small and simple interface.
diff --git a/compiler/cmm/CmmType.hs b/compiler/GHC/Cmm/Type.hs
index 0d6e770..0e7601c 100644
--- a/compiler/cmm/CmmType.hs
+++ b/compiler/GHC/Cmm/Type.hs
@@ -1,4 +1,4 @@
-module CmmType
+module GHC.Cmm.Type
( CmmType -- Abstract
, b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord
, cInt
@@ -29,11 +29,11 @@ module CmmType
where
-import GhcPrelude
+import GHC.Prelude
-import DynFlags
-import FastString
-import Outputable
+import GHC.Platform
+import GHC.Data.FastString
+import GHC.Utils.Outputable
import Data.Word
import Data.Int
@@ -120,17 +120,17 @@ f32 = cmmFloat W32
f64 = cmmFloat W64
-- CmmTypes of native word widths
-bWord :: DynFlags -> CmmType
-bWord dflags = cmmBits (wordWidth dflags)
+bWord :: Platform -> CmmType
+bWord platform = cmmBits (wordWidth platform)
-bHalfWord :: DynFlags -> CmmType
-bHalfWord dflags = cmmBits (halfWordWidth dflags)
+bHalfWord :: Platform -> CmmType
+bHalfWord platform = cmmBits (halfWordWidth platform)
-gcWord :: DynFlags -> CmmType
-gcWord dflags = CmmType GcPtrCat (wordWidth dflags)
+gcWord :: Platform -> CmmType
+gcWord platform = CmmType GcPtrCat (wordWidth platform)
-cInt :: DynFlags -> CmmType
-cInt dflags = cmmBits (cIntWidth dflags)
+cInt :: Platform -> CmmType
+cInt platform = cmmBits (cIntWidth platform)
------------ Predicates ----------------
isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool
@@ -166,9 +166,6 @@ isFloat64 _other = False
-----------------------------------------------------------------------------
data Width = W8 | W16 | W32 | W64
- | W80 -- Extended double-precision float,
- -- used in x86 native codegen only.
- -- (we use Ord, so it'd better be in this order)
| W128
| W256
| W512
@@ -178,38 +175,28 @@ instance Outputable Width where
ppr rep = ptext (mrStr rep)
mrStr :: Width -> PtrString
-mrStr W8 = sLit("W8")
-mrStr W16 = sLit("W16")
-mrStr W32 = sLit("W32")
-mrStr W64 = sLit("W64")
-mrStr W128 = sLit("W128")
-mrStr W256 = sLit("W256")
-mrStr W512 = sLit("W512")
-mrStr W80 = sLit("W80")
+mrStr = sLit . show
-------- Common Widths ------------
-wordWidth :: DynFlags -> Width
-wordWidth dflags
- | wORD_SIZE dflags == 4 = W32
- | wORD_SIZE dflags == 8 = W64
- | otherwise = panic "MachOp.wordRep: Unknown word size"
-
-halfWordWidth :: DynFlags -> Width
-halfWordWidth dflags
- | wORD_SIZE dflags == 4 = W16
- | wORD_SIZE dflags == 8 = W32
- | otherwise = panic "MachOp.halfWordRep: Unknown word size"
-
-halfWordMask :: DynFlags -> Integer
-halfWordMask dflags
- | wORD_SIZE dflags == 4 = 0xFFFF
- | wORD_SIZE dflags == 8 = 0xFFFFFFFF
- | otherwise = panic "MachOp.halfWordMask: Unknown word size"
+wordWidth :: Platform -> Width
+wordWidth platform = case platformWordSize platform of
+ PW4 -> W32
+ PW8 -> W64
+
+halfWordWidth :: Platform -> Width
+halfWordWidth platform = case platformWordSize platform of
+ PW4 -> W16
+ PW8 -> W32
+
+halfWordMask :: Platform -> Integer
+halfWordMask platform = case platformWordSize platform of
+ PW4 -> 0xFFFF
+ PW8 -> 0xFFFFFFFF
-- cIntRep is the Width for a C-language 'int'
-cIntWidth :: DynFlags -> Width
-cIntWidth dflags = case cINT_SIZE dflags of
+cIntWidth :: Platform -> Width
+cIntWidth platform = case pc_CINT_SIZE (platformConstants platform) of
4 -> W32
8 -> W64
s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s)
@@ -222,7 +209,7 @@ widthInBits W64 = 64
widthInBits W128 = 128
widthInBits W256 = 256
widthInBits W512 = 512
-widthInBits W80 = 80
+
widthInBytes :: Width -> Int
widthInBytes W8 = 1
@@ -232,7 +219,7 @@ widthInBytes W64 = 8
widthInBytes W128 = 16
widthInBytes W256 = 32
widthInBytes W512 = 64
-widthInBytes W80 = 10
+
widthFromBytes :: Int -> Width
widthFromBytes 1 = W8
@@ -242,7 +229,7 @@ widthFromBytes 8 = W64
widthFromBytes 16 = W128
widthFromBytes 32 = W256
widthFromBytes 64 = W512
-widthFromBytes 10 = W80
+
widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n)
-- log_2 of the width in bytes, useful for generating shifts.
@@ -254,7 +241,7 @@ widthInLog W64 = 3
widthInLog W128 = 4
widthInLog W256 = 5
widthInLog W512 = 6
-widthInLog W80 = panic "widthInLog: F80"
+
-- widening / narrowing
@@ -335,25 +322,25 @@ data ForeignHint
-- These don't really belong here, but I don't know where is best to
-- put them.
-rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType
-rEP_CostCentreStack_mem_alloc dflags
+rEP_CostCentreStack_mem_alloc :: Platform -> CmmType
+rEP_CostCentreStack_mem_alloc platform
= cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc))
- where pc = sPlatformConstants (settings dflags)
+ where pc = platformConstants platform
-rEP_CostCentreStack_scc_count :: DynFlags -> CmmType
-rEP_CostCentreStack_scc_count dflags
+rEP_CostCentreStack_scc_count :: Platform -> CmmType
+rEP_CostCentreStack_scc_count platform
= cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc))
- where pc = sPlatformConstants (settings dflags)
+ where pc = platformConstants platform
-rEP_StgEntCounter_allocs :: DynFlags -> CmmType
-rEP_StgEntCounter_allocs dflags
+rEP_StgEntCounter_allocs :: Platform -> CmmType
+rEP_StgEntCounter_allocs platform
= cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc))
- where pc = sPlatformConstants (settings dflags)
+ where pc = platformConstants platform
-rEP_StgEntCounter_allocd :: DynFlags -> CmmType
-rEP_StgEntCounter_allocd dflags
+rEP_StgEntCounter_allocd :: Platform -> CmmType
+rEP_StgEntCounter_allocd platform
= cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc))
- where pc = sPlatformConstants (settings dflags)
+ where pc = platformConstants platform
-------------------------------------------------------------------------
{- Note [Signed vs unsigned]
diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs
new file mode 100644
index 0000000..e6b5489
--- /dev/null
+++ b/compiler/GHC/CmmToAsm/Config.hs
@@ -0,0 +1,46 @@
+-- | Native code generator configuration
+module GHC.CmmToAsm.Config
+ ( NCGConfig(..)
+ , ncgWordWidth
+ , ncgSpillPreallocSize
+ , platformWordWidth
+ )
+where
+
+import GHC.Prelude
+import GHC.Platform
+import GHC.Cmm.Type (Width(..))
+
+-- | Native code generator configuration
+data NCGConfig = NCGConfig
+ { ncgPlatform :: !Platform -- ^ Target platform
+ , ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment
+ , ncgDebugLevel :: !Int -- ^ Debug level
+ , ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
+ , ncgPIC :: !Bool -- ^ Enable Position-Independent Code
+ , ncgInlineThresholdMemcpy :: !Word -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it
+ , ncgInlineThresholdMemset :: !Word -- ^ Ditto for `memset`
+ , ncgSplitSections :: !Bool -- ^ Split sections
+ , ncgRegsIterative :: !Bool
+ , ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass
+ , ncgDoConstantFolding :: !Bool -- ^ Perform CMM constant folding
+ , ncgSseVersion :: Maybe SseVersion -- ^ (x86) SSE instructions
+ , ncgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions
+ , ncgDumpRegAllocStages :: !Bool
+ , ncgDumpAsmStats :: !Bool
+ , ncgDumpAsmConflicts :: !Bool
+ }
+
+-- | Return Word size
+ncgWordWidth :: NCGConfig -> Width
+ncgWordWidth config = platformWordWidth (ncgPlatform config)
+
+-- | Size in bytes of the pre-allocated spill space on the C stack
+ncgSpillPreallocSize :: NCGConfig -> Int
+ncgSpillPreallocSize config = pc_RESERVED_C_STACK_BYTES (platformConstants (ncgPlatform config))
+
+-- | Return Word size
+platformWordWidth :: Platform -> Width
+platformWordWidth platform = case platformWordSize platform of
+ PW4 -> W32
+ PW8 -> W64
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/GHC/Core.hs
index ecf8bfe..c01c14a 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/GHC/Core.hs
@@ -6,9 +6,11 @@
{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
--- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
-module CoreSyn (
+-- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection
+module GHC.Core (
-- * Main data types
Expr(..), Alt, Bind(..), AltCon(..), Arg,
Tickish(..), TickishScoping(..), TickishPlacement(..),
@@ -67,7 +69,7 @@ module CoreSyn (
maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
- isStableUnfolding, isFragileUnfolding, hasSomeUnfolding,
+ isStableUnfolding, hasCoreUnfolding, hasSomeUnfolding,
isBootUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
@@ -87,7 +89,7 @@ module CoreSyn (
-- * Core rule data types
CoreRule(..), RuleBase,
RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
- RuleEnv(..), mkRuleEnv, emptyRuleEnv,
+ RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv,
-- ** Operations on 'CoreRule's
ruleArity, ruleName, ruleIdName, ruleActivation,
@@ -97,26 +99,26 @@ module CoreSyn (
#include "GhclibHsVersions.h"
-import GhcPrelude
-
-import CostCentre
-import VarEnv( InScopeSet )
-import Var
-import Type
-import Coercion
-import Name
-import NameSet
-import NameEnv( NameEnv, emptyNameEnv )
-import Literal
-import DataCon
-import Module
-import BasicTypes
-import DynFlags
-import Outputable
-import Util
-import UniqSet
-import SrcLoc ( RealSrcSpan, containsSpan )
-import Binary
+import GHC.Prelude
+import GHC.Platform
+
+import GHC.Types.CostCentre
+import GHC.Types.Var.Env( InScopeSet )
+import GHC.Types.Var
+import GHC.Core.Type
+import GHC.Core.Coercion
+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 GHC.Unit.Module
+import GHC.Types.Basic
+import GHC.Utils.Outputable
+import GHC.Utils.Misc
+import GHC.Types.Unique.Set
+import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan )
+import GHC.Utils.Binary
import Data.Data hiding (TyCon)
import Data.Int
@@ -142,10 +144,10 @@ These data types are the heart of the compiler
-- We get from Haskell source to this Core language in a number of stages:
--
-- 1. The source code is parsed into an abstract syntax tree, which is represented
--- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'
+-- by the data type 'GHC.Hs.Expr.HsExpr' with the names being 'GHC.Types.Name.Reader.RdrNames'
--
--- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'
--- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical.
+-- 2. This syntax tree is /renamed/, which attaches a 'GHC.Types.Unique.Unique' to every 'GHC.Types.Name.Reader.RdrName'
+-- (yielding a 'GHC.Types.Name.Name') to disambiguate identifiers which are lexically identical.
-- For example, this program:
--
-- @
@@ -162,9 +164,9 @@ These data types are the heart of the compiler
-- But see Note [Shadowing] below.
--
-- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating
--- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names.
+-- type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'GHC.Types.Id.Id' as it's names.
--
--- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into
+-- 4. Finally the syntax tree is /desugared/ from the expressive 'GHC.Hs.Expr.HsExpr' type into
-- this 'Expr' type, which has far fewer constructors and hence is easier to perform
-- optimization, analysis and code generation on.
--
@@ -178,7 +180,7 @@ These data types are the heart of the compiler
-- * Primitive literals
--
-- * Applications: note that the argument may be a 'Type'.
--- See Note [CoreSyn let/app invariant]
+-- See Note [Core let/app invariant]
-- See Note [Levity polymorphism invariants]
--
-- * Lambda abstraction
@@ -188,10 +190,10 @@ These data types are the heart of the compiler
-- this corresponds to allocating a thunk for the things
-- bound and then executing the sub-expression.
--
--- See Note [CoreSyn letrec invariant]
--- See Note [CoreSyn let/app invariant]
+-- See Note [Core letrec invariant]
+-- See Note [Core let/app invariant]
-- See Note [Levity polymorphism invariants]
--- See Note [CoreSyn type and coercion invariant]
+-- See Note [Core type and coercion invariant]
--
-- * Case expression. Operationally this corresponds to evaluating
-- the scrutinee (expression examined) to weak head normal form
@@ -201,61 +203,64 @@ These data types are the heart of the compiler
-- The binder gets bound to the value of the scrutinee,
-- and the 'Type' must be that of all the case alternatives
--
--- #case_invariants#
--- This is one of the more complicated elements of the Core language,
--- and comes with a number of restrictions:
---
--- 1. The list of alternatives may be empty;
--- See Note [Empty case alternatives]
---
--- 2. The 'DEFAULT' case alternative must be first in the list,
--- if it occurs at all.
---
--- 3. The remaining cases are in order of increasing
--- tag (for 'DataAlts') or
--- lit (for 'LitAlts').
--- This makes finding the relevant constructor easy,
--- and makes comparison easier too.
---
--- 4. The list of alternatives must be exhaustive. An /exhaustive/ case
--- does not necessarily mention all constructors:
---
--- @
--- data Foo = Red | Green | Blue
--- ... case x of
--- Red -> True
--- other -> f (case x of
--- Green -> ...
--- Blue -> ... ) ...
--- @
---
--- The inner case does not need a @Red@ alternative, because @x@
--- can't be @Red@ at that program point.
---
--- 5. Floating-point values must not be scrutinised against literals.
--- See Trac #9238 and Note [Rules for floating-point comparisons]
--- in PrelRules for rationale.
+-- IMPORTANT: see Note [Case expression invariants]
--
-- * Cast an expression to a particular type.
-- This is used to implement @newtype@s (a @newtype@ constructor or
-- destructor just becomes a 'Cast' in Core) and GADTs.
--
--- * Notes. These allow general information to be added to expressions
--- in the syntax tree
+-- * Ticks. These are used to represent all the source annotation we
+-- support: profiling SCCs, HPC ticks, and GHCi breakpoints.
--
-- * A type: this should only show up at the top level of an Arg
--
-- * A coercion
+{- Note [Why does Case have a 'Type' field?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The obvious alternative is
+ exprType (Case scrut bndr alts)
+ | (_,_,rhs1):_ <- alts
+ = exprType rhs1
+
+But caching the type in the Case constructor
+ exprType (Case scrut bndr ty alts) = ty
+is better for at least three reasons:
+
+* It works when there are no alternatives (see case invariant 1 above)
+
+* It might be faster in deeply-nested situations.
+
+* It might not be quite the same as (exprType rhs) for one
+ of the RHSs in alts. Consider a phantom type synonym
+ type S a = Int
+ and we want to form the case expression
+ case x of { K (a::*) -> (e :: S a) }
+ Then exprType of the RHS is (S a), but we cannot make that be
+ the 'ty' in the Case constructor because 'a' is simply not in
+ scope there. Instead we must expand the synonym to Int before
+ putting it in the Case constructor. See GHC.Core.Utils.mkSingleAltCase.
+
+ So we'd have to do synonym expansion in exprType which would
+ be inefficient.
+
+* The type stored in the case is checked with lintInTy. This checks
+ (among other things) that it does not mention any variables that are
+ not in scope. If we did not have the type there, it would be a bit
+ harder for Core Lint to reject case blah of Ex x -> x where
+ data Ex = forall a. Ex a.
+-}
+
-- If you edit this type, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+-- See Note [GHC Formalism] in GHC.Core.Lint
data Expr b
= Var Id
| Lit Literal
| App (Expr b) (Arg b)
| Lam b (Expr b)
| Let (Bind b) (Expr b)
- | Case (Expr b) b Type [Alt b] -- See #case_invariants#
+ | Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants]
+ -- and Note [Why does Case have a 'Type' field?]
| Cast (Expr b) Coercion
| Tick (Tickish Id) (Expr b)
| Type Type
@@ -271,13 +276,13 @@ type Arg b = Expr b
-- The default alternative is @(DEFAULT, [], rhs)@
-- If you edit this type, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+-- See Note [GHC Formalism] in GHC.Core.Lint
type Alt b = (AltCon, [b], Expr b)
-- | A case alternative constructor (i.e. pattern match)
-- If you edit this type, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+-- See Note [GHC Formalism] in GHC.Core.Lint
data AltCon
= DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
-- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
@@ -292,7 +297,7 @@ data AltCon
-- This instance is a bit shady. It can only be used to compare AltCons for
-- a single type constructor. Fortunately, it seems quite unlikely that we'll
-- ever need to compare AltCons for different type constructors.
--- The instance adheres to the order described in [CoreSyn case invariants]
+-- The instance adheres to the order described in [Core case invariants]
instance Ord AltCon where
compare (DataAlt con1) (DataAlt con2) =
ASSERT( dataConTyCon con1 == dataConTyCon con2 )
@@ -307,7 +312,7 @@ instance Ord AltCon where
-- | Binding, used for top level bindings in a module and local bindings in a @let@.
-- If you edit this type, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+-- See Note [GHC Formalism] in GHC.Core.Lint
data Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
deriving Data
@@ -338,20 +343,21 @@ Note [Literal alternatives]
Literal alternatives (LitAlt lit) are always for *un-lifted* literals.
We have one literal, a literal Integer, that is lifted, and we don't
allow in a LitAlt, because LitAlt cases don't do any evaluation. Also
-(see Trac #5603) if you say
+(see #5603) if you say
case 3 of
- S# x -> ...
- J# _ _ -> ...
-(where S#, J# are the constructors for Integer) we don't want the
+ IS x -> ...
+ IP _ -> ...
+ IN _ -> ...
+(where IS, IP, IN are the constructors for Integer) we don't want the
simplifier calling findAlt with argument (LitAlt 3). No no. Integer
literals are an opaque encoding of an algebraic data type, not of
an unlifted literal, like all the others.
Also, we do not permit case analysis with literal patterns on floating-point
-types. See Trac #9238 and Note [Rules for floating-point comparisons] in
-PrelRules for the rationale for this restriction.
+types. See #9238 and Note [Rules for floating-point comparisons] in
+GHC.Core.Opt.ConstantFold for the rationale for this restriction.
--------------------------- CoreSyn INVARIANTS ---------------------------
+-------------------------- GHC.Core INVARIANTS ---------------------------
Note [Variable occurrences in Core]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -363,18 +369,18 @@ For example
Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in
a Coercion, (sym c).
-Note [CoreSyn letrec invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Core letrec invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The right hand sides of all top-level and recursive @let@s
/must/ be of lifted type (see "Type#type_classification" for
the meaning of /lifted/ vs. /unlifted/).
There is one exception to this rule, top-level @let@s are
allowed to bind primitive string literals: see
-Note [CoreSyn top-level string literals].
+Note [Core top-level string literals].
-Note [CoreSyn top-level string literals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Core top-level string literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As an exception to the usual rule that top-level binders must be lifted,
we allow binding primitive string literals (of type Addr#) of type Addr# at the
top level. This allows us to share string literals earlier in the pipeline and
@@ -386,7 +392,7 @@ Consider,
In order to be able to inline `f`, we would like to float `a` to the top.
Another option would be to inline `a`, but that would lead to duplicating string
-literals, which we want to avoid. See Trac #8472.
+literals, which we want to avoid. See #8472.
The solution is simply to allow top-level unlifted binders. We can't allow
arbitrary unlifted expression at the top-level though, unlifted binders cannot
@@ -395,7 +401,7 @@ be thunks, so we just allow string literals.
We allow the top-level primitive string literals to be wrapped in Ticks
in the same way they can be wrapped when nested in an expression.
CoreToSTG currently discards Ticks around top-level primitive string literals.
-See Trac #14779.
+See #14779.
Also see Note [Compilation plan for top-level string literals].
@@ -408,7 +414,7 @@ parts of the compilation pipeline.
at the top level.
* In Core, we have a special rule that permits top-level Addr# bindings. See
- Note [CoreSyn top-level string literals]. Core-to-core passes may introduce
+ Note [Core top-level string literals]. Core-to-core passes may introduce
new top-level string literals.
* In STG, top-level string literals are explicitly represented in the syntax
@@ -418,8 +424,8 @@ parts of the compilation pipeline.
in the object file, the content of the exported literal is given a label with
the _bytes suffix.
-Note [CoreSyn let/app invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Core let/app invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The let/app invariant
the right hand side of a non-recursive 'Let', and
the argument of an 'App',
@@ -438,18 +444,87 @@ expression is floated out:
y::Int# = fac 4#
In this situation you should use @case@ rather than a @let@. The function
-'CoreUtils.needsCaseBinding' can help you determine which to generate, or
-alternatively use 'MkCore.mkCoreLet' rather than this constructor directly,
+'GHC.Core.Utils.needsCaseBinding' can help you determine which to generate, or
+alternatively use 'GHC.Core.Make.mkCoreLet' rather than this constructor directly,
which will generate a @case@ if necessary
The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in
-coreSyn/MkCore.
+GHC.Core.Make.
For discussion of some implications of the let/app invariant primops see
-Note [Checking versus non-checking primops] in PrimOp.
-
-Note [CoreSyn type and coercion invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps.
+
+Note [Case expression invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Case expressions are one of the more complicated elements of the Core
+language, and come with a number of invariants. All of them should be
+checked by Core Lint.
+
+1. The list of alternatives may be empty;
+ See Note [Empty case alternatives]
+
+2. The 'DEFAULT' case alternative must be first in the list,
+ if it occurs at all. Checked in GHC.Core.Lint.checkCaseAlts.
+
+3. The remaining cases are in order of (strictly) increasing
+ tag (for 'DataAlts') or
+ lit (for 'LitAlts').
+ This makes finding the relevant constructor easy, and makes
+ comparison easier too. Checked in GHC.Core.Lint.checkCaseAlts.
+
+4. The list of alternatives must be exhaustive. An /exhaustive/ case
+ does not necessarily mention all constructors:
+
+ @
+ data Foo = Red | Green | Blue
+ ... case x of
+ Red -> True
+ other -> f (case x of
+ Green -> ...
+ Blue -> ... ) ...
+ @
+
+ The inner case does not need a @Red@ alternative, because @x@
+ can't be @Red@ at that program point.
+
+ This is not checked by Core Lint -- it's very hard to do so.
+ E.g. suppose that inner case was floated out, thus:
+ let a = case x of
+ Green -> ...
+ Blue -> ... )
+ case x of
+ Red -> True
+ other -> f a
+ Now it's really hard to see that the Green/Blue case is
+ exhaustive. But it is.
+
+ If you have a case-expression that really /isn't/ exhaustive,
+ we may generate seg-faults. Consider the Green/Blue case
+ above. Since there are only two branches we may generate
+ code that tests for Green, and if not Green simply /assumes/
+ Blue (since, if the case is exhaustive, that's all that
+ remains). Of course, if it's not Blue and we start fetching
+ fields that should be in a Blue constructor, we may die
+ horribly. See also Note [Core Lint guarantee] in GHC.Core.Lint.
+
+5. Floating-point values must not be scrutinised against literals.
+ See #9238 and Note [Rules for floating-point comparisons]
+ in GHC.Core.Opt.ConstantFold for rationale. Checked in lintCaseExpr;
+ see the call to isFloatingTy.
+
+6. The 'ty' field of (Case scrut bndr ty alts) is the type of the
+ /entire/ case expression. Checked in lintAltExpr.
+ See also Note [Why does Case have a 'Type' field?].
+
+7. The type of the scrutinee must be the same as the type
+ of the case binder, obviously. Checked in lintCaseExpr.
+
+8. The multiplicity of the binders in constructor patterns must be the
+ multiplicity of the corresponding field /scaled by the multiplicity of the
+ case binder/. Checked in lintCoreAlt.
+
+Note [Core type and coercion invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We allow a /non-recursive/, /non-top-level/ let to bind type and
coercion variables. These can be very convenient for postponing type
substitutions until the next run of the simplifier.
@@ -463,15 +538,15 @@ substitutions until the next run of the simplifier.
case (eq_sel d) of (co :: a ~# b) -> blah
where eq_sel :: (a~b) -> (a~#b)
- Or even even
+ Or even
case (df @Int) of (co :: a ~# b) -> blah
Which is very exotic, and I think never encountered; but see
Note [Equality superclasses in quantified constraints]
- in TcCanonical
+ in GHC.Tc.Solver.Canonical
-Note [CoreSyn case invariants]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #case_invariants#
+Note [Core case invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Note [Case expression invariants]
Note [Levity polymorphism invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -490,19 +565,15 @@ For example
\(r::RuntimeRep). \(a::TYPE r). \(x::a). e
is illegal because x's type has kind (TYPE r), which has 'r' free.
-See Note [Levity polymorphism checking] in DsMonad to see where these
+See Note [Levity polymorphism checking] in GHC.HsToCore.Monad to see where these
invariants are established for user-written code.
-Note [CoreSyn let goal]
-~~~~~~~~~~~~~~~~~~~~~~~
+Note [Core let goal]
+~~~~~~~~~~~~~~~~~~~~
* The simplifier tries to ensure that if the RHS of a let is a constructor
application, its arguments are trivial, so that the constructor can be
inlined vigorously.
-Note [Type let]
-~~~~~~~~~~~~~~~
-See #type_let#
-
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The alternatives of a case expression should be exhaustive. But
@@ -510,7 +581,7 @@ this exhaustive list can be empty!
* A case expression can have empty alternatives if (and only if) the
scrutinee is bound to raise an exception or diverge. When do we know
- this? See Note [Bottoming expressions] in CoreUtils.
+ this? See Note [Bottoming expressions] in GHC.Core.Utils.
* The possibility of empty alternatives is one reason we need a type on
the case expression: if the alternatives are empty we can't get the
@@ -521,13 +592,9 @@ this exhaustive list can be empty!
we do NOT want to replace
case (x::T) of Bool {} --> error Bool "Inaccessible case"
because x might raise an exception, and *that*'s what we want to see!
- (Trac #6067 is an example.) To preserve semantics we'd have to say
+ (#6067 is an example.) To preserve semantics we'd have to say
x `seq` error Bool "Inaccessible case"
- but the 'seq' is just a case, so we are back to square 1. Or I suppose
- we could say
- x |> UnsafeCoerce T Bool
- but that loses all trace of the fact that this originated with an empty
- set of alternatives.
+ but the 'seq' is just such a case, so we are back to square 1.
* We can use the empty-alternative construct to coerce error values from
one type to another. For example
@@ -548,8 +615,8 @@ this exhaustive list can be empty!
unboxed type.
* We treat a case expression with empty alternatives as trivial iff
- its scrutinee is (see CoreUtils.exprIsTrivial). This is actually
- important; see Note [Empty case is trivial] in CoreUtils
+ its scrutinee is (see GHC.Core.Utils.exprIsTrivial). This is actually
+ important; see Note [Empty case is trivial] in GHC.Core.Utils
* An empty case is replaced by its scrutinee during the CoreToStg
conversion; remember STG is un-typed, so there is no need for
@@ -611,11 +678,23 @@ Join points must follow these invariants:
See Note [Join points are less general than the paper]
2. For join arity n, the right-hand side must begin with at least n lambdas.
- No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity.
+ No ticks, no casts, just lambdas! C.f. GHC.Core.Utils.joinRhsArity.
+
+ 2a. Moreover, this same constraint applies to any unfolding of
+ the binder. Reason: if we want to push a continuation into
+ the RHS we must push it into the unfolding as well.
- 2a. Moreover, this same constraint applies to any unfolding of the binder.
- Reason: if we want to push a continuation into the RHS we must push it
- into the unfolding as well.
+ 2b. The Arity (in the IdInfo) of a join point is the number of value
+ binders in the top n lambdas, where n is the join arity.
+
+ So arity <= join arity; the former counts only value binders
+ while the latter counts all binders.
+ e.g. Suppose $j has join arity 1
+ let j = \x y. e in case x of { A -> j 1; B -> j 2 }
+ Then its ordinary arity is also 1, not 2.
+
+ The arity of a join point isn't very important; but short of setting
+ it to zero, it is helpful to have an invariant. E.g. #17294.
3. If the binding is recursive, then all other bindings in the recursive group
must also be join points.
@@ -631,7 +710,7 @@ However, join points have simpler invariants in other ways
6. A join point can have a levity-polymorphic RHS
e.g. let j :: r :: TYPE l = fail void# in ...
- This happened in an intermediate program Trac #13394
+ This happened in an intermediate program #13394
Examples:
@@ -655,6 +734,16 @@ invariant 3 does still need to be checked.) For the rigorous definition of
Invariant 4 is subtle; see Note [The polymorphism rule of join points].
+Invariant 6 is to enable code like this:
+
+ f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
+ join j :: a
+ j = error @r @a "bloop"
+ in case x of
+ A -> j
+ B -> j
+ C -> error @r @a "blurp"
+
Core Lint will check these invariants, anticipating that any binder whose
OccInfo is marked AlwaysTailCalled will become a join point as soon as the
simplifier (or simpleOptPgm) runs.
@@ -695,8 +784,8 @@ is crucial for understanding how case-of-case interacts with join points:
"" -> True
_ -> False
-The simplifier will pull the case into the join point (see Note [Case-of-case
-and join points] in Simplify):
+The simplifier will pull the case into the join point (see Note [Join points
+and case-of-case] in GHC.Core.Opt.Simplify):
join
j :: Int -> Bool -> Bool -- changed!
@@ -705,15 +794,18 @@ and join points] in Simplify):
in
jump j z w
-The body of the join point now returns a Bool, so the label `j` has to have its
-type updated accordingly. Inconvenient though this may be, it has the advantage
-that 'CoreUtils.exprType' can still return a type for any expression, including
-a jump.
+The body of the join point now returns a Bool, so the label `j` has to
+have its type updated accordingly, which is done by
+GHC.Core.Opt.Simplify.Env.adjustJoinPointType. Inconvenient though
+this may be, it has the advantage that 'GHC.Core.Utils.exprType' can
+still return a type for any expression, including a jump.
+
+Relationship to the paper
-This differs from the paper (see Note [Invariants on join points]). In the
-paper, we instead give j the type `Int -> Bool -> forall a. a`. Then each jump
-carries the "return type" as a parameter, exactly the way other non-returning
-functions like `error` work:
+This plan differs from the paper (see Note [Invariants on join
+points]). In the paper, we instead give j the type `Int -> Bool ->
+forall a. a`. Then each jump carries the "return type" as a parameter,
+exactly the way other non-returning functions like `error` work:
case (join
j :: Int -> Bool -> forall a. a
@@ -791,7 +883,7 @@ transformation universally. This transformation would do:
===>
join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2
- n -> go @a (n-1) f (f x)
+ n -> go @a (n-1) f (f x)
in go @Bool n neg True
but that is ill-typed, as `x` is type `a`, not `Bool`.
@@ -843,7 +935,7 @@ type MOutCoercion = MCoercion
-- | Allows attaching extra information to points in expressions
-- If you edit this type, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+-- See Note [GHC Formalism] in GHC.Core.Lint
data Tickish id =
-- | An @{-# SCC #-}@ profiling annotation, either automatically
-- added by the desugarer as a result of -auto-all, or added by
@@ -872,10 +964,10 @@ data Tickish id =
{ breakpointId :: !Int
, breakpointFVs :: [id] -- ^ the order of this list is important:
-- it matches the order of the lists in the
- -- appropriate entry in HscTypes.ModBreaks.
+ -- appropriate entry in 'GHC.Driver.Types.ModBreaks'.
--
-- Careful about substitution! See
- -- Note [substTickish] in CoreSubst.
+ -- Note [substTickish] in "GHC.Core.Subst".
}
-- | A source note.
@@ -952,7 +1044,7 @@ data TickishScoping =
-- ==>
-- tick<...> case foo of x -> bar
--
- -- While this is always leagl, we want to make a best effort to
+ -- While this is always legal, we want to make a best effort to
-- only make us of this where it exposes transformation
-- opportunities.
| SoftScope
@@ -1137,8 +1229,8 @@ notOrphan _ = False
chooseOrphanAnchor :: NameSet -> IsOrphan
-- Something (rule, instance) is relate to all the Names in this
-- list. Choose one of them to be an "anchor" for the orphan. We make
--- the choice deterministic to avoid gratuitious changes in the ABI
--- hash (Trac #4012). Specifically, use lexicographic comparison of
+-- the choice deterministic to avoid gratuitous changes in the ABI
+-- hash (#4012). Specifically, use lexicographic comparison of
-- OccName rather than comparing Uniques
--
-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically
@@ -1172,8 +1264,8 @@ its left hand side mentions nothing defined in this module. Orphan-hood
has two major consequences
* A module that contains orphans is called an "orphan module". If
- the module being compiled depends (transitively) on an oprhan
- module M, then M.hi is read in regardless of whether M is oherwise
+ the module being compiled depends (transitively) on an orphan
+ module M, then M.hi is read in regardless of whether M is otherwise
needed. This is to ensure that we don't miss any instance decls in
M. But it's painful, because it means we need to keep track of all
the orphan modules below us.
@@ -1183,12 +1275,12 @@ has two major consequences
mentions on the LHS. For example
data T = T1 | T2
instance Eq T where ....
- The instance (Eq T) is incorprated as part of T's fingerprint.
+ The instance (Eq T) is incorporated as part of T's fingerprint.
In contrast, orphans are all fingerprinted together in the
mi_orph_hash field of the ModIface.
- See MkIface.addFingerprints.
+ See GHC.Iface.Recomp.addFingerprints.
Orphan-hood is computed
* For class instances:
@@ -1196,19 +1288,20 @@ Orphan-hood is computed
(because it is needed during instance lookup)
* For rules and family instances:
- when we generate an IfaceRule (MkIface.coreRuleToIfaceRule)
- or IfaceFamInst (MkIface.instanceToIfaceInst)
+ when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule)
+ or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst)
-}
{-
************************************************************************
* *
-\subsection{Transformation rules}
+\subsection{Rewrite rules}
* *
************************************************************************
-The CoreRule type and its friends are dealt with mainly in CoreRules,
-but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
+The CoreRule type and its friends are dealt with mainly in GHC.Core.Rules, but
+GHC.Core.FVs, GHC.Core.Subst, GHC.Core.Ppr, GHC.Core.Tidy also inspect the
+representation.
-}
-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
@@ -1244,7 +1337,7 @@ data CoreRule
-- Rough-matching stuff
-- see comments with InstEnv.ClsInst( is_cls, is_rough )
- ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule
+ ru_fn :: Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule
ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side
-- Proper-matching stuff
@@ -1261,7 +1354,7 @@ data CoreRule
ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated
-- (notably by Specialise or SpecConstr)
-- @False@ <=> generated at the user's behest
- -- See Note [Trimming auto-rules] in TidyPgm
+ -- See Note [Trimming auto-rules] in "GHC.Iface.Tidy"
-- for the sole purpose of this field.
ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used
@@ -1293,9 +1386,16 @@ data CoreRule
-- arguments, it simply discards them; the returned 'CoreExpr'
-- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
}
- -- See Note [Extra args in rule matching] in Rules.hs
+ -- See Note [Extra args in rule matching] in GHC.Core.Rules
+
+-- | Rule options
+data RuleOpts = RuleOpts
+ { roPlatform :: !Platform -- ^ Target platform
+ , roNumConstantFolding :: !Bool -- ^ Enable more advanced numeric constant folding
+ , roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled
+ }
-type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
+type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
type InScopeEnv = (InScopeSet, IdUnfoldingFun)
type IdUnfoldingFun = Id -> Unfolding
@@ -1328,14 +1428,14 @@ ruleActivation :: CoreRule -> Activation
ruleActivation (BuiltinRule { }) = AlwaysActive
ruleActivation (Rule { ru_act = act }) = act
--- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
+-- | The 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side
ruleIdName :: CoreRule -> Name
ruleIdName = ru_fn
isLocalRule :: CoreRule -> Bool
isLocalRule = ru_local
--- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side
+-- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side
setRuleIdName :: Name -> CoreRule -> CoreRule
setRuleIdName nm ru = ru { ru_fn = nm }
@@ -1351,13 +1451,13 @@ The @Unfolding@ type is declared here to avoid numerous loops
-- | Records the /unfolding/ of an identifier, which is approximately the form the
-- identifier would have if we substituted its definition in for the identifier.
--- This type should be treated as abstract everywhere except in "CoreUnfold"
+-- This type should be treated as abstract everywhere except in "GHC.Core.Unfold"
data Unfolding
= NoUnfolding -- ^ We have no information about the unfolding.
| BootUnfolding -- ^ We have no information about the unfolding, because
-- this 'Id' came from an @hi-boot@ file.
- -- See Note [Inlining and hs-boot files] in ToIface
+ -- See Note [Inlining and hs-boot files] in "GHC.CoreToIface"
-- for what this is used for.
| OtherCon [AltCon] -- ^ It ain't one of these constructors.
@@ -1442,7 +1542,7 @@ data UnfoldingSource
| InlineCompulsory -- Something that *has* no binding, so you *must* inline it
-- Only a few primop-like things have this property
- -- (see MkId.hs, calls to mkCompulsoryUnfolding).
+ -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding).
-- Inline absolutely always, however boring the context.
@@ -1452,7 +1552,7 @@ data UnfoldingGuidance
= UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl
-- Used (a) for small *and* cheap unfoldings
-- (b) for INLINE functions
- -- See Note [INLINE for small functions] in CoreUnfold
+ -- See Note [INLINE for small functions] in GHC.Core.Unfold
ug_arity :: Arity, -- Number of value arguments expected
ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated
@@ -1469,7 +1569,7 @@ data UnfoldingGuidance
ug_size :: Int, -- The "size" of the unfolding.
- ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in
+ ug_res :: Int -- Scrutinee discount: the discount to subtract if the thing is in
} -- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
@@ -1613,7 +1713,7 @@ isExpandableUnfolding _ = False
expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
-- Expand an expandable unfolding; this is used in rule matching
--- See Note [Expanding variables] in Rules.hs
+-- See Note [Expanding variables] in GHC.Core.Rules
-- The key point here is that CONLIKE things can be expanded
expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
expandUnfolding_maybe _ = Nothing
@@ -1643,14 +1743,13 @@ neverUnfoldGuidance :: UnfoldingGuidance -> Bool
neverUnfoldGuidance UnfNever = True
neverUnfoldGuidance _ = False
-isFragileUnfolding :: Unfolding -> Bool
--- An unfolding is fragile if it mentions free variables or
--- is otherwise subject to change. A robust one can be kept.
--- See Note [Fragile unfoldings]
-isFragileUnfolding (CoreUnfolding {}) = True
-isFragileUnfolding (DFunUnfolding {}) = True
-isFragileUnfolding _ = False
- -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile
+hasCoreUnfolding :: Unfolding -> Bool
+-- An unfolding "has Core" if it contains a Core expression, which
+-- may mention free variables. See Note [Fragile unfoldings]
+hasCoreUnfolding (CoreUnfolding {}) = True
+hasCoreUnfolding (DFunUnfolding {}) = True
+hasCoreUnfolding _ = False
+ -- NoUnfolding, BootUnfolding, OtherCon have no Core
canUnfold :: Unfolding -> Bool
canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
@@ -1666,7 +1765,7 @@ ones are
OtherCon {} If we know this binder (say a lambda binder) will be
bound to an evaluated thing, we want to retain that
- info in simpleOptExpr; see Trac #13077.
+ info in simpleOptExpr; see #13077.
We consider even a StableUnfolding as fragile, because it needs substitution.
@@ -1698,7 +1797,7 @@ on the left, thus
it'd only inline when applied to three arguments. This slightly-experimental
change was requested by Roman, but it seems to make sense.
-See also Note [Inlining an InlineRule] in CoreUnfold.
+See also Note [Inlining an InlineRule] in GHC.Core.Unfold.
Note [OccInfo in unfoldings and rules]
@@ -1721,9 +1820,9 @@ the occurrence info is wrong
-}
-- The Ord is needed for the FiniteMap used in the lookForConstructor
--- in SimplEnv. If you declared that lookForConstructor *ignores*
--- constructor-applications with LitArg args, then you could get
--- rid of this Ord.
+-- in GHC.Core.Opt.Simplify.Env. If you declared that lookForConstructor
+-- *ignores* constructor-applications with LitArg args, then you could get rid
+-- of this Ord.
instance Outputable AltCon where
ppr (DataAlt dc) = ppr dc
@@ -1738,8 +1837,8 @@ ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
cmpAltCon :: AltCon -> AltCon -> Ordering
-- ^ Compares 'AltCon's within a single list of alternatives
--- DEFAULT comes out smallest, so that sorting by AltCon
--- puts alternatives in the order required by #case_invariants#
+-- DEFAULT comes out smallest, so that sorting by AltCon puts
+-- alternatives in the order required: see Note [Case expression invariants]
cmpAltCon DEFAULT DEFAULT = EQ
cmpAltCon DEFAULT _ = LT
@@ -1781,7 +1880,7 @@ a list of CoreBind
-}
-- If you edit this type, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+-- See Note [GHC Formalism] in GHC.Core.Lint
type CoreProgram = [CoreBind] -- See Note [CoreProgram]
-- | The common case for the type of binders and variables when
@@ -1843,7 +1942,7 @@ deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs)
-}
-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
--- use 'MkCore.mkCoreApps' if possible
+-- use 'GHC.Core.Make.mkCoreApps' if possible
mkApps :: Expr b -> [Arg b] -> Expr b
-- | Apply a list of type argument expressions to a function expression in a nested fashion
mkTyApps :: Expr b -> [Type] -> Expr b
@@ -1852,7 +1951,7 @@ mkCoApps :: Expr b -> [Coercion] -> Expr b
-- | Apply a list of type or value variables to a function expression in a nested fashion
mkVarApps :: Expr b -> [Var] -> Expr b
-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
--- use 'MkCore.mkCoreConApps' if possible
+-- use 'GHC.Core.Make.mkCoreConApps' if possible
mkConApp :: DataCon -> [Arg b] -> Expr b
mkApps f args = foldl' App f args
@@ -1873,24 +1972,24 @@ mkTyArg ty
| otherwise = Type ty
-- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
--- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
-mkIntLit :: DynFlags -> Integer -> Expr b
+-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
+mkIntLit :: Platform -> Integer -> Expr b
-- | Create a machine integer literal expression of type @Int#@ from an @Int@.
--- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
-mkIntLitInt :: DynFlags -> Int -> Expr b
+-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
+mkIntLitInt :: Platform -> Int -> Expr b
-mkIntLit dflags n = Lit (mkLitInt dflags n)
-mkIntLitInt dflags n = Lit (mkLitInt dflags (toInteger n))
+mkIntLit platform n = Lit (mkLitInt platform n)
+mkIntLitInt platform n = Lit (mkLitInt platform (toInteger n))
-- | Create a machine word literal expression of type @Word#@ from an @Integer@.
--- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
-mkWordLit :: DynFlags -> Integer -> Expr b
+-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
+mkWordLit :: Platform -> Integer -> Expr b
-- | Create a machine word literal expression of type @Word#@ from a @Word@.
--- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
-mkWordLitWord :: DynFlags -> Word -> Expr b
+-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
+mkWordLitWord :: Platform -> Word -> Expr b
-mkWordLit dflags w = Lit (mkLitWord dflags w)
-mkWordLitWord dflags w = Lit (mkLitWord dflags (toInteger w))
+mkWordLit platform w = Lit (mkLitWord platform w)
+mkWordLitWord platform w = Lit (mkLitWord platform (toInteger w))
mkWord64LitWord64 :: Word64 -> Expr b
mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))
@@ -1899,41 +1998,41 @@ mkInt64LitInt64 :: Int64 -> Expr b
mkInt64LitInt64 w = Lit (mkLitInt64 (toInteger w))
-- | Create a machine character literal expression of type @Char#@.
--- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
+-- If you want an expression of type @Char@ use 'GHC.Core.Make.mkCharExpr'
mkCharLit :: Char -> Expr b
-- | Create a machine string literal expression of type @Addr#@.
--- If you want an expression of type @String@ use 'MkCore.mkStringExpr'
+-- If you want an expression of type @String@ use 'GHC.Core.Make.mkStringExpr'
mkStringLit :: String -> Expr b
mkCharLit c = Lit (mkLitChar c)
mkStringLit s = Lit (mkLitString s)
-- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.
--- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
+-- If you want an expression of type @Float@ use 'GHC.Core.Make.mkFloatExpr'
mkFloatLit :: Rational -> Expr b
-- | Create a machine single precision literal expression of type @Float#@ from a @Float@.
--- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
+-- If you want an expression of type @Float@ use 'GHC.Core.Make.mkFloatExpr'
mkFloatLitFloat :: Float -> Expr b
mkFloatLit f = Lit (mkLitFloat f)
mkFloatLitFloat f = Lit (mkLitFloat (toRational f))
-- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.
--- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
+-- If you want an expression of type @Double@ use 'GHC.Core.Make.mkDoubleExpr'
mkDoubleLit :: Rational -> Expr b
-- | Create a machine double precision literal expression of type @Double#@ from a @Double@.
--- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
+-- If you want an expression of type @Double@ use 'GHC.Core.Make.mkDoubleExpr'
mkDoubleLitDouble :: Double -> Expr b
mkDoubleLit d = Lit (mkLitDouble d)
mkDoubleLitDouble d = Lit (mkLitDouble (toRational d))
-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes
--- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if
+-- that the rhs satisfies the let/app invariant. Prefer to use 'GHC.Core.Make.mkCoreLets' if
-- possible, which does guarantee the invariant
mkLets :: [Bind b] -> Expr b -> Expr b
-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
--- use 'MkCore.mkCoreLams' if possible
+-- use 'GHC.Core.Make.mkCoreLams' if possible
mkLams :: [b] -> Expr b -> Expr b
mkLams binders body = foldr Lam body binders
@@ -1955,12 +2054,14 @@ mkLetRec :: [(b, Expr b)] -> Expr b -> Expr b
mkLetRec [] body = body
mkLetRec bs body = Let (Rec bs) body
--- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
+-- | Create a binding group where a type variable is bound to a type.
+-- Per Note [Core type and coercion invariant],
-- this can only be used to bind something in a non-recursive @let@ expression
mkTyBind :: TyVar -> Type -> CoreBind
mkTyBind tv ty = NonRec tv (Type ty)
--- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
+-- | Create a binding group where a type variable is bound to a type.
+-- Per Note [Core type and coercion invariant],
-- this can only be used to bind something in a non-recursive @let@ expression
mkCoBind :: CoVar -> Coercion -> CoreBind
mkCoBind cv co = NonRec cv (Coercion co)
@@ -1981,7 +2082,7 @@ varsToCoreExprs vs = map varToCoreExpr vs
* *
************************************************************************
-These are defined here to avoid a module loop between CoreUtils and CoreFVs
+These are defined here to avoid a module loop between GHC.Core.Utils and GHC.Core.FVs
-}
@@ -2012,7 +2113,7 @@ exprToCoercion_maybe _ = Nothing
-- | Extract every variable by this group
bindersOf :: Bind b -> [b]
-- If you edit this function, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+-- See Note [GHC Formalism] in GHC.Core.Lint
bindersOf (NonRec binder _) = [binder]
bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
diff --git a/compiler/types/Class.hs b/compiler/GHC/Core/Class.hs
index 1a50f1a..ca5e1e8 100644
--- a/compiler/types/Class.hs
+++ b/compiler/GHC/Core/Class.hs
@@ -5,7 +5,7 @@
{-# LANGUAGE CPP #-}
-module Class (
+module GHC.Core.Class (
Class,
ClassOpItem,
ClassATItem(..),
@@ -23,18 +23,19 @@ module Class (
#include "GhclibHsVersions.h"
-import GhcPrelude
+import GHC.Prelude
-import {-# SOURCE #-} TyCon ( TyCon )
-import {-# SOURCE #-} TyCoRep ( Type, PredType, pprType )
-import Var
-import Name
-import BasicTypes
-import Unique
-import Util
-import SrcLoc
-import Outputable
-import BooleanFormula (BooleanFormula, mkTrue)
+import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )
+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType )
+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )
+import GHC.Types.Var
+import GHC.Types.Name
+import GHC.Types.Basic
+import GHC.Types.Unique
+import GHC.Utils.Misc
+import GHC.Types.SrcLoc
+import GHC.Utils.Outputable
+import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)
import qualified Data.Data as Data
@@ -52,7 +53,7 @@ data Class
= Class {
classTyCon :: TyCon, -- The data type constructor for
-- dictionaries of this class
- -- See Note [ATyCon for classes] in TyCoRep
+ -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep
className :: Name, -- Just the cached name of the TyCon
classKey :: Unique, -- Cached unique of TyCon
@@ -76,9 +77,9 @@ data Class
--
-- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
--
--- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'',
+-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'',
--- For details on above see note [Api annotations] in ApiAnnotation
+-- For details on above see note [Api annotations] in GHC.Parser.Annotation
type FunDep a = ([a],[a])
type ClassOpItem = (Id, DefMethInfo)
@@ -211,7 +212,7 @@ The TyCon of an associated type should use the same variable names as its
parent class. Thus
class C a b where
type F b x a :: *
-We make F use the same Name for 'a' as C does, and similary 'b'.
+We make F use the same Name for 'a' as C does, and similarly 'b'.
The reason for this is when checking instances it's easier to match
them up, to ensure they match. Eg
@@ -221,7 +222,7 @@ we should make sure that the first and third args match the instance
header.
Having the same variables for class and tycon is also used in checkValidRoles
-(in TcTyClsDecls) when checking a class's roles.
+(in GHC.Tc.TyCl) when checking a class's roles.
************************************************************************
diff --git a/compiler/types/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index 15e3fab..7761a1f 100644
--- a/compiler/types/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -6,21 +6,22 @@
ScopedTypeVariables #-}
-- | Module for (a) type kinds and (b) type coercions,
--- as used in System FC. See 'CoreSyn.Expr' for
+-- as used in System FC. See 'GHC.Core.Expr' for
-- more on System FC and how coercions fit into it.
--
-module Coercion (
+module GHC.Core.Coercion (
-- * Main data type
Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,
- UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
+ UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..),
+ coHoleCoVar, setCoHoleCoVar,
LeftOrRight(..),
Var, CoVar, TyCoVar,
Role(..), ltRole,
-- ** Functions over coercions
coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole,
- coercionType, coercionKind, coercionKinds,
- mkCoercionType,
+ coercionType, mkCoercionType,
+ coercionKind, coercionLKind, coercionRKind,coercionKinds,
coercionRole, coercionKindRole,
-- ** Constructing coercions
@@ -35,13 +36,15 @@ module Coercion (
mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo,
mkForAllCo, mkForAllCos, mkHomoForAllCos,
mkPhantomCo,
- mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo,
+ mkHoleCo, mkUnivCo, mkSubCo,
mkAxiomInstCo, mkProofIrrelCo,
- downgradeRole, maybeSubCo, mkAxiomRuleCo,
+ downgradeRole, mkAxiomRuleCo,
mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,
mkKindCo, castCoercionKind, castCoercionKindI,
mkHeteroCoercionType,
+ mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,
+ mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,
-- ** Decomposition
instNewTyCon_maybe,
@@ -62,7 +65,7 @@ module Coercion (
pickLR,
isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,
- isReflCoVar_maybe,
+ isReflCoVar_maybe, isGReflMCo, coToMCo,
-- ** Coercion variables
mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,
@@ -109,39 +112,49 @@ module Coercion (
-- * Other
promoteCoercion, buildCoercion,
- simplifyArgsWorker
+ multToCo,
+
+ simplifyArgsWorker,
+
+ badCoercionHole, badCoercionHoleCo
) where
#include "GhclibHsVersions.h"
-import {-# SOURCE #-} ToIface (toIfaceTyCon, tidyToIfaceTcArgs)
-
-import GhcPrelude
-
-import IfaceType
-import TyCoRep
-import Type
-import TyCon
-import CoAxiom
-import Var
-import VarEnv
-import VarSet
-import Name hiding ( varName )
-import Util
-import BasicTypes
-import Outputable
-import Unique
-import Pair
-import SrcLoc
-import PrelNames
-import TysPrim ( eqPhantPrimTyCon )
-import ListSetOps
-import Maybes
-import UniqFM
+import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs)
+
+import GHC.Prelude
+
+import GHC.Iface.Type
+import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.FVs
+import GHC.Core.TyCo.Ppr
+import GHC.Core.TyCo.Subst
+import GHC.Core.TyCo.Tidy
+import GHC.Core.Type
+import GHC.Core.TyCon
+import GHC.Core.Coercion.Axiom
+import {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType )
+import GHC.Types.Var
+import GHC.Types.Var.Env
+import GHC.Types.Var.Set
+import GHC.Types.Name hiding ( varName )
+import GHC.Utils.Misc
+import GHC.Types.Basic
+import GHC.Utils.Outputable
+import GHC.Types.Unique
+import GHC.Data.Pair
+import GHC.Types.SrcLoc
+import GHC.Builtin.Names
+import GHC.Builtin.Types.Prim
+import GHC.Data.List.SetOps
+import GHC.Data.Maybe
+import GHC.Types.Unique.FM
import Control.Monad (foldM, zipWithM)
import Data.Function ( on )
import Data.Char( isDigit )
+import qualified Data.Monoid as Monoid
{-
%************************************************************************
@@ -149,7 +162,7 @@ import Data.Char( isDigit )
-- The coercion arguments always *precisely* saturate
-- arity of (that branch of) the CoAxiom. If there are
-- any left over, we use AppCo. See
- -- See [Coercion axioms applied to coercions] in TyCoRep
+ -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep
\subsection{Coercion variables}
%* *
@@ -179,7 +192,7 @@ Defined here to avoid module loops. CoAxiom is loaded very early on.
etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type)
-- Return the (tvs,lhs,rhs) after eta-expanding,
-- to the way in which the axiom was originally written
--- See Note [Eta reduction for data families] in CoAxiom
+-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs
, cab_eta_tvs = eta_tvs
, cab_lhs = lhs
@@ -196,8 +209,8 @@ pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))
pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc
--- Used when printing injectivity errors (FamInst.makeInjectivityErrors)
--- and inaccessible branches (TcValidity.inaccessibleCoAxBranch)
+-- Used when printing injectivity errors (FamInst.reportInjectivityErrors)
+-- and inaccessible branches (GHC.Tc.Validity.inaccessibleCoAxBranch)
-- This happens in error messages: don't print the RHS of a data
-- family axiom, which is meaningless to a user
pprCoAxBranchUser tc br
@@ -209,7 +222,7 @@ pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc
-- a conflict between equations (FamInst.conflictInstErr)
-- For type families the RHS is important; for data families not so.
-- Indeed for data families the RHS is a mysterious internal
--- type constructor, so we suppress it (Trac #14179)
+-- type constructor, so we suppress it (#14179)
-- See FamInstEnv Note [Family instance overlap conflicts]
pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs
where
@@ -225,7 +238,7 @@ ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc)
ppr_co_ax_branch ppr_rhs fam_tc branch
= foldr1 (flip hangNotEmpty 2)
[ pprUserForAll (mkTyCoVarBinders Inferred bndrs')
- -- See Note [Printing foralls in type family instances] in IfaceType
+ -- See Note [Printing foralls in type family instances] in GHC.Iface.Type
, pp_lhs <+> ppr_rhs tidy_env ee_rhs
, text "-- Defined" <+> pp_loc ]
where
@@ -235,7 +248,7 @@ ppr_co_ax_branch ppr_rhs fam_tc branch
-- Eta-expand LHS and RHS types, because sometimes data family
-- instances are eta-reduced.
- -- See Note [Eta reduction for data families] in FamInstEnv.
+ -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.
(ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch
pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc)
@@ -252,6 +265,7 @@ tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var])
-- forall a _1 _2. F _1 [a] _2 = ...
--
-- This is a rather disgusting function
+-- See Note [Wildcard names] in GHC.Tc.Gen.HsType
tidyCoAxBndrsForUser init_env tcvs
= (tidy_env, reverse tidy_bndrs)
where
@@ -282,12 +296,14 @@ tidyCoAxBndrsForUser init_env tcvs
Note [Function coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~
Remember that
- (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep
+ (->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> TYPE LiftedRep
+whose `RuntimeRep' arguments are intentionally marked inferred to
+avoid type application.
Hence
- FunCo r co1 co2 :: (s1->t1) ~r (s2->t2)
+ FunCo r mult co1 co2 :: (s1->t1) ~r (s2->t2)
is short for
- TyConAppCo (->) co_rep1 co_rep2 co1 co2
+ TyConAppCo (->) mult co_rep1 co_rep2 co1 co2
where co_rep1, co_rep2 are the coercions on the representations.
-}
@@ -308,12 +324,12 @@ decomposeCo arity co rs
decomposeFunCo :: HasDebugCallStack
=> Role -- Role of the input coercion
-> Coercion -- Input coercion
- -> (Coercion, Coercion)
+ -> (CoercionN, Coercion, Coercion)
-- Expects co :: (s1 -> t1) ~ (s2 -> t2)
-- Returns (co1 :: s1~s2, co2 :: t1~t2)
--- See Note [Function coercions] for the "2" and "3"
+-- See Note [Function coercions] for the "3" and "4"
decomposeFunCo r co = ASSERT2( all_ok, ppr co )
- (mkNthCo r 2 co, mkNthCo r 3 co)
+ (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co)
where
Pair s1t1 s2t2 = coercionKind co
all_ok = isFunTy s1t1 && isFunTy s2t2
@@ -324,7 +340,7 @@ Suppose we have this:
(f |> co) t1 .. tn
Then we want to push the coercion into the arguments, so as to make
progress. For example of why you might want to do so, see Note
-[Respecting definitional equality] in TyCoRep.
+[Respecting definitional equality] in GHC.Core.TyCo.Rep.
This is done by decomposePiCos. Specifically, if
decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor)
@@ -342,7 +358,7 @@ Notes:
where co :: (forall a. ty) ~ (ty1 -> ty2)
Here 'co' is insoluble, but we don't want to crash in decoposePiCos.
So decomposePiCos carefully tests both sides of the coercion to check
- they are both foralls or both arrows. Not doing this caused Trac #15343.
+ they are both foralls or both arrows. Not doing this caused #15343.
-}
decomposePiCos :: HasDebugCallStack
@@ -381,14 +397,16 @@ decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args
in
go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys
- | Just (_s1, t1) <- splitFunTy_maybe k1
- , Just (_s2, t2) <- splitFunTy_maybe k2
+ | Just (_w1, _s1, t1) <- splitFunTy_maybe k1
+ , Just (_w1, _s2, t2) <- splitFunTy_maybe k2
-- know co :: (s1 -> t1) ~ (s2 -> t2)
-- function :: s1 -> t1
-- ty :: s2
-- need arg_co :: s2 ~ s1
-- res_co :: t1 ~ t2
- = let (sym_arg_co, res_co) = decomposeFunCo Nominal co
+ = let (_, sym_arg_co, res_co) = decomposeFunCo Nominal co
+ -- It should be fine to ignore the multiplicity bit of the coercion
+ -- for a Nominal coercion.
arg_co = mkSymCo sym_arg_co
in
go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys
@@ -417,10 +435,13 @@ splitTyConAppCo_maybe co
; let args = zipWith mkReflCo (tyConRolesX r tc) tys
; return (tc, args) }
splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos)
-splitTyConAppCo_maybe (FunCo _ arg res) = Just (funTyCon, cos)
- where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res]
+splitTyConAppCo_maybe (FunCo _ w arg res) = Just (funTyCon, cos)
+ where cos = [w, mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res]
splitTyConAppCo_maybe _ = Nothing
+multToCo :: Mult -> Coercion
+multToCo r = mkNomReflCo r
+
-- first result has role equal to input; third result is Nominal
splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
-- ^ Attempt to take a coercion application apart.
@@ -430,7 +451,7 @@ splitAppCo_maybe (TyConAppCo r tc args)
, Just (args', arg') <- snocView args
= Just ( mkTyConAppCo r tc args', arg' )
- | mightBeUnsaturatedTyCon tc
+ | not (mustBeSaturated tc)
-- Never create unsaturated type family apps!
, Just (args', arg') <- snocView args
, Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg'
@@ -444,8 +465,9 @@ splitAppCo_maybe co
= Just (mkReflCo r ty1, mkNomReflCo ty2)
splitAppCo_maybe _ = Nothing
+-- Only used in specialise/Rules
splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
-splitFunCo_maybe (FunCo _ arg res) = Just (arg, res)
+splitFunCo_maybe (FunCo _ _ arg res) = Just (arg, res)
splitFunCo_maybe _ = Nothing
splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)
@@ -467,6 +489,10 @@ splitForAllCo_co_maybe _ = Nothing
-------------------------------------------------------
-- and some coercion kind stuff
+coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type
+coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1
+coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2
+
coVarTypes :: HasDebugCallStack => CoVar -> Pair Type
coVarTypes cv
| (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv
@@ -475,13 +501,10 @@ coVarTypes cv
coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role)
coVarKindsTypesRole cv
| Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv)
- = let role
- | tc `hasKey` eqPrimTyConKey = Nominal
- | tc `hasKey` eqReprPrimTyConKey = Representational
- | otherwise = panic "coVarKindsTypesRole"
- in (k1,k2,ty1,ty2,role)
- | otherwise = pprPanic "coVarKindsTypesRole, non coercion variable"
- (ppr cv $$ ppr (varType cv))
+ = (k1, k2, ty1, ty2, eqTyConRole tc)
+ | otherwise
+ = pprPanic "coVarKindsTypesRole, non coercion variable"
+ (ppr cv $$ ppr (varType cv))
coVarKind :: CoVar -> Type
coVarKind cv
@@ -490,33 +513,19 @@ coVarKind cv
coVarRole :: CoVar -> Role
coVarRole cv
+ = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of
+ Just tc0 -> tc0
+ Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv))
+
+eqTyConRole :: TyCon -> Role
+-- Given (~#) or (~R#) return the Nominal or Representational respectively
+eqTyConRole tc
| tc `hasKey` eqPrimTyConKey
= Nominal
| tc `hasKey` eqReprPrimTyConKey
= Representational
| otherwise
- = pprPanic "coVarRole: unknown tycon" (ppr cv <+> dcolon <+> ppr (varType cv))
-
- where
- tc = case tyConAppTyCon_maybe (varType cv) of
- Just tc0 -> tc0
- Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv)
-
--- | Makes a coercion type from two types: the types whose equality
--- is proven by the relevant 'Coercion'
-mkCoercionType :: Role -> Type -> Type -> Type
-mkCoercionType Nominal = mkPrimEqPred
-mkCoercionType Representational = mkReprPrimEqPred
-mkCoercionType Phantom = \ty1 ty2 ->
- let ki1 = typeKind ty1
- ki2 = typeKind ty2
- in
- TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2]
-
-mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type
-mkHeteroCoercionType Nominal = mkHeteroPrimEqPred
-mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred
-mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType"
+ = pprPanic "eqTyConRole: unknown tycon" (ppr tc)
-- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@,
-- produce a coercion @rep_co :: r1 ~ r2@.
@@ -592,6 +601,11 @@ isReflexiveCo_maybe co
= Nothing
where (Pair ty1 ty2, r) = coercionKindRole co
+coToMCo :: Coercion -> MCoercion
+coToMCo c = if isReflCo c
+ then MRefl
+ else MCo c
+
{-
%************************************************************************
%* *
@@ -639,8 +653,7 @@ it is not absolutely critical that setNominalRole_maybe be complete.
Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom
UnivCos are perfectly type-safe, whereas representational and nominal ones are
-not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo.
-(Nominal ones are no worse than representational ones, so this function *will*
+not. (Nominal ones are no worse than representational ones, so this function *will*
change a UnivCo Representational to a UnivCo Nominal.)
Conal Elliott also came across a need for this function while working with the
@@ -678,12 +691,12 @@ mkNomReflCo = Refl
-- caller's responsibility to get the roles correct on argument coercions.
mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo r tc cos
- | tc `hasKey` funTyConKey
- , [_rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions]
+ | [w, _rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions]
+ , isFunTyCon tc
= -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd)
-- rep1 :: ra ~ rc rep2 :: rb ~ rd
-- co1 :: a ~ c co2 :: b ~ d
- mkFunCo r co1 co2
+ mkFunCo r w co1 co2
-- Expand type synonyms
| Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos
@@ -697,13 +710,14 @@ mkTyConAppCo r tc cos
-- | Build a function 'Coercion' from two other 'Coercion's. That is,
-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@.
-mkFunCo :: Role -> Coercion -> Coercion -> Coercion
-mkFunCo r co1 co2
+mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion
+mkFunCo r w co1 co2
-- See Note [Refl invariant]
| Just (ty1, _) <- isReflCo_maybe co1
, Just (ty2, _) <- isReflCo_maybe co2
- = mkReflCo r (mkFunTy ty1 ty2)
- | otherwise = FunCo r co1 co2
+ , Just (w, _) <- isReflCo_maybe w
+ = mkReflCo r (mkVisFunTy w ty1 ty2)
+ | otherwise = FunCo r w co1 co2
-- | Apply a 'Coercion' to another 'Coercion'.
-- The second coercion must be Nominal, unless the first is Phantom.
@@ -718,7 +732,7 @@ mkAppCo co arg
| Just (ty1, r) <- isReflCo_maybe co
, Just (tc, tys) <- splitTyConApp_maybe ty1
- -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102)
+ -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)
= mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)
where
zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg]
@@ -735,7 +749,7 @@ mkAppCo (TyConAppCo r tc args) arg
mkAppCo co arg = AppCo co arg
-- Note, mkAppCo is careful to maintain invariants regarding
-- where Refl constructors appear; see the comments in the definition
--- of Coercion and the Note [Refl invariant] in TyCoRep.
+-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep.
-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.
-- See also 'mkAppCo'.
@@ -746,8 +760,8 @@ mkAppCos co1 cos = foldl' mkAppCo co1 cos
{- Note [Unused coercion variable in ForAllCo]
-See Note [Unused coercion variable in ForAllTy] in TyCoRep for the motivation for
-checking coercion variable in types.
+See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the
+motivation for checking coercion variable in types.
To lift the design choice to (ForAllCo cv kind_co body_co), we have two options:
(1) In mkForAllCo, we check whether cv is a coercion variable
@@ -806,7 +820,8 @@ mkForAllCo_NoRefl v kind_co co
, ASSERT( not (isReflCo co)) True
, isCoVar v
, not (v `elemVarSet` tyCoVarsOfCo co)
- = FunCo (coercionRole co) kind_co co
+ = FunCo (coercionRole co) (multToCo Many) kind_co co
+ -- Functions from coercions are always unrestricted
| otherwise
= ForAllCo v kind_co co
@@ -850,7 +865,7 @@ mkCoVarCos = map mkCoVarCo
{- Note [mkCoVarCo]
~~~~~~~~~~~~~~~~~~~
In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is
-valid (although see Note [Unbound RULE binders] in Rules), but
+valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but
it's a relatively expensive test and perhaps better done in
optCoercion. Not a big deal either way.
-}
@@ -938,14 +953,6 @@ mkAxInstLHS ax index tys cos
mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type
mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0
--- | Manufacture an unsafe coercion from thin air.
--- Currently (May 14) this is used only to implement the
--- @unsafeCoerce#@ primitive. Optimise by pushing
--- down through type constructors.
-mkUnsafeCo :: Role -> Type -> Type -> Coercion
-mkUnsafeCo role ty1 ty2
- = mkUnivCo UnsafeCoerceProv role ty1 ty2
-
-- | Make a coercion from a coercion hole
mkHoleCo :: CoercionHole -> Coercion
mkHoleCo h = HoleCo h
@@ -1028,21 +1035,22 @@ mkNthCo r n co
-- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)
-- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4))
- go r n co@(FunCo r0 arg res)
+ go r n co@(FunCo r0 w arg res)
-- See Note [Function coercions]
- -- If FunCo _ arg_co res_co :: (s1:TYPE sk1 -> s2:TYPE sk2)
- -- ~ (t1:TYPE tk1 -> t2:TYPE tk2)
+ -- If FunCo _ mult arg_co res_co :: (s1:TYPE sk1 :mult-> s2:TYPE sk2)
+ -- ~ (t1:TYPE tk1 :mult-> t2:TYPE tk2)
-- Then we want to behave as if co was
- -- TyConAppCo argk_co resk_co arg_co res_co
+ -- TyConAppCo mult argk_co resk_co arg_co res_co
-- where
-- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co)
-- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co)
-- i.e. mkRuntimeRepCo
= case n of
- 0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg
- 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res
- 2 -> ASSERT( r == r0 ) arg
- 3 -> ASSERT( r == r0 ) res
+ 0 -> ASSERT( r == Nominal ) w
+ 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg
+ 2 -> ASSERT( r == Nominal ) mkRuntimeRepCo res
+ 3 -> ASSERT( r == r0 ) arg
+ 4 -> ASSERT( r == r0 ) res
_ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co)
go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n
@@ -1111,7 +1119,8 @@ nthCoRole n co
= pprPanic "nthCoRole" (ppr co)
where
- (Pair lty _, r) = coercionKindRole co
+ lty = coercionLKind co
+ r = coercionRole co
mkLRCo :: LeftOrRight -> Coercion -> Coercion
mkLRCo lr co
@@ -1189,8 +1198,8 @@ mkSubCo (Refl ty) = GRefl Representational ty MRefl
mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co
mkSubCo (TyConAppCo Nominal tc cos)
= TyConAppCo Representational tc (applyRoles tc cos)
-mkSubCo (FunCo Nominal arg res)
- = FunCo Representational
+mkSubCo (FunCo Nominal w arg res)
+ = FunCo Representational w
(downgradeRole Representational Nominal arg)
(downgradeRole Representational Nominal res)
mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) )
@@ -1223,13 +1232,6 @@ downgradeRole r1 r2 co
Just co' -> co'
Nothing -> pprPanic "downgradeRole" (ppr co)
--- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing.
--- Note that the input coercion should always be nominal.
-maybeSubCo :: EqRel -> Coercion -> Coercion
-maybeSubCo NomEq = id
-maybeSubCo ReprEq = mkSubCo
-
-
mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
mkAxiomRuleCo = AxiomRuleCo
@@ -1269,10 +1271,10 @@ setNominalRole_maybe r co
setNominalRole_maybe_helper (TyConAppCo Representational tc cos)
= do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos
; return $ TyConAppCo Nominal tc cos' }
- setNominalRole_maybe_helper (FunCo Representational co1 co2)
+ setNominalRole_maybe_helper (FunCo Representational w co1 co2)
= do { co1' <- setNominalRole_maybe Representational co1
; co2' <- setNominalRole_maybe Representational co2
- ; return $ FunCo Nominal co1' co2'
+ ; return $ FunCo Nominal w co1' co2'
}
setNominalRole_maybe_helper (SymCo co)
= SymCo <$> setNominalRole_maybe_helper co
@@ -1289,8 +1291,7 @@ setNominalRole_maybe r co
setNominalRole_maybe_helper (InstCo co arg)
= InstCo <$> setNominalRole_maybe_helper co <*> pure arg
setNominalRole_maybe_helper (UnivCo prov _ co1 co2)
- | case prov of UnsafeCoerceProv -> True -- it's always unsafe
- PhantomProv _ -> False -- should always be phantom
+ | case prov of PhantomProv _ -> False -- should always be phantom
ProofIrrelProv _ -> True -- it's always safe
PluginProv _ -> False -- who knows? This choice is conservative.
= Just $ UnivCo prov Nominal co1 co2
@@ -1385,9 +1386,9 @@ promoteCoercion co = case co of
ForAllCo _ _ _
-> ASSERT( False )
mkNomReflCo liftedTypeKind
- -- See Note [Weird typing rule for ForAllTy] in Type
+ -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep
- FunCo _ _ _
+ FunCo _ _ _ _
-> ASSERT( False )
mkNomReflCo liftedTypeKind
@@ -1396,7 +1397,6 @@ promoteCoercion co = case co of
AxiomInstCo {} -> mkKindCo co
AxiomRuleCo {} -> mkKindCo co
- UnivCo UnsafeCoerceProv _ t1 t2 -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2)
UnivCo (PhantomProv kco) _ _ _ -> kco
UnivCo (ProofIrrelProv kco) _ _ _ -> kco
UnivCo (PluginProv _) _ _ _ -> mkKindCo co
@@ -1435,7 +1435,7 @@ promoteCoercion co = case co of
| otherwise
-> ASSERT( False)
mkNomReflCo liftedTypeKind
- -- See Note [Weird typing rule for ForAllTy] in Type
+ -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep
KindCo _
-> ASSERT( False )
@@ -1505,7 +1505,7 @@ castCoercionKindI g h1 h2
= mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)
where (Pair t1 t2, r) = coercionKindRole g
--- See note [Newtype coercions] in TyCon
+-- See note [Newtype coercions] in GHC.Core.TyCon
mkPiCos :: Role -> [Var] -> Coercion -> Coercion
mkPiCos r vs co = foldr (mkPiCo r) co vs
@@ -1518,10 +1518,10 @@ mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co
-- We didn't call mkForAllCo here because if v does not appear
-- in co, the argement coercion will be nominal. But here we
-- want it to be r. It is only called in 'mkPiCos', which is
- -- only used in SimplUtils, where we are sure for
+ -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for
-- now (Aug 2018) v won't occur in co.
- mkFunCo r (mkReflCo r (varType v)) co
- | otherwise = mkFunCo r (mkReflCo r (varType v)) co
+ mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co
+ | otherwise = mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co
-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2
-- The first coercion might be lifted or unlifted; thus the ~? above
@@ -1541,7 +1541,7 @@ mkCoCast c g
-- g :: (s1 ~# t1) ~# (s2 ~# t2)
-- g1 :: s1 ~# s2
-- g2 :: t1 ~# t2
- (tc, _) = splitTyConApp (pFst $ coercionKind g)
+ (tc, _) = splitTyConApp (coercionLKind g)
co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc)
{-
@@ -1762,8 +1762,8 @@ This follows the lifting context extension definition in the
data LiftingContext = LC TCvSubst LiftCoEnv
-- in optCoercion, we need to lift when optimizing InstCo.
- -- See Note [Optimising InstCo] in OptCoercion
- -- We thus propagate the substitution from OptCoercion here.
+ -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt
+ -- We thus propagate the substitution from GHC.Core.Coercion.Opt here.
instance Outputable LiftingContext where
ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env)
@@ -1794,6 +1794,8 @@ liftCoSubstWith r tvs cos ty
-- @lc_left@ is a substitution mapping type variables to the left-hand
-- types of the mapped coercions in @lc@, and similar for @lc_right@.
liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
+{-# INLINE liftCoSubst #-}
+-- Inlining this function is worth 2% of allocation in T9872d,
liftCoSubst r lc@(LC subst env) ty
| isEmptyVarEnv env = mkReflCo r (substTy subst ty)
| otherwise = ty_co_subst lc r ty
@@ -1889,7 +1891,9 @@ substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co
--
-- For the inverse operation, see 'liftCoMatch'
ty_co_subst :: LiftingContext -> Role -> Type -> Coercion
-ty_co_subst lc role ty
+ty_co_subst !lc role ty
+ -- !lc: making this function strict in lc allows callers to
+ -- pass its two components separately, rather than boxing them
= go role ty
where
go :: Role -> Type -> Coercion
@@ -1900,7 +1904,7 @@ ty_co_subst lc role ty
liftCoSubstTyVar lc r tv
go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2)
go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys)
- go r (FunTy ty1 ty2) = mkFunCo r (go r ty1) (go r ty2)
+ go r (FunTy _ w ty1 ty2) = mkFunCo r (go Nominal w) (go r ty1) (go r ty2)
go r t@(ForAllTy (Bndr v _) ty)
= let (lc', v', h) = liftCoSubstVarBndr lc v
body_co = ty_co_subst lc' r ty in
@@ -1931,7 +1935,7 @@ Note [liftCoSubstTyVar]
This function can fail if a coercion in the environment is of too low a role.
liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and
-also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting
+also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting
lemma guarantees that the roles work out. If we fail in this
case, we really should panic -- something is deeply wrong. But, in matchAxiom,
failing is fine. matchAxiom is trying to find a set of coercions
@@ -1951,7 +1955,7 @@ liftCoSubstTyVar (LC subst env) r v
callback:
We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in
- FamInstEnv, therefore the input arg 'fun' returns a pair with polymophic type
+ FamInstEnv, therefore the input arg 'fun' returns a pair with polymorphic type
in snd.
However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and
ignore the fourth component of the return value.
@@ -2014,7 +2018,7 @@ liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var
where
old_kind = tyVarKind old_var
(eta, stuff) = fun lc old_kind
- Pair k1 _ = coercionKind eta
+ k1 = coercionLKind eta
new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1)
lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta
@@ -2032,7 +2036,7 @@ liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var
where
old_kind = coVarKind old_var
(eta, stuff) = fun lc old_kind
- Pair k1 _ = coercionKind eta
+ k1 = coercionLKind eta
new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1)
-- old_var :: s1 ~r s2
@@ -2137,7 +2141,7 @@ seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos
seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2
seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k
`seq` seqCo co
-seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2
+seqCo (FunCo r w co1 co2) = r `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2
seqCo (CoVarCo cv) = cv `seq` ()
seqCo (HoleCo h) = coHoleCoVar h `seq` ()
seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos
@@ -2153,7 +2157,6 @@ seqCo (SubCo co) = seqCo co
seqCo (AxiomRuleCo _ cs) = seqCos cs
seqProv :: UnivCoProvenance -> ()
-seqProv UnsafeCoerceProv = ()
seqProv (PhantomProv co) = seqCo co
seqProv (ProofIrrelProv co) = seqCo co
seqProv (PluginProv _) = ()
@@ -2170,6 +2173,14 @@ seqCos (co:cos) = seqCo co `seq` seqCos cos
%************************************************************************
-}
+-- | Apply 'coercionKind' to multiple 'Coercion's
+coercionKinds :: [Coercion] -> Pair [Type]
+coercionKinds tys = sequenceA $ map coercionKind tys
+
+-- | Get a coercion's kind and role.
+coercionKindRole :: Coercion -> (Pair Type, Role)
+coercionKindRole co = (coercionKind co, coercionRole co)
+
coercionType :: Coercion -> Type
coercionType co = case coercionKindRole co of
(Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2
@@ -2182,84 +2193,128 @@ coercionType co = case coercionKindRole co of
-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.
coercionKind :: Coercion -> Pair Type
-coercionKind co =
- go co
+coercionKind co = Pair (coercionLKind co) (coercionRKind co)
+
+coercionLKind :: Coercion -> Type
+coercionLKind co
+ = go co
+ where
+ go (Refl ty) = ty
+ go (GRefl _ ty _) = ty
+ go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos)
+ go (AppCo co1 co2) = mkAppTy (go co1) (go co2)
+ go (ForAllCo tv1 _ co1) = mkTyCoInvForAllTy tv1 (go co1)
+ go (FunCo _ w co1 co2) = mkFunctionType (go w) (go co1) (go co2)
+ go (CoVarCo cv) = coVarLType cv
+ go (HoleCo h) = coVarLType (coHoleCoVar h)
+ go (UnivCo _ _ ty1 _) = ty1
+ go (SymCo co) = coercionRKind co
+ go (TransCo co1 _) = go co1
+ go (LRCo lr co) = pickLR lr (splitAppTy (go co))
+ go (InstCo aco arg) = go_app aco [go arg]
+ go (KindCo co) = typeKind (go co)
+ go (SubCo co) = go co
+ go (NthCo _ d co) = go_nth d (go co)
+ go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)
+ go (AxiomRuleCo ax cos) = pFst $ expectJust "coercionKind" $
+ coaxrProves ax $ map coercionKind cos
+
+ go_ax_inst ax ind tys
+ | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
+ , cab_lhs = lhs } <- coAxiomNthBranch ax ind
+ , let (tys1, cotys1) = splitAtList tvs tys
+ cos1 = map stripCoercionTy cotys1
+ = ASSERT( tys `equalLength` (tvs ++ cvs) )
+ -- Invariant of AxiomInstCo: cos should
+ -- exactly saturate the axiom branch
+ substTyWith tvs tys1 $
+ substTyWithCoVars cvs cos1 $
+ mkTyConApp (coAxiomTyCon ax) lhs
+
+ go_app :: Coercion -> [Type] -> Type
+ -- Collect up all the arguments and apply all at once
+ -- See Note [Nested InstCos]
+ go_app (InstCo co arg) args = go_app co (go arg:args)
+ go_app co args = piResultTys (go co) args
+
+go_nth :: Int -> Type -> Type
+go_nth d ty
+ | Just args <- tyConAppArgs_maybe ty
+ = ASSERT( args `lengthExceeds` d )
+ args `getNth` d
+
+ | d == 0
+ , Just (tv,_) <- splitForAllTy_maybe ty
+ = tyVarKind tv
+
+ | otherwise
+ = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty)
+
+coercionRKind :: Coercion -> Type
+coercionRKind co
+ = go co
where
- go (Refl ty) = Pair ty ty
- go (GRefl _ ty MRefl) = Pair ty ty
- go (GRefl _ ty (MCo co1)) = Pair ty (mkCastTy ty co1)
- go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos)
- go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2
+ go (Refl ty) = ty
+ go (GRefl _ ty MRefl) = ty
+ go (GRefl _ ty (MCo co1)) = mkCastTy ty co1
+ go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos)
+ go (AppCo co1 co2) = mkAppTy (go co1) (go co2)
+ go (CoVarCo cv) = coVarRType cv
+ go (HoleCo h) = coVarRType (coHoleCoVar h)
+ go (FunCo _ w co1 co2) = mkFunctionType (go w) (go co1) (go co2)
+ go (UnivCo _ _ _ ty2) = ty2
+ go (SymCo co) = coercionLKind co
+ go (TransCo _ co2) = go co2
+ go (LRCo lr co) = pickLR lr (splitAppTy (go co))
+ go (InstCo aco arg) = go_app aco [go arg]
+ go (KindCo co) = typeKind (go co)
+ go (SubCo co) = go co
+ go (NthCo _ d co) = go_nth d (go co)
+ go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)
+ go (AxiomRuleCo ax cos) = pSnd $ expectJust "coercionKind" $
+ coaxrProves ax $ map coercionKind cos
+
go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar
- | isGReflCo k_co = mkTyCoInvForAllTy tv1 <$> go co1
+ | isGReflCo k_co = mkTyCoInvForAllTy tv1 (go co1)
-- kind_co always has kind @Type@, thus @isGReflCo@
| otherwise = go_forall empty_subst co
where
empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co)
- go (FunCo _ co1 co2) = mkFunTy <$> go co1 <*> go co2
- go (CoVarCo cv) = coVarTypes cv
- go (HoleCo h) = coVarTypes (coHoleCoVar h)
- go (AxiomInstCo ax ind cos)
+
+ go_ax_inst ax ind tys
| CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
- , cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind
- , let Pair tycos1 tycos2 = sequenceA (map go cos)
- (tys1, cotys1) = splitAtList tvs tycos1
- (tys2, cotys2) = splitAtList tvs tycos2
- cos1 = map stripCoercionTy cotys1
+ , cab_rhs = rhs } <- coAxiomNthBranch ax ind
+ , let (tys2, cotys2) = splitAtList tvs tys
cos2 = map stripCoercionTy cotys2
- = ASSERT( cos `equalLength` (tvs ++ cvs) )
+ = ASSERT( tys `equalLength` (tvs ++ cvs) )
-- Invariant of AxiomInstCo: cos should
-- exactly saturate the axiom branch
- Pair (substTyWith tvs tys1 $
- substTyWithCoVars cvs cos1 $
- mkTyConApp (coAxiomTyCon ax) lhs)
- (substTyWith tvs tys2 $
- substTyWithCoVars cvs cos2 rhs)
- go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2
- go (SymCo co) = swap $ go co
- go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2)
- go g@(NthCo _ d co)
- | Just argss <- traverse tyConAppArgs_maybe tys
- = ASSERT( and $ (`lengthExceeds` d) <$> argss )
- (`getNth` d) <$> argss
-
- | d == 0
- , Just splits <- traverse splitForAllTy_maybe tys
- = (tyVarKind . fst) <$> splits
+ substTyWith tvs tys2 $
+ substTyWithCoVars cvs cos2 rhs
- | otherwise
- = pprPanic "coercionKind" (ppr g)
- where
- tys = go co
- go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co
- go (InstCo aco arg) = go_app aco [arg]
- go (KindCo co) = typeKind <$> go co
- go (SubCo co) = go co
- go (AxiomRuleCo ax cos) = expectJust "coercionKind" $
- coaxrProves ax (map go cos)
-
- go_app :: Coercion -> [Coercion] -> Pair Type
+ go_app :: Coercion -> [Type] -> Type
-- Collect up all the arguments and apply all at once
-- See Note [Nested InstCos]
- go_app (InstCo co arg) args = go_app co (arg:args)
- go_app co args = piResultTys <$> go co <*> (sequenceA $ map go args)
+ go_app (InstCo co arg) args = go_app co (go arg:args)
+ go_app co args = piResultTys (go co) args
go_forall subst (ForAllCo tv1 k_co co)
-- See Note [Nested ForAllCos]
| isTyVar tv1
- = mkInvForAllTy <$> Pair tv1 tv2 <*> go_forall subst' co
+ = mkInfForAllTy tv2 (go_forall subst' co)
where
- Pair _ k2 = go k_co
- tv2 = setTyVarKind tv1 (substTy subst k2)
+ k2 = coercionRKind k_co
+ tv2 = setTyVarKind tv1 (substTy subst k2)
subst' | isGReflCo k_co = extendTCvInScope subst tv1
-- kind_co always has kind @Type@, thus @isGReflCo@
| otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $
TyVarTy tv2 `mkCastTy` mkSymCo k_co
+
go_forall subst (ForAllCo cv1 k_co co)
| isCoVar cv1
- = mkTyCoInvForAllTy <$> Pair cv1 cv2 <*> go_forall subst' co
+ = mkTyCoInvForAllTy cv2 (go_forall subst' co)
where
- Pair _ k2 = go k_co
+ k2 = coercionRKind k_co
r = coVarRole cv1
eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co)
eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co)
@@ -2281,7 +2336,7 @@ coercionKind co =
go_forall subst other_co
-- when other_co is not a ForAllCo
- = substTy subst `pLiftSnd` go other_co
+ = substTy subst (go other_co)
{-
@@ -2292,22 +2347,14 @@ Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an
co)...) )`. We do not want to perform `n` single-type-variable
substitutions over the kind of `co`; rather we want to do one substitution
which substitutes for all of `a1`, `a2` ... simultaneously. If we do one
-at a time we get the performance hole reported in Trac #11735.
+at a time we get the performance hole reported in #11735.
Solution: gather up the type variables for nested `ForAllCos`, and
-substitute for them all at once. Remarkably, for Trac #11735 this single
+substitute for them all at once. Remarkably, for #11735 this single
change reduces /total/ compile time by a factor of more than ten.
-}
--- | Apply 'coercionKind' to multiple 'Coercion's
-coercionKinds :: [Coercion] -> Pair [Type]
-coercionKinds tys = sequenceA $ map coercionKind tys
-
--- | Get a coercion's kind and role.
-coercionKindRole :: Coercion -> (Pair Type, Role)
-coercionKindRole co = (coercionKind co, coercionRole co)
-
-- | Retrieve the role from a coercion.
coercionRole :: Coercion -> Role
coercionRole = go
@@ -2317,7 +2364,7 @@ coercionRole = go
go (TyConAppCo r _ _) = r
go (AppCo co1 _) = go co1
go (ForAllCo _ _ co) = go co
- go (FunCo r _ _) = r
+ go (FunCo r _ _ _) = r
go (CoVarCo cv) = coVarRole cv
go (HoleCo h) = coVarRole (coHoleCoVar h)
go (AxiomInstCo ax _ _) = coAxiomRole ax
@@ -2334,7 +2381,7 @@ coercionRole = go
{-
Note [Nested InstCos]
~~~~~~~~~~~~~~~~~~~~~
-In Trac #5631 we found that 70% of the entire compilation time was
+In #5631 we found that 70% of the entire compilation time was
being spent in coercionKind! The reason was that we had
(g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos
where
@@ -2342,16 +2389,65 @@ where
If we deal with the InstCos one at a time, we'll do this:
1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi'
2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst
-But this is a *quadratic* algorithm, and the blew up Trac #5631.
+But this is a *quadratic* algorithm, and the blew up #5631.
So it's very important to do the substitution simultaneously;
cf Type.piResultTys (which in fact we call here).
-}
+-- | Makes a coercion type from two types: the types whose equality
+-- is proven by the relevant 'Coercion'
+mkCoercionType :: Role -> Type -> Type -> Type
+mkCoercionType Nominal = mkPrimEqPred
+mkCoercionType Representational = mkReprPrimEqPred
+mkCoercionType Phantom = \ty1 ty2 ->
+ let ki1 = typeKind ty1
+ ki2 = typeKind ty2
+ in
+ TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2]
+
+mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type
+mkHeteroCoercionType Nominal = mkHeteroPrimEqPred
+mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred
+mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType"
+
+-- | Creates a primitive type equality predicate.
+-- Invariant: the types are not Coercions
+mkPrimEqPred :: Type -> Type -> Type
+mkPrimEqPred ty1 ty2
+ = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]
+ where
+ k1 = typeKind ty1
+ k2 = typeKind ty2
+
+-- | Makes a lifted equality predicate at the given role
+mkPrimEqPredRole :: Role -> Type -> Type -> PredType
+mkPrimEqPredRole Nominal = mkPrimEqPred
+mkPrimEqPredRole Representational = mkReprPrimEqPred
+mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom"
+
+-- | Creates a primitive type equality predicate with explicit kinds
+mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type
+mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]
+
+-- | Creates a primitive representational type equality predicate
+-- with explicit kinds
+mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type
+mkHeteroReprPrimEqPred k1 k2 ty1 ty2
+ = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]
+
+mkReprPrimEqPred :: Type -> Type -> Type
+mkReprPrimEqPred ty1 ty2
+ = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]
+ where
+ k1 = typeKind ty1
+ k2 = typeKind ty2
+
-- | Assuming that two types are the same, ignoring coercions, find
-- a nominal coercion between the types. This is useful when optimizing
-- transitivity over coercion applications, where splitting two
--- AppCos might yield different kinds. See Note [EtaAppCo] in OptCoercion.
+-- AppCos might yield different kinds. See Note [EtaAppCo] in
+-- "GHC.Core.Coercion.Opt".
buildCoercion :: Type -> Type -> CoercionN
buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
where
@@ -2374,8 +2470,9 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
; _ -> False } )
mkNomReflCo ty1
- go (FunTy arg1 res1) (FunTy arg2 res2)
- = mkFunCo Nominal (go arg1 arg2) (go res1 res2)
+ go (FunTy { ft_mult = w1, ft_arg = arg1, ft_res = res1 })
+ (FunTy { ft_mult = w2, ft_arg = arg2, ft_res = res2 })
+ = mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2)
go (TyConApp tc1 args1) (TyConApp tc2 args2)
= ASSERT( tc1 == tc2 )
@@ -2446,7 +2543,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
%* *
%************************************************************************
-The function below morally belongs in TcFlatten, but it is used also in
+The function below morally belongs in GHC.Tc.Solver.Flatten, but it is used also in
FamInstEnv, and so lives here.
Note [simplifyArgsWorker]
@@ -2594,8 +2691,9 @@ Then we do the process described in Note [simplifyArgsWorker].
2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1).
This is not a dependent argument, so we don't extend the lifting context.
-Now we need to deal with argument (3). After flattening, should we tack on a homogenizing
-coercion? The way we normally tell is to lift the kind of the binder.
+Now we need to deal with argument (3).
+The way we normally proceed is to lift the kind of the binder, to see whether
+it's dependent.
But here, the remainder of the kind of `a` that we're left with
after processing two arguments is just `k`.
@@ -2702,10 +2800,23 @@ as desired.
Whew.
+Historical note: I (Richard E) once thought that the final part of the kind
+had to be a variable k (as in the example above). But it might not be: it could
+be an application of a variable. Here is the example:
+
+ let f :: forall (a :: Type) (b :: a -> Type). b (Any @a)
+ k :: Type
+ x :: k
+
+ flatten (f @Type @((->) k) x)
+
+After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)`
+is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded.
+
-}
--- This is shared between the flattener and the normaliser in FamInstEnv.
+-- This is shared between the flattener and the normaliser in GHC.Core.FamInstEnv.
-- See Note [simplifyArgsWorker]
{-# INLINE simplifyArgsWorker #-}
simplifyArgsWorker :: [TyCoBinder] -> Kind
@@ -2739,23 +2850,25 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
-> [Role] -- Roles at which to flatten these ...
-> [(Type, Coercion)] -- flattened arguments, with their flattening coercions
-> ([Type], [Coercion], CoercionN)
- go acc_xis acc_cos lc binders inner_ki _ []
+ go acc_xis acc_cos !lc binders inner_ki _ []
+ -- The !lc makes the function strict in the lifting context
+ -- which means GHC can unbox that pair. A modest win.
= (reverse acc_xis, reverse acc_cos, kind_co)
where
- final_kind = mkTyCoPiTys binders inner_ki
+ final_kind = mkPiTys binders inner_ki
kind_co = liftCoSubst Nominal lc final_kind
go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args)
- = -- By Note [Flattening] in TcFlatten invariant (F2),
+ = -- By Note [Flattening] in GHC.Tc.Solver.Flatten invariant (F2),
-- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be
-- used as an argument to a function whose kind is different, if
-- earlier arguments have been flattened to new types. We thus
-- need a coercion (kind_co :: old_kind ~ new_kind).
--
-- The bangs here have been observed to improve performance
- -- significantly in optimized builds.
- let kind_co = mkSymCo $
- liftCoSubst Nominal lc (tyCoBinderType binder)
+ -- significantly in optimized builds; see #18502
+ let !kind_co = mkSymCo $
+ liftCoSubst Nominal lc (tyCoBinderType binder)
!casted_xi = xi `mkCastTy` kind_co
casted_co = mkCoherenceLeftCo role xi kind_co co
@@ -2776,10 +2889,9 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
-- See Note [Last case in simplifyArgsWorker]
go acc_xis acc_cos lc [] inner_ki roles args
- | Just k <- getTyVar_maybe inner_ki
- , Just co1 <- liftCoSubstTyVar lc Nominal k
- = let co1_kind = coercionKind co1
- unflattened_tys = map (pSnd . coercionKind . snd) args
+ = let co1 = liftCoSubst Nominal lc inner_ki
+ co1_kind = coercionKind co1
+ unflattened_tys = map (coercionRKind . snd) args
(arg_cos, res_co) = decomposePiCos co1 co1_kind unflattened_tys
casted_args = ASSERT2( equalLength args arg_cos
, ppr args $$ ppr arg_cos )
@@ -2806,8 +2918,8 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
"simplifyArgsWorker wandered into deeper water than usual"
-- This debug information is commented out because leaving it in
-- causes a ~2% increase in allocations in T9872d.
- -- That's independent of the analagous case in flatten_args_fast
- -- in TcFlatten:
+ -- That's independent of the analogous case in flatten_args_fast
+ -- in GHC.Tc.Solver.Flatten:
-- each of these causes a 2% increase on its own, so commenting them
-- both out gives a 4% decrease in T9872d.
{-
@@ -2817,3 +2929,40 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
ppr (take 10 orig_roles), -- often infinite!
ppr orig_tys])
-}
+
+{-
+%************************************************************************
+%* *
+ Coercion holes
+%* *
+%************************************************************************
+-}
+
+bad_co_hole_ty :: Type -> Monoid.Any
+bad_co_hole_co :: Coercion -> Monoid.Any
+(bad_co_hole_ty, _, bad_co_hole_co, _)
+ = foldTyCo folder ()
+ where
+ folder = TyCoFolder { tcf_view = const Nothing
+ , tcf_tyvar = const2 (Monoid.Any False)
+ , tcf_covar = const2 (Monoid.Any False)
+ , tcf_hole = const hole
+ , tcf_tycobinder = const2
+ }
+
+ const2 :: a -> b -> c -> a
+ const2 x _ _ = x
+
+ hole :: CoercionHole -> Monoid.Any
+ hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True
+ hole _ = Monoid.Any False
+
+-- | Is there a blocking coercion hole in this type? See
+-- "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds]
+badCoercionHole :: Type -> Bool
+badCoercionHole = Monoid.getAny . bad_co_hole_ty
+
+-- | Is there a blocking coercion hole in this coercion? See
+-- GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]
+badCoercionHoleCo :: Coercion -> Bool
+badCoercionHoleCo = Monoid.getAny . bad_co_hole_co
diff --git a/compiler/types/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot
index 322b127..7a92a84 100644
--- a/compiler/types/Coercion.hs-boot
+++ b/compiler/GHC/Core/Coercion.hs-boot
@@ -1,27 +1,26 @@
{-# LANGUAGE FlexibleContexts #-}
-module Coercion where
+module GHC.Core.Coercion where
-import GhcPrelude
+import GHC.Prelude
-import {-# SOURCE #-} TyCoRep
-import {-# SOURCE #-} TyCon
+import {-# SOURCE #-} GHC.Core.TyCo.Rep
+import {-# SOURCE #-} GHC.Core.TyCon
-import BasicTypes ( LeftOrRight )
-import CoAxiom
-import Var
-import Pair
-import Util
+import GHC.Types.Basic ( LeftOrRight )
+import GHC.Core.Coercion.Axiom
+import GHC.Types.Var
+import GHC.Data.Pair
+import GHC.Utils.Misc
mkReflCo :: Role -> Type -> Coercion
mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
mkAppCo :: Coercion -> Coercion -> Coercion
mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion
-mkFunCo :: Role -> Coercion -> Coercion -> Coercion
+mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion
mkCoVarCo :: CoVar -> Coercion
mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion
mkPhantomCo :: Coercion -> Type -> Type -> Coercion
-mkUnsafeCo :: Role -> Type -> Type -> Coercion
mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkSymCo :: Coercion -> Coercion
mkTransCo :: Coercion -> Coercion -> Coercion
@@ -49,4 +48,6 @@ liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
seqCo :: Coercion -> ()
coercionKind :: Coercion -> Pair Type
+coercionLKind :: Coercion -> Type
+coercionRKind :: Coercion -> Type
coercionType :: Coercion -> Type
diff --git a/compiler/types/CoAxiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs
index fe85521..7c2e935 100644
--- a/compiler/types/CoAxiom.hs
+++ b/compiler/GHC/Core/Coercion/Axiom.hs
@@ -6,7 +6,7 @@
-- | Module for coercion axioms, used to represent type family instances
-- and newtypes
-module CoAxiom (
+module GHC.Core.Coercion.Axiom (
BranchFlag, Branched, Unbranched, BranchIndex, Branches(..),
manyBranches, unbranched,
fromBranches, numBranches,
@@ -29,21 +29,22 @@ module CoAxiom (
BuiltInSynFamily(..), trivialBuiltInFamily
) where
-import GhcPrelude
-
-import {-# SOURCE #-} TyCoRep ( Type, pprType )
-import {-# SOURCE #-} TyCon ( TyCon )
-import Outputable
-import FastString
-import Name
-import Unique
-import Var
-import Util
-import Binary
-import Pair
-import BasicTypes
+import GHC.Prelude
+
+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )
+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )
+import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )
+import GHC.Utils.Outputable
+import GHC.Data.FastString
+import GHC.Types.Name
+import GHC.Types.Unique
+import GHC.Types.Var
+import GHC.Utils.Misc
+import GHC.Utils.Binary
+import GHC.Data.Pair
+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 )
@@ -86,7 +87,7 @@ can unify with the supplied arguments. After all, it is possible that some
of the type arguments are lambda-bound type variables whose instantiation may
cause an earlier match among the branches. We wish to prohibit this behavior,
so the type checker rules out the choice of a branch where a previous branch
-can unify. See also [Apartness] in FamInstEnv.hs.
+can unify. See also [Apartness] in GHC.Core.FamInstEnv.
For example, the following is malformed, where 'a' is a lambda-bound type
variable:
@@ -183,9 +184,10 @@ Note [Storing compatibility]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
During axiom application, we need to be aware of which branches are compatible
with which others. The full explanation is in Note [Compatibility] in
-FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on
-the unification algorithm.) Although we could theoretically compute
-compatibility on the fly, this is silly, so we store it in a CoAxiom.
+GHc.Core.FamInstEnv. (The code is placed there to avoid a dependency from
+GHC.Core.Coercion.Axiom on the unification algorithm.) Although we could
+theoretically compute compatibility on the fly, this is silly, so we store it
+in a CoAxiom.
Specifically, each branch refers to all other branches with which it is
incompatible. This list might well be empty, and it will always be for the
@@ -197,12 +199,23 @@ axiom as a whole, and they are computed only when the final axiom is built.
During serialization, the list is converted into a list of the indices
of the branches.
+
+Note [CoAxioms are homogeneous]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+All axioms must be *homogeneous*, meaning that the kind of the LHS must
+match the kind of the RHS. In practice, this means:
+
+ Given a CoAxiom { co_ax_tc = ax_tc },
+ for every branch CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }:
+ typeKind (mkTyConApp ax_tc lhs) `eqType` typeKind rhs
+
+This is checked in FamInstEnv.mkCoAxBranch.
-}
-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.
-- If you edit this type, you may need to update the GHC formalism
--- See Note [GHC Formalism] in coreSyn/CoreLint.hs
+-- See Note [GHC Formalism] in GHC.Core.Lint
data CoAxiom br
= CoAxiom -- Type equality axiom.
{ co_ax_unique :: Unique -- Unique identifier
@@ -221,18 +234,18 @@ data CoAxBranch
{ cab_loc :: SrcSpan -- Location of the defining equation
-- See Note [CoAxiom locations]
, cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh
- , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars
-- See Note [CoAxBranch type variables]
- -- cab_tvs and cab_lhs may be eta-reduded; see
+ , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars
+ -- cab_tvs and cab_lhs may be eta-reduced; see
-- Note [Eta reduction for data families]
, cab_cvs :: [CoVar] -- Bound coercion variables
-- Always empty, for now.
-- See Note [Constraints in patterns]
- -- in TcTyClsDecls
+ -- in GHC.Tc.TyCl
, cab_roles :: [Role] -- See Note [CoAxBranch roles]
, cab_lhs :: [Type] -- Type patterns to match against
- -- See Note [CoAxiom saturation]
, cab_rhs :: Type -- Right-hand side of the equality
+ -- See Note [CoAxioms are homogeneous]
, cab_incomps :: [CoAxBranch] -- The previous incompatible branches
-- See Note [Storing compatibility]
}
@@ -306,14 +319,11 @@ isImplicitCoAxiom = co_ax_implicit
coAxBranchIncomps :: CoAxBranch -> [CoAxBranch]
coAxBranchIncomps = cab_incomps
--- See Note [Compatibility checking] in FamInstEnv
+-- See Note [Compatibility checking] in GHC.Core.FamInstEnv
placeHolderIncomps :: [CoAxBranch]
placeHolderIncomps = panic "placeHolderIncomps"
-{- Note [CoAxiom saturation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* When co
-
+{-
Note [CoAxBranch type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the case of a CoAxBranch of an associated type-family instance,
@@ -369,7 +379,7 @@ giving rise to the FamInstBranch.
Note [Implicit axioms]
~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Implicit TyThings] in HscTypes
+See also Note [Implicit TyThings] in GHC.Driver.Types
* A CoAxiom arising from data/type family instances is not "implicit".
That is, it has its own IfaceAxiom declaration in an interface file
@@ -418,7 +428,7 @@ TyCon rep_tc:
- This eta reduction happens for data instances as well
as newtype instances. Here we want to eta-reduce the data family axiom.
- - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl.
+ - This eta-reduction is done in GHC.Tc.TyCl.Instance.tcDataFamInstDecl.
But for a /type/ family
- cab_lhs has the exact arity of the family tycon
@@ -434,9 +444,13 @@ looked like
(See #9692, #14179, and #15845 for examples of what can go wrong if
we don't eta-expand when showing things to the user.)
-(See also Note [Newtype eta] in TyCon. This is notionally separate
-and deals with the axiom connecting a newtype with its representation
-type; but it too is eta-reduced.)
+See also:
+
+* Note [Newtype eta] in GHC.Core.TyCon. This is notionally separate
+ and deals with the axiom connecting a newtype with its representation
+ type; but it too is eta-reduced.
+* Note [Implementing eta reduction for data families] in "GHC.Tc.TyCl.Instance". This
+ describes the implementation details of this eta reduction happen.
-}
instance Eq (CoAxiom br) where
@@ -476,8 +490,8 @@ instance Outputable CoAxBranch where
Roles are defined here to avoid circular dependencies.
-}
--- See Note [Roles] in Coercion
--- defined here to avoid cyclic dependency with Coercion
+-- See Note [Roles] in GHC.Core.Coercion
+-- defined here to avoid cyclic dependency with GHC.Core.Coercion
--
-- Order of constructors matters: the Ord instance coincides with the *super*typing
-- relation on roles.
@@ -487,7 +501,7 @@ data Role = Nominal | Representational | Phantom
-- These names are slurped into the parser code. Changing these strings
-- will change the **surface syntax** that GHC accepts! If you want to
-- change only the pretty-printing, do some replumbing. See
--- mkRoleAnnotDecl in RdrHsSyn
+-- mkRoleAnnotDecl in GHC.Parser.PostProcess
fsFromRole :: Role -> FastString
fsFromRole Nominal = fsLit "nominal"
fsFromRole Representational = fsLit "representational"
diff --git a/compiler/types/OptCoercion.hs b/compiler/GHC/Core/Coercion/Opt.hs
index 8efcf52..15e4fad 100644
--- a/compiler/types/OptCoercion.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -2,32 +2,29 @@
{-# LANGUAGE CPP #-}
--- The default iteration limit is a bit too low for the definitions
--- in this module.
-{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
-
-module OptCoercion ( optCoercion, checkAxInstCo ) where
+module GHC.Core.Coercion.Opt ( optCoercion, checkAxInstCo ) where
#include "GhclibHsVersions.h"
-import GhcPrelude
-
-import DynFlags
-import TyCoRep
-import Coercion
-import Type hiding( substTyVarBndr, substTy )
-import TcType ( exactTyCoVarsOfType )
-import TyCon
-import CoAxiom
-import VarSet
-import VarEnv
-import Outputable
-import FamInstEnv ( flattenTys )
-import Pair
-import ListSetOps ( getNth )
-import Util
-import Unify
-import InstEnv
+import GHC.Prelude
+
+import GHC.Driver.Session
+import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Subst
+import GHC.Core.Coercion
+import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )
+import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType )
+import GHC.Core.TyCon
+import GHC.Core.Coercion.Axiom
+import GHC.Types.Var.Set
+import GHC.Types.Var.Env
+import GHC.Utils.Outputable
+import GHC.Core.FamInstEnv ( flattenTys )
+import GHC.Data.Pair
+import GHC.Data.List.SetOps ( getNth )
+import GHC.Utils.Misc
+import GHC.Core.Unify
+import GHC.Core.InstEnv
import Control.Monad ( zipWithM )
{-
@@ -78,7 +75,7 @@ If we substitute the *type* tv for the *coercion*
(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly.
This is bizarre,
though, because we're substituting a type variable with a coercion. However,
-this operation already exists: it's called *lifting*, and defined in Coercion.
+this operation already exists: it's called *lifting*, and defined in GHC.Core.Coercion.
We just need to enhance the lifting operation to be able to deal with
an ambient substitution, which is why a LiftingContext stores a TCvSubst.
@@ -122,8 +119,8 @@ optCoercion' env co
(Pair in_ty1 in_ty2, in_role) = coercionKindRole co
(Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co
in
- ASSERT2( substTy env in_ty1 `eqType` out_ty1 &&
- substTy env in_ty2 `eqType` out_ty2 &&
+ ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&
+ substTyUnchecked env in_ty2 `eqType` out_ty2 &&
in_role == out_role
, text "optCoercion changed types!"
$$ hang (text "in_co:") 2 (ppr co)
@@ -254,14 +251,15 @@ opt_co4 env sym rep r (ForAllCo tv k_co co)
opt_co4_wrap env' sym rep r co
-- Use the "mk" functions to check for nested Refls
-opt_co4 env sym rep r (FunCo _r co1 co2)
+opt_co4 env sym rep r (FunCo _r cow co1 co2)
= ASSERT( r == _r )
if rep
- then mkFunCo Representational co1' co2'
- else mkFunCo r co1' co2'
+ then mkFunCo Representational cow' co1' co2'
+ else mkFunCo r cow' co1' co2'
where
co1' = opt_co4_wrap env sym rep r co1
co2' = opt_co4_wrap env sym rep r co2
+ cow' = opt_co1 env sym cow
opt_co4 env sym rep r (CoVarCo cv)
| Just co <- lookupCoVar (lcTCvSubst env) cv
@@ -465,7 +463,7 @@ If we have (c :: t~t) we can optimise it to Refl. That increases the
chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t)
We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo]
-in Coercion.
+in GHC.Core.Coercion.
-}
-------------
@@ -488,7 +486,7 @@ of arguments in a `CoTyConApp` can differ. Consider
Any * Int :: *
Any (*->*) Maybe Int :: *
-Hence the need to compare argument lengths; see Trac #13658
+Hence the need to compare argument lengths; see #13658
-}
opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role
@@ -557,14 +555,14 @@ opt_univ env sym prov role oty1 oty2
where
prov' = case prov of
- UnsafeCoerceProv -> prov
PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco
ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco
PluginProv _ -> prov
-------------
-opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
-opt_transList is = zipWith (opt_trans is)
+opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
+opt_transList is = zipWithEqual "opt_transList" (opt_trans is)
+ -- The input lists must have identical length.
opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
opt_trans is co1 co2
@@ -637,7 +635,6 @@ opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
mkUnivCo prov' r1 tyl1 tyr2
where
-- if the provenances are different, opt'ing will be very confusing
- opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv = Just UnsafeCoerceProv
opt_trans_prov (PhantomProv kco1) (PhantomProv kco2)
= Just $ PhantomProv $ opt_trans is kco1 kco2
opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)
@@ -652,10 +649,10 @@ opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2
fireTransRule "PushTyConApp" in_co1 in_co2 $
mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)
-opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b)
- = ASSERT( r1 == r2 ) -- Just like the TyConAppCo/TyConAppCo case
+opt_trans_rule is in_co1@(FunCo r1 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b)
+ = ASSERT( r1 == r2) -- Just like the TyConAppCo/TyConAppCo case
fireTransRule "PushFun" in_co1 in_co2 $
- mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b)
+ mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b)
opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
-- Must call opt_trans_rule_app; see Note [EtaAppCo]
@@ -664,14 +661,12 @@ opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
-- Eta rules
opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
| Just cos2 <- etaTyConAppCo_maybe tc co2
- = ASSERT( cos1 `equalLength` cos2 )
- fireTransRule "EtaCompL" co1 co2 $
+ = fireTransRule "EtaCompL" co1 co2 $
mkTyConAppCo r tc (opt_transList is cos1 cos2)
opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
| Just cos1 <- etaTyConAppCo_maybe tc co1
- = ASSERT( cos1 `equalLength` cos2 )
- fireTransRule "EtaCompR" co1 co2 $
+ = fireTransRule "EtaCompR" co1 co2 $
mkTyConAppCo r tc (opt_transList is cos1 cos2)
opt_trans_rule is co1@(AppCo co1a co1b) co2
@@ -798,8 +793,9 @@ opt_trans_rule is co1 co2
role = coercionRole co1 -- should be the same as coercionRole co2!
opt_trans_rule _ co1 co2 -- Identity rule
- | (Pair ty1 _, r) <- coercionKindRole co1
- , Pair _ ty2 <- coercionKind co2
+ | let ty1 = coercionLKind co1
+ r = coercionRole co1
+ ty2 = coercionRKind co2
, ty1 `eqType` ty2
= fireTransRule "RedTypeDirRefl" co1 co2 $
mkReflCo r ty2
@@ -827,11 +823,13 @@ opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs
| otherwise
= ASSERT( co1bs `equalLength` co2bs )
fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $
- let Pair _ rt1a = coercionKind co1a
- (Pair lt2a _, rt2a) = coercionKindRole co2a
+ let rt1a = coercionRKind co1a
+
+ lt2a = coercionLKind co2a
+ rt2a = coercionRole co2a
- Pair _ rt1bs = traverse coercionKind co1bs
- Pair lt2bs _ = traverse coercionKind co2bs
+ rt1bs = map coercionRKind co1bs
+ lt2bs = map coercionLKind co2bs
rt2bs = map coercionRole co2bs
kcoa = mkKindCo $ buildCoercion lt2a rt1a
@@ -869,7 +867,7 @@ False) and that all is OK. But, all is not OK: we want to use the first branch
of the axiom in this case, not the second. The problem is that the parameters
of the first branch can unify with the supplied coercions, thus meaning that
the first branch should be taken. See also Note [Apartness] in
-types/FamInstEnv.hs.
+"GHC.Core.FamInstEnv".
Note [Why call checkAxInstCo during optimisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -932,7 +930,7 @@ First, convince yourself of the following:
(a |> (h -> <Type>)) (b |> h) `eqType` a b
-That last fact is due to Note [Non-trivial definitional equality] in TyCoRep,
+That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep,
where we ignore coercions in types as long as two types' kinds are the same.
In our case, we meet this last condition, because
@@ -967,15 +965,15 @@ The problem described here was first found in dependent/should_compile/dynamic-p
-- Returns the conflicting branch, if it exists
-- See Note [Conflict checking with AxiomInstCo]
checkAxInstCo :: Coercion -> Maybe CoAxBranch
--- defined here to avoid dependencies in Coercion
+-- defined here to avoid dependencies in GHC.Core.Coercion
-- If you edit this function, you may need to update the GHC formalism
--- See Note [GHC Formalism] in CoreLint
+-- See Note [GHC Formalism] in GHC.Core.Lint
checkAxInstCo (AxiomInstCo ax ind cos)
= let branch = coAxiomNthBranch ax ind
tvs = coAxBranchTyVars branch
cvs = coAxBranchCoVars branch
incomps = coAxBranchIncomps branch
- (tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos)
+ (tys, cotys) = splitAtList tvs (map coercionLKind cos)
co_args = map stripCoercionTy cotys
subst = zipTvSubst tvs tys `composeTCvSubst`
zipCvSubst cvs co_args
@@ -988,7 +986,7 @@ checkAxInstCo (AxiomInstCo ax ind cos)
check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch
check_no_conflict _ [] = Nothing
check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)
- -- See Note [Apartness] in FamInstEnv
+ -- See Note [Apartness] in GHC.Core.FamInstEnv
| SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp
= check_no_conflict flat rest
| otherwise
@@ -1048,8 +1046,8 @@ compatible_co :: Coercion -> Coercion -> Bool
compatible_co co1 co2
= x1 `eqType` x2
where
- Pair _ x1 = coercionKind co1
- Pair x2 _ = coercionKind co2
+ x1 = coercionRKind co1
+ x2 = coercionLKind co2
-------------
{-
@@ -1159,16 +1157,16 @@ etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)
= ASSERT( tc == tc2 ) Just cos2
etaTyConAppCo_maybe tc co
- | mightBeUnsaturatedTyCon tc
+ | not (mustBeSaturated tc)
, (Pair ty1 ty2, r) <- coercionKindRole co
, Just (tc1, tys1) <- splitTyConApp_maybe ty1
, Just (tc2, tys2) <- splitTyConApp_maybe ty2
, tc1 == tc2
- , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in TyCoRep
+ , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in GHC.Core.TyCo.Rep
, let n = length tys1
- , tys2 `lengthIs` n -- This can fail in an erroneous progam
+ , tys2 `lengthIs` n -- This can fail in an erroneous program
-- E.g. T a ~# T a b
- -- Trac #14607
+ -- #14607
= ASSERT( tc == tc1 )
Just (decomposeCo n co (tyConRolesX r tc1))
-- NB: n might be <> tyConArity tc
diff --git a/compiler/basicTypes/ConLike.hs b/compiler/GHC/Core/ConLike.hs
index 659042b..6d7fb20 100644
--- a/compiler/basicTypes/ConLike.hs
+++ b/compiler/GHC/Core/ConLike.hs
@@ -7,11 +7,12 @@
{-# LANGUAGE CPP #-}
-module ConLike (
+module GHC.Core.ConLike (
ConLike(..)
, conLikeArity
, conLikeFieldLabels
, conLikeInstOrigArgTys
+ , conLikeUserTyVarBinders
, conLikeExTyCoVars
, conLikeName
, conLikeStupidTheta
@@ -26,18 +27,19 @@ module ConLike (
#include "GhclibHsVersions.h"
-import GhcPrelude
+import GHC.Prelude
-import DataCon
-import PatSyn
-import Outputable
-import Unique
-import Util
-import Name
-import BasicTypes
-import TyCoRep (Type, ThetaType)
-import Var
-import Type (mkTyConApp)
+import GHC.Core.DataCon
+import GHC.Core.PatSyn
+import GHC.Utils.Outputable
+import GHC.Types.Unique
+import GHC.Utils.Misc
+import GHC.Types.Name
+import GHC.Types.Basic
+import GHC.Core.TyCo.Rep (Type, ThetaType)
+import GHC.Types.Var
+import GHC.Core.Type(mkTyConApp)
+import GHC.Core.Multiplicity
import qualified Data.Data as Data
@@ -69,7 +71,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
@@ -107,11 +109,23 @@ conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn
-- | Returns just the instantiated /value/ argument types of a 'ConLike',
-- (excluding dictionary args)
-conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type]
+conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type]
conLikeInstOrigArgTys (RealDataCon data_con) tys =
dataConInstOrigArgTys data_con tys
conLikeInstOrigArgTys (PatSynCon pat_syn) tys =
- patSynInstArgTys pat_syn tys
+ map unrestricted $ patSynInstArgTys pat_syn tys
+
+-- | 'TyVarBinder's for the type variables of the 'ConLike'. For pattern
+-- synonyms, this will always consist of the universally quantified variables
+-- followed by the existentially quantified type variables. For data
+-- constructors, the situation is slightly more complicated—see
+-- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon".
+conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder]
+conLikeUserTyVarBinders (RealDataCon data_con) =
+ dataConUserTyVarBinders data_con
+conLikeUserTyVarBinders (PatSynCon pat_syn) =
+ patSynUnivTyVarBinders pat_syn ++ patSynExTyVarBinders pat_syn
+ -- The order here is because of the order in `GHC.Tc.TyCl.PatSyn`.
-- | Existentially quantified type/coercion variables
conLikeExTyCoVars :: ConLike -> [TyCoVar]
@@ -167,8 +181,8 @@ conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys
conLikeFullSig :: ConLike
-> ([TyVar], [TyCoVar], [EqSpec]
-- Why tyvars for universal but tycovars for existential?
- -- See Note [Existential coercion variables] in DataCon
- , ThetaType, ThetaType, [Type], Type)
+ -- See Note [Existential coercion variables] in GHC.Core.DataCon
+ , ThetaType, ThetaType, [Scaled Type], Type)
conLikeFullSig (RealDataCon con) =
let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con
-- Required theta is empty as normal data cons require no additional
diff --git a/compiler/GHC/Core/ConLike.hs-boot b/compiler/GHC/Core/ConLike.hs-boot
new file mode 100644
index 0000000..0a6e732
--- /dev/null
+++ b/compiler/GHC/Core/ConLike.hs-boot
@@ -0,0 +1,9 @@
+module GHC.Core.ConLike where
+import {-# SOURCE #-} GHC.Core.DataCon (DataCon)
+import {-# SOURCE #-} GHC.Core.PatSyn (PatSyn)
+import GHC.Types.Name ( Name )
+
+data ConLike = RealDataCon DataCon
+ | PatSynCon PatSyn
+
+conLikeName :: ConLike -> Name
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/GHC/Core/DataCon.hs
index bb572e8..edaefc1 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/GHC/Core/DataCon.hs
@@ -7,7 +7,7 @@
{-# LANGUAGE CPP, DeriveDataTypeable #-}
-module DataCon (
+module GHC.Core.DataCon (
-- * Main data types
DataCon, DataConRep(..),
SrcStrictness(..), SrcUnpackedness(..),
@@ -24,17 +24,20 @@ module DataCon (
FieldLbl(..), FieldLabel, FieldLabelString,
-- ** Type construction
- mkDataCon, buildAlgTyCon, buildSynTyCon, fIRST_TAG,
+ mkDataCon, fIRST_TAG,
-- ** Type deconstruction
- dataConRepType, dataConSig, dataConInstSig, dataConFullSig,
+ dataConRepType, dataConInstSig, dataConFullSig,
dataConName, dataConIdentity, dataConTag, dataConTagZ,
dataConTyCon, dataConOrigTyCon,
- dataConUserType,
+ dataConWrapperType,
+ dataConNonlinearType,
+ dataConDisplayType,
dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars,
dataConUserTyVars, dataConUserTyVarBinders,
dataConEqSpec, dataConTheta,
dataConStupidTheta,
+ dataConOtherTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,
@@ -61,32 +64,34 @@ module DataCon (
#include "GhclibHsVersions.h"
-import GhcPrelude
-
-import {-# SOURCE #-} MkId( DataConBoxer )
-import Type
-import ForeignCall ( CType )
-import Coercion
-import Unify
-import TyCon
-import FieldLabel
-import Class
-import Name
-import PrelNames
-import Var
-import VarSet( emptyVarSet )
-import Outputable
-import Util
-import BasicTypes
-import FastString
-import Module
-import Binary
-import UniqSet
-import Unique( mkAlphaTyVarUnique )
-
+import GHC.Prelude
+
+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 GHC.Core.Multiplicity
+import GHC.Types.FieldLabel
+import GHC.Core.Class
+import GHC.Types.Name
+import GHC.Builtin.Names
+import GHC.Core.Predicate
+import GHC.Types.Var
+import GHC.Utils.Outputable
+import GHC.Utils.Misc
+import GHC.Types.Basic
+import GHC.Data.FastString
+import GHC.Unit
+import GHC.Utils.Binary
+import GHC.Types.Unique.Set
+import GHC.Types.Unique( mkAlphaTyVarUnique )
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Builder as BSB
+import qualified Data.ByteString.Lazy as LBS
import qualified Data.Data as Data
import Data.Char
-import Data.Word
import Data.List( find )
{-
@@ -187,7 +192,7 @@ Note [Data constructor workers and wrappers]
* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
-* The wrapper (if it exists) takes dcOrigArgTys as its arguments
+* The wrapper (if it exists) takes dcOrigArgTys as its arguments.
The worker takes dataConRepArgTys as its arguments
If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys
@@ -203,7 +208,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)
@@ -294,10 +299,10 @@ Note that (Foo a) might not be an instance of Ord.
-- | A data constructor
--
--- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
--- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma'
+-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
+-- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma'
--- For details on above see note [Api annotations] in ApiAnnotation
+-- For details on above see note [Api annotations] in GHC.Parser.Annotation
data DataCon
= MkData {
dcName :: Name, -- This is the name of the *source data con*
@@ -363,14 +368,14 @@ data DataCon
dcExTyCoVars :: [TyCoVar],
-- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames
- -- Reason: less confusing, and easier to generate IfaceSyn
+ -- Reason: less confusing, and easier to generate Iface syntax
-- The type/coercion vars in the order the user wrote them [c,y,x,b]
-- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set
-- of tyvars (*not* covars) of dcExTyCoVars unioned with the
-- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec
-- See Note [DataCon user type variable binders]
- dcUserTyVarBinders :: [TyVarBinder],
+ dcUserTyVarBinders :: [InvisTVBinder],
dcEqSpec :: [EqSpec], -- Equalities derived from the result type,
-- _as written by the programmer_.
@@ -383,7 +388,9 @@ data DataCon
-- MkT :: forall a b. (a ~ [b]) => b -> T a
-- MkT :: forall b. b -> T [b]
-- Each equality is of the form (a ~ ty), where 'a' is one of
- -- the universally quantified type variables
+ -- the universally quantified type variables. Moreover, the
+ -- only place in the DataCon where this 'a' will occur is in
+ -- dcUnivTyVars. See [The dcEqSpec domain invariant].
-- The next two fields give the type context of the data constructor
-- (aside from the GADT constraints,
@@ -409,13 +416,13 @@ data DataCon
-- the wrapper Id, because that makes it harder to use the wrap-id
-- to rebuild values after record selection or in generics.
- dcOrigArgTys :: [Type], -- Original argument types
+ dcOrigArgTys :: [Scaled Type], -- Original argument types
-- (before unboxing and flattening of strict fields)
dcOrigResTy :: Type, -- Original result type, as seen by the user
-- NB: for a data instance, the original user result type may
-- differ from the DataCon's representation TyCon. Example
-- data instance T [a] where MkT :: a -> T [a]
- -- The OrigResTy is T [a], but the dcRepTyCon might be :T123
+ -- The dcOrigResTy is T [a], but the dcRepTyCon might be R:TList
-- Now the strictness annotations and field labels of the constructor
dcSrcBangs :: [HsSrcBang],
@@ -460,7 +467,7 @@ data DataCon
-- It's convenient to apply the rep-type of MkT to 't', to get
-- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t
-- and use that to check the pattern. Mind you, this is really only
- -- used in CoreLint.
+ -- used in GHC.Core.Lint.
dcInfix :: Bool, -- True <=> declared infix
@@ -468,7 +475,7 @@ data DataCon
-- The actual fixity is stored elsewhere
dcPromoted :: TyCon -- The promoted TyCon
- -- See Note [Promoted data constructors] in TyCon
+ -- See Note [Promoted data constructors] in GHC.Core.TyCon
}
@@ -478,7 +485,7 @@ For the TyVarBinders in a DataCon and PatSyn:
* Each argument flag is Inferred or Specified.
None are Required. (A DataCon is a term-level function; see
- Note [No Required TyCoBinder in terms] in TyCoRep.)
+ Note [No Required TyCoBinder in terms] in GHC.Core.TyCo.Rep.)
Why do we need the TyVarBinders, rather than just the TyVars? So that
we can construct the right type for the DataCon with its foralls
@@ -592,8 +599,37 @@ sometimes refer to this as "the dcUserTyVarBinders invariant".
dcUserTyVarBinders, as the name suggests, is the one that users will see most of
the time. It's used when computing the type signature of a data constructor (see
-dataConUserType), and as a result, it's what matters from a TypeApplications
+dataConWrapperType), and as a result, it's what matters from a TypeApplications
perspective.
+
+Note [The dcEqSpec domain invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this example of a GADT constructor:
+
+ data Y a where
+ MkY :: Bool -> Y Bool
+
+The user-written type of MkY is `Bool -> Y Bool`, but what is the underlying
+Core type for MkY? There are two conceivable possibilities:
+
+1. MkY :: forall a. (a ~# Bool) => Bool -> Y a
+2. MkY :: forall a. (a ~# Bool) => a -> Y a
+
+In practice, GHC picks (1) as the Core type for MkY. This is because we
+maintain an invariant that the type variables in the domain of dcEqSpec will
+only ever appear in the dcUnivTyVars. As a consequence, the type variables in
+the domain of dcEqSpec will /never/ appear in the dcExTyCoVars, dcOtherTheta,
+dcOrigArgTys, or dcOrigResTy; these can only ever mention variables from
+dcUserTyVarBinders, which excludes things in the domain of dcEqSpec.
+(See Note [DataCon user type variable binders].) This explains why GHC would
+not pick (2) as the Core type, since the argument type `a` mentions a type
+variable in the dcEqSpec.
+
+There are certain parts of the codebase where it is convenient to apply the
+substitution arising from the dcEqSpec to the dcUnivTyVars in order to obtain
+the user-written return type of a GADT constructor. A consequence of the
+dcEqSpec domain invariant is that you /never/ need to apply the substitution
+to any other part of the constructor type, as they don't require it.
-}
-- | Data Constructor Representation
@@ -608,12 +644,12 @@ data DataConRep
, dcr_boxer :: DataConBoxer
- , dcr_arg_tys :: [Type] -- Final, representation argument types,
- -- after unboxing and flattening,
- -- and *including* all evidence args
+ , dcr_arg_tys :: [Scaled Type] -- Final, representation argument types,
+ -- after unboxing and flattening,
+ -- 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]
, dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures)
-- about the original arguments; 1-1 with orig_arg_tys
@@ -633,7 +669,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
@@ -714,8 +750,26 @@ filterEqSpec eq_spec
instance Outputable EqSpec where
ppr (EqSpec tv ty) = ppr (tv, ty)
-{- Note [Bangs on data constructor arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- 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.
+
+Note [Bangs on data constructor arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = MkT !Int {-# UNPACK #-} !Int Bool
@@ -739,7 +793,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
@@ -889,14 +943,14 @@ mkDataCon :: Name
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universals.
-> [TyCoVar] -- ^ Existentials.
- -> [TyVarBinder] -- ^ User-written 'TyVarBinder's.
- -- These must be Inferred/Specified.
- -- See @Note [TyVarBinders in DataCons]@
- -> [EqSpec] -- ^ GADT equalities
+ -> [InvisTVBinder] -- ^ User-written 'TyVarBinder's.
+ -- These must be Inferred/Specified.
+ -- See @Note [TyVarBinders in DataCons]@
+ -> [EqSpec] -- ^ GADT equalities
-> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper
- -> [KnotTied Type] -- ^ Original argument types
+ -> [KnotTied (Scaled Type)] -- ^ Original argument types
-> KnotTied Type -- ^ Original result type
- -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo'
+ -> RuntimeRepInfo -- ^ See comments on 'GHC.Core.TyCon.RuntimeRepInfo'
-> KnotTied TyCon -- ^ Representation type constructor
-> ConTag -- ^ Constructor tag
-> ThetaType -- ^ The "stupid theta", context of the data
@@ -952,41 +1006,38 @@ mkDataCon name declared_infix prom_info
rep_ty =
case rep of
-- If the DataCon has no wrapper, then the worker's type *is* the
- -- user-facing type, so we can simply use dataConUserType.
- NoDataConRep -> dataConUserType con
+ -- user-facing type, so we can simply use dataConWrapperType.
+ NoDataConRep -> dataConWrapperType con
-- If the DataCon has a wrapper, then the worker's type is never seen
-- by the user. The visibilities we pick do not matter here.
- DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $
- mkFunTys rep_arg_tys $
+ DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $
+ mkVisFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
- -- See Note [Promoted data constructors] in TyCon
- prom_tv_bndrs = [ mkNamedTyConBinder vis tv
- | Bndr tv vis <- user_tvbs ]
-
- prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys)
- prom_res_kind = orig_res_ty
- promoted = mkPromotedDataCon con name prom_info
- (prom_tv_bndrs ++ prom_arg_bndrs)
- prom_res_kind roles rep_info
+ -- See Note [Promoted data constructors] in GHC.Core.TyCon
+ prom_tv_bndrs = [ mkNamedTyConBinder (Invisible spec) tv
+ | Bndr tv spec <- user_tvbs ]
+
+ fresh_names = freshNames (map getName user_tvbs)
+ -- fresh_names: make sure that the "anonymous" tyvars don't
+ -- clash in name or unique with the universal/existential ones.
+ -- Tiresome! And unnecessary because these tyvars are never looked at
+ prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t)
+ {- Invisible -} | (n,t) <- fresh_names `zip` theta ]
+ prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t)
+ {- Visible -} | (n,t) <- dropList theta fresh_names `zip` map scaledThing orig_arg_tys ]
+ prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs
+ prom_res_kind = orig_res_ty
+ promoted = mkPromotedDataCon con name prom_info prom_bndrs
+ prom_res_kind roles rep_info
roles = map (\tv -> if isTyVar tv then Nominal else Phantom)
(univ_tvs ++ ex_tvs)
- ++ map (const Representational) orig_arg_tys
-
-mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder]
--- Make sure that the "anonymous" tyvars don't clash in
--- name or unique with the universal/existential ones.
--- Tiresome! And unnecessary because these tyvars are never looked at
-mkCleanAnonTyConBinders tc_bndrs tys
- = [ mkAnonTyConBinder (mkTyVar name ty)
- | (name, ty) <- fresh_names `zip` tys ]
- where
- fresh_names = freshNames (map getName (binderVars tc_bndrs))
+ ++ map (const Representational) (theta ++ map scaledThing orig_arg_tys)
freshNames :: [Name] -> [Name]
--- Make names whose Uniques and OccNames differ from
--- those in the 'avoid' list
+-- Make an infinite list of Names whose Uniques and OccNames
+-- differ from those in the 'avoid' list
freshNames avoids
= [ mkSystemName uniq occ
| n <- [0..]
@@ -1055,9 +1106,9 @@ dataConUserTyVars :: DataCon -> [TyVar]
dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs
-- See Note [DataCon user type variable binders]
--- | 'TyCoVarBinder's for the type variables of the constructor, in the order the
+-- | 'InvisTVBinder's for the type variables of the constructor, in the order the
-- user wrote them
-dataConUserTyVarBinders :: DataCon -> [TyVarBinder]
+dataConUserTyVarBinders :: DataCon -> [InvisTVBinder]
dataConUserTyVarBinders = dcUserTyVarBinders
-- | Equalities derived from the result type of the data constructor, as written
@@ -1159,7 +1210,7 @@ dataConFieldType con label = case dataConFieldType_maybe con label of
dataConFieldType_maybe :: DataCon -> FieldLabelString
-> Maybe (FieldLabel, Type)
dataConFieldType_maybe con label
- = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con)
+ = find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con))
-- | Strictness/unpack annotations, from user; or, for imported
-- DataCons, from the interface file
@@ -1207,22 +1258,6 @@ dataConBoxer :: DataCon -> Maybe DataConBoxer
dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer
dataConBoxer _ = Nothing
--- | The \"signature\" of the 'DataCon' returns, in order:
---
--- 1) The result of 'dataConUnivAndExTyCoVars',
---
--- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary,
--- implicit parameter - whatever), including dependent GADT equalities.
--- Dependent GADT equalities are *also* listed in return value (1), so be
--- careful!
---
--- 3) The type arguments to the constructor
---
--- 4) The /original/ result type of the 'DataCon'
-dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type)
-dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
- = (dataConUnivAndExTyCoVars con, dataConTheta con, arg_tys, res_ty)
-
dataConInstSig
:: DataCon
-> [Type] -- Instantiate the *universal* tyvars with these types
@@ -1239,7 +1274,7 @@ dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs
univ_tys
= ( ex_tvs'
, substTheta subst (dataConTheta con)
- , substTys subst arg_tys)
+ , substTys subst (map scaledThing arg_tys))
where
univ_subst = zipTvSubst univ_tvs univ_tys
(subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs
@@ -1259,11 +1294,12 @@ dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs
-- equalities
--
-- 5) The original argument types to the 'DataCon' (i.e. before
--- any change of the representation of the type)
+-- any change of the representation of the type) with linearity
+-- annotations
--
-- 6) The original result type of the 'DataCon'
dataConFullSig :: DataCon
- -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type)
+ -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type)
dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs,
dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
@@ -1278,7 +1314,41 @@ dataConOrigResTy dc = dcOrigResTy dc
dataConStupidTheta :: DataCon -> ThetaType
dataConStupidTheta dc = dcStupidTheta dc
-dataConUserType :: DataCon -> Type
+{-
+Note [Displaying linear fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A constructor with a linear field can be written either as
+MkT :: a #-> T a (with -XLinearTypes)
+or
+MkT :: a -> T a (with -XNoLinearTypes)
+
+There are two different methods to retrieve a type of a datacon.
+They differ in how linear fields are handled.
+
+1. dataConWrapperType:
+The type of the wrapper in Core.
+For example, dataConWrapperType for Maybe is a #-> Just a.
+
+2. dataConNonlinearType:
+The type of the constructor, with linear arrows replaced by unrestricted ones.
+Used when we don't want to introduce linear types to user (in holes
+and in types in hie used by haddock).
+
+3. dataConDisplayType (take a boolean indicating if -XLinearTypes is enabled):
+The type we'd like to show in error messages, :info and -ddump-types.
+Ideally, it should reflect the type written by the user;
+the function returns a type with arrows that would be required
+to write this constructor under the current setting of -XLinearTypes.
+In principle, this type can be different from the user's source code
+when the value of -XLinearTypes has changed, but we don't
+expect this to cause much trouble.
+
+Due to internal plumbing in checkValidDataCon, we can't just return a Doc.
+The multiplicity of arrows returned by dataConDisplayType and
+dataConDisplayType is used only for pretty-printing.
+-}
+
+dataConWrapperType :: DataCon -> Type
-- ^ The user-declared type of the data constructor
-- in the nice-to-read form:
--
@@ -1293,14 +1363,30 @@ dataConUserType :: DataCon -> Type
--
-- NB: If the constructor is part of a data instance, the result type
-- mentions the family tycon, not the internal one.
-dataConUserType (MkData { dcUserTyVarBinders = user_tvbs,
- dcOtherTheta = theta, dcOrigArgTys = arg_tys,
- dcOrigResTy = res_ty })
- = mkForAllTys user_tvbs $
- mkFunTys theta $
- mkFunTys arg_tys $
+dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs,
+ dcOtherTheta = theta, dcOrigArgTys = arg_tys,
+ dcOrigResTy = res_ty })
+ = mkInvisForAllTys user_tvbs $
+ mkInvisFunTysMany theta $
+ mkVisFunTys arg_tys $
res_ty
+dataConNonlinearType :: DataCon -> Type
+dataConNonlinearType (MkData { dcUserTyVarBinders = user_tvbs,
+ dcOtherTheta = theta, dcOrigArgTys = arg_tys,
+ dcOrigResTy = res_ty })
+ = let arg_tys' = map (\(Scaled w t) -> Scaled (case w of One -> Many; _ -> w) t) arg_tys
+ in mkInvisForAllTys user_tvbs $
+ mkInvisFunTysMany theta $
+ mkVisFunTys arg_tys' $
+ res_ty
+
+dataConDisplayType :: Bool -> DataCon -> Type
+dataConDisplayType show_linear_types dc
+ = if show_linear_types
+ then dataConWrapperType dc
+ else dataConNonlinearType dc
+
-- | Finds the instantiated types of the arguments required to construct a
-- 'DataCon' representation
-- NB: these INCLUDE any dictionary args
@@ -1310,13 +1396,13 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality
-- However, it can have a dcTheta (notably it can be a
-- class dictionary, with superclasses)
-> [Type] -- ^ Instantiated at these types
- -> [Type]
+ -> [Scaled Type]
dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,
dcExTyCoVars = ex_tvs}) inst_tys
= ASSERT2( univ_tvs `equalLength` inst_tys
, text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
ASSERT2( null ex_tvs, ppr dc )
- map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc)
+ map (mapScaledType (substTyWith univ_tvs inst_tys)) (dataConRepArgTys dc)
-- | Returns just the instantiated /value/ argument types of a 'DataCon',
-- (excluding dictionary args)
@@ -1324,43 +1410,55 @@ dataConInstOrigArgTys
:: DataCon -- Works for any DataCon
-> [Type] -- Includes existential tyvar args, but NOT
-- equality constraints or dicts
- -> [Type]
+ -> [Scaled Type]
-- For vanilla datacons, it's all quite straightforward
--- But for the call in MatchCon, we really do want just the value args
+-- But for the call in GHC.HsToCore.Match.Constructor, we really do want just
+-- the value args
dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
dcUnivTyVars = univ_tvs,
dcExTyCoVars = ex_tvs}) inst_tys
= ASSERT2( tyvars `equalLength` inst_tys
, text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
- map (substTy subst) arg_tys
+ substScaledTys subst arg_tys
where
tyvars = univ_tvs ++ ex_tvs
subst = zipTCvSubst tyvars inst_tys
-- | Returns the argument types of the wrapper, excluding all dictionary arguments
-- and without substituting for any type variables
-dataConOrigArgTys :: DataCon -> [Type]
+dataConOrigArgTys :: DataCon -> [Scaled Type]
dataConOrigArgTys dc = dcOrigArgTys dc
+-- | Returns constraints in the wrapper type, other than those in the dataConEqSpec
+dataConOtherTheta :: DataCon -> ThetaType
+dataConOtherTheta dc = dcOtherTheta dc
+
-- | Returns the arg types of the worker, including *all* non-dependent
-- evidence, after any flattening has been done and without substituting for
-- any type variables
-dataConRepArgTys :: DataCon -> [Type]
+dataConRepArgTys :: DataCon -> [Scaled Type]
dataConRepArgTys (MkData { dcRep = rep
, dcEqSpec = eq_spec
, dcOtherTheta = theta
, dcOrigArgTys = orig_arg_tys })
= case rep of
- NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys
+ NoDataConRep -> ASSERT( null eq_spec ) (map unrestricted theta) ++ orig_arg_tys
DCR { dcr_arg_tys = arg_tys } -> arg_tys
-- | The string @package:module.name@ identifying a constructor, which is attached
-- to its info table and used by the GHCi debugger and the heap profiler
-dataConIdentity :: DataCon -> [Word8]
+dataConIdentity :: DataCon -> ByteString
-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.
-dataConIdentity dc = bytesFS (unitIdFS (moduleUnitId mod)) ++
- fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++
- fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name))
+dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat
+ [ BSB.shortByteString $ fastStringToShortByteString $
+ unitFS $ moduleUnit mod
+ , BSB.int8 $ fromIntegral (ord ':')
+ , BSB.shortByteString $ fastStringToShortByteString $
+ moduleNameFS $ moduleName mod
+ , BSB.int8 $ fromIntegral (ord '.')
+ , BSB.shortByteString $ fastStringToShortByteString $
+ occNameFS $ nameOccName name
+ ]
where name = dataConName dc
mod = ASSERT( isExternalName name ) nameModule name
@@ -1392,6 +1490,10 @@ dataConCannotMatch :: [Type] -> DataCon -> Bool
-- scrutinee of type (T tys)
-- where T is the dcRepTyCon for the data con
dataConCannotMatch tys con
+ -- See (U6) in Note [Implementing unsafeCoerce]
+ -- in base:Unsafe.Coerce
+ | dataConName con == unsafeReflDataConName
+ = False
| null inst_theta = False -- Common
| all isTyVarTy tys = False -- Also common
| otherwise = typesCantMatch (concatMap predEqs inst_theta)
@@ -1400,10 +1502,13 @@ dataConCannotMatch tys con
-- TODO: could gather equalities from superclasses too
predEqs pred = case classifyPredType pred of
- EqPred NomEq ty1 ty2 -> [(ty1, ty2)]
- ClassPred eq [_, ty1, ty2]
- | eq `hasKey` eqTyConKey -> [(ty1, ty2)]
- _ -> []
+ EqPred NomEq ty1 ty2 -> [(ty1, ty2)]
+ ClassPred eq args
+ | eq `hasKey` eqTyConKey
+ , [_, ty1, ty2] <- args -> [(ty1, ty2)]
+ | eq `hasKey` heqTyConKey
+ , [_, _, ty1, ty2] <- args -> [(ty1, ty2)]
+ _ -> []
-- | Were the type variables of the data con written in a different order
-- than the regular order (universal tyvars followed by existential tyvars)?
@@ -1459,7 +1564,7 @@ splitDataProductType_maybe
-> Maybe (TyCon, -- The type constructor
[Type], -- Type args of the tycon
DataCon, -- The data constructor
- [Type]) -- Its /representation/ arg types
+ [Scaled Type]) -- Its /representation/ arg types
-- Rejecting existentials is conservative. Maybe some things
-- could be made to work with them, but I'm not going to sweat
@@ -1471,39 +1576,3 @@ splitDataProductType_maybe ty
= Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
| otherwise
= Nothing
-
-{-
-************************************************************************
-* *
- Building an algebraic data type
-* *
-************************************************************************
-
-buildAlgTyCon is here because it is called from TysWiredIn, which can
-depend on this module, but not on BuildTyCl.
--}
-
-buildAlgTyCon :: Name
- -> [TyVar] -- ^ Kind variables and type variables
- -> [Role]
- -> Maybe CType
- -> ThetaType -- ^ Stupid theta
- -> AlgTyConRhs
- -> Bool -- ^ True <=> was declared in GADT syntax
- -> AlgTyConFlav
- -> TyCon
-
-buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
- gadt_syn parent
- = mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta
- rhs parent gadt_syn
- where
- binders = mkTyConBindersPreferAnon ktvs emptyVarSet
-
-buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind
- -> [Role] -> KnotTied Type -> TyCon
-buildSynTyCon name binders res_kind roles rhs
- = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free
- where
- is_tau = isTauTy rhs
- is_fam_free = isFamFreeTy rhs
diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot
new file mode 100644
index 0000000..831392e
--- /dev/null
+++ b/compiler/GHC/Core/DataCon.hs-boot
@@ -0,0 +1,34 @@
+module GHC.Core.DataCon where
+
+import GHC.Prelude
+import GHC.Types.Var( TyVar, TyCoVar, InvisTVBinder )
+import GHC.Types.Name( Name, NamedThing )
+import {-# SOURCE #-} GHC.Core.TyCon( TyCon )
+import GHC.Types.FieldLabel ( FieldLabel )
+import GHC.Types.Unique ( Uniquable )
+import GHC.Utils.Outputable ( Outputable, OutputableBndr )
+import GHC.Types.Basic (Arity)
+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType, Scaled )
+
+data DataCon
+data DataConRep
+data EqSpec
+
+dataConName :: DataCon -> Name
+dataConTyCon :: DataCon -> TyCon
+dataConExTyCoVars :: DataCon -> [TyCoVar]
+dataConUserTyVars :: DataCon -> [TyVar]
+dataConUserTyVarBinders :: DataCon -> [InvisTVBinder]
+dataConSourceArity :: DataCon -> Arity
+dataConFieldLabels :: DataCon -> [FieldLabel]
+dataConInstOrigArgTys :: DataCon -> [Type] -> [Scaled Type]
+dataConStupidTheta :: DataCon -> ThetaType
+dataConFullSig :: DataCon
+ -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type)
+isUnboxedSumCon :: DataCon -> Bool
+
+instance Eq DataCon
+instance Uniquable DataCon
+instance NamedThing DataCon
+instance Outputable DataCon
+instance OutputableBndr DataCon
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/GHC/Core/FVs.hs
index b579215..952ce1c 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/GHC/Core/FVs.hs
@@ -8,7 +8,7 @@ Taken quite directly from the Peyton Jones/Lester paper.
{-# LANGUAGE CPP #-}
-- | A module concerned with finding the free variables of an expression.
-module CoreFVs (
+module GHC.Core.FVs (
-- * Free variables of expressions and binding groups
exprFreeVars,
exprFreeVarsDSet,
@@ -35,7 +35,7 @@ module CoreFVs (
idFVs,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
- rulesFreeVarsDSet,
+ rulesFreeVarsDSet, mkRuleInfo,
ruleLhsFreeIds, ruleLhsFreeIdsList,
expr_fvs,
@@ -59,28 +59,30 @@ module CoreFVs (
#include "GhclibHsVersions.h"
-import GhcPrelude
-
-import CoreSyn
-import Id
-import IdInfo
-import NameSet
-import UniqSet
-import Unique (Uniquable (..))
-import Name
-import VarSet
-import Var
-import Type
-import TyCoRep
-import TyCon
-import CoAxiom
-import FamInstEnv
-import TysPrim( funTyConName )
-import Maybes( orElse )
-import Util
-import BasicTypes( Activation )
-import Outputable
-import FV
+import GHC.Prelude
+
+import GHC.Core
+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
+import GHC.Core.TyCon
+import GHC.Core.Coercion.Axiom
+import GHC.Core.FamInstEnv
+import GHC.Builtin.Types( unrestrictedFunTyConName )
+import GHC.Builtin.Types.Prim( funTyConName )
+import GHC.Data.Maybe( orElse )
+import GHC.Utils.Misc
+import GHC.Types.Basic( Activation )
+import GHC.Utils.Outputable
+import GHC.Utils.FV as FV
{-
************************************************************************
@@ -104,7 +106,7 @@ exprFreeVars :: CoreExpr -> VarSet
exprFreeVars = fvVarSet . exprFVs
-- | Find all locally-defined free Ids or type variables in an expression
--- returning a composable FV computation. See Note [FV naming conventions] in FV
+-- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV"
-- for why export it.
exprFVs :: CoreExpr -> FV
exprFVs = filterFV isLocalVar . expr_fvs
@@ -149,7 +151,7 @@ exprsFreeVars :: [CoreExpr] -> VarSet
exprsFreeVars = fvVarSet . exprsFVs
-- | Find all locally-defined free Ids or type variables in several expressions
--- returning a composable FV computation. See Note [FV naming conventions] in FV
+-- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV"
-- for why export it.
exprsFVs :: [CoreExpr] -> FV
exprsFVs exprs = mapUnionFV exprFVs exprs
@@ -209,7 +211,7 @@ exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interestin
exprsSomeFreeVarsDSet fv_cand e =
fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e
--- Comment about obselete code
+-- Comment about obsolete code
-- We used to gather the free variables the RULES at a variable occurrence
-- with the following cryptic comment:
-- "At a variable occurrence, add in any free variables of its rule rhss
@@ -346,14 +348,20 @@ orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConCl
orphNamesOfType :: Type -> NameSet
orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty'
- -- Look through type synonyms (Trac #4912)
+ -- Look through type synonyms (#4912)
orphNamesOfType (TyVarTy _) = emptyNameSet
orphNamesOfType (LitTy {}) = emptyNameSet
-orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
+orphNamesOfType (TyConApp tycon tys) = func
+ `unionNameSet` orphNamesOfTyCon tycon
`unionNameSet` orphNamesOfTypes tys
+ where func = case tys of
+ arg:_ | tycon == funTyCon -> orph_names_of_fun_ty_con arg
+ _ -> emptyNameSet
orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr)
`unionNameSet` orphNamesOfType res
-orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535
+orphNamesOfType (FunTy _ w arg res) = orph_names_of_fun_ty_con w
+ `unionNameSet` unitNameSet funTyConName
+ `unionNameSet` orphNamesOfType w
`unionNameSet` orphNamesOfType arg
`unionNameSet` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
@@ -377,7 +385,7 @@ orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` or
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ kind_co co)
= orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co
-orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
+orphNamesOfCo (FunCo _ co_mult co1 co2) = orphNamesOfCo co_mult `unionNameSet` orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (CoVarCo _) = emptyNameSet
orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2
@@ -392,7 +400,6 @@ orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs
orphNamesOfCo (HoleCo _) = emptyNameSet
orphNamesOfProv :: UnivCoProvenance -> NameSet
-orphNamesOfProv UnsafeCoerceProv = emptyNameSet
orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
orphNamesOfProv (PluginProv _) = emptyNameSet
@@ -428,6 +435,12 @@ orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
orphNamesOfFamInst :: FamInst -> NameSet
orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)
+-- Detect FUN 'Many as an application of (->), so that :i (->) works as expected
+-- (see #8535) Issue #16475 describes a more robust solution
+orph_names_of_fun_ty_con :: Mult -> NameSet
+orph_names_of_fun_ty_con Many = unitNameSet unrestrictedFunTyConName
+orph_names_of_fun_ty_con _ = emptyNameSet
+
{-
************************************************************************
* *
@@ -469,6 +482,11 @@ rulesFVs = mapUnionFV ruleFVs
rulesFreeVarsDSet :: [CoreRule] -> DVarSet
rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules
+-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
+-- for putting into an 'IdInfo'
+mkRuleInfo :: [CoreRule] -> RuleInfo
+mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)
+
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
-- Just the variables free on the *rhs* of a rule
idRuleRhsVars is_active id
@@ -477,7 +495,7 @@ idRuleRhsVars is_active id
get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
, ru_rhs = rhs, ru_act = act })
| is_active act
- -- See Note [Finding rule RHS free vars] in OccAnal.hs
+ -- See Note [Finding rule RHS free vars] in "GHC.Core.Opt.OccurAnal"
= delOneFromUniqSet_Directly fvs (getUnique fn)
-- Note [Rule free var hack]
where
@@ -495,7 +513,7 @@ ruleLhsFreeIds = fvVarSet . ruleLhsFVIds
ruleLhsFreeIdsList :: CoreRule -> [Var]
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
--- and returns them as a determinisitcally ordered list
+-- and returns them as a deterministically ordered list
ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds
ruleLhsFVIds :: CoreRule -> FV
@@ -711,9 +729,10 @@ freeVars = go
where
go :: CoreExpr -> CoreExprWithFVs
go (Var v)
- | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, AnnVar v)
+ | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs `unionFVs` mult_vars, AnnVar v)
| otherwise = (emptyDVarSet, AnnVar v)
where
+ mult_vars = tyCoVarsOfTypeDSet (varMult v)
ty_fvs = dVarTypeTyCoVars v
-- See Note [The FVAnn invariant]
diff --git a/compiler/types/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index d3e287f..8aac4c2 100644
--- a/compiler/types/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -2,9 +2,12 @@
--
-- FamInstEnv: Type checked family instance declarations
-{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections #-}
+{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections,
+ DeriveFunctor #-}
-module FamInstEnv (
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+module GHC.Core.FamInstEnv (
FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,
famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,
pprFamInst, pprFamInsts,
@@ -29,8 +32,8 @@ module FamInstEnv (
-- Normalisation
topNormaliseType, topNormaliseType_maybe,
- normaliseType, normaliseTcApp, normaliseTcArgs,
- reduceTyFamApp_maybe,
+ normaliseType, normaliseTcApp,
+ topReduceTyFamApp_maybe, reduceTyFamApp_maybe,
-- Flattening
flattenTys
@@ -38,28 +41,26 @@ module FamInstEnv (
#include "GhclibHsVersions.h"
-import GhcPrelude
-
-import Unify
-import Type
-import TyCoRep
-import TyCon
-import Coercion
-import CoAxiom
-import VarSet
-import VarEnv
-import Name
-import PrelNames ( eqPrimTyConKey )
-import UniqDFM
-import Outputable
-import Maybes
-import CoreMap
-import Unique
-import Util
-import Var
-import Pair
-import SrcLoc
-import FastString
+import GHC.Prelude
+
+import GHC.Core.Unify
+import GHC.Core.Type as Type
+import GHC.Core.TyCo.Rep
+import GHC.Core.TyCon
+import GHC.Core.Coercion
+import GHC.Core.Coercion.Axiom
+import GHC.Types.Var.Set
+import GHC.Types.Var.Env
+import GHC.Types.Name
+import GHC.Types.Unique.DFM
+import GHC.Utils.Outputable
+import GHC.Data.Maybe
+import GHC.Core.Map
+import GHC.Types.Unique
+import GHC.Utils.Misc
+import GHC.Types.Var
+import GHC.Types.SrcLoc
+import GHC.Data.FastString
import Control.Monad
import Data.List( mapAccumL )
import Data.Array( Array, assocs )
@@ -105,7 +106,7 @@ data FamInst -- See Note [FamInsts and CoAxioms]
, fi_fam :: Name -- Family name
-- Used for "rough matching"; same idea as for class instances
- -- See Note [Rough-match field] in InstEnv
+ -- See Note [Rough-match field] in GHC.Core.InstEnv
, fi_tcs :: [Maybe Name] -- Top of type args
-- INVARIANT: fi_tcs = roughMatchTcs fi_tys
@@ -113,10 +114,11 @@ data FamInst -- See Note [FamInsts and CoAxioms]
, fi_tvs :: [TyVar] -- Template tyvars for full match
, fi_cvs :: [CoVar] -- Template covars for full match
-- Like ClsInsts, these variables are always fresh
- -- See Note [Template tyvars are fresh] in InstEnv
+ -- See Note [Template tyvars are fresh] in GHC.Core.InstEnv
, fi_tys :: [Type] -- The LHS type patterns
-- May be eta-reduced; see Note [Eta reduction for data families]
+ -- in GHC.Core.Coercion.Axiom
, fi_rhs :: Type -- the RHS, with its freshened vars
}
@@ -131,7 +133,8 @@ Note [Arity of data families]
Data family instances might legitimately be over- or under-saturated.
Under-saturation has two potential causes:
- U1) Eta reduction. See Note [Eta reduction for data families].
+ U1) Eta reduction. See Note [Eta reduction for data families] in
+ GHC.Core.Coercion.Axiom.
U2) When the user has specified a return kind instead of written out patterns.
Example:
@@ -159,8 +162,8 @@ Over-saturation is also possible:
However, we require that any over-saturation is eta-reducible. That is,
we require that any extra patterns be bare unrepeated type variables;
- see Note [Eta reduction for data families]. Accordingly, the FamInst
- is never over-saturated.
+ see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.
+ Accordingly, the FamInst is never over-saturated.
Why can we allow such flexibility for data families but not for type families?
Because data families can be decomposed -- that is, they are generative and
@@ -219,7 +222,7 @@ instance Outputable FamInst where
pprFamInst :: FamInst -> SDoc
-- Prints the FamInst as a family instance declaration
-- NB: This function, FamInstEnv.pprFamInst, is used only for internal,
--- debug printing. See PprTyThing.pprFamInst for printing for the user
+-- debug printing. See GHC.Core.Ppr.TyThing.pprFamInst for printing for the user
pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax
, fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs })
= hang (ppr_tc_sort <+> text "instance"
@@ -246,7 +249,7 @@ pprFamInsts finsts = vcat (map pprFamInst finsts)
Note [Lazy axiom match]
~~~~~~~~~~~~~~~~~~~~~~~
It is Vitally Important that mkImportedFamInst is *lazy* in its axiom
-parameter. The axiom is loaded lazily, via a forkM, in TcIface. Sometime
+parameter. The axiom is loaded lazily, via a forkM, in GHC.IfaceToCore. Sometime
later, mkImportedFamInst is called using that axiom. However, the axiom
may itself depend on entities which are not yet loaded as of the time
of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the
@@ -313,7 +316,7 @@ Nevertheless it is still useful to have data families in the FamInstEnv:
- For finding overlaps and conflicts
- For finding the representation type...see FamInstEnv.topNormaliseType
- and its call site in Simplify
+ and its call site in GHC.Core.Opt.Simplify
- In standalone deriving instance Eq (T [Int]) we need to find the
representation type for T [Int]
@@ -334,7 +337,7 @@ Then we get a data type for each instance, and an axiom:
axiom ax8 a :: T Bool [a] ~ TBoolList a
These two axioms for T, one with one pattern, one with two;
-see Note [Eta reduction for data families]
+see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
Note [FamInstEnv determinism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -349,7 +352,10 @@ UniqFM and UniqDFM.
See Note [Deterministic UniqFM].
-}
-type FamInstEnv = UniqDFM FamilyInstEnv -- Maps a family to its instances
+-- Internally we sometimes index by Name instead of TyCon despite
+-- of what the type says. This is safe since
+-- getUnique (tyCon) == getUniqe (tcName tyCon)
+type FamInstEnv = UniqDFM TyCon FamilyInstEnv -- Maps a family to its instances
-- See Note [FamInstEnv]
-- See Note [FamInstEnv determinism]
@@ -362,6 +368,14 @@ newtype FamilyInstEnv
instance Outputable FamilyInstEnv where
ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs)
+-- | Index a FamInstEnv by the tyCons name.
+toNameInstEnv :: FamInstEnv -> UniqDFM Name FamilyInstEnv
+toNameInstEnv = unsafeCastUDFMKey
+
+-- | Create a FamInstEnv from Name indices.
+fromNameInstEnv :: UniqDFM Name FamilyInstEnv -> FamInstEnv
+fromNameInstEnv = unsafeCastUDFMKey
+
-- INVARIANTS:
-- * The fs_tvs are distinct in each FamInst
-- of a range value of the map (so we can safely unify them)
@@ -377,8 +391,8 @@ famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts]
-- See Note [FamInstEnv determinism]
famInstEnvSize :: FamInstEnv -> Int
-famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0
- -- It's OK to use nonDetFoldUDFM here since we're just computing the
+famInstEnvSize = nonDetStrictFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0
+ -- It's OK to use nonDetStrictFoldUDFM here since we're just computing the
-- size.
familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
@@ -395,7 +409,7 @@ extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis
extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
extendFamInstEnv inst_env
ins_item@(FamInst {fi_fam = cls_nm})
- = addToUDFM_C add inst_env cls_nm (FamIE [ins_item])
+ = fromNameInstEnv $ addToUDFM_C add (toNameInstEnv inst_env) cls_nm (FamIE [ins_item])
where
add (FamIE items) _ = FamIE (ins_item:items)
@@ -478,7 +492,7 @@ irrelevant (clause 1 of compatible) or benign (clause 2 of compatible).
Note [Compatibility of eta-reduced axioms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In newtype instances of data families we eta-reduce the axioms,
-See Note [Eta reduction for data families] in FamInstEnv. This means that
+See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. This means that
we sometimes need to test compatibility of two axioms that were eta-reduced to
different degrees, e.g.:
@@ -534,12 +548,12 @@ injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch
injectiveBranches injectivity
ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })
ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })
- -- See Note [Verifying injectivity annotation]. This function implements first
- -- check described there.
+ -- See Note [Verifying injectivity annotation], case 1.
= let getInjArgs = filterByList injectivity
in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification
- Nothing -> InjectivityAccepted -- RHS are different, so equations are
- -- injective.
+ Nothing -> InjectivityAccepted
+ -- RHS are different, so equations are injective.
+ -- This is case 1A from Note [Verifying injectivity annotation]
Just subst -> -- RHS unify under a substitution
let lhs1Subst = Type.substTys subst (getInjArgs lhs1)
lhs2Subst = Type.substTys subst (getInjArgs lhs2)
@@ -548,16 +562,18 @@ injectiveBranches injectivity
-- equal under that substitution then this pair of equations violates
-- injectivity annotation, but for closed type families it still might
-- be the case that one LHS after substitution is unreachable.
- in if eqTypes lhs1Subst lhs2Subst
+ in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note.
then InjectivityAccepted
else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1
, cab_rhs = Type.substTy subst rhs1 })
( ax2 { cab_lhs = Type.substTys subst lhs2
, cab_rhs = Type.substTy subst rhs2 })
+ -- payload of InjectivityUnified used only for check 1B2, only
+ -- for closed type families
-- takes a CoAxiom with unknown branch incompatibilities and computes
-- the compatibilities
--- See Note [Storing compatibility] in CoAxiom
+-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom
computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch]
computeAxiomIncomps branches
= snd (mapAccumL go [] branches)
@@ -577,7 +593,7 @@ computeAxiomIncomps branches
* *
Constructing axioms
These functions are here because tidyType / tcUnifyTysFG
- are not available in CoAxiom
+ are not available in GHC.Core.Coercion.Axiom
Also computeAxiomIncomps is too sophisticated for CoAxiom
* *
@@ -589,7 +605,7 @@ Like types and classes, we build axioms fully quantified over all
their variables, and tidy them when we build them. For example,
we print out axioms and don't want to print stuff like
F k k a b = ...
-Instead we must tidy those kind variables. See Trac #7524.
+Instead we must tidy those kind variables. See #7524.
We could instead tidy when we print, but that makes it harder to get
things like injectivity errors to come out right. Danger of
@@ -626,7 +642,7 @@ here:
Which is at least legal syntax.
-See also Note [CoAxBranch type variables] in CoAxiom; note that we
+See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom; note that we
are tidying (changing OccNames only), not freshening, in accordance with
that Note.
-}
@@ -654,7 +670,7 @@ mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc
(env2, eta_tvs') = tidyVarBndrs env1 eta_tvs
(env, cvs') = tidyVarBndrs env2 cvs
-- See Note [Tidy axioms when we build them]
- -- See also Note [CoAxBranch type variables] in CoAxiom
+ -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom
init_occ_env = initTidyOccEnv [mkTyVarOcc "_"]
init_tidy_env = mkEmptyTidyEnv init_occ_env
@@ -684,7 +700,7 @@ mkSingleCoAxiom :: Role -> Name
-> [TyVar] -> [TyVar] -> [CoVar]
-> TyCon -> [Type] -> Type
-> CoAxiom Unbranched
--- Make a single-branch CoAxiom, incluidng making the branch itself
+-- Make a single-branch CoAxiom, including making the branch itself
-- Used for both type family (Nominal) and data family (Representational)
-- axioms, hence passing in the Role
mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty
@@ -708,7 +724,7 @@ mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbran
mkNewTypeCoAxiom name tycon tvs roles rhs_ty
= CoAxiom { co_ax_unique = nameUnique name
, co_ax_name = name
- , co_ax_implicit = True -- See Note [Implicit axioms] in TyCon
+ , co_ax_implicit = True -- See Note [Implicit axioms] in GHC.Core.TyCon
, co_ax_role = Representational
, co_ax_tc = tycon
, co_ax_branches = unbranched (branch { cab_incomps = [] }) }
@@ -813,11 +829,11 @@ lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom })
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Injectivity means that the RHS of a type family uniquely determines the LHS (see
-Note [Type inference for type families with injectivity]). User informs about
+Note [Type inference for type families with injectivity]). The user informs us about
injectivity using an injectivity annotation and it is GHC's task to verify that
-that annotation is correct wrt. to type family equations. Whenever we see a new
-equation of a type family we need to make sure that adding this equation to
-already known equations of a type family does not violate injectivity annotation
+this annotation is correct w.r.t. type family equations. Whenever we see a new
+equation of a type family we need to make sure that adding this equation to the
+already known equations of a type family does not violate the injectivity annotation
supplied by the user (see Note [Injectivity annotation]). Of course if the type
family has no injectivity annotation then no check is required. But if a type
family has injectivity annotation we need to make sure that the following
@@ -826,7 +842,7 @@ conditions hold:
1. For each pair of *different* equations of a type family, one of the following
conditions holds:
- A: RHSs are different.
+ A: RHSs are different. (Check done in GHC.Core.FamInstEnv.injectiveBranches)
B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution
then it must be possible to unify the LHSs under the same substitution.
@@ -838,7 +854,7 @@ conditions hold:
RHSs of these two equations unify under [ a |-> Int ] substitution.
Under this substitution LHSs are equal therefore these equations don't
- violate injectivity annotation.
+ violate injectivity annotation. (Check done in GHC.Core.FamInstEnv.injectiveBranches)
B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some
substitution then either the LHSs unify under the same substitution or
@@ -855,7 +871,7 @@ conditions hold:
of last equation and check whether it is overlapped by any of previous
equations. Since it is overlapped by the first equation we conclude
that pair of last two equations does not violate injectivity
- annotation.
+ annotation. (Check done in GHC.Tc.Validity.checkValidCoAxiom#gather_conflicts)
A special case of B is when RHSs unify with an empty substitution ie. they
are identical.
@@ -869,7 +885,7 @@ conditions hold:
Note that we only take into account these LHS patterns that were declared
as injective.
-2. If a RHS of a type family equation is a bare type variable then
+2. If an RHS of a type family equation is a bare type variable then
all LHS variables (including implicit kind variables) also have to be bare.
In other words, this has to be a sole equation of that type family and it has
to cover all possible patterns. So for example this definition will be
@@ -880,17 +896,26 @@ conditions hold:
If it were accepted we could call `W1 [W1 Int]`, which would reduce to
`W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`,
- which is bogus.
+ which is bogus. Checked FamInst.bareTvInRHSViolated.
-3. If a RHS of a type family equation is a type family application then the type
- family is rejected as not injective.
+3. If the RHS of a type family equation is a type family application then the type
+ family is rejected as not injective. This is checked by FamInst.isTFHeaded.
-4. If a LHS type variable that is declared as injective is not mentioned on
+4. If a LHS type variable that is declared as injective is not mentioned in an
injective position in the RHS then the type family is rejected as not
injective. "Injective position" means either an argument to a type
constructor or argument to a type family on injective position.
+ There are subtleties here. See Note [Coverage condition for injective type families]
+ in GHC.Tc.Instance.Family.
-See also Note [Injective type families] in TyCon
+Check (1) must be done for all family instances (transitively) imported. Other
+checks (2-4) should be done just for locally written equations, as they are checks
+involving just a single equation, not about interactions. Doing the other checks for
+imported equations led to #17405, as the behavior of check (4) depends on
+-XUndecidableInstances (see Note [Coverage condition for injective type families] in
+FamInst), which may vary between modules.
+
+See also Note [Injective type families] in GHC.Core.TyCon
-}
@@ -1042,7 +1067,7 @@ We handle data families and type families separately here:
* For data family instances, though, we need to re-split for each
instance, because the breakdown might be different for each
instance. Why? Because of eta reduction; see
- Note [Eta reduction for data families].
+ Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.
-}
-- checks if one LHS is dominated by a list of other branches
@@ -1081,9 +1106,9 @@ reduceTyFamApp_maybe :: FamInstEnvs
-- but *not* newtypes
-- Works on type-synonym families always; data-families only if
-- the role we seek is representational
--- It does *not* normlise the type arguments first, so this may not
+-- It does *not* normalise the type arguments first, so this may not
-- go as far as you want. If you want normalised type arguments,
--- use normaliseTcArgs first.
+-- use topReduceTyFamApp_maybe
--
-- The TyCon can be oversaturated.
-- Works on both open and closed families
@@ -1107,13 +1132,13 @@ reduceTyFamApp_maybe envs role tc tys
-- NB: Allow multiple matches because of compatible overlap
= let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos
- ty = pSnd (coercionKind co)
+ ty = coercionRKind co
in Just (co, ty)
| Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc
, Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys
= let co = mkAxInstCo role ax ind inst_tys inst_cos
- ty = pSnd (coercionKind co)
+ ty = coercionRKind co
in Just (co, ty)
| Just ax <- isBuiltInSynFamTyCon_maybe tc
@@ -1172,7 +1197,7 @@ findBranch branches target_tys
apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure
-- they're flattened! See Note [Flattening].
-- (NB: This "flat" is a different
- -- "flat" than is used in TcFlatten.)
+ -- "flat" than is used in GHC.Tc.Solver.Flatten.)
-> CoAxBranch -- ^ the candidate equation we wish to use
-- Precondition: this matches the target
-> Bool -- ^ True <=> equation can fire
@@ -1206,7 +1231,7 @@ type. However, an ordinary TCvSubst just won't do: when we hit a type variable
whose kind has changed during normalisation, we need both the new type
variable *and* the coercion. We could conjure up a new VarEnv with just this
property, but a usable substitution environment already exists:
-LiftingContexts from the liftCoSubst family of functions, defined in Coercion.
+LiftingContexts from the liftCoSubst family of functions, defined in GHC.Core.Coercion.
A LiftingContext maps a type variable to a coercion and a coercion variable to
a pair of coercions. Let's ignore coercion variables for now. Because the
coercion a type variable maps to contains the destination type (via
@@ -1233,7 +1258,7 @@ That's what the CoercionTy case is doing within normalise_type.
Note [Normalisation and type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to be a bit careful about normalising in the presence of type
-synonyms (Trac #13035). Suppose S is a type synonym, and we have
+synonyms (#13035). Suppose S is a type synonym, and we have
S t1 t2
If S is family-free (on its RHS) we can just normalise t1 and t2 and
reconstruct (S t1' t2'). Expanding S could not reveal any new redexes
@@ -1241,7 +1266,7 @@ because type families are saturated.
But if S has a type family on its RHS we expand /before/ normalising
the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them
-after expansion, and that can lead to /exponential/ behavour; see Trac #13035.
+after expansion, and that can lead to /exponential/ behaviour; see #13035.
Notice, though, that expanding first can in principle duplicate t1,t2,
which might contain redexes. I'm sure you could conjure up an exponential
@@ -1291,10 +1316,9 @@ topNormaliseType_maybe env ty
-- to the normalised type's kind
tyFamStepper :: NormaliseStepper (Coercion, MCoercionN)
tyFamStepper rec_nts tc tys -- Try to step a type/data family
- = let (args_co, ntys, res_co) = normaliseTcArgs env Representational tc tys in
- case reduceTyFamApp_maybe env Representational tc ntys of
- Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co, MCo res_co)
- _ -> NS_Done
+ = case topReduceTyFamApp_maybe env tc tys of
+ Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, MCo res_co)
+ _ -> NS_Done
---------------
normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type)
@@ -1349,18 +1373,23 @@ normalise_tc_app tc tys
final_co = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty
---------------
--- | Normalise arguments to a tycon
-normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances
- -> Role -- ^ desired role of output coercion
- -> TyCon -- ^ tc
- -> [Type] -- ^ tys
- -> (Coercion, [Type], CoercionN)
- -- ^ co :: tc tys ~ tc new_tys
- -- NB: co might not be homogeneous
- -- last coercion :: kind(tc tys) ~ kind(tc new_tys)
-normaliseTcArgs env role tc tys
- = initNormM env role (tyCoVarsOfTypes tys) $
- normalise_tc_args tc tys
+-- | Try to simplify a type-family application, by *one* step
+-- If topReduceTyFamApp_maybe env r F tys = Just (co, rhs, res_co)
+-- then co :: F tys ~R# rhs
+-- res_co :: typeKind(F tys) ~ typeKind(rhs)
+-- Type families and data families; always Representational role
+topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type]
+ -> Maybe (Coercion, Type, Coercion)
+topReduceTyFamApp_maybe envs fam_tc arg_tys
+ | isFamilyTyCon fam_tc -- type families and data families
+ , Just (co, rhs) <- reduceTyFamApp_maybe envs role fam_tc ntys
+ = Just (args_co `mkTransCo` co, rhs, res_co)
+ | otherwise
+ = Nothing
+ where
+ role = Representational
+ (args_co, ntys, res_co) = initNormM envs role (tyCoVarsOfTypes arg_tys) $
+ normalise_tc_args fam_tc arg_tys
normalise_tc_args :: TyCon -> [Type] -- tc tys
-> NormM (Coercion, [Type], CoercionN)
@@ -1396,14 +1425,14 @@ normalise_type ty
go (TyConApp tc tys) = normalise_tc_app tc tys
go ty@(LitTy {}) = do { r <- getRole
; return (mkReflCo r ty, ty) }
-
go (AppTy ty1 ty2) = go_app_tys ty1 [ty2]
- go (FunTy ty1 ty2)
+ go ty@(FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 })
= do { (co1, nty1) <- go ty1
; (co2, nty2) <- go ty2
+ ; (wco, wty) <- withRole Nominal $ go w
; r <- getRole
- ; return (mkFunCo r co1 co2, mkFunTy nty1 nty2) }
+ ; return (mkFunCo r wco co1 co2, ty { ft_mult = wty, ft_arg = nty1, ft_res = nty2 }) }
go (ForAllTy (Bndr tcvar vis) ty)
= do { (lc', tv', h, ki') <- normalise_var_bndr tcvar
; (co, nty) <- withLC lc' $ normalise_type ty
@@ -1428,7 +1457,7 @@ normalise_type ty
go_app_tys :: Type -- function
-> [Type] -- args
-> NormM (Coercion, Type)
- -- cf. TcFlatten.flatten_app_ty_args
+ -- cf. GHC.Tc.Solver.Flatten.flatten_app_ty_args
go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys)
go_app_tys fun_ty arg_tys
= do { (fun_co, nfun) <- go fun_ty
@@ -1459,7 +1488,7 @@ normalise_args :: Kind -- of the function
-- and the res_co :: kind(f orig_args) ~ kind(f xis)
-- NB: The xis might *not* have the same kinds as the input types,
-- but the resulting application *will* be well-kinded
--- cf. TcFlatten.flatten_args_slow
+-- cf. GHC.Tc.Solver.Flatten.flatten_args_slow
normalise_args fun_ki roles args
= do { normed_args <- zipWithM normalise1 roles args
; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args
@@ -1482,7 +1511,7 @@ normalise_tyvar tv
do { lc <- getLC
; r <- getRole
; return $ case liftCoSubstTyVar lc r tv of
- Just co -> (co, pSnd $ coercionKind co)
+ Just co -> (co, coercionRKind co)
Nothing -> (mkReflCo r ty, ty) }
where ty = mkTyVarTy tv
@@ -1498,6 +1527,7 @@ normalise_var_bndr tcvar
-- a 'LiftingContext', and a 'Role'.
newtype NormM a = NormM { runNormM ::
FamInstEnvs -> LiftingContext -> Role -> a }
+ deriving (Functor)
initNormM :: FamInstEnvs -> Role
-> TyCoVarSet -- the in-scope variables
@@ -1528,8 +1558,6 @@ instance Monad NormM where
let a = runNormM ma env lc r in
runNormM (fmb a) env lc r
-instance Functor NormM where
- fmap = liftM
instance Applicative NormM where
pure x = NormM $ \ _ _ _ -> x
(<*>) = ap
@@ -1571,43 +1599,155 @@ can see that (F x x) can reduce to Double. So, it had better be the
case that (F blah blah) can reduce to Double, no matter what (blah)
is! Flattening as done below ensures this.
+The algorithm works by building up a TypeMap TyVar, mapping
+type family applications to fresh variables. This mapping must
+be threaded through all the function calls, as any entry in
+the mapping must be propagated to all future nodes in the tree.
+
+The algorithm also must track the set of in-scope variables, in
+order to make fresh variables as it flattens. (We are far from a
+source of fresh Uniques.) See Wrinkle 2, below.
+
+There are wrinkles, of course:
+
+1. The flattening algorithm must account for the possibility
+ of inner `forall`s. (A `forall` seen here can happen only
+ because of impredicativity. However, the flattening operation
+ is an algorithm in Core, which is impredicative.)
+ Suppose we have (forall b. F b) -> (forall b. F b). Of course,
+ those two bs are entirely unrelated, and so we should certainly
+ not flatten the two calls F b to the same variable. Instead, they
+ must be treated separately. We thus carry a substitution that
+ freshens variables; we must apply this substitution (in
+ `coreFlattenTyFamApp`) before looking up an application in the environment.
+ Note that the range of the substitution contains only TyVars, never anything
+ else.
+
+ For the sake of efficiency, we only apply this substitution when absolutely
+ necessary. Namely:
+
+ * We do not perform the substitution at all if it is empty.
+ * We only need to worry about the arguments of a type family that are within
+ the arity of said type family, so we can get away with not applying the
+ substitution to any oversaturated type family arguments.
+ * Importantly, we do /not/ achieve this substitution by recursively
+ flattening the arguments, as this would be wrong. Consider `F (G a)`,
+ where F and G are type families. We might decide that `F (G a)` flattens
+ to `beta`. Later, the substitution is non-empty (but does not map `a`) and
+ so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,
+ `F gamma` is unknown, and so we flatten it to `delta`, but it really
+ should have been `beta`! Argh!
+
+ Moral of the story: instead of flattening the arguments, just substitute
+ them directly.
+
+2. There are two different reasons we might add a variable
+ to the in-scope set as we work:
+
+ A. We have just invented a new flattening variable.
+ B. We have entered a `forall`.
+
+ Annoying here is that in-scope variable source (A) must be
+ threaded through the calls. For example, consider (F b -> forall c. F c).
+ Suppose that, when flattening F b, we invent a fresh variable c.
+ Now, when we encounter (forall c. F c), we need to know c is already in
+ scope so that we locally rename c to c'. However, if we don't thread through
+ the in-scope set from one argument of (->) to the other, we won't know this
+ and might get very confused.
+
+ In contrast, source (B) increases only as we go deeper, as in-scope sets
+ normally do. However, even here we must be careful. The TypeMap TyVar that
+ contains mappings from type family applications to freshened variables will
+ be threaded through both sides of (forall b. F b) -> (forall b. F b). We
+ thus must make sure that the two `b`s don't get renamed to the same b1. (If
+ they did, then looking up `F b1` would yield the same flatten var for
+ each.) So, even though `forall`-bound variables should really be in the
+ in-scope set only when they are in scope, we retain these variables even
+ outside of their scope. This ensures that, if we encounter a fresh
+ `forall`-bound b, we will rename it to b2, not b1. Note that keeping a
+ larger in-scope set than strictly necessary is always OK, as in-scope sets
+ are only ever used to avoid collisions.
+
+ Sadly, the freshening substitution described in (1) really mustn't bind
+ variables outside of their scope: note that its domain is the *unrenamed*
+ variables. This means that the substitution gets "pushed down" (like a
+ reader monad) while the in-scope set gets threaded (like a state monad).
+ Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;
+ instead, we just carry a TvSubstEnv down, tying it to the InScopeSet
+ traveling separately as necessary.
+
+3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:
+
+ type family F ty_1 ... ty_k :: res_k
+
+ It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a
+ flattening skolem. But we must instead flatten it to
+ `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the
+ type family.
+
+ Why is this better? Consider the following concrete example from #16995:
+
+ type family Param :: Type -> Type
+
+ type family LookupParam (a :: Type) :: Type where
+ LookupParam (f Char) = Bool
+ LookupParam x = Int
+
+ foo :: LookupParam (Param ())
+ foo = 42
+
+ In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to
+ `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if
+ `alpha` is apart from `f Char`, so it won't fall through to the second
+ equation. But since the `Param` type family has arity 0, we can instead
+ flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is
+ apart from `f Char`, permitting the second equation to be reached.
+
+ Not only does this allow more programs to be accepted, it's also important
+ for correctness. Not doing this was the root cause of the Core Lint error
+ in #16995.
+
flattenTys is defined here because of module dependencies.
-}
-data FlattenEnv = FlattenEnv { fe_type_map :: TypeMap TyVar
- , fe_subst :: TCvSubst }
+data FlattenEnv
+ = FlattenEnv { fe_type_map :: TypeMap TyVar
+ -- domain: exactly-saturated type family applications
+ -- range: fresh variables
+ , fe_in_scope :: InScopeSet }
+ -- See Note [Flattening]
emptyFlattenEnv :: InScopeSet -> FlattenEnv
emptyFlattenEnv in_scope
= FlattenEnv { fe_type_map = emptyTypeMap
- , fe_subst = mkEmptyTCvSubst in_scope }
+ , fe_in_scope = in_scope }
--- See Note [Flattening]
-flattenTys :: InScopeSet -> [Type] -> [Type]
-flattenTys in_scope tys = snd $ coreFlattenTys env tys
- where
- -- when we hit a type function, we replace it with a fresh variable
- -- but, we need to make sure that this fresh variable isn't mentioned
- -- *anywhere* in the types we're flattening, even if locally-bound in
- -- a forall. That way, we can ensure consistency both within and outside
- -- of that forall.
- all_in_scope = in_scope `extendInScopeSetSet` allTyCoVarsInTys tys
- env = emptyFlattenEnv all_in_scope
-
-coreFlattenTys :: FlattenEnv -> [Type] -> (FlattenEnv, [Type])
-coreFlattenTys = go []
- where
- go rtys env [] = (env, reverse rtys)
- go rtys env (ty : tys)
- = let (env', ty') = coreFlattenTy env ty in
- go (ty' : rtys) env' tys
+updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv
+updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }
-coreFlattenTy :: FlattenEnv -> Type -> (FlattenEnv, Type)
-coreFlattenTy = go
+flattenTys :: InScopeSet -> [Type] -> [Type]
+-- See Note [Flattening]
+-- NB: the returned types may mention fresh type variables,
+-- arising from the flattening. We don't return the
+-- mapping from those fresh vars to the ty-fam
+-- applications they stand for (we could, but no need)
+flattenTys in_scope tys
+ = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys
+
+coreFlattenTys :: TvSubstEnv -> FlattenEnv
+ -> [Type] -> (FlattenEnv, [Type])
+coreFlattenTys subst = mapAccumL (coreFlattenTy subst)
+
+coreFlattenTy :: TvSubstEnv -> FlattenEnv
+ -> Type -> (FlattenEnv, Type)
+coreFlattenTy subst = go
where
go env ty | Just ty' <- coreView ty = go env ty'
- go env (TyVarTy tv) = (env, substTyVar (fe_subst env) tv)
+ go env (TyVarTy tv)
+ | Just ty <- lookupVarEnv subst tv = (env, ty)
+ | otherwise = let (env', ki) = go env (tyVarKind tv) in
+ (env', mkTyVarTy $ setTyVarKind tv ki)
go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1
(env2, ty2') = go env1 ty2 in
(env2, AppTy ty1' ty2')
@@ -1615,139 +1755,98 @@ coreFlattenTy = go
-- NB: Don't just check if isFamilyTyCon: this catches *data* families,
-- which are generative and thus can be preserved during flattening
| not (isGenerativeTyCon tc Nominal)
- = let (env', tv) = coreFlattenTyFamApp env tc tys in
- (env', mkTyVarTy tv)
+ = coreFlattenTyFamApp subst env tc tys
| otherwise
- = let (env', tys') = coreFlattenTys env tys in
+ = let (env', tys') = coreFlattenTys subst env tys in
(env', mkTyConApp tc tys')
- go env (FunTy ty1 ty2) = let (env1, ty1') = go env ty1
- (env2, ty2') = go env1 ty2 in
- (env2, mkFunTy ty1' ty2')
+ go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
+ = let (env1, ty1') = go env ty1
+ (env2, ty2') = go env1 ty2
+ (env3, mult') = go env2 mult in
+ (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' })
go env (ForAllTy (Bndr tv vis) ty)
- = let (env1, tv') = coreFlattenVarBndr env tv
- (env2, ty') = go env1 ty in
+ = let (env1, subst', tv') = coreFlattenVarBndr subst env tv
+ (env2, ty') = coreFlattenTy subst' env1 ty in
(env2, ForAllTy (Bndr tv' vis) ty')
go env ty@(LitTy {}) = (env, ty)
- go env (CastTy ty co) = let (env1, ty') = go env ty
- (env2, co') = coreFlattenCo env1 co in
- (env2, CastTy ty' co')
+ go env (CastTy ty co)
+ = let (env1, ty') = go env ty
+ (env2, co') = coreFlattenCo subst env1 co in
+ (env2, CastTy ty' co')
+
+ go env (CoercionTy co)
+ = let (env', co') = coreFlattenCo subst env co in
+ (env', CoercionTy co')
- go env (CoercionTy co) = let (env', co') = coreFlattenCo env co in
- (env', CoercionTy co')
-- when flattening, we don't care about the contents of coercions.
-- so, just return a fresh variable of the right (flattened) type
-coreFlattenCo :: FlattenEnv -> Coercion -> (FlattenEnv, Coercion)
-coreFlattenCo env co
+coreFlattenCo :: TvSubstEnv -> FlattenEnv
+ -> Coercion -> (FlattenEnv, Coercion)
+coreFlatte